'From Squeak3.8alpha of 8 September 2004 [latest update: #5993] on 3 November 2004 at 7:27:59 pm'! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/12/2001 17:57'! bytesPerEncodedFrame "Answer the number of bytes required to hold one frame of compressed sound data." "Note: When used as a normal codec, the frame size is always 8 samples which results in (8 * bitsPerSample) / 8 = bitsPerSample bytes." | bitCount | frameSizeMask = 0 ifTrue: [^ bitsPerSample]. "Following assumes mono:" bitCount _ 16 + 6 + ((self samplesPerFrame - 1) * bitsPerSample). ^ (bitCount + 7) // 8 ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/14/2001 11:21'! reset self resetForMono. ! ! !ADPCMCodec methodsFor: 'private' stamp: 'jm 11/21/2001 11:35'! encodeLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits frameSize: frameSize forFlash: flashFlag | stereoFlag sampleCount sampleBitCount bitCount | self initializeForBitsPerSample: bits samplesPerFrame: frameSize. stereoFlag _ rightSoundBuffer notNil. sampleCount _ leftSoundBuffer monoSampleCount. stereoFlag ifTrue: [sampleBitCount _ 2 * (sampleCount * bitsPerSample)] ifFalse: [sampleBitCount _ sampleCount * bitsPerSample]. bitCount _ sampleBitCount + (self headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag). encodedBytes _ ByteArray new: ((bitCount / 8) ceiling roundUpTo: self bytesPerEncodedFrame). byteIndex _ 0. bitPosition _ 0. currentByte _ 0. flashFlag ifTrue: [self nextBits: 2 put: bits - 2]. stereoFlag ifTrue: [ samples _ Array with: leftSoundBuffer with: rightSoundBuffer. sampleIndex _ Array with: 0 with: 0. self privateEncodeStereo: sampleCount] ifFalse: [ samples _ leftSoundBuffer. sampleIndex _ 0. self privateEncodeMono: sampleCount]. ^ encodedBytes ! ! !ADPCMCodec methodsFor: 'private' stamp: 'zz 3/2/2004 07:58' prior: 16787369! indexForDeltaFrom: thisSample to: nextSample "Answer the best index to use for the difference between the given samples." "Details: Scan stepSizeTable for the first entry >= the absolute value of the difference between sample values. Since indexes are zero-based, the index used during decoding will be the one in the following stepSizeTable entry. Since the index field of a Flash frame header is only six bits, the maximum index value is 63." "Note: Since there does not appear to be any documentation of how Flash actually computes the indices used in its frame headers, this algorithm was guessed by reverse-engineering the Flash ADPCM decoder." | diff bestIndex | self inline: true. diff _ nextSample - thisSample. diff < 0 ifTrue: [diff _ 0 - diff]. bestIndex _ 63. 1 to: 62 do: [:j | bestIndex = 63 ifTrue: [ (stepSizeTable at: j) >= diff ifTrue: [bestIndex _ j]]]. ^ bestIndex ! ! !ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'! privateDecodeMono: count | delta step predictedDelta bit | self var: #stepSizeTable declareC: 'short int *stepSizeTable'. self var: #indexTable declareC: 'short int *indexTable'. self var: #samples declareC: 'short int *samples'. self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. 1 to: count do: [:i | (i bitAnd: frameSizeMask) = 1 ifTrue: [ "start of frame; read frame header" predicted _ self nextBits: 16. predicted > 32767 ifTrue: [predicted _ predicted - 65536]. index _ self nextBits: 6. samples at: (sampleIndex _ sampleIndex + 1) put: predicted] ifFalse: [ delta _ self nextBits: bitsPerSample. step _ stepSizeTable at: index + 1. predictedDelta _ 0. bit _ deltaValueHighBit. [bit > 0] whileTrue: [ (delta bitAnd: bit) > 0 ifTrue: [predictedDelta _ predictedDelta + step]. step _ step bitShift: -1. bit _ bit bitShift: -1]. predictedDelta _ predictedDelta + step. (delta bitAnd: deltaSignMask) > 0 ifTrue: [predicted _ predicted - predictedDelta] ifFalse: [predicted _ predicted + predictedDelta]. predicted > 32767 ifTrue: [predicted _ 32767] ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]]. index _ index + (indexTable at: (delta bitAnd: deltaValueMask) + 1). index < 0 ifTrue: [index _ 0] ifFalse: [index > 88 ifTrue: [index _ 88]]. samples at: (sampleIndex _ sampleIndex + 1) put: predicted]]. ! ! !ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'! privateDecodeStereo: count | predictedLeft predictedRight indexLeft indexRight deltaLeft deltaRight stepLeft stepRight predictedDeltaLeft predictedDeltaRight bit | self var: #stepSizeTable declareC: 'short int *stepSizeTable'. self var: #indexTable declareC: 'short int *indexTable'. self var: #samples declareC: 'short int *samples'. self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. self var: #rightSamples declareC: 'short int *rightSamples'. self var: #predicted declareC: 'short int *predicted'. self var: #index declareC: 'short int *index'. "make local copies of decoder state variables" predictedLeft _ predicted at: 1. predictedRight _ predicted at: 2. indexLeft _ index at: 1. indexRight _ index at: 2. 1 to: count do: [:i | (i bitAnd: frameSizeMask) = 1 ifTrue: [ "start of frame; read frame header" predictedLeft _ self nextBits: 16. indexLeft _ self nextBits: 6. predictedRight _ self nextBits: 16. indexRight _ self nextBits: 6. predictedLeft > 32767 ifTrue: [predictedLeft _ predictedLeft - 65536]. predictedRight > 32767 ifTrue: [predictedRight _ predictedRight - 65536]. samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft. rightSamples at: sampleIndex put: predictedRight] ifFalse: [ deltaLeft _ self nextBits: bitsPerSample. deltaRight _ self nextBits: bitsPerSample. stepLeft _ stepSizeTable at: indexLeft + 1. stepRight _ stepSizeTable at: indexRight + 1. predictedDeltaLeft _ predictedDeltaRight _ 0. bit _ deltaValueHighBit. [bit > 0] whileTrue: [ (deltaLeft bitAnd: bit) > 0 ifTrue: [ predictedDeltaLeft _ predictedDeltaLeft + stepLeft]. (deltaRight bitAnd: bit) > 0 ifTrue: [ predictedDeltaRight _ predictedDeltaRight + stepRight]. stepLeft _ stepLeft bitShift: -1. stepRight _ stepRight bitShift: -1. bit _ bit bitShift: -1]. predictedDeltaLeft _ predictedDeltaLeft + stepLeft. predictedDeltaRight _ predictedDeltaRight + stepRight. (deltaLeft bitAnd: deltaSignMask) > 0 ifTrue: [predictedLeft _ predictedLeft - predictedDeltaLeft] ifFalse: [predictedLeft _ predictedLeft + predictedDeltaLeft]. (deltaRight bitAnd: deltaSignMask) > 0 ifTrue: [predictedRight _ predictedRight - predictedDeltaRight] ifFalse: [predictedRight _ predictedRight + predictedDeltaRight]. predictedLeft > 32767 ifTrue: [predictedLeft _ 32767] ifFalse: [predictedLeft < -32768 ifTrue: [predictedLeft _ -32768]]. predictedRight > 32767 ifTrue: [predictedRight _ 32767] ifFalse: [predictedRight < -32768 ifTrue: [predictedRight _ -32768]]. indexLeft _ indexLeft + (indexTable at: (deltaLeft bitAnd: deltaValueMask) + 1). indexLeft < 0 ifTrue: [indexLeft _ 0] ifFalse: [indexLeft > 88 ifTrue: [indexLeft _ 88]]. indexRight _ indexRight + (indexTable at: (deltaRight bitAnd: deltaValueMask) + 1). indexRight < 0 ifTrue: [indexRight _ 0] ifFalse: [indexRight > 88 ifTrue: [indexRight _ 88]]. samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft. rightSamples at: sampleIndex put: predictedRight]]. "save local copies of decoder state variables" predicted at: 1 put: predictedLeft. predicted at: 2 put: predictedRight. index at: 1 put: indexLeft. index at: 2 put: indexRight. ! ! !ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'! privateEncodeMono: count | step sign diff delta predictedDelta bit p | self var: #stepSizeTable declareC: 'short int *stepSizeTable'. self var: #indexTable declareC: 'short int *indexTable'. self var: #samples declareC: 'short int *samples'. self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. step _ stepSizeTable at: 1. 1 to: count do: [:i | (i bitAnd: frameSizeMask) = 1 ifTrue: [ predicted _ samples at: (sampleIndex _ sampleIndex + 1). (p _ predicted) < 0 ifTrue: [p _ p + 65536]. self nextBits: 16 put: p. i < count ifTrue: [ index _ self indexForDeltaFrom: predicted to: (samples at: sampleIndex + 1)]. self nextBits: 6 put: index. ] ifFalse: [ "compute sign and magnitude of difference from the predicted sample" sign _ 0. diff _ (samples at: (sampleIndex _ sampleIndex + 1)) - predicted. diff < 0 ifTrue: [ sign _ deltaSignMask. diff _ 0 - diff]. "Compute encoded delta and the difference that this will cause in the predicted sample value during decoding. Note that this code approximates: delta _ (4 * diff) / step. predictedDelta _ ((delta + 0.5) * step) / 4; but in the shift step bits are dropped. Thus, even if you have fast mul/div hardware you cannot use it since you would get slightly different bits what than the algorithm defines." delta _ 0. predictedDelta _ 0. bit _ deltaValueHighBit. [bit > 0] whileTrue: [ diff >= step ifTrue: [ delta _ delta + bit. predictedDelta _ predictedDelta + step. diff _ diff - step]. step _ step bitShift: -1. bit _ bit bitShift: -1]. predictedDelta _ predictedDelta + step. "compute and clamp new prediction" sign > 0 ifTrue: [predicted _ predicted - predictedDelta] ifFalse: [predicted _ predicted + predictedDelta]. predicted > 32767 ifTrue: [predicted _ 32767] ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]]. "compute new index and step values" index _ index + (indexTable at: delta + 1). index < 0 ifTrue: [index _ 0] ifFalse: [index > 88 ifTrue: [index _ 88]]. step _ stepSizeTable at: index + 1. "output encoded, signed delta" self nextBits: bitsPerSample put: (sign bitOr: delta)]]. bitPosition > 0 ifTrue: [ "flush the last output byte, if necessary" encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte]. ! ! !ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:12'! privateEncodeStereo: count "not yet implemented" self inline: false. self success: false.! ! !ADPCMCodec commentStamp: '' prior: 0! This is a simple ADPCM (adapative delta pulse code modulation) codec. This is a general audio codec that compresses speech, music, or sound effects equally well, and works at any sampling rate (i.e., it contains no frequency-sensitive filters). It compresses 16-bit sample data down to 5, 4, 3, or 2 bits per sample, with lower fidelity and increased noise at the lowest bit rates. Although it does not deliver state-of-the-art compressions, the algorithm is small, simple, and extremely fast, since the encode/decode primitives have been translated into C primitives. This codec will also encode and decode all Flash .swf file compressed sound formats, both mono and stereo. (Note: stereo Flash compression is not yet implemented, but stereo decompression works.) ! !ADPCMCodec class methodsFor: 'instance creation' stamp: 'jm 11/15/2001 16:02'! newBitsPerSample: bitsPerSample ^ super new initializeForBitsPerSample: bitsPerSample samplesPerFrame: 0. ! ! !AIFFFileReader methodsFor: 'reading' stamp: 'jm 10/17/2001 17:20'! readFromFile: fileName mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag "Read the AIFF file of the given name. See comment in readFromStream:mergeIfStereo:skipDataChunk:." "AIFFFileReader new readFromFile: 'test.aiff' mergeIfStereo: false skipDataChunk: true" | f | f _ (FileStream readOnlyFileNamed: fileName) binary. self readFromStream: f mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag. f close. ! ! !AIFFFileReader methodsFor: 'reading'! readFromStream: aBinaryStream mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag "Read an AIFF file from the given binary stream. If mergeFlag is true and the file contains stereo data, then the left and right channels will be mixed together as the samples are read in. If skipDataFlag is true, then the data chunk to be skipped; this allows the other chunks of a file to be processed in order to extract format information quickly without reading the data." mergeIfStereo _ mergeFlag. skipDataChunk _ skipDataFlag. isLooped _ false. gain _ 1.0. self readFrom: aBinaryStream. ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 10/20/2001 15:07'! channelDataOffset ^ channelDataOffset ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 10/20/2001 15:07'! readSamplesChunk: chunkSize "Read a SSND chunk. All AIFF files with a non-zero frameCount contain exactly one chunk of this type." | offset blockSize bytesOfSamples s | offset _ in nextNumber: 4. blockSize _ in nextNumber: 4. ((offset ~= 0) or: [blockSize ~= 0]) ifTrue: [^ self error: 'this AIFF reader cannot handle blocked sample chunks']. bytesOfSamples _ chunkSize - 8. bytesOfSamples = (channelCount * frameCount * (bitsPerSample // 8)) ifFalse: [self error: 'actual sample count does not match COMM chunk']. channelDataOffset _ in position. "record stream position for start of data" skipDataChunk ifTrue: [in skip: (chunkSize - 8). ^ self]. "if skipDataChunk, skip sample data" (mergeIfStereo and: [channelCount = 2]) ifTrue: [ channelData _ Array with: (SoundBuffer newMonoSampleCount: frameCount)] ifFalse: [ channelData _ (1 to: channelCount) collect: [:i | SoundBuffer newMonoSampleCount: frameCount]]. (bytesOfSamples < (Smalltalk garbageCollectMost - 300000)) ifTrue: [s _ ReadStream on: (in next: bytesOfSamples)] "bulk-read, then process" ifFalse: [s _ in]. "not enough space to buffer; read directly from file" "mono and stereo are special-cased for better performance" channelCount = 1 ifTrue: [^ self readMonoChannelDataFrom: s]. channelCount = 2 ifTrue: [ mergeIfStereo ifTrue: [channelCount _ 1. ^ self readMergedStereoChannelDataFrom: s] ifFalse: [^ self readStereoChannelDataFrom: s]]. self readMultiChannelDataFrom: s. ! ! !Abort methodsFor: 'as yet unclassified' stamp: 'ajh 3/24/2003 00:55'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:10'! changeKind ^self class changeKind! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:43'! environmentAt: anItemKind (self itemKind = anItemKind) ifTrue: [^self item]. ^environment at: anItemKind ifAbsent: [nil]! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:20'! eventSelector ^self class eventSelectorBlock value: itemKind value: self changeKind! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'! item: anItem kind: anItemKind item := anItem. itemKind := anItemKind. environment := Dictionary new! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:37'! itemCategory: aCategory environment at: self class categoryKind put: aCategory! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'! itemClass: aClass environment at: self class classKind put: aClass! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 12:11'! itemExpression: anExpression environment at: self class expressionKind put: anExpression! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'! itemMethod: aMethod environment at: self class methodKind put: aMethod! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'! itemProtocol: aProtocol environment at: self class protocolKind put: aProtocol! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:38'! itemRequestor: requestor environment at: #requestor put: requestor! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:39'! itemSelector: aSymbol environment at: #selector put: aSymbol! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'! item "Return the item that triggered the event (typically the name of a class, a category, a protocol, a method)." ^item! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'! itemCategory ^self environmentAt: self class categoryKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'! itemClass ^self environmentAt: self class classKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 12:10'! itemExpression ^self environmentAt: self class expressionKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'! itemKind "Return the kind of the item of the event (#category, #class, #protocol, #method, ...)" ^itemKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'! itemMethod ^self environmentAt: self class methodKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'! itemProtocol ^self environmentAt: self class protocolKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'! itemRequestor ^self environmentAt: #requestor! ! !AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'! itemSelector ^self environmentAt: #selector! ! !AbstractEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 17:52'! printOn: aStream self printEventKindOn: aStream. aStream nextPutAll: ' Event for item: '; print: self item; nextPutAll: ' of kind: '; print: self itemKind! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'! isAdded ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 18:41'! isCategoryKnown ^self itemCategory notNil! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/10/2003 15:01'! isCommented ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/14/2003 10:15'! isDoIt ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 15:09'! isModified ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/21/2004 09:40'! isProtocolKnown ^self itemCategory notNil! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 19:53'! isRecategorized ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'! isRemoved ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:35'! isRenamed ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/27/2004 12:44'! isReorganized ^ false! ! !AbstractEvent methodsFor: 'triggering' stamp: 'rw 7/14/2003 17:06'! trigger: anEventManager "Trigger the event manager." anEventManager triggerEvent: self eventSelector with: self.! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'! class: aClass ^ self item: aClass kind: AbstractEvent classKind.! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'! class: aClass category: cat | instance | instance := self class: aClass. instance itemCategory: cat. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 7/9/2003 11:19'! item: anItem kind: anItemKind ^self basicNew item: anItem kind: anItemKind! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:19'! method: aMethod class: aClass | instance | instance := self item: aMethod kind: self methodKind. instance itemClass: aClass. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:20'! method: aMethod protocol: prot class: aClass | instance | instance := self method: aMethod class: aClass. instance itemProtocol: prot. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:48'! method: aMethod selector: aSymbol class: aClass | instance | instance := self item: aMethod kind: self methodKind. instance itemSelector: aSymbol. instance itemClass: aClass. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'! method: aMethod selector: aSymbol class: aClass requestor: requestor | instance | instance := self method: aMethod selector: aSymbol class: aClass. instance itemRequestor: requestor. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'! method: aMethod selector: aSymbol protocol: prot class: aClass | instance | instance := self method: aMethod selector: aSymbol class: aClass. instance itemProtocol: prot. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:50'! method: aMethod selector: aSymbol protocol: prot class: aClass requestor: requestor | instance | instance := self method: aMethod selector: aSymbol protocol: prot class: aClass. instance itemRequestor: requestor. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 6/30/2003 09:20'! new "Override new to trigger an error, since we want to use specialized methods to create basic and higher-level events." ^self error: 'Instances can only be created using specialized instance creation methods.'! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'NS 1/16/2004 14:08'! allChangeKinds "AbstractEvent allChangeKinds" ^AbstractEvent allSubclasses collect: [:cl | cl changeKind]! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/29/2003 15:14'! allItemKinds "SystemEvent allItemKinds" ^(AbstractEvent class organization listAtCategoryNamed: #'item kinds') collect: [:sel | self perform: sel]! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'! changeKind "Return a symbol, with a : as last character, identifying the change kind." self subclassResponsibility! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:18'! eventSelectorBlock ^[:itemKind :changeKind | itemKind, changeKind, 'Event:']! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:19'! itemChangeCombinations ^self supportedKinds collect: [:itemKind | self eventSelectorBlock value: itemKind value: self changeKind]! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:04'! supportedKinds "All the kinds of items that this event can take. By default this is all the kinds in the system. But subclasses can override this to limit the choices. For example, the SuperChangedEvent only works with classes, and not with methods, instance variables, ..." ^self allItemKinds! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:39'! systemEvents "Return all the possible events in the system. Make a cross product of the items and the change types." "self systemEvents" ^self allSubclasses inject: OrderedCollection new into: [:allEvents :eventClass | allEvents addAll: eventClass itemChangeCombinations; yourself]! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! categoryKind ^#category! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! classKind ^#class! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/14/2003 11:41'! expressionKind ^#expression! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! methodKind ^#method! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/10/2003 12:36'! protocolKind ^#protocol! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:23'! comment1 "Smalltalk organization removeElement: #ClassForTestingSystemChanges3 Smalltalk garbageCollect Smalltalk organizati classify:under: SystemChangeNotifier uniqueInstance releaseAll SystemChangeNotifier uniqueInstance noMoreNotificationsFor: aDependent. aDependent := SystemChangeNotifierTest new. SystemChangeNotifier uniqueInstance notifyOfAllSystemChanges: aDependent using: #event: SystemChangeNotifier uniqueInstance classAdded: #Foo inCategory: #FooCat | eventSource dependentObject | eventSource := EventManager new. dependentObject := Object new. register - dependentObject becomes dependent: eventSource when: #anEvent send: #error to: dependentObject. unregister dependentObject: eventSource removeDependent: dependentObject. [eventSource triggerEvent: #anEvent] on: Error do: [:exc | self halt: 'Should not be!!']."! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:24'! comment2 "HTTPSocket useProxyServerNamed: 'proxy.telenet.be' port: 8080 TestRunner open -------------------- We propose two orthogonal groups to categorize each event: (1) the 'change type': added, removed, modified, renamed + the composite 'changed' (see below for an explanation) (2) the 'item type': class, method, instance variable, pool variable, protocol, category + the composite 'any' (see below for an explanation). The list of supported events is the cross product of these two lists (see below for an explicit enumeration of the events). Depending on the change type, certain information related to the change is always present (for adding, the new things that was added, for removals, what was removed, for renaming, the old and the new name, etc.). Depending on the item type, information regarding the item is present (for a method, which class it belongs to). Certain events 'overlap', for example, a method rename triggers a class change. To capture this I impose a hierarchy on the 'item types' (just put some numbers to clearly show the idea. They don't need numbers, really. Items at a certain categories are included by items one category number higher): level 1 category level 2 class level 3 instance variable, pool variable, protocol, method. Changes propagate according to this tree: any 'added', 'removed' or 'renamed' change type in level X triggers a 'changed' change type in level X - 1. A 'modified' change type does not trigger anything special. For example, a method additions triggers a class modification. This does not trigger a category modification. Note that we added 'composite events': wildcards for the 'change type' ('any' - any system additions) and for the 'item type' ('Changed' - all changes related to classes), and one for 'any change systemwide' (systemChanged). This result is this list of Events: classAdded classRemoved classModified classRenamed (?) classChanged (composite) methodAdded methodRemoved methodModified methodRenamed (?) methodChanged (composite) instanceVariableAdded instanceVariableRemoved instanceVariableModified instanceVariableRenamed (?) instanceVariableChanged (composite) protocolAdded protocolRemoved protocolModified protocolRenamed (?) protocolChanged (composite) poolVariableAdded poolVariableRemoved poolVariableModified poolVariableRenamed (?) poolChanged (composite) categoryAdded categoryRemoved categoryModified categeryRenamed (?) categoryChanged (composite) anyAdded (composite) anyRemoved (composite) anyModified (composite) anyRenamed (composite) anyChanged (composite) To check: can we pass somehow the 'source' of the change (a browser, a file-in, something else) ? Maybe by checking the context, but should not be too expensive either... I found this useful in some of my tools, but it might be too advanced to have in general. Tools that need this can always write code to check it for them. But is not always simple... Utilities (for the recent methods) and ChangeSet are the two main clients at this moment. Important: make it very explicit that the event is send synchronously (or asynchronously, would we take that route). category class comment protocol method OR category Smalltalk class comment protocol method ?? Smalltalk category \ / class / | \ comment | protocol | / method "! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 15:43'! comment3 "Things to consider for trapping: ClassOrganizer>>#changeFromCategorySpecs: Problem: I want to trap this to send the appropriate bunch of ReCategorization events, but ClassOrganizer instances do not know where they belong to (what class, or what system); it just uses symbols. So I cannot trigger the change, because not enough information is available. This is a conceptual problem: the organization is stand-alone implementation-wise, while conceptually it belongs to a class. The clean solution could be to reroute this message to a class, but this does not work for all of the senders (that would work from the browserm but not for the file-in). Browser>>#categorizeAllUncategorizedMethods Problem: should be trapped to send a ReCategorization event. However, this is model code that should not be in the Browser. Clean solution is to move it out of there to the model, and then trap it there (or reroute it to one of the trapped places). Note: Debugger>>#contents:notifying: recompiles methods when needed, so I trapped it to get updates. However, I need to find a way to write a unit test for this. Haven't gotten around yet for doing this though... "! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 11/4/2003 14:32'! saveChangeNotificationAsSARFileWithNumber: aNumber "Use the SARBuilder package to output the SystemChangeNotification stuff as a SAR file. Put this statement here so that I don't forget it when moving between images :-)" "self saveChangeNotificationAsSARFileWithNumber: 6" | filename changesText readmeText | filename := 'SystemchangeNotification'. changesText := ' 0.6 Version for Squeak 3.7 (no longer for 3.6!!!!) Changed one hook method to make this version work in Squeak3.7. Download version 5 from http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar if you are working with Squeak 3.6. 0.5 Updated the safeguard mechanism so that clients with halts and errors do not stop all notifications. Added and updated new tests for this. If this interests you have a look at the class WeakActionSequenceTrappingErrors. 0.4 Ported to Squeak 3.6. 0.3 Added the hooks for instance variables (addition, removal and renaming). Refactored the tests. 0.2 Added hooks and tests for method removal and method recategorization. 0.1 First release'. readmeText := 'Implements (part of) the system change notification mechanism. Clients that want to receive notifications about system changes should look at the category #public of the class SystemChangeNotifier, and the unit tests. VERY IMPORTANT: This version is for Squeak 3.7 only. It will not work in Squeak version 3.6. Download and install the last version that worked in Squeak 3.6 (version 5) from the following URL: http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar'. (SARChangeSetDumper on: Project current changeSet including: (ChangeSorter allChangeSetNames select: [:ea | 'SystemChangeHooks' match: ea])) changesText: changesText; readmeText: readmeText; fileOutAsZipNamed: filename , aNumber printString , '.sar'! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'sd 3/9/2004 19:42' prior: 33583975! saveChangeNotificationAsSARFileWithNumber: aNumber "Use the SARBuilder package to output the SystemChangeNotification stuff as a SAR file. Put this statement here so that I don't forget it when moving between images :-)" "self saveChangeNotificationAsSARFileWithNumber: 6" | filename changesText readmeText dumper | filename := 'SystemchangeNotification'. dumper _ self class environment at: #SARChangeSetDumper ifAbsent: [ ^self ]. changesText := ' 0.6 Version for Squeak 3.7 (no longer for 3.6!!!!) Changed one hook method to make this version work in Squeak3.7. Download version 5 from http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar if you are working with Squeak 3.6. 0.5 Updated the safeguard mechanism so that clients with halts and errors do not stop all notifications. Added and updated new tests for this. If this interests you have a look at the class WeakActionSequenceTrappingErrors. 0.4 Ported to Squeak 3.6. 0.3 Added the hooks for instance variables (addition, removal and renaming). Refactored the tests. 0.2 Added hooks and tests for method removal and method recategorization. 0.1 First release'. readmeText := 'Implements (part of) the system change notification mechanism. Clients that want to receive notifications about system changes should look at the category #public of the class SystemChangeNotifier, and the unit tests. VERY IMPORTANT: This version is for Squeak 3.7 only. It will not work in Squeak version 3.6. Download and install the last version that worked in Squeak 3.6 (version 5) from the following URL: http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar'. (dumper on: Project current changeSet including: (ChangeSorter allChangeSetNames select: [:ea | 'SystemChangeHooks' match: ea])) changesText: changesText; readmeText: readmeText; fileOutAsZipNamed: filename , aNumber printString , '.sar'! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:06'! baseKern ^0! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'! derivativeFonts ^#()! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:51'! height "Answer the height of the receiver, total of maximum extents of characters above and below the baseline." ^self ascent + self descent! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 12/20/2002 18:59'! isL2R self subclassResponsibility ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 09:45'! isRegular ^false! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:07'! lineGrid "Answer the relative space between lines" ^ self ascent + self descent! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/25/2004 15:29'! pixelSize "Make sure that we don't return a Fraction" ^ self pointSize * 96.0 / 72.0. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:33' prior: 33588592! pixelSize "Make sure that we don't return a Fraction" ^ TextStyle pointsToPixels: self pointSize! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:48'! pointSize self subclassResponsibility.! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 7/11/2004 21:15'! textStyle ^ TextStyle actualTextStyles detect: [:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 7/11/2004 21:15' prior: 33589047! textStyle ^ TextStyle actualTextStyles detect: [:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/22/2004 15:15'! textStyleName "Answer the name to be used as a key in the TextConstants dictionary." ^self familyName! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/22/2004 15:15' prior: 33589477! textStyleName "Answer the name to be used as a key in the TextConstants dictionary." ^self familyName! ! !AbstractFont methodsFor: 'displaying' stamp: 'yo 12/20/2002 18:58'! displayStringR2L: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta "Draw the given string from startIndex to stopIndex at aPoint on the (already prepared) display context." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'measuring' stamp: 'sps 3/23/2004 15:49'! approxWidthOfText: aText "Return the width of aText -- quickly, and a little bit dirty. Used by lists morphs containing Text objects to get a quick, fairly accurate measure of the width of a list item." | w | (aText isNil or: [aText size == 0 ]) ifTrue:[^0]. w _ self widthOfString: aText asString from: 1 to: aText size. "If the text has no emphasis, just return the string size. If it is empasized, just approximate the width by adding about 20% to the width" (((aText runLengthFor: 1) == aText size) and: [(aText emphasisAt: 1) == 0 ]) ifTrue:[^w] ifFalse:[ ^w * 6 // 5 ]. ! ! !AbstractFont methodsFor: 'measuring' stamp: 'ar 12/31/2001 14:25'! widthOfString: aString aString ifNil:[^0]. ^self widthOfString: aString from: 1 to: aString size. " TextStyle default defaultFont widthOfString: 'zort' 21 "! ! !AbstractFont methodsFor: 'measuring' stamp: 'ar 12/31/2001 00:54'! widthOfString: aString from: startIndex to: stopIndex "Measure the length of the given string between start and stop index" | character resultX | resultX _ 0. startIndex to: stopIndex do:[:i | character _ aString at: i. resultX _ resultX + (self widthOf: character)]. ^resultX! ! !AbstractFont methodsFor: 'measuring' stamp: 'sps 3/23/2004 15:50'! widthOfStringOrText: aStringOrText aStringOrText ifNil:[^0]. ^aStringOrText isText ifTrue:[self approxWidthOfText: aStringOrText ] ifFalse:[self widthOfString: aStringOrText ] ! ! !AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'! isTTCFont ^false! ! !AbstractFont methodsFor: 'notifications' stamp: 'nk 4/2/2004 11:25'! pixelsPerInchChanged "The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! ! !AbstractFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:47'! releaseCachedState ! ! !AbstractFont commentStamp: '' prior: 0! AbstractFont defines the generic interface that all fonts need to implement.! !AbstractLauncher methodsFor: 'private' stamp: 'mdr 4/10/2001 10:50'! numericParameterAtOneOf: alternateParameterNames ifAbsent: aBlock "Return the parameter named using one of the alternate names or an empty string" | parameterValue | parameterValue _ self parameterAtOneOf: alternateParameterNames. parameterValue isEmpty ifTrue: [^aBlock value]. ^[Number readFrom: parameterValue] ifError: aBlock ! ! !AbstractLauncher methodsFor: 'running' stamp: 'tk 10/24/2001 06:40'! startUp "A backstop for subclasses. Note that this is not a class message (most startUps are class messages)." ! ! !AbstractLauncher class methodsFor: 'private' stamp: 'sd 9/30/2003 13:55' prior: 16841786! extractParameters ^ SmalltalkImage current extractParameters! ! !AbstractLauncher class methodsFor: 'activation'! deactivate "Unregister this launcher with the auto start class" self autoStarter removeLauncher: self! ! !AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color paleYellow! ! !AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:38' prior: 16843275! initialize "initialize the state of the receiver" super initialize. "" self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 2; rubberBandCells: true! ! !AbstractSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 22:34'! isStereo "Answer true if this sound has distinct left and right channels. (Every sound plays into a stereo sample buffer, but most sounds, which produce exactly the same samples on both channels, are not stereo.)" ^ false ! ! !AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/16/2001 13:14'! originalSamplingRate "For sampled sounds, answer the sampling rate used to record the stored samples. For other sounds, this is the same as the playback sampling rate." ^ SoundPlayer samplingRate ! ! !AbstractSound methodsFor: 'conversion' stamp: 'jm 12/16/2001 13:26'! asSampledSound "Answer a SampledSound containing my samples. If the receiver is some kind of sampled sound, the resulting SampledSound will have the same original sampling rate as the receiver." ^ SampledSound samples: self samples samplingRate: self originalSamplingRate ! ! !AbstractSound methodsFor: 'playing' stamp: 'gk 2/24/2004 22:23' prior: 16851715! play "Play this sound to the sound output port in real time." SoundPlayer playSound: self.! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:22'! samples "Answer a monophonic sample buffer containing my samples. The left and write channels are merged." "Warning: This may require a lot of memory!!" ^ (self computeSamplesForSeconds: self duration) mergeStereo ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:24'! viewSamples "Open a WaveEditor on my samples." WaveEditor openOn: self samples. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 21:51'! storeAIFFOnFileNamed: fileName "Store this sound as a AIFF file of the given name." | f | f _ (FileStream fileNamed: fileName) binary. self storeAIFFSamplesOn: f. f close. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:31'! storeAIFFSamplesOn: aBinaryStream "Store this sound as a 16-bit AIFF file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." | samplesToStore channelCount dataByteCount | samplesToStore _ (self duration * self samplingRate) ceiling. channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. dataByteCount _ samplesToStore * channelCount * 2. "write AIFF file header:" aBinaryStream nextPutAll: 'FORM' asByteArray. aBinaryStream nextInt32Put: ((7 * 4) + 18) + dataByteCount. aBinaryStream nextPutAll: 'AIFF' asByteArray. aBinaryStream nextPutAll: 'COMM' asByteArray. aBinaryStream nextInt32Put: 18. aBinaryStream nextNumber: 2 put: channelCount. aBinaryStream nextInt32Put: samplesToStore. aBinaryStream nextNumber: 2 put: 16. "bits/sample" self storeExtendedFloat: self samplingRate on: aBinaryStream. aBinaryStream nextPutAll: 'SSND' asByteArray. aBinaryStream nextInt32Put: dataByteCount + 8. aBinaryStream nextInt32Put: 0. aBinaryStream nextInt32Put: 0. "write data:" self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/17/2001 08:36'! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files). If self isStereo is true, both channels are stored, creating a stereo file. Otherwise, only the left channel is stored, creating a mono file." | bufSize stereoBuffer reverseBytes remaining out | self reset. bufSize _ (2 * self samplingRate rounded) min: samplesToStore. "two second buffer" stereoBuffer _ SoundBuffer newStereoSampleCount: bufSize. reverseBytes _ bigEndianFlag ~= (Smalltalk endianness = #big). 'Storing audio...' displayProgressAt: Sensor cursorPoint from: 0 to: samplesToStore during: [:bar | remaining _ samplesToStore. [remaining > 0] whileTrue: [ bar value: samplesToStore - remaining. stereoBuffer primFill: 0. "clear the buffer" self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1. self isStereo ifTrue: [out _ stereoBuffer] ifFalse: [out _ stereoBuffer extractLeftChannel]. reverseBytes ifTrue: [out reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (out size // 2) putAll: out startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: out monoSampleCount do: [:i | aBinaryStream int16: (out at: i)]]. remaining _ remaining - bufSize]]. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'sd 9/30/2003 13:41' prior: 33596947! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files). If self isStereo is true, both channels are stored, creating a stereo file. Otherwise, only the left channel is stored, creating a mono file." | bufSize stereoBuffer reverseBytes remaining out | self reset. bufSize _ (2 * self samplingRate rounded) min: samplesToStore. "two second buffer" stereoBuffer _ SoundBuffer newStereoSampleCount: bufSize. reverseBytes _ bigEndianFlag ~= (SmalltalkImage current isBigEndian). 'Storing audio...' displayProgressAt: Sensor cursorPoint from: 0 to: samplesToStore during: [:bar | remaining _ samplesToStore. [remaining > 0] whileTrue: [ bar value: samplesToStore - remaining. stereoBuffer primFill: 0. "clear the buffer" self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1. self isStereo ifTrue: [out _ stereoBuffer] ifFalse: [out _ stereoBuffer extractLeftChannel]. reverseBytes ifTrue: [out reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (out size // 2) putAll: out startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: out monoSampleCount do: [:i | aBinaryStream int16: (out at: i)]]. remaining _ remaining - bufSize]]. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 21:47'! storeSunAudioOnFileNamed: fileName "Store this sound as an uncompressed Sun audio file of the given name." | f | f _ (FileStream fileNamed: fileName) binary. self storeSunAudioSamplesOn: f. f close. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:32'! storeSunAudioSamplesOn: aBinaryStream "Store this sound as a 16-bit Sun audio file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." | samplesToStore channelCount dataByteCount | samplesToStore _ (self duration * self samplingRate) ceiling. channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. dataByteCount _ samplesToStore * channelCount * 2. "write Sun audio file header" channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. aBinaryStream nextPutAll: '.snd' asByteArray. aBinaryStream uint32: 24. "header size in bytes" aBinaryStream uint32: dataByteCount. aBinaryStream uint32: 3. "format: 16-bit linear" aBinaryStream uint32: self samplingRate truncated. aBinaryStream uint32: channelCount. "write data:" self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 20:03'! storeWAVOnFileNamed: fileName "Store this sound as a 16-bit Windows WAV file of the given name." | f | f _ (FileStream fileNamed: fileName) binary. self storeWAVSamplesOn: f. f close. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:32'! storeWAVSamplesOn: aBinaryStream "Store this sound as a 16-bit Windows WAV file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." | samplesToStore channelCount dataByteCount samplesPerSec bytesPerSec | samplesToStore _ (self duration * self samplingRate) ceiling. channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. dataByteCount _ samplesToStore * channelCount * 2. samplesPerSec _ self samplingRate rounded. bytesPerSec _ samplesPerSec * channelCount * 2. "file header" aBinaryStream nextPutAll: 'RIFF' asByteArray; nextLittleEndianNumber: 4 put: dataByteCount + 36; "total length of all chunks" nextPutAll: 'WAVE' asByteArray. "format chunk" aBinaryStream nextPutAll: 'fmt ' asByteArray; nextLittleEndianNumber: 4 put: 16; "length of this chunk" nextLittleEndianNumber: 2 put: 1; "format tag" nextLittleEndianNumber: 2 put: channelCount; nextLittleEndianNumber: 4 put: samplesPerSec; nextLittleEndianNumber: 4 put: bytesPerSec; nextLittleEndianNumber: 2 put: 4; "alignment" nextLittleEndianNumber: 2 put: 16. "bits per sample" "data chunk" aBinaryStream nextPutAll: 'data' asByteArray; nextLittleEndianNumber: 4 put: dataByteCount. "length of this chunk" self storeSampleCount: samplesToStore bigEndian: false on: aBinaryStream. ! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:27'! beep "Make a primitive beep." self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:47'! playSampledSound: samples rate: rate self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:50'! playSoundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamedOrBeep: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! randomBitsFromSoundInput: bitCount self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! sampledSoundChoices self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'! shutDown "Default is to do nothing."! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'sw 3/4/2004 02:40'! soundNameFromUser "Pop up a list of available sound names and answer the one the user chooses, or nil if no choice made" ^ (SelectionMenu selections: self sampledSoundChoices asSortedArray) startUpWithCaption: 'Sounds' translated " SoundService default soundNameFromUser "! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:56'! soundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem commentStamp: 'gk 2/24/2004 08:34' prior: 0! This is the abstract base class for a sound system. A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in the application registry SoundService and can be accessed by "SoundService default" like for example: SoundService default playSoundNamed: 'croak' The idea is that as much sound playing as possible should go through this facade. This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the Preference class>>soundsEnabled. Two basic subclasses exist at the time of this writing, the BaseSoundSystem which represents the standard Squeak sound system, and the DummySoundSystem which is a dummy implementation that can be used when there is no sound card available, or when the base sound system isn't in the image, or when you simply don't want to use the available sound card.! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/26/2002 22:26'! at: index ^ super at: index. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/26/2002 22:27'! at: index put: aCharacter super at: index put: Character asciiValue. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:21'! byteAt: index ^ super at: index. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:22'! byteAt: index put: value ^ super at: index put: value. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/26/2002 20:31'! byteSize ^self size! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! do: aBlock toFieldNumber: aNumber "Considering the receiver as a holder of tab-delimited fields, evaluate aBlock on behalf of a field in this string" | start end index | start _ 1. index _ 1. [start <= self size] whileTrue: [end _ self indexOf: Character tab startingAt: start ifAbsent: [self size + 1]. end _ end - 1. aNumber = index ifTrue: [aBlock value: (self copyFrom: start to: end). ^ self]. index _ index + 1. start _ end + 2] " 1 to: 6 do: [:aNumber | 'fred charlie elmo wimpy friml' do: [:aField | Transcript cr; show: aField] toFieldNumber: aNumber] "! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! endsWithDigit "Answer whether the receiver's final character represents a digit. 3/11/96 sw" ^ self size > 0 and: [self last isDigit]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findAnySubStr: delimiters startingAt: start "Answer the index of the character within the receiver, starting at start, that begins a substring matching one of the delimiters. delimiters is an Array of Strings (Characters are permitted also). If the receiver does not contain any of the delimiters, answer size + 1." | min ind | min _ self size + 1. delimiters do: [:delim | "May be a char, a string of length 1, or a substring" delim class == Character ifTrue: [ind _ self indexOfSubCollection: (String with: delim) startingAt: start ifAbsent: [min]] ifFalse: [ind _ self indexOfSubCollection: delim startingAt: start ifAbsent: [min]]. min _ min min: ind]. ^ min! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findBetweenSubStrs: delimiters "Answer the collection of String tokens that result from parsing self. Tokens are separated by 'delimiters', which can be a collection of Strings, or a collection of Characters. Several delimiters in a row are considered as just one separation." | tokens keyStart keyStop | tokens _ OrderedCollection new. keyStop _ 1. [keyStop <= self size] whileTrue: [keyStart _ self skipAnySubStr: delimiters startingAt: keyStop. keyStop _ self findAnySubStr: delimiters startingAt: keyStart. keyStart < keyStop ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. ^tokens! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findCloseParenthesisFor: startIndex "assume (self at: startIndex) is $(. Find the matching $), allowing parentheses to nest." " '(1+(2-3))-3.14159' findCloseParenthesisFor: 1 " " '(1+(2-3))-3.14159' findCloseParenthesisFor: 4 " | pos nestLevel | pos := startIndex+1. nestLevel := 1. [ pos <= self size ] whileTrue: [ (self at: pos) = $( ifTrue: [ nestLevel := nestLevel + 1 ]. (self at: pos) = $) ifTrue: [ nestLevel := nestLevel - 1 ]. nestLevel = 0 ifTrue: [ ^pos ]. pos := pos + 1. ]. ^self size + 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findDelimiters: delimiters startingAt: start "Answer the index of the character within the receiver, starting at start, that matches one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1." start to: self size do: [:i | delimiters do: [:delim | delim = (self at: i) ifTrue: [^ i]]]. ^ self size + 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 10/15/2003 15:32'! findLastOccuranceOfString: subString startingAt: start "Answer the index of the last occurance of subString within the receiver, starting at start. If the receiver does not contain subString, answer 0." | last now | last _ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder. last = 0 ifTrue: [^ 0]. [last > 0] whileTrue: [ now _ last. last _ self findSubstring: subString in: self startingAt: last + subString size matchTable: CaseSensitiveOrder. ]. ^ now. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findString: subString "Answer the index of subString within the receiver, starting at start. If the receiver does not contain subString, answer 0." ^self findString: subString startingAt: 1.! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findString: subString startingAt: start "Answer the index of subString within the receiver, starting at start. If the receiver does not contain subString, answer 0." ^ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findString: key startingAt: start caseSensitive: caseSensitive "Answer the index in this String at which the substring key first occurs, at or beyond start. The match can be case-sensitive or not. If no match is found, zero will be returned." caseSensitive ifTrue: [^ self findSubstring: key in: self startingAt: start matchTable: CaseSensitiveOrder] ifFalse: [^ self findSubstring: key in: self startingAt: start matchTable: CaseInsensitiveOrder]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findTokens: delimiters "Answer the collection of tokens that result from parsing self. Return strings between the delimiters. Any character in the Collection delimiters marks a border. Several delimiters in a row are considered as just one separation. Also, allow delimiters to be a single character." | tokens keyStart keyStop separators | tokens _ OrderedCollection new. separators _ delimiters class == Character ifTrue: [Array with: delimiters] ifFalse: [delimiters]. keyStop _ 1. [keyStop <= self size] whileTrue: [keyStart _ self skipDelimiters: separators startingAt: keyStop. keyStop _ self findDelimiters: separators startingAt: keyStart. keyStart < keyStop ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. ^tokens! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findTokens: delimiters includes: subString "Divide self into pieces using delimiters. Return the piece that includes subString anywhere in it. Is case sensitive (say asLowercase to everything beforehand to make insensitive)." ^ (self findTokens: delimiters) detect: [:str | (str includesSubString: subString)] ifNone: [nil]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findTokens: delimiters keep: keepers "Answer the collection of tokens that result from parsing self. The tokens are seperated by delimiters, any of a string of characters. If a delimiter is also in keepers, make a token for it. (Very useful for carriage return. A sole return ends a line, but is also saved as a token so you can see where the line breaks were.)" | tokens keyStart keyStop | tokens _ OrderedCollection new. keyStop _ 1. [keyStop <= self size] whileTrue: [keyStart _ self skipDelimiters: delimiters startingAt: keyStop. keyStop to: keyStart-1 do: [:ii | (keepers includes: (self at: ii)) ifTrue: [ tokens add: (self copyFrom: ii to: ii)]]. "Make this keeper be a token" keyStop _ self findDelimiters: delimiters startingAt: keyStart. keyStart < keyStop ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. ^tokens! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findWordStart: key startingAt: start | ind | "HyperCard style searching. Answer the index in self of the substring key, when that key is preceeded by a separator character. Must occur at or beyond start. The match is case-insensitive. If no match is found, zero will be returned." ind _ start. [ind _ self findSubstring: key in: self startingAt: ind matchTable: CaseInsensitiveOrder. ind = 0 ifTrue: [^ 0]. "not found" ind = 1 ifTrue: [^ 1]. "First char is the start of a word" (self at: ind-1) isSeparator] whileFalse: [ind _ ind + 1]. ^ ind "is a word start"! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! includesSubString: subString ^ (self findString: subString startingAt: 1) > 0! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! includesSubstring: aString caseSensitive: caseSensitive ^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOf: aCharacter (aCharacter class == Character) ifFalse: [^ 0]. ^ String indexOfAscii: aCharacter asciiValue inString: self startingAt: 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/28/2002 16:45' prior: 33614752! indexOf: aCharacter aCharacter isCharacter ifFalse: [^ 0]. ^ self class indexOfAscii: aCharacter asciiValue inString: self startingAt: 1. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOf: aCharacter startingAt: start (aCharacter class == Character) ifFalse: [^ 0]. ^ String indexOfAscii: aCharacter asciiValue inString: self startingAt: start! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOf: aCharacter startingAt: start ifAbsent: aBlock | ans | (aCharacter class == Character) ifFalse: [ ^ aBlock value ]. ans _ String indexOfAscii: aCharacter asciiValue inString: self startingAt: start. ans = 0 ifTrue: [ ^ aBlock value ] ifFalse: [ ^ ans ]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfAnyOf: aCharacterSet "returns the index of the first character in the given set. Returns 0 if none are found" ^self indexOfAnyOf: aCharacterSet startingAt: 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfAnyOf: aCharacterSet ifAbsent: aBlock "returns the index of the first character in the given set. Returns the evaluation of aBlock if none are found" ^self indexOfAnyOf: aCharacterSet startingAt: 1 ifAbsent: aBlock! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfAnyOf: aCharacterSet startingAt: start "returns the index of the first character in the given set, starting from start. Returns 0 if none are found" ^self indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: [ 0 ]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: aBlock "returns the index of the first character in the given set, starting from start" | ans | ans _ String findFirstInString: self inSet: aCharacterSet byteArrayMap startingAt: start. ans = 0 ifTrue: [ ^aBlock value ] ifFalse: [ ^ans ]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfSubCollection: sub #Collectn. "Added 2000/04/08 For ANSI protocol." ^ self indexOfSubCollection: sub startingAt: 1 ifAbsent: [0]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock | index | index _ self findSubstring: sub in: self startingAt: start matchTable: CaseSensitiveOrder. index = 0 ifTrue: [^ exceptionBlock value]. ^ index! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! lastIndexOfPKSignature: aSignature "Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found" | a b c d | a _ aSignature first. b _ aSignature second. c _ aSignature third. d _ aSignature fourth. (self size - 3) to: 1 by: -1 do: [ :i | (((self at: i) = a) and: [ ((self at: i + 1) = b) and: [ ((self at: i + 2) = c) and: [ ((self at: i + 3) = d) ]]]) ifTrue: [ ^i ] ]. ^0! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 12/17/2002 16:56'! leadingCharRunLengthAt: index | leadingChar | leadingChar _ (self at: index) leadingChar. index to: self size do: [:i | (self at: i) leadingChar ~= leadingChar ifTrue: [^ i - index]. ]. ^ self size - index + 1. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! lineCorrespondingToIndex: anIndex "Answer a string containing the line at the given character position. 1/15/96 sw: Inefficient first stab at this" | cr aChar answer | cr _ Character cr. answer _ ''. 1 to: self size do: [:i | aChar _ self at: i. aChar == cr ifTrue: [i > anIndex ifTrue: [^ answer] ifFalse: [answer _ '']] ifFalse: [answer _ answer copyWith: aChar]]. ^ answer! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:33' prior: 33618363! lineCorrespondingToIndex: anIndex "Answer a string containing the line at the given character position. 1/15/96 sw: Inefficient first stab at this" | cr aChar answer | cr _ Character cr. answer _ ''. 1 to: self size do: [:i | aChar _ self at: i. aChar = cr ifTrue: [i > anIndex ifTrue: [^ answer] ifFalse: [answer _ '']] ifFalse: [answer _ answer copyWith: aChar]]. ^ answer! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! lineCount "Answer the number of lines represented by the receiver, where every cr adds one line. 5/10/96 sw" | cr count | cr _ Character cr. count _ 1 min: self size. 1 to: self size do: [:i | (self at: i) == cr ifTrue: [count _ count + 1]]. ^ count " 'Fred the Bear' lineCount "! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34' prior: 33619400! lineCount "Answer the number of lines represented by the receiver, where every cr adds one line. 5/10/96 sw" | cr count | cr _ Character cr. count _ 1 min: self size.. 1 to: self size do: [:i | (self at: i) = cr ifTrue: [count _ count + 1]]. ^ count " 'Fred the Bear' lineCount "! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! lineNumber: anIndex "Answer a string containing the characters in the given line number. 5/10/96 sw" | crString pos finalPos | crString _ String with: Character cr. pos _ 0. 1 to: anIndex - 1 do: [:i | pos _ self findString: crString startingAt: pos + 1. pos == 0 ifTrue: [^ nil]]. finalPos _ self findString: crString startingAt: pos + 1. finalPos == 0 ifTrue: [finalPos _ self size + 1]. ^ self copyFrom: pos + 1 to: finalPos - 1 " 'Fred the Bear' lineNumber: 3 "! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34' prior: 33620146! lineNumber: anIndex "Answer a string containing the characters in the given line number. 5/10/96 sw" | crString pos finalPos | crString _ String with: Character cr. pos _ 0. 1 to: anIndex - 1 do: [:i | pos _ self findString: crString startingAt: pos + 1. pos = 0 ifTrue: [^ nil]]. finalPos _ self findString: crString startingAt: pos + 1. finalPos = 0 ifTrue: [finalPos _ self size + 1]. ^ self copyFrom: pos + 1 to: finalPos - 1 " 'Fred the Bear' lineNumber: 3 "! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! linesDo: aBlock "execute aBlock with each line in this string. The terminating CR's are not included in what is passed to aBlock" | start end | start _ 1. [ start <= self size ] whileTrue: [ end _ self indexOf: Character cr startingAt: start ifAbsent: [ self size + 1 ]. end _ end - 1. aBlock value: (self copyFrom: start to: end). start _ end + 2. ].! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! skipAnySubStr: delimiters startingAt: start "Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed). If the receiver is all delimiters, answer size + 1." | any this ind ii | ii _ start-1. [(ii _ ii + 1) <= self size] whileTrue: [ "look for char that does not match" any _ false. delimiters do: [:delim | delim class == Character ifTrue: [(self at: ii) == delim ifTrue: [any _ true]] ifFalse: ["a substring" delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was." [ind _ 0. this _ true. delim do: [:dd | dd == (self at: ii+ind) ifFalse: [this _ false]. ind _ ind + 1]. this ifTrue: [ii _ ii + delim size - 1. any _ true]] ifTrue: [any _ false] "if the delim is too big, it can't match"]]. any ifFalse: [^ ii]]. ^ self size + 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:28' prior: 33621712! skipAnySubStr: delimiters startingAt: start "Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed). If the receiver is all delimiters, answer size + 1." | any this ind ii | ii _ start-1. [(ii _ ii + 1) <= self size] whileTrue: [ "look for char that does not match" any _ false. delimiters do: [:delim | delim isCharacter ifTrue: [(self at: ii) == delim ifTrue: [any _ true]] ifFalse: ["a substring" delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was." [ind _ 0. this _ true. delim do: [:dd | dd == (self at: ii+ind) ifFalse: [this _ false]. ind _ ind + 1]. this ifTrue: [ii _ ii + delim size - 1. any _ true]] ifTrue: [any _ false] "if the delim is too big, it can't match"]]. any ifFalse: [^ ii]]. ^ self size + 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! skipDelimiters: delimiters startingAt: start "Answer the index of the character within the receiver, starting at start, that does NOT match one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1. Assumes the delimiters to be a non-empty string." start to: self size do: [:i | delimiters detect: [:delim | delim = (self at: i)] ifNone: [^ i]]. ^ self size + 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! startsWithDigit "Answer whether the receiver's first character represents a digit" ^ self size > 0 and: [self first isDigit]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! tabDelimitedFieldsDo: aBlock "Considering the receiver as a holder of tab-delimited fields, evaluate execute aBlock with each field in this string. The separatilng tabs are not included in what is passed to aBlock" | start end | "No senders but was useful enough in earlier work that it's retained for the moment." start _ 1. [start <= self size] whileTrue: [end _ self indexOf: Character tab startingAt: start ifAbsent: [self size + 1]. end _ end - 1. aBlock value: (self copyFrom: start to: end). start _ end + 2] " 'fred charlie elmo 2' tabDelimitedFieldsDo: [:aField | Transcript cr; show: aField] "! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:31'! < aString "Answer whether the receiver sorts before aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:31'! <= aString "Answer whether the receiver sorts before or equal to aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! = aString "Answer whether the receiver sorts equally as aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! > aString "Answer whether the receiver sorts after aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! >= aString "Answer whether the receiver sorts after or equal to aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! alike: aString "Answer some indication of how alike the receiver is to the argument, 0 is no match, twice aString size is best score. Case is ignored." | i j k minSize bonus | minSize _ (j _ self size) min: (k _ aString size). bonus _ (j - k) abs < 2 ifTrue: [ 1 ] ifFalse: [ 0 ]. i _ 1. [(i <= minSize) and: [((super at: i) bitAnd: 16rDF) = ((aString at: i) asciiValue bitAnd: 16rDF)]] whileTrue: [ i _ i + 1 ]. [(j > 0) and: [(k > 0) and: [((super at: j) bitAnd: 16rDF) = ((aString at: k) asciiValue bitAnd: 16rDF)]]] whileTrue: [ j _ j - 1. k _ k - 1. ]. ^ i - 1 + self size - j + bonus. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! beginsWith: prefix "Answer whether the receiver begins with the given prefix string. The comparison is case-sensitive." self size < prefix size ifTrue: [^ false]. ^ (self findSubstring: prefix in: self startingAt: 1 matchTable: CaseSensitiveOrder) = 1 ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! caseInsensitiveLessOrEqual: aString "Answer whether the receiver sorts before or equal to aString. The collation order is case insensitive." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! caseSensitiveLessOrEqual: aString "Answer whether the receiver sorts before or equal to aString. The collation order is case sensitive." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! charactersExactlyMatching: aString "Do a character-by-character comparison between the receiver and aString. Return the index of the final character that matched exactly." | count | count _ self size min: aString size. 1 to: count do: [:i | (self at: i) == (aString at: i) ifFalse: [ ^ i - 1]]. ^ count! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 8/27/2002 14:15' prior: 33627860! charactersExactlyMatching: aString "Do a character-by-character comparison between the receiver and aString. Return the index of the final character that matched exactly." | count | count _ self size min: aString size. 1 to: count do: [:i | (self at: i) = (aString at: i) ifFalse: [ ^ i - 1]]. ^ count! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! compare: aString "Answer a comparison code telling how the receiver sorts relative to aString: 1 - before 2 - equal 3 - after. The collation sequence is ascii with case differences ignored. To get the effect of a <= b, but ignoring case, use (a compare: b) <= 2." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! crc16 "Compute a 16 bit cyclic redundancy check." | crc | crc := 0. self do: [:c | crc := (crc bitShift: -8) bitXor: ( #( 16r0000 16rC0C1 16rC181 16r0140 16rC301 16r03C0 16r0280 16rC241 16rC601 16r06C0 16r0780 16rC741 16r0500 16rC5C1 16rC481 16r0440 16rCC01 16r0CC0 16r0D80 16rCD41 16r0F00 16rCFC1 16rCE81 16r0E40 16r0A00 16rCAC1 16rCB81 16r0B40 16rC901 16r09C0 16r0880 16rC841 16rD801 16r18C0 16r1980 16rD941 16r1B00 16rDBC1 16rDA81 16r1A40 16r1E00 16rDEC1 16rDF81 16r1F40 16rDD01 16r1DC0 16r1C80 16rDC41 16r1400 16rD4C1 16rD581 16r1540 16rD701 16r17C0 16r1680 16rD641 16rD201 16r12C0 16r1380 16rD341 16r1100 16rD1C1 16rD081 16r1040 16rF001 16r30C0 16r3180 16rF141 16r3300 16rF3C1 16rF281 16r3240 16r3600 16rF6C1 16rF781 16r3740 16rF501 16r35C0 16r3480 16rF441 16r3C00 16rFCC1 16rFD81 16r3D40 16rFF01 16r3FC0 16r3E80 16rFE41 16rFA01 16r3AC0 16r3B80 16rFB41 16r3900 16rF9C1 16rF881 16r3840 16r2800 16rE8C1 16rE981 16r2940 16rEB01 16r2BC0 16r2A80 16rEA41 16rEE01 16r2EC0 16r2F80 16rEF41 16r2D00 16rEDC1 16rEC81 16r2C40 16rE401 16r24C0 16r2580 16rE541 16r2700 16rE7C1 16rE681 16r2640 16r2200 16rE2C1 16rE381 16r2340 16rE101 16r21C0 16r2080 16rE041 16rA001 16r60C0 16r6180 16rA141 16r6300 16rA3C1 16rA281 16r6240 16r6600 16rA6C1 16rA781 16r6740 16rA501 16r65C0 16r6480 16rA441 16r6C00 16rACC1 16rAD81 16r6D40 16rAF01 16r6FC0 16r6E80 16rAE41 16rAA01 16r6AC0 16r6B80 16rAB41 16r6900 16rA9C1 16rA881 16r6840 16r7800 16rB8C1 16rB981 16r7940 16rBB01 16r7BC0 16r7A80 16rBA41 16rBE01 16r7EC0 16r7F80 16rBF41 16r7D00 16rBDC1 16rBC81 16r7C40 16rB401 16r74C0 16r7580 16rB541 16r7700 16rB7C1 16rB681 16r7640 16r7200 16rB2C1 16rB381 16r7340 16rB101 16r71C0 16r7080 16rB041 16r5000 16r90C1 16r9181 16r5140 16r9301 16r53C0 16r5280 16r9241 16r9601 16r56C0 16r5780 16r9741 16r5500 16r95C1 16r9481 16r5440 16r9C01 16r5CC0 16r5D80 16r9D41 16r5F00 16r9FC1 16r9E81 16r5E40 16r5A00 16r9AC1 16r9B81 16r5B40 16r9901 16r59C0 16r5880 16r9841 16r8801 16r48C0 16r4980 16r8941 16r4B00 16r8BC1 16r8A81 16r4A40 16r4E00 16r8EC1 16r8F81 16r4F40 16r8D01 16r4DC0 16r4C80 16r8C41 16r4400 16r84C1 16r8581 16r4540 16r8701 16r47C0 16r4680 16r8641 16r8201 16r42C0 16r4380 16r8341 16r4100 16r81C1 16r8081 16r4040) at: ((crc bitXor: c asciiValue) bitAnd: 16rFF) + 1) ]. ^crc! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! endsWith: suffix "Answer whether the tail end of the receiver is the same as suffix. The comparison is case-sensitive." | extra | (extra _ self size - suffix size) < 0 ifTrue: [^ false]. ^ (self findSubstring: suffix in: self startingAt: extra + 1 matchTable: CaseSensitiveOrder) > 0 " 'Elvis' endsWith: 'vis' "! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! endsWithAnyOf: aCollection aCollection do:[:suffix| (self endsWith: suffix) ifTrue:[^true]. ]. ^false! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! hash "#hash is implemented, because #= is implemented" ^ByteArray hashBytes: self startingWith: self species hash! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:43' prior: 33632019! hash "#hash is implemented, because #= is implemented" ^ self class stringHash: self initialHash: self species hash ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! hashMappedBy: map "My hash is independent of my oop." ^self hash! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! howManyMatch: string "Count the number of characters that match up in self and aString." | count shorterLength | count _ 0 . shorterLength _ ((self size ) min: (string size ) ) . (1 to: shorterLength do: [:index | (((self at: index ) = (string at: index ) ) ifTrue: [count _ (count + 1 ) . ] ). ] ). ^ count ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! match: text "Answer whether text matches the pattern in this string. Matching ignores upper/lower case differences. Where this string contains #, text may contain any character. Where this string contains *, text may contain any sequence of characters." ^ self startingAt: 1 match: text startingAt: 1 " '*' match: 'zort' true '*baz' match: 'mobaz' true '*baz' match: 'mobazo' false '*baz*' match: 'mobazo' true '*baz*' match: 'mozo' false 'foo*' match: 'foozo' true 'foo*' match: 'bozo' false 'foo*baz' match: 'foo23baz' true 'foo*baz' match: 'foobaz' true 'foo*baz' match: 'foo23bazo' false 'foo' match: 'Foo' true 'foo*baz*zort' match: 'foobazort' false 'foo*baz*zort' match: 'foobazzort' false '*foo#zort' match: 'afoo3zortthenfoo3zort' true '*foo*zort' match: 'afoodezortorfoo3zort' true "! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! sameAs: aString "Answer whether the receiver sorts equal to aString. The collation sequence is ascii with case differences ignored." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! startingAt: keyStart match: text startingAt: textStart "Answer whether text matches the pattern in this string. Matching ignores upper/lower case differences. Where this string contains #, text may contain any character. Where this string contains *, text may contain any sequence of characters." | anyMatch matchStart matchEnd i matchStr j ii jj | i _ keyStart. j _ textStart. "Check for any #'s" [i > self size ifTrue: [^ j > text size "Empty key matches only empty string"]. (self at: i) = $#] whileTrue: ["# consumes one char of key and one char of text" j > text size ifTrue: [^ false "no more text"]. i _ i+1. j _ j+1]. "Then check for *" (self at: i) = $* ifTrue: [i = self size ifTrue: [^ true "Terminal * matches all"]. "* means next match string can occur anywhere" anyMatch _ true. matchStart _ i + 1] ifFalse: ["Otherwise match string must occur immediately" anyMatch _ false. matchStart _ i]. "Now determine the match string" matchEnd _ self size. (ii _ self indexOf: $* startingAt: matchStart) > 0 ifTrue: [ii = 1 ifTrue: [self error: '** not valid -- use * instead']. matchEnd _ ii-1]. (ii _ self indexOf: $# startingAt: matchStart) > 0 ifTrue: [ii = 1 ifTrue: [self error: '*# not valid -- use #* instead']. matchEnd _ matchEnd min: ii-1]. matchStr _ self copyFrom: matchStart to: matchEnd. "Now look for the match string" [jj _ text findString: matchStr startingAt: j caseSensitive: false. anyMatch ifTrue: [jj > 0] ifFalse: [jj = j]] whileTrue: ["Found matchStr at jj. See if the rest matches..." (self startingAt: matchEnd+1 match: text startingAt: jj + matchStr size) ifTrue: [^ true "the rest matches -- success"]. "The rest did not match." anyMatch ifFalse: [^ false]. "Preceded by * -- try for a later match" j _ j+1]. ^ false "Failed to find the match string"! ! !AbstractString methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'! copyReplaceTokens: oldSubstring with: newSubstring "Replace all occurrences of oldSubstring that are surrounded by non-alphanumeric characters" ^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true "'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"! ! !AbstractString methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'! deepCopy "DeepCopy would otherwise mean make a copy of the character; since characters are unique, just return a shallowCopy." ^self shallowCopy! ! !AbstractString methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'! padded: leftOrRight to: length with: char leftOrRight = #left ifTrue: [^ (String new: (length - self size max: 0) withAll: char) , self]. leftOrRight = #right ifTrue: [^ self , (String new: (length - self size max: 0) withAll: char)].! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! adaptToCollection: rcvr andSend: selector "If I am involved in arithmetic with a collection, convert me to a number." ^ rcvr perform: selector with: self asNumber! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! adaptToNumber: rcvr andSend: selector "If I am involved in arithmetic with a number, convert me to a number." ^ rcvr perform: selector with: self asNumber! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! adaptToPoint: rcvr andSend: selector "If I am involved in arithmetic with a point, convert me to a number." ^ rcvr perform: selector with: self asNumber! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! adaptToString: rcvr andSend: selector "If I am involved in arithmetic with a string, convert us both to numbers, and return the printString of the result." ^ (rcvr asNumber perform: selector with: self asNumber) printString! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asCharacter "Answer the receiver's first character, or '•' if none. Idiosyncratic, provisional." ^ self size > 0 ifTrue: [self first] ifFalse: [$•]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/4/2003 14:37' prior: 33637966! asCharacter "Answer the receiver's first character, or '*' if none. Idiosyncratic, provisional." ^ self size > 0 ifTrue: [self first] ifFalse: [$*]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asDate "Many allowed forms, see Date>>#readFrom:" ^ Date fromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asDateAndTime "Convert from UTC format" ^ DateAndTime fromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 10/22/2002 17:38'! asDefaultDecodedString ^ self ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asDisplayText "Answer a DisplayText whose text string is the receiver." ^DisplayText text: self asText! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asDuration "convert from [nnnd]hh:mm:ss[.nanos] format. [] implies optional elements" ^ Duration fromString: self ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asFileName "Answer a String made up from the receiver that is an acceptable file name." ^FileDirectory checkName: self fixErrors: true! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asFourCode |result| self size = 4 ifFalse: [^self error: 'must be exactly four characters']. result _ self inject: 0 into: [:val :each | 256 * val + each asciiValue]. (result bitAnd: 16r80000000) = 0 ifFalse: [self error: 'cannot resolve fourcode']. (result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000]. ^result! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:38' prior: 33639434! asFourCode | result | self size = 4 ifFalse: [^self error: 'must be exactly four characters']. result _ self inject: 0 into: [:val :each | 256 * val + each asciiValue]. (result bitAnd: 16r80000000) = 0 ifFalse: [self error: 'cannot resolve fourcode']. (result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000]. ^ result ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asHex | stream | stream _ WriteStream on: (String new: self size * 2). self do: [ :ch | stream nextPutAll: ch hex ]. ^stream contents! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/26/2002 23:06' prior: 33640272! asHex | stream | stream _ WriteStream on: (String new: self size * 4). self do: [ :ch | stream nextPutAll: ch hex ]. ^stream contents! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asHtml "Do the basic character conversion for HTML. Leave all original return and tabs in place, so can conver back by simply removing bracked things. 4/4/96 tk" | temp | temp _ self copyReplaceAll: '&' with: '&'. HtmlEntities keysAndValuesDo: [:entity :char | char = $& ifFalse: [temp _ temp copyReplaceAll: char asString with: '&' , entity , ';']]. temp _ temp copyReplaceAll: ' ' with: ' '. temp _ temp copyReplaceAll: ' ' with: '
'. ^ temp " 'A<&>B' asHtml "! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asIRCLowercase "Answer a String made up from the receiver whose characters are all lowercase, where 'lowercase' is by IRC's definition" ^self collect: [ :c | c asIRCLowercase ]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asIdentifier: shouldBeCapitalized "Return a legal identifier, with first character in upper case if shouldBeCapitalized is true, else lower case. This will always return a legal identifier, even for an empty string" | aString firstChar firstLetterPosition | aString _ self select: [:el | el isAlphaNumeric]. firstLetterPosition _ aString findFirst: [:ch | ch isLetter]. aString _ firstLetterPosition == 0 ifFalse: [aString copyFrom: firstLetterPosition to: aString size] ifTrue: ['a', aString]. firstChar _ shouldBeCapitalized ifTrue: [aString first asUppercase] ifFalse: [aString first asLowercase]. ^ firstChar asString, (aString copyFrom: 2 to: aString size) " '234Fred987' asIdentifier: false '235Fred987' asIdentifier: true '' asIdentifier: true '()87234' asIdentifier: false '())z>=PPve889 U >' asIdentifier: false "! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asInteger "Answer the Integer created by interpreting the receiver as the string representation of an integer. Answer nil if no digits, else find the first digit and then all consecutive digits after that" | startPosition tail endPosition | startPosition _ self findFirst: [:ch | ch isDigit]. startPosition == 0 ifTrue: [^ nil]. tail _ self copyFrom: startPosition to: self size. endPosition _ tail findFirst: [:ch | ch isDigit not]. endPosition == 0 ifTrue: [endPosition _ tail size + 1]. ^ Number readFromString: (tail copyFrom: 1 to: endPosition - 1) " '1796exportFixes-tkMX' asInteger '1848recentLogFile-sw' asInteger 'donald' asInteger 'abc234def567' asInteger "! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asLegalSelector | toUse | toUse _ ''. self do: [:char | char isAlphaNumeric ifTrue: [toUse _ toUse copyWith: char]]. (self size == 0 or: [self first isLetter not]) ifTrue: [toUse _ 'v', toUse]. ^ toUse withFirstCharacterDownshifted "'234znak 43 ) 2' asLegalSelector"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asLowercase "Answer a String made up from the receiver whose characters are all lowercase." ^ self copy asString translateToLowercase! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asMorph "Answer the receiver as a StringMorph" ^ StringMorph contents: self "'bugs black blood' asMorph openInHand"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asNumber "Answer the Number created by interpreting the receiver as the string representation of a number." ^Number readFromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 16:51'! asOctetString self subclassResponsibility. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asPacked "Convert to a longinteger that describes the string" ^ self inject: 0 into: [ :pack :next | pack _ pack * 256 + next asInteger ].! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:39' prior: 33644336! asPacked "Convert to a longinteger that describes the string" ^ self inject: 0 into: [ :pack :next | pack _ pack * 256 + next asInteger ].! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asParagraph "Answer a Paragraph whose text string is the receiver." ^Paragraph withText: self asText! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asSignedInteger "Answer the Integer created by interpreting the receiver as the string representation of an integer, possibly with a leading minus sign. Answer nil if no digits, else find the first digit and then all consecutive digits after that" | startPosition tail endPosition | startPosition _ self findFirst: [:ch | ch isDigit or: [ch == $-]]. startPosition == 0 ifTrue: [^ nil]. tail _ self copyFrom: startPosition to: self size. endPosition _ tail findFirst: [:ch | ch isDigit not and: [ch ~~ $-]]. endPosition == 0 ifTrue: [endPosition _ tail size + 1]. ^ Number readFromString: (tail copyFrom: 1 to: endPosition - 1) " 'znak -58 to wit' asSignedInteger "! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asSmalltalkComment "return this string, munged so that it can be treated as a comment in Smalltalk code. Quote marks are added to the beginning and end of the string, and whenever a solitary quote mark appears within the string, it is doubled" ^String streamContents: [ :str | | quoteCount first | str nextPut: $". quoteCount := 0. first := true. self do: [ :char | char = $" ifTrue: [ first ifFalse: [ str nextPut: char. quoteCount := quoteCount + 1 ] ] ifFalse: [ quoteCount odd ifTrue: [ "add a quote to even the number of quotes in a row" str nextPut: $" ]. quoteCount := 0. str nextPut: char ]. first := false ]. quoteCount odd ifTrue: [ "check at the end" str nextPut: $". ]. str nextPut: $". ]. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asString "Answer this string." ^ self ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asStringOrText "Answer this string." ^ self ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asSymbol "Answer the unique Symbol whose characters are the characters of the string." ^Symbol intern: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:53' prior: 33646817! asSymbol "Answer the unique Symbol whose characters are the characters of the string." ^ self class correspondingSymbolClass intern: self. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asText "Answer a Text whose string is the receiver." ^Text fromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asTime "Many allowed forms, see Time>>readFrom:" ^ Time fromString: self.! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asTimeStamp "Convert from obsolete TimeStamp format" ^ TimeStamp fromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/8/2002 11:33'! asTranslatedWording self subclassResponsibility ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asUnHtml "Strip out all Html stuff (commands in angle brackets <>) and convert the characters &<> back to their real value. Leave actual cr and tab as they were in text." | in out char rest did | in _ ReadStream on: self. out _ WriteStream on: (String new: self size). [in atEnd] whileFalse: [in peek = $< ifTrue: [in unCommand] "Absorb <...><...>" ifFalse: [(char _ in next) = $& ifTrue: [rest _ in upTo: $;. did _ out position. rest = 'lt' ifTrue: [out nextPut: $<]. rest = 'gt' ifTrue: [out nextPut: $>]. rest = 'amp' ifTrue: [out nextPut: $&]. rest = 'deg' ifTrue: [out nextPut: $°]. rest = 'quot' ifTrue: [out nextPut: $"]. did = out position ifTrue: [ self error: 'unknown encoded HTML char'. "Please add it to this method"]] ifFalse: [out nextPut: char]]. ]. ^ out contents! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/26/2002 20:31' prior: 33647828! asUnHtml "Strip out all Html stuff (commands in angle brackets <>) and convert the characters &<> back to their real value. Leave actual cr and tab as they were in text." | in out char rest did | in _ ReadStream on: self. out _ WriteStream on: (String new: self size). [in atEnd] whileFalse: [in peek = $< ifTrue: [in unCommand] "Absorb <...><...>" ifFalse: [(char _ in next) = $& ifTrue: [rest _ in upTo: $;. did _ out position. rest = 'lt' ifTrue: [out nextPut: $<]. rest = 'gt' ifTrue: [out nextPut: $>]. rest = 'amp' ifTrue: [out nextPut: $&]. did = out position ifTrue: [ self error: 'new HTML char encoding'. "Please add it to this code"]] ifFalse: [out nextPut: char]]. ]. ^ out contents! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asUppercase "Answer a String made up from the receiver whose characters are all uppercase." ^self copy asString translateToUppercase! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asUrl "convert to a Url" "'http://www.cc.gatech.edu/' asUrl" "msw://chaos.resnet.gatech.edu:9000/' asUrl" ^Url absoluteFromText: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asUrlRelativeTo: aUrl ^aUrl newFromRelativeText: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! askIfAddStyle: priorMethod req: requestor ^ self "we are a string with no text style"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! capitalized "Return a copy with the first letter capitalized" | cap | self isEmpty ifTrue: [ ^self copy ]. cap _ self copy. cap at: 1 put: (cap at: 1) asUppercase. ^ cap! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! compressWithTable: tokens "Return a string with all substrings that occur in tokens replaced by a character with ascii code = 127 + token index. This will work best if tokens are sorted by size. Assumes this string contains no characters > 127, or that they are intentionally there and will not interfere with this process." | str null finalSize start result ri c ts | null _ Character value: 0. str _ self copyFrom: 1 to: self size. "Working string will get altered" finalSize _ str size. tokens doWithIndex: [:token :tIndex | start _ 1. [(start _ str findString: token startingAt: start) > 0] whileTrue: [ts _ token size. ((start + ts) <= str size and: [(str at: start + ts) = $ and: [tIndex*2 <= 128]]) ifTrue: [ts _ token size + 1. "include training blank" str at: start put: (Character value: tIndex*2 + 127)] ifFalse: [str at: start put: (Character value: tIndex + 127)]. str at: start put: (Character value: tIndex + 127). 1 to: ts-1 do: [:i | str at: start+i put: null]. finalSize _ finalSize - (ts - 1). start _ start + ts]]. result _ String new: finalSize. ri _ 0. 1 to: str size do: [:i | (c _ str at: i) = null ifFalse: [result at: (ri _ ri+1) put: c]]. ^ result! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! contractTo: smallSize "return myself or a copy shortened by ellipsis to smallSize" | leftSize | self size <= smallSize ifTrue: [^ self]. "short enough" smallSize < 5 ifTrue: [^ self copyFrom: 1 to: smallSize]. "First N characters" leftSize _ smallSize-2//2. ^ self copyReplaceFrom: leftSize+1 "First N/2 ... last N/2" to: self size - (smallSize - leftSize - 3) with: '...' " 'A clear but rather long-winded summary' contractTo: 18 "! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! correctAgainst: wordList "Correct the receiver: assume it is a misspelled word and return the (maximum of five) nearest words in the wordList. Depends on the scoring scheme of alike:" | results | results _ self correctAgainst: wordList continuedFrom: nil. results _ self correctAgainst: nil continuedFrom: results. ^ results! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! correctAgainst: wordList continuedFrom: oldCollection "Like correctAgainst:. Use when you want to correct against several lists, give nil as the first oldCollection, and nil as the last wordList." ^ wordList isNil ifTrue: [ self correctAgainstEnumerator: nil continuedFrom: oldCollection ] ifFalse: [ self correctAgainstEnumerator: [ :action | wordList do: action without: nil] continuedFrom: oldCollection ]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! correctAgainstDictionary: wordDict continuedFrom: oldCollection "Like correctAgainst:continuedFrom:. Use when you want to correct against a dictionary." ^ wordDict isNil ifTrue: [ self correctAgainstEnumerator: nil continuedFrom: oldCollection ] ifFalse: [ self correctAgainstEnumerator: [ :action | wordDict keysDo: action ] continuedFrom: oldCollection ]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! encodeForHTTP "change dangerous characters to their %XX form, for use in HTTP transactions" | encodedStream | encodedStream _ WriteStream on: (String new). self do: [ :c | c isSafeForHTTP ifTrue: [ encodedStream nextPut: c ] ifFalse: [ encodedStream nextPut: $%. encodedStream nextPut: (c asciiValue // 16) asHexDigit. encodedStream nextPut: (c asciiValue \\ 16) asHexDigit. ] ]. ^encodedStream contents. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 16:58' prior: 33653822! encodeForHTTP "change dangerous characters to their %XX form, for use in HTTP transactions" | encodedStream | encodedStream _ WriteStream on: String new. self do: [:character | character isSafeForHTTP ifTrue: [encodedStream nextPut: character] ifFalse: [character == Character space ifTrue: [encodedStream nextPut: $+] ifFalse: [encodedStream nextPut: $%. encodedStream nextPut: (character asciiValue // 16) asHexDigit. encodedStream nextPut: (character asciiValue \\ 16) asHexDigit]]]. ^ encodedStream contents. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! findSelector "Dan's code for hunting down selectors with keyword parts; while this doesn't give a true parse, in most cases it does what we want, in where it doesn't, we're none the worse for it." | sel possibleParens level n | sel _ self withBlanksTrimmed. (sel includes: $:) ifTrue: [sel _ sel copyReplaceAll: ':' with: ': '. "for the style (aa max:bb) with no space" possibleParens _ sel findTokens: Character separators. sel _ String streamContents: [:s | level _ 0. possibleParens do: [:token | (level = 0 and: [token endsWith: ':']) ifTrue: [s nextPutAll: token] ifFalse: [(n _ token occurrencesOf: $( ) > 0 ifTrue: [level _ level + n]. (n _ token occurrencesOf: $[ ) > 0 ifTrue: [level _ level + n]. (n _ token occurrencesOf: $] ) > 0 ifTrue: [level _ level - n]. (n _ token occurrencesOf: $) ) > 0 ifTrue: [level _ level - n]]]]]. sel isEmpty ifTrue: [^ nil]. Symbol hasInterned: sel ifTrue: [:aSymbol | ^ aSymbol]. ^ nil! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:52' prior: 33654970! findSelector "Dan's code for hunting down selectors with keyword parts; while this doesn't give a true parse, in most cases it does what we want, in where it doesn't, we're none the worse for it." | sel possibleParens level n | sel _ self withBlanksTrimmed. (sel includes: $:) ifTrue: [sel _ sel copyReplaceAll: ':' with: ': '. "for the style (aa max:bb) with no space" possibleParens _ sel findTokens: Character separators. sel _ self class streamContents: [:s | level _ 0. possibleParens do: [:token | (level = 0 and: [token endsWith: ':']) ifTrue: [s nextPutAll: token] ifFalse: [(n _ token occurrencesOf: $( ) > 0 ifTrue: [level _ level + n]. (n _ token occurrencesOf: $[ ) > 0 ifTrue: [level _ level + n]. (n _ token occurrencesOf: $] ) > 0 ifTrue: [level _ level - n]. (n _ token occurrencesOf: $) ) > 0 ifTrue: [level _ level - n]]]]]. sel isEmpty ifTrue: [^ nil]. self class correspondingSymbolClass hasInterned: sel ifTrue: [:aSymbol | ^ aSymbol]. ^ nil! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! initialIntegerOrNil "Answer the integer represented by the leading digits of the receiver, or nil if the receiver does not begin with a digit" | firstNonDigit | (self size == 0 or: [self first isDigit not]) ifTrue: [^ nil]. firstNonDigit _ (self findFirst: [:m | m isDigit not]). firstNonDigit = 0 ifTrue: [firstNonDigit _ self size + 1]. ^ (self copyFrom: 1 to: (firstNonDigit - 1)) asNumber " '234Whoopie' initialIntegerOrNil 'wimpy' initialIntegerOrNil '234' initialIntegerOrNil '2N' initialIntegerOrNil '2' initialIntegerOrNil ' 89Ten ' initialIntegerOrNil '78 92' initialIntegerOrNil " ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! keywords "Answer an array of the keywords that compose the receiver." | kwd char keywords | keywords _ Array streamContents: [:kwds | kwd _ WriteStream on: (String new: 16). 1 to: self size do: [:i | kwd nextPut: (char _ self at: i). char = $: ifTrue: [kwds nextPut: kwd contents. kwd reset]]. kwd isEmpty ifFalse: [kwds nextPut: kwd contents]]. (keywords size >= 1 and: [(keywords at: 1) = ':']) ifTrue: ["Has an initial keyword, as in #:if:then:else:" keywords _ keywords allButFirst]. (keywords size >= 2 and: [(keywords at: keywords size - 1) = ':']) ifTrue: ["Has a final keyword, as in #nextPut::andCR" keywords _ keywords copyReplaceFrom: keywords size - 1 to: keywords size with: {':' , keywords last}]. ^ keywords! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! numericSuffix ^ self stemAndNumericSuffix last " 'abc98' numericSuffix '98abc' numericSuffix "! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! onlyLetters "answer the receiver with only letters" ^ self select:[:each | each isLetter]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! openAsMorph "Open the receiver as a morph" ^ self asMorph openInHand ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! romanNumber | value v1 v2 | value _ v1 _ v2 _ 0. self reverseDo: [:each | v1 _ #(1 5 10 50 100 500 1000) at: ('IVXLCDM' indexOf: each). v1 >= v2 ifTrue: [value _ value + v1] ifFalse: [value _ value - v1]. v2 _ v1]. ^ value! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! sansPeriodSuffix "Return a copy of the receiver up to, but not including, the first period. If the receiver's *first* character is a period, then just return the entire receiver. " | likely | likely _ self copyUpTo: $.. ^ likely size == 0 ifTrue: [self] ifFalse: [likely]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! splitInteger "Answer an array that is a splitting of self into a string and an integer. '43Sam' ==> #(43 'Sam'). 'Try90' ==> #('Try' 90) BUT NOTE: 'Sam' ==> #('Sam' 0), and '90' ==> #('' 90) ie, ( )." | pos | (pos _ self findFirst: [:d | d isDigit not]) == 0 ifTrue: [^ Array with: '' with: self asNumber]. self first isDigit ifTrue: [ ^ Array with: (self copyFrom: 1 to: pos - 1) asNumber with: (self copyFrom: pos to: self size)]. (pos _ self findFirst: [:d | d isDigit]) == 0 ifTrue: [^ Array with: self with: 0]. ^ Array with: (self copyFrom: 1 to: pos - 1) with: (self copyFrom: pos to: self size) asNumber! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 11:13' prior: 33659823! splitInteger "Answer an array that is a splitting of self into a string and an integer. '43Sam' ==> #(43 'Sam'). 'Try90' ==> #('Try' 90) BUT NOTE: 'Sam' ==> #('Sam' 0), and '90' ==> #('' 90) ie, ( )." | pos | (pos _ self findFirst: [:d | d isDigit not]) = 0 ifTrue: [^ Array with: '' with: self asNumber]. self first isDigit ifTrue: [ ^ Array with: (self copyFrom: 1 to: pos - 1) asNumber with: (self copyFrom: pos to: self size)]. (pos _ self findFirst: [:d | d isDigit]) = 0 ifTrue: [^ Array with: self with: 0]. ^ Array with: (self copyFrom: 1 to: pos - 1) with: (self copyFrom: pos to: self size) asNumber! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! stemAndNumericSuffix "Parse the receiver into a string-valued stem and a numeric-valued suffix. 6/7/96 sw" | stem suffix position | stem _ self. suffix _ 0. position _ 1. [stem endsWithDigit and: [stem size > 1]] whileTrue: [suffix _ stem last digitValue * position + suffix. position _ position * 10. stem _ stem copyFrom: 1 to: stem size - 1]. ^ Array with: stem with: suffix "'Fred2305' stemAndNumericSuffix"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! subStrings "Answer an array of the substrings that compose the receiver." #Collectn. "Added 2000/04/08 For ANSI protocol." ^ self substrings! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! subStrings: separators "Answer an array containing the substrings in the receiver separated by the elements of separators." | char result sourceStream subString | #Collectn. "Changed 2000/04/08 For ANSI protocol." (separators allSatisfy: [:element | element isKindOf: Character]) ifFalse: [^ self error: 'separators must be Characters.']. sourceStream := ReadStream on: self. result := OrderedCollection new. subString := String new. [sourceStream atEnd] whileFalse: [char := sourceStream next. (separators includes: char) ifTrue: [subString notEmpty ifTrue: [result add: subString copy. subString := String new]] ifFalse: [subString := subString , (String with: char)]]. subString notEmpty ifTrue: [result add: subString copy]. ^ result asArray! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! substrings "Answer an array of the substrings that compose the receiver." | result end beginning | result _ WriteStream on: (Array new: 10). end _ 0. "find one substring each time through this loop" [ "find the beginning of the next substring" beginning _ self indexOfAnyOf: CSNonSeparators startingAt: end+1 ifAbsent: [ nil ]. beginning ~~ nil ] whileTrue: [ "find the end" end _ self indexOfAnyOf: CSSeparators startingAt: beginning ifAbsent: [ self size + 1 ]. end _ end - 1. result nextPut: (self copyFrom: beginning to: end). ]. ^result contents! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! surroundedBySingleQuotes "Answer the receiver with leading and trailing quotes. " ^ $' asString, self, $' asString! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! translateFrom: start to: stop table: table "translate the characters in the string by the given table, in place" String translate: self from: start to: stop table: table! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:14' prior: 33663767! translateFrom: start to: stop table: table "translate the characters in the string by the given table, in place" self class translate: self from: start to: stop table: table! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! translateToLowercase "Translate all characters to lowercase, in place" self translateWith: LowercasingTable! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! translateToUppercase "Translate all characters to lowercase, in place" self translateWith: UppercasingTable! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! translateWith: table "translate the characters in the string by the given table, in place" ^self translateFrom: 1 to: self size table: table! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:13' prior: 33664654! translateWith: table "translate the characters in the string by the given table, in place" ^ self translateFrom: 1 to: self size table: table! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! truncateTo: smallSize "return myself or a copy shortened to smallSize. 1/18/96 sw" ^ self size <= smallSize ifTrue: [self] ifFalse: [self copyFrom: 1 to: smallSize]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! truncateWithElipsisTo: maxLength "Return myself or a copy suitably shortened but with elipsis added" ^ self size <= maxLength ifTrue: [self] ifFalse: [(self copyFrom: 1 to: (maxLength - 3)), '...'] "'truncateWithElipsisTo:' truncateWithElipsisTo: 20"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! unparenthetically "If the receiver starts with (..( and ends with matching )..), strip them" | curr | curr _ self. [((curr first == $() and: [curr last == $)])] whileTrue: [curr _ curr copyFrom: 2 to: (curr size - 1)]. ^ curr " '((fred the bear))' unparenthetically " ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 11:20' prior: 33665699! unparenthetically "If the receiver starts with (..( and ends with matching )..), strip them" | curr | curr _ self. [((curr first = $() and: [curr last = $)])] whileTrue: [curr _ curr copyFrom: 2 to: (curr size - 1)]. ^ curr " '((fred the bear))' unparenthetically " ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! unzipped | magic1 magic2 | magic1 _ (self at: 1) asInteger. magic2 _ (self at: 2) asInteger. (magic1 = 16r1F and:[magic2 = 16r8B]) ifFalse:[^self]. ^(GZipReadStream on: self) upToEnd! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withBlanksCondensed "Return a copy of the receiver with leading/trailing blanks removed and consecutive white spaces condensed." | trimmed lastBlank | trimmed _ self withBlanksTrimmed. ^String streamContents: [:stream | lastBlank _ false. trimmed do: [:c | (c isSeparator and: [lastBlank]) ifFalse: [stream nextPut: c]. lastBlank _ c isSeparator]]. " ' abc d ' withBlanksCondensed" ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withBlanksTrimmed "Return a copy of the receiver from which leading and trailing blanks have been trimmed." | first | first _ self findFirst: [:c | c isSeparator not]. first = 0 ifTrue: [^ '']. "no non-separator character" ^ self copyFrom: first to: (self findLast: [:c | c isSeparator not]) " ' abc d ' withBlanksTrimmed" ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withFirstCharacterDownshifted "Answer an object like the receiver but with first character downshifted if necesary" "'MElViN' withFirstCharacterDownshifted" "#Will withFirstCharacterDownshifted" | answer | self isEmpty ifTrue: [^ self]. answer _ self isString ifTrue: ["don't change receiver" self copy] ifFalse: [self asString]. answer at: 1 put: (answer at: 1) asLowercase. ^ self isString ifTrue: [answer] ifFalse: [answer as: self class]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/26/2002 20:31' prior: 33667579! withFirstCharacterDownshifted "Answer an object like the receiver but with first character downshifted if necesary" "'MElViN' withFirstCharacterDownshifted" "#Will withFirstCharacterDownshifted" | answer | answer _ self isString ifTrue: ["don't change receiver" self copy] ifFalse: [self asString]. answer at: 1 put: (answer at: 1) asLowercase. ^ self isString ifTrue: [answer] ifFalse: [answer as: self class]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withNoLineLongerThan: aNumber "Answer a string with the same content as receiver, but rewrapped so that no line has more characters than the given number" | listOfLines currentLast currentStart resultString putativeLast putativeLine crPosition | aNumber isNumber not | (aNumber < 1) ifTrue: [self error: 'too narrow']. listOfLines _ OrderedCollection new. currentLast _ 0. [currentLast < self size] whileTrue: [currentStart _ currentLast + 1. putativeLast _ (currentStart + aNumber - 1) min: self size. putativeLine _ self copyFrom: currentStart to: putativeLast. (crPosition _ putativeLine indexOf: Character cr) > 0 ifTrue: [putativeLast _ currentStart + crPosition - 1. putativeLine _ self copyFrom: currentStart to: putativeLast]. currentLast _ putativeLast == self size ifTrue: [putativeLast] ifFalse: [currentStart + putativeLine lastSpacePosition - 1]. currentLast <= currentStart ifTrue: ["line has NO spaces; baleout!!" currentLast _ putativeLast]. listOfLines add: (self copyFrom: currentStart to: currentLast) withBlanksTrimmed]. listOfLines size > 0 ifFalse: [^ '']. resultString _ listOfLines first. 2 to: listOfLines size do: [:i | resultString _ resultString, String cr, (listOfLines at: i)]. ^ resultString "#(5 7 20) collect: [:i | 'Fred the bear went down to the brook to read his book in silence' withNoLineLongerThan: i]"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withSeparatorsCompacted "replace each sequences of whitespace by a single space character" | out pos textEnd | self isEmpty ifTrue: [ ^self ]. out _ WriteStream on: (String new: self size). pos _ 1. "current position in a scan through aString" "handle the case of initial separators" self first isSeparator ifTrue: [ out nextPut: Character space. pos _ self indexOfAnyOf: CSNonSeparators ifAbsent: [ self size + 1 ] ]. "central loop: handle a segment of text, followed possibly by a segment of whitespace" [ pos <= self size ] whileTrue: [ "handle a segment of text..." textEnd _ self indexOfAnyOf: CSSeparators startingAt: pos ifAbsent: [ self size + 1 ]. textEnd _ textEnd - 1. out nextPutAll: (self copyFrom: pos to: textEnd). pos _ textEnd + 1. pos <= self size ifTrue: [ pos _ self indexOfAnyOf: CSNonSeparators startingAt: pos ifAbsent: [ self size + 1 ]. out nextPut: Character space ] ]. ^out contents! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withoutLeadingDigits "Answer the portion of the receiver that follows any leading series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" | firstNonDigit | firstNonDigit _ (self findFirst: [:m | m isDigit not and: [m ~~ $ ]]). ^ firstNonDigit > 0 ifTrue: [self copyFrom: firstNonDigit to: self size] ifFalse: [''] " '234Whoopie' withoutLeadingDigits ' 4321 BlastOff!!' withoutLeadingDigits 'wimpy' withoutLeadingDigits ' 89Ten ' withoutLeadingDigits '78 92' withoutLeadingDigits " ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06' prior: 33671171! withoutLeadingDigits "Answer the portion of the receiver that follows any leading series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" | firstNonDigit | firstNonDigit _ (self findFirst: [:m | m isDigit not and: [m ~= $ ]]). ^ firstNonDigit > 0 ifTrue: [self copyFrom: firstNonDigit to: self size] ifFalse: [''] " '234Whoopie' withoutLeadingDigits ' 4321 BlastOff!!' withoutLeadingDigits 'wimpy' withoutLeadingDigits ' 89Ten ' withoutLeadingDigits '78 92' withoutLeadingDigits " ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withoutTrailingBlanks "Return a copy of the receiver from which trailing blanks have been trimmed." | last | last _ self findLast: [:c | c isSeparator not]. last = 0 ifTrue: [^ '']. "no non-separator character" ^ self copyFrom: 1 to: last " ' abc d ' withoutTrailingBlanks" ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withoutTrailingDigits "Answer the portion of the receiver that precedes any trailing series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" | firstDigit | firstDigit _ (self findFirst: [:m | m isDigit or: [m == $ ]]). ^ firstDigit > 0 ifTrue: [self copyFrom: 1 to: firstDigit-1] ifFalse: [self] " 'Whoopie234' withoutTrailingDigits ' 4321 BlastOff!!' withoutLeadingDigits 'wimpy' withoutLeadingDigits ' 89Ten ' withoutLeadingDigits '78 92' withoutLeadingDigits " ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06' prior: 33672802! withoutTrailingDigits "Answer the portion of the receiver that precedes any trailing series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" | firstDigit | firstDigit _ (self findFirst: [:m | m isDigit or: [m = $ ]]). ^ firstDigit > 0 ifTrue: [self copyFrom: 1 to: firstDigit-1] ifFalse: [self] " 'Whoopie234' withoutTrailingDigits ' 4321 BlastOff!!' withoutLeadingDigits 'wimpy' withoutLeadingDigits ' 89Ten ' withoutLeadingDigits '78 92' withoutLeadingDigits " ! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayAt: aPoint "Display the receiver as a DisplayText at aPoint on the display screen." self displayOn: Display at: aPoint! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayOn: aDisplayMedium "Display the receiver on the given DisplayMedium. 5/16/96 sw" self displayOn: aDisplayMedium at: 0 @ 0! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayOn: aDisplayMedium at: aPoint "Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, using black-colored text." self displayOn: aDisplayMedium at: aPoint textColor: Color black! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayOn: aDisplayMedium at: aPoint textColor: aColor "Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, rendering the text in the designated color" (self asDisplayText foregroundColor: (aColor ifNil: [Color black]) backgroundColor: Color white) displayOn: aDisplayMedium at: aPoint! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayProgressAt: aPoint from: minVal to: maxVal during: workBlock "Display this string as a caption over a progress bar while workBlock is evaluated. EXAMPLE (Select next 6 lines and Do It) 'Now here''s some Real Progress' displayProgressAt: Sensor cursorPoint from: 0 to: 10 during: [:bar | 1 to: 10 do: [:x | bar value: x. (Delay forMilliseconds: 500) wait]]. HOW IT WORKS (Try this in any other language :-) Since your code (the last 2 lines in the above example) is in a block, this method gets control to display its heading before, and clean up the screen after, its execution. The key, though, is that the block is supplied with an argument, named 'bar' in the example, which will update the bar image every it is sent the message value: x, where x is in the from:to: range. " ^ProgressInitiationException display: self at: aPoint from: minVal to: maxVal during: workBlock! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! newTileMorphRepresentative ^ TileMorph new setLiteral: self! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! basicType "Answer a symbol representing the inherent type of the receiver" "Number String Boolean player collection sound color etc" ^ #String! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! encodeDoublingQuoteOn: aStream "Print inside string quotes, doubling inbedded quotes." | x | aStream print: $'. 1 to: self size do: [:i | aStream print: (x _ self at: i). x == $' ifTrue: [aStream print: x]]. aStream print: $'! ! !AbstractString methodsFor: 'printing' stamp: 'yo 8/26/2002 22:57' prior: 33676491! encodeDoublingQuoteOn: aStream "Print inside string quotes, doubling inbedded quotes." | x | aStream print: $'. 1 to: self size do: [:i | aStream print: (x _ self at: i). x = $' ifTrue: [aStream print: x]]. aStream print: $'! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! isLiteral ^true! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! printOn: aStream "Print inside string quotes, doubling inbedded quotes." self storeOn: aStream! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! storeOn: aStream "Print inside string quotes, doubling inbedded quotes." | x | aStream nextPut: $'. 1 to: self size do: [:i | aStream nextPut: (x _ self at: i). x == $' ifTrue: [aStream nextPut: x]]. aStream nextPut: $'! ! !AbstractString methodsFor: 'printing' stamp: 'yo 8/26/2002 22:58' prior: 33677387! storeOn: aStream "Print inside string quotes, doubling inbedded quotes." | x | aStream nextPut: $'. 1 to: self size do: [:i | aStream nextPut: (x _ self at: i). x = $' ifTrue: [aStream nextPut: x]]. aStream nextPut: $'! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! stringRepresentation "Answer a string that represents the receiver. For most objects this is simply its printString, but for strings themselves, it's themselves, to avoid the superfluous extra pair of quotes. 6/12/96 sw" ^ self ! ! !AbstractString methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! correctAgainstEnumerator: wordBlock continuedFrom: oldCollection "The guts of correction, instead of a wordList, there is a block that should take another block and enumerate over some list with it." | choices scoreMin results score maxChoices | scoreMin _ self size // 2 min: 3. maxChoices _ 10. oldCollection isNil ifTrue: [ choices _ SortedCollection sortBlock: [ :x :y | x value > y value ] ] ifFalse: [ choices _ oldCollection ]. wordBlock isNil ifTrue: [ results _ OrderedCollection new. 1 to: (maxChoices min: choices size) do: [ :i | results add: (choices at: i) key ] ] ifFalse: [ wordBlock value: [ :word | (score _ self alike: word) >= scoreMin ifTrue: [ choices add: (Association key: word value: score). (choices size >= maxChoices) ifTrue: [ scoreMin _ (choices at: maxChoices) value] ] ]. results _ choices ]. ^ results! ! !AbstractString methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! evaluateExpression: aString parameters: aCollection "private - evaluate the expression aString with aCollection as the parameters and answer the evaluation result as an string" | index | index := ('0' , aString) asNumber. index isZero ifTrue: [^ '[invalid subscript: {1}]' format: {aString}]. index > aCollection size ifTrue: [^ '[subscript is out of bounds: {1}]' format: {aString}]. ^ (aCollection at: index) asString! ! !AbstractString methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! getEnclosedExpressionFrom: aStream "private - get the expression enclosed between '{' and '}' and remove all the characters from the stream" | result currentChar | result := String new writeStream. [aStream atEnd or: [(currentChar := aStream next) == $}]] whileFalse: [result nextPut: currentChar]. ^ result contents withBlanksTrimmed! ! !AbstractString methodsFor: 'private' stamp: 'yo 8/26/2002 22:53'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !AbstractString methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! stringhash ^self hash! ! !AbstractString methodsFor: 'private' stamp: 'yo 8/28/2002 15:22' prior: 33680698! stringhash ^ self hash. ! ! !AbstractString methodsFor: 'system primitives' stamp: 'yo 11/5/2002 15:32'! compare: string1 with: string2 collated: order "Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array." self subclassResponsibility. ! ! !AbstractString methodsFor: 'system primitives' stamp: 'yo 11/3/2004 19:24'! findSubstring: key in: body startingAt: start matchTable: matchTable "Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned. The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter." | index | self var: #key declareC: 'unsigned char *key'. self var: #body declareC: 'unsigned char *body'. self var: #matchTable declareC: 'unsigned char *matchTable'. key size = 0 ifTrue: [^ 0]. start to: body size - key size + 1 do: [:startIndex | index _ 1. [(matchTable at: (body at: startIndex+index-1) asciiValue + 1) = (matchTable at: (key at: index) asciiValue + 1)] whileTrue: [index = key size ifTrue: [^ startIndex]. index _ index+1]]. ^ 0 " ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 1 matchTable: CaseSensitiveOrder 1 ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 2 matchTable: CaseSensitiveOrder 7 ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 8 matchTable: CaseSensitiveOrder 0 ' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseSensitiveOrder 0 ' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseInsensitiveOrder 7 "! ! !AbstractString methodsFor: 'system primitives' stamp: 'yo 11/3/2004 19:24'! numArgs "Answer either the number of arguments that the receiver would take if considered a selector. Answer -1 if it couldn't be a selector. Note that currently this will answer -1 for anything begining with an uppercase letter even though the system will accept such symbols as selectors. It is intended mostly for the assistance of spelling correction." | firstChar numColons excess start ix | self size = 0 ifTrue: [^ -1]. firstChar _ self at: 1. (firstChar isLetter or: [firstChar = $:]) ifTrue: ["Fast reject if any chars are non-alphanumeric" (self findSubstring: '~' in: self startingAt: 1 matchTable: Tokenish) > 0 ifTrue: [^ -1]. "Fast colon count" numColons _ 0. start _ 1. [(ix _ self findSubstring: ':' in: self startingAt: start matchTable: CaseSensitiveOrder) > 0] whileTrue: [numColons _ numColons + 1. start _ ix + 1]. numColons = 0 ifTrue: [^ 0]. firstChar = $: ifTrue: [excess _ 2 "Has an initial keyword, as #:if:then:else:"] ifFalse: [excess _ 0]. self last = $: ifTrue: [^ numColons - excess] ifFalse: [^ numColons - excess - 1 "Has a final keywords as #nextPut::andCR"]]. firstChar isSpecial ifTrue: [self size = 1 ifTrue: [^ 1]. 2 to: self size do: [:i | (self at: i) isSpecial ifFalse: [^ -1]]. ^ 1]. ^ -1.! ! !AbstractString methodsFor: 'Celeste' stamp: 'yo 11/3/2004 19:24'! withCRs "Return a copy of the receiver in which backslash (\) characters have been replaced with carriage returns." ^ self collect: [ :c | c = $\ ifTrue: [ Character cr ] ifFalse: [ c ]].! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! decodeMimeHeader "See RFC 2047, MIME Part Three: Message Header Extension for Non-ASCII Text. Text containing non-ASCII characters is encoded by the sequence =?character-set?encoding?encoded-text?= Encoding is Q (quoted printable) or B (Base64), handled by Base64MimeConverter / RFC2047MimeConverter. The character-set (usually iso-8859-1) is ignored" | input output temp decoder encoding pos | input _ ReadStream on: self. output _ WriteStream on: String new. [output nextPutAll: (input upTo: $=). "ASCII Text" input atEnd] whileFalse: [ (temp _ input next) = $? ifFalse: [output nextPut: $=; nextPut: temp] ifTrue: [ input skipTo: $?. "Skip charset" encoding _ (input upTo: $?) asUppercase. temp _ input upTo: $?. input next. "Skip final =" decoder _ encoding = 'B' ifTrue: [Base64MimeConverter new] ifFalse: [RFC2047MimeConverter new]. decoder mimeStream: (ReadStream on: temp); dataStream: output; mimeDecode. pos _ input position. input skipSeparators. "Delete spaces if followed by =" input peek = $= ifFalse: [input position: pos]]]. ^output contents! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/23/2003 20:35' prior: 33684339! decodeMimeHeader "See RFC 2047, MIME Part Three: Message Header Extension for Non-ASCII Text. Text containing non-ASCII characters is encoded by the sequence =?character-set?encoding?encoded-text?= Encoding is Q (quoted printable) or B (Base64), handled by Base64MimeConverter / RFC2047MimeConverter. Thanks to Yokokawa-san, it works in m17n package. Try the following: '=?ISO-2022-JP?B?U1dJS0lQT1AvGyRCPUJDKyVpJXMlQRsoQi8=?= =?ISO-2022-JP?B?GyRCJVElRiUjJSobKEIoUGF0aW8p?=' decodeMimeHeader. " | input output temp charset decoder encodedStream encoding pos | input _ ReadStream on: self. output _ WriteStream on: String new. [output nextPutAll: (input upTo: $=). "ASCII Text" input atEnd] whileFalse: [(temp _ input next) = $? ifTrue: [charset _ input upTo: $?. encoding _ (input upTo: $?) asUppercase. temp _ input upTo: $?. input next. "Skip final =" encodedStream _ MultiByteBinaryOrTextStream on: String new encoding: charset. decoder _ encoding = 'B' ifTrue: [Base64MimeConverter new] ifFalse: [RFC2047MimeConverter new]. decoder mimeStream: (ReadStream on: temp); dataStream: encodedStream; mimeDecode. output nextPutAll: encodedStream reset contents. pos _ input position. input skipSeparators. "Delete spaces if followed by =" input peek = $= ifFalse: [input position: pos]] ifFalse: [output nextPut: $=; nextPut: temp]]. ^ output contents! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! decodeQuotedPrintable "Assume receiver is in MIME 'quoted-printable' encoding, and decode it." ^QuotedPrintableMimeConverter mimeDecode: self as: self class! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! isoToSqueak ^ self collect: [:each | each isoToSqueak]! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! isoToUtf8 "Convert ISO 8559-1 to UTF-8" | s v | s _ WriteStream on: (String new: self size). self do: [:c | v _ c asciiValue. (v > 128) ifFalse: [s nextPut: c] ifTrue: [ s nextPut: (192+(v >> 6)) asCharacter. s nextPut: (128+(v bitAnd: 63)) asCharacter]]. ^s contents. ! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! squeakToIso ^self collect: [:c | c squeakToIso ]! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! unescapePercents "change each %XY substring to the character with ASCII value XY in hex. This is the opposite of #encodeForHTTP" | ans c asciiVal pos oldPos specialChars | ans _ WriteStream on: String new. oldPos _ 1. specialChars _ '+%' asCharacterSet. [pos _ self indexOfAnyOf: specialChars startingAt: oldPos. pos > 0] whileTrue: [ ans nextPutAll: (self copyFrom: oldPos to: pos - 1). c _ self at: pos. c = $+ ifTrue: [ans nextPut: $ ] ifFalse: [ (c = $% and: [pos + 2 <= self size]) ifTrue: [ asciiVal _ (self at: pos+1) asUppercase digitValue * 16 + (self at: pos+2) asUppercase digitValue. pos _ pos + 2. asciiVal > 255 ifTrue: [^self]. "not really an escaped string" ans nextPut: (Character value: asciiVal)] ifFalse: [ans nextPut: c]]. oldPos _ pos+1]. ans nextPutAll: (self copyFrom: oldPos to: self size). ^ ans contents! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! utf8ToIso "Only UTF-8 characters that maps to 8-bit ISO-8559-1 values are converted. Others raises an error" | s i c v c2 v2 | s _ WriteStream on: (String new: self size). i _ 1. [i <= self size] whileTrue: [ c _ self at: i. i_i+1. v _ c asciiValue. (v > 128) ifFalse: [ s nextPut: c ] ifTrue: [((v bitAnd: 252) == 192) ifFalse: [self error: 'illegal UTF-8 ISO character'] ifTrue: [ (i > self size) ifTrue: [ self error: 'illegal end-of-string, expected 2nd byte of UTF-8']. c2 _ self at: i. i_i+1. v2 _ c2 asciiValue. ((v2 bitAnd: 192) = 128) ifFalse: [self error: 'illegal 2nd UTF-8 char']. s nextPut: ((v2 bitAnd: 63) bitOr: ((v << 6) bitAnd: 192)) asCharacter]]]. ^s contents. ! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! withInternetLineEndings "change line endings from CR's to CRLF's. This is probably in prepration for sending a string over the Internet" | cr lf | cr _ Character cr. lf _ Character linefeed. ^self class streamContents: [ :stream | self do: [ :c | stream nextPut: c. c = cr ifTrue:[ stream nextPut: lf ]. ] ].! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! withSqueakLineEndings "assume the string is textual, and that CR, LF, and CRLF are all valid line endings. Replace each occurence with a single CR" | cr lf input c crlf inPos outPos outString lineEndPos newOutPos | cr _ Character cr. lf _ Character linefeed. crlf _ CharacterSet new. crlf add: cr; add: lf. inPos _ 1. outPos _ 1. outString _ String new: self size. [ lineEndPos _ self indexOfAnyOf: crlf startingAt: inPos ifAbsent: [0]. lineEndPos ~= 0 ] whileTrue: [ newOutPos _ outPos + (lineEndPos - inPos + 1). outString replaceFrom: outPos to: newOutPos - 2 with: self startingAt: inPos. outString at: newOutPos-1 put: cr. outPos _ newOutPos. ((self at: lineEndPos) = cr and: [ lineEndPos < self size and: [ (self at: lineEndPos+1) = lf ] ]) ifTrue: [ "CRLF ending" inPos _ lineEndPos + 2 ] ifFalse: [ "CR or LF ending" inPos _ lineEndPos + 1 ]. ]. "no more line endings. copy the rest" newOutPos _ outPos + (self size - inPos + 1). outString replaceFrom: outPos to: newOutPos-1 with: self startingAt: inPos. ^outString copyFrom: 1 to: newOutPos-1 ! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! withoutQuoting "remove the initial and final quote marks, if present" "'''h''' withoutQuoting" | quote | self size < 2 ifTrue: [ ^self ]. quote _ self first. (quote = $' or: [ quote = $" ]) ifTrue: [ ^self copyFrom: 2 to: self size - 1 ] ifFalse: [ ^self ].! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! hasContentsInExplorer ^false! ! !AbstractString methodsFor: 'testing' stamp: 'yo 7/29/2003 14:09'! includesUnifiedCharacter self subclassResponsibility. ! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! isAllDigits "whether the receiver is composed entirely of digits" self do: [:c | c isDigit ifFalse: [^ false]]. ^ true! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! isAllSeparators "whether the receiver is composed entirely of separators" self do: [ :c | c isSeparator ifFalse: [ ^false ] ]. ^true! ! !AbstractString methodsFor: 'testing' stamp: 'yo 8/4/2003 12:26'! isAsciiString | c | c _ self detect: [:each | each asciiValue > 127] ifNone: [nil]. ^ c isNil. ! ! !AbstractString methodsFor: 'testing' stamp: 'yo 8/28/2002 15:19'! isOctetString self subclassResponsibility. ! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! isString ^ true! ! !AbstractString methodsFor: 'testing' stamp: 'yo 12/29/2002 10:30'! isUnicodeString ^ false. ! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! lastSpacePosition "Answer the character position of the final space or other separator character in the receiver, and 0 if none" self size to: 1 by: -1 do: [:i | ((self at: i) isSeparator) ifTrue: [^ i]]. ^ 0 " 'fred the bear' lastSpacePosition 'ziggie' lastSpacePosition 'elvis ' lastSpacePosition 'wimpy ' lastSpacePosition '' lastSpacePosition "! ! !AbstractString methodsFor: 'paragraph support' stamp: 'yo 11/3/2004 19:24'! indentationIfBlank: aBlock "Answer the number of leading tabs in the receiver. If there are no visible characters, pass the number of tabs to aBlock and return its value." | reader leadingTabs lastSeparator cr tab ch | cr _ Character cr. tab _ Character tab. reader _ ReadStream on: self. leadingTabs _ 0. [reader atEnd not and: [(ch _ reader next) == tab]] whileTrue: [leadingTabs _ leadingTabs + 1]. lastSeparator _ leadingTabs + 1. [reader atEnd not and: [ch isSeparator and: [ch ~~ cr]]] whileTrue: [lastSeparator _ lastSeparator + 1. ch _ reader next]. lastSeparator = self size | (ch == cr) ifTrue: [^aBlock value: leadingTabs]. ^leadingTabs! ! !AbstractString methodsFor: 'paragraph support' stamp: 'yo 8/26/2002 22:19' prior: 33693208! indentationIfBlank: aBlock "Answer the number of leading tabs in the receiver. If there are no visible characters, pass the number of tabs to aBlock and return its value." | reader leadingTabs lastSeparator cr tab ch | cr _ Character cr. tab _ Character tab. reader _ ReadStream on: self. leadingTabs _ 0. [reader atEnd not and: [(ch _ reader next) = tab]] whileTrue: [leadingTabs _ leadingTabs + 1]. lastSeparator _ leadingTabs + 1. [reader atEnd not and: [ch isSeparator and: [ch ~= cr]]] whileTrue: [lastSeparator _ lastSeparator + 1. ch _ reader next]. lastSeparator = self size | (ch = cr) ifTrue: [^aBlock value: leadingTabs]. ^ leadingTabs. ! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! * arg ^ arg adaptToString: self andSend: #*! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! + arg ^ arg adaptToString: self andSend: #+! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! - arg ^ arg adaptToString: self andSend: #-! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! / arg ^ arg adaptToString: self andSend: #/! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! // arg ^ arg adaptToString: self andSend: #//! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! \\ arg ^ arg adaptToString: self andSend: #\\! ! !AbstractString methodsFor: 'filter streaming' stamp: 'yo 11/3/2004 19:24'! byteEncode:aStream ^aStream writeString:self.! ! !AbstractString methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31' prior: 33695448! byteEncode:aStream ^aStream writeString: self. ! ! !AbstractString methodsFor: 'filter streaming' stamp: 'yo 11/3/2004 19:24'! putOn:aStream ^aStream nextPutAll:self. ! ! !AbstractString methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31' prior: 33695721! putOn:aStream ^aStream nextPutAll: self. ! ! !AbstractString methodsFor: 'encoding' stamp: 'yo 11/3/2004 19:24'! getInteger32: location | integer | "^IntegerPokerPlugin doPrimitive: #getInteger" "the following is about 7x faster than interpreting the plugin if not compiled" integer := ((self byteAt: location) bitShift: 24) + ((self byteAt: location+1) bitShift: 16) + ((self byteAt: location+2) bitShift: 8) + (self byteAt: location+3). integer > 1073741824 ifTrue: [ ^1073741824 - integer ]. ^integer ! ! !AbstractString methodsFor: 'encoding' stamp: 'yo 11/3/2004 19:24'! putInteger32: anInteger at: location | integer | "IntegerPokerPlugin doPrimitive: #putInteger" "the following is close to 20x faster than the above if the primitive is not compiled" "PUTCOUNTER _ PUTCOUNTER + 1." integer _ anInteger. integer < 0 ifTrue: [integer := 1073741824 - integer. ]. self byteAt: location+3 put: (integer \\ 256). self byteAt: location+2 put: (integer bitShift: -8) \\ 256. self byteAt: location+1 put: (integer bitShift: -16) \\ 256. self byteAt: location put: (integer bitShift: -24) \\ 256. "Smalltalk at: #PUTCOUNTER put: 0"! ! !AbstractString methodsFor: 'user interface' stamp: 'yo 11/3/2004 19:24'! asExplorerString ^ self printString! ! !AbstractString methodsFor: 'user interface' stamp: 'yo 8/26/2002 22:20' prior: 33697215! asExplorerString ^ self asString! ! !AbstractString methodsFor: 'user interface' stamp: 'yo 11/3/2004 19:24'! openInWorkspaceWithTitle: aTitle "Open up a workspace with the receiver as its contents, with the given title" (Workspace new contents: self) openLabel: aTitle! ! !AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 11/3/2004 19:24'! sunitAsSymbol ^self asSymbol! ! !AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 8/26/2002 20:31' prior: 33697700! sunitAsSymbol ^self asSymbol! ! !AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 11/3/2004 19:24'! sunitMatch: aString ^self match: aString! ! !AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 8/26/2002 20:31' prior: 33697951! sunitMatch: aString ^self match: aString! ! !AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 11/3/2004 19:24'! sunitSubStrings ^self substrings! ! !AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 8/26/2002 20:31' prior: 33698226! sunitSubStrings ^self substrings! ! !AbstractString methodsFor: '*packageinfo-base' stamp: 'yo 11/3/2004 19:24'! escapeEntities ^ String streamContents: [:s | self do: [:c | s nextPutAll: c escapeEntities]] ! ! !AbstractString methodsFor: 'translating' stamp: 'yo 11/3/2004 19:24'! translated "answer the receiver translated to the default language" ^ Language defaultLanguage translationFor: self! ! !AbstractString methodsFor: 'translating' stamp: 'yo 11/3/2004 19:24'! translatedTo: languageNameSymbol "answer the receiver translated to the language named languageNameSymbol " ^ (Language languageNamed: languageNameSymbol) translationFor: self! ! !AbstractString methodsFor: 'formatting' stamp: 'yo 11/3/2004 19:24'! format: aCollection "format the receiver with aCollection simplest example: 'foo {1} bar' format: {Date today}. complete example: '\{ \} \\ foo {1} bar {2}' format: {12. 'string'}. " | result stream | result := String new writeStream. stream := self readStream. [stream atEnd] whileFalse: [| currentChar | currentChar := stream next. currentChar == ${ ifTrue: [| expression | expression := self getEnclosedExpressionFrom: stream. result nextPutAll: (self evaluateExpression: expression parameters: aCollection)] ifFalse: [ currentChar == $\ ifTrue: [stream atEnd ifFalse: [result nextPut: stream next]] ifFalse: [result nextPut: currentChar]]]. ^ result contents! ! !AbstractString methodsFor: '*morphic-Postscript Canvases' stamp: 'yo 11/3/2004 19:24'! asPostscript | temp | temp _ self asString copyReplaceAll: '(' with: '\('. temp _ temp copyReplaceAll: ')' with: '\)'. temp _ temp copyReplaceAll: ' ' with: ''. ^ PostscriptEncoder mapMacStringToPS: temp! ! !AbstractString methodsFor: '*versionnumber' stamp: 'yo 11/3/2004 19:24'! asVersion "Answer a VersionNumber" ^VersionNumber fromString: self! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 14:50'! correspondingSymbolClass ^ self subclassResponsibility. ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! cr "Answer a string containing a single carriage return character." ^ self with: Character cr ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! crlf "Answer a string containing a carriage return and a linefeed." ^ self with: Character cr with: Character lf ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! crlfcrlf ^self crlf , self crlf. ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! fromPacked: aLong "Convert from a longinteger to a String of length 4." | s | s _ self new: 4. s at: 1 put: (aLong digitAt: 4) asCharacter. s at: 2 put: (aLong digitAt: 3) asCharacter. s at: 3 put: (aLong digitAt: 2) asCharacter. s at: 4 put: (aLong digitAt: 1) asCharacter. ^s "String fromPacked: 'TEXT' asPacked" ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! fromString: aString "Answer an instance of me that is a copy of the argument, aString." ^ aString copyFrom: 1 to: aString size! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! lf "Answer a string containing a single carriage return character." ^ self with: Character lf! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! readFrom: inStream "Answer an instance of me that is determined by reading the stream, inStream. Embedded double quotes become the quote Character." | outStream char done | outStream _ WriteStream on: (String new: 16). "go to first quote" inStream skipTo: $'. done _ false. [done or: [inStream atEnd]] whileFalse: [char _ inStream next. char = $' ifTrue: [char _ inStream next. char = $' ifTrue: [outStream nextPut: char] ifFalse: [done _ true]] ifFalse: [outStream nextPut: char]]. ^outStream contents! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:27' prior: 33701876! readFrom: inStream "Answer an instance of me that is determined by reading the stream, inStream. Embedded double quotes become the quote Character." | outStream char done | outStream _ WriteStream on: (self new: 16). "go to first quote" inStream skipTo: $'. done _ false. [done or: [inStream atEnd]] whileFalse: [char _ inStream next. char = $' ifTrue: [char _ inStream next. char = $' ifTrue: [outStream nextPut: char] ifFalse: [done _ true]] ifFalse: [outStream nextPut: char]]. ^outStream contents! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! tab "Answer a string containing a single tab character." ^ self with: Character tab ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! value: anInteger ^self with: (Character value: anInteger)! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:29' prior: 33703347! value: anInteger ^ self with: (Character value: anInteger). ! ! !AbstractString class methodsFor: 'initialization' stamp: 'yo 11/3/2004 19:24'! initialize "String initialize" | order | AsciiOrder _ (0 to: 255) as: ByteArray. CaseInsensitiveOrder _ AsciiOrder copy. ($a to: $z) do: [:c | CaseInsensitiveOrder at: c asciiValue + 1 put: (CaseInsensitiveOrder at: c asUppercase asciiValue +1)]. "Case-sensitive compare sorts space, digits, letters, all the rest..." CaseSensitiveOrder _ ByteArray new: 256 withAll: 255. order _ -1. ' 0123456789' do: "0..10" [:c | CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)]. ($a to: $z) do: "11-64" [:c | CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order _ order+1). CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)]. 1 to: CaseSensitiveOrder size do: [:i | (CaseSensitiveOrder at: i) = 255 ifTrue: [CaseSensitiveOrder at: i put: (order _ order+1)]]. order = 255 ifFalse: [self error: 'order problem']. "a table for translating to lower case" LowercasingTable _ String withAll: (Character allCharacters collect: [:c | c asLowercase]). "a table for translating to upper case" UppercasingTable _ String withAll: (Character allCharacters collect: [:c | c asUppercase]). "a table for testing tokenish (for fast numArgs)" Tokenish _ String withAll: (Character allCharacters collect: [:c | c tokenish ifTrue: [c] ifFalse: [$~]]). "CR and LF--characters that terminate a line" CSLineEnders _ CharacterSet empty. CSLineEnders add: Character cr. CSLineEnders add: Character lf. "separators and non-separators" CSSeparators _ CharacterSet separators. CSNonSeparators _ CSSeparators complement.! ! !AbstractString class methodsFor: 'initialization' stamp: 'yo 8/28/2002 13:31' prior: 33703656! initialize "self initialize" | order | AsciiOrder _ (0 to: 255) as: ByteArray. CaseInsensitiveOrder _ AsciiOrder copy. ($a to: $z) do: [:c | CaseInsensitiveOrder at: c asciiValue + 1 put: (CaseInsensitiveOrder at: c asUppercase asciiValue +1)]. "Case-sensitive compare sorts space, digits, letters, all the rest..." CaseSensitiveOrder _ ByteArray new: 256 withAll: 255. order _ -1. ' 0123456789' do: "0..10" [:c | CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)]. ($a to: $z) do: "11-64" [:c | CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order _ order+1). CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)]. 1 to: CaseSensitiveOrder size do: [:i | (CaseSensitiveOrder at: i) = 255 ifTrue: [CaseSensitiveOrder at: i put: (order _ order+1)]]. order = 255 ifFalse: [self error: 'order problem']. "a table for translating to lower case" LowercasingTable _ String withAll: (Character allCharacters collect: [:c | c asLowercase]). "a table for translating to upper case" UppercasingTable _ String withAll: (Character allCharacters collect: [:c | c asUppercase]). "a table for testing tokenish (for fast numArgs)" Tokenish _ String withAll: (Character allCharacters collect: [:c | c tokenish ifTrue: [c] ifFalse: [$~]]). "CR and LF--characters that terminate a line" CSLineEnders _ CharacterSet empty. CSLineEnders add: Character cr. CSLineEnders add: Character lf. "separators and non-separators" CSSeparators _ CharacterSet separators. CSNonSeparators _ CSSeparators complement.! ! !AbstractString class methodsFor: 'initialization' stamp: 'yo 11/3/2004 19:24'! initializeHtmlEntities "String initializeHtmlEntities" HtmlEntities _ (Dictionary new: 128) at: 'amp' put: $&; at: 'lt' put: $<; at: 'gt' put: $>; at: 'quot' put: $"; at: 'euro' put: Character euro; yourself. #('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo: [:each :index | "filter out base characters CdG 1/8/2004 15:17" | char | char _ (index + 159) asCharacter isoToSqueak. char >= (Character value: 128) ifTrue: [ HtmlEntities at: each put: char]]! ! !AbstractString class methodsFor: 'initialization' stamp: 'yo 8/11/2003 21:11' prior: 33707006! initializeHtmlEntities "self initializeHtmlEntities" HtmlEntities _ (Dictionary new: 128) at: 'amp' put: $&; at: 'lt' put: $<; at: 'gt' put: $>; at: 'quot' put: $"; at: 'euro' put: Character euro; yourself. #('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo: [:each :index | HtmlEntities at: each put: (index + 159) asCharacter]! ! !AbstractString class methodsFor: 'examples' stamp: 'yo 11/3/2004 19:24'! example "To see the string displayed at the cursor point, execute this expression and select a point by pressing a mouse button." 'this is some text' displayOn: Display at: Sensor waitButton! ! !AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:32'! findFirstInString: aString inSet: inclusionMap startingAt: start self subclassResponsibility. ! ! !AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:06'! indexOfAscii: anInteger inString: aString startingAt: start self subclassResponsibility. ! ! !AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:32'! stringHash: aString initialHash: speciesHash self subclassResponsibility. ! ! !AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:32'! translate: aString from: start to: stop table: table self subclassResponsibility. ! ! !AcceptableCleanTextMorph methodsFor: 'menu commands' stamp: 'dgd 2/21/2003 22:50' prior: 16902486! accept "Overridden to allow accept of clean text" | textToAccept ok | textToAccept := textMorph asText. ok := setTextSelector isNil or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: textToAccept with: self] ifFalse: [model perform: setTextSelector with: textToAccept]]. ok ifTrue: [self setText: self getText. self hasUnacceptedEdits: false]! ! !AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 6/7/2003 09:56'! checkName: aFileName fixErrors: fixing "Check if the file name contains any invalid characters" | fName badChars hasBadChars | fName _ super checkName: aFileName fixErrors: fixing. badChars _ #( $# $: $< $> $| $? $* $") asSet. hasBadChars _ fName includesAnyOf: badChars. (hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name']. hasBadChars ifFalse:[^ fName]. ^ fName collect: [:char | (badChars includes: char) ifTrue:[$!!] ifFalse:[char]]! ! !AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 8/2/2003 19:34' prior: 33710991! checkName: aFileName fixErrors: fixing "Check if the file name contains any invalid characters" | fName badChars hasBadChars | fName _ super checkName: aFileName fixErrors: fixing. badChars _ #( $# $: $< $> $| $? $* $" $%) asSet. hasBadChars _ fName includesAnyOf: badChars. (hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name']. hasBadChars ifFalse:[^ fName]. ^ fName collect: [:char | (badChars includes: char) ifTrue:[$!!] ifFalse:[char]]! ! !AcornFileDirectory methodsFor: 'private' stamp: 'tpr 12/21/2002 13:37'! directoryContentsFor: fullPath "Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details." "FileDirectory default directoryContentsFor: ''" | entries extraPath | entries _ super directoryContentsFor: fullPath. fullPath isEmpty ifTrue: [ "For Acorn we also make sure that at least the parent of the current dir is added - sometimes this is in a filing system that has not been (or cannot be) polled for disc root names" extraPath _ self class default containingDirectory. (entries findFirst: [:ent | ent name = extraPath fullName] ) > 0 ifFalse: [entries _ entries copyWith: (DirectoryEntry name: extraPath fullName creationTime: 0 modificationTime: 0 isDirectory: true fileSize: 0)]]. ^ entries ! ! !AcornFileDirectory methodsFor: 'testing' stamp: 'tpr 12/3/2002 19:35'! directoryExists: filenameOrPath "if the path is a root,we have to treat it carefully" (filenameOrPath endsWith: '$') ifTrue:[^(FileDirectory on: filenameOrPath) exists]. ^super directoryExists: filenameOrPath! ! !AcornFileDirectory methodsFor: 'testing' stamp: 'tpr 4/28/2004 21:54' prior: 33713094! directoryExists: filenameOrPath "if the path is a root,we have to treat it carefully" (filenameOrPath endsWith: '$') ifTrue:[^(FileDirectory on: filenameOrPath) exists]. ^(self directoryNamed: filenameOrPath ) exists! ! !AcornFileDirectory methodsFor: 'path access' stamp: 'tpr 11/30/2003 21:42'! pathParts "Return the path from the root of the file system to this directory as an array of directory names. This version tries to cope with the RISC OS' strange filename formatting; filesystem::discname/$/path/to/file where the $ needs to be considered part of the filingsystem-discname atom." | pathList | pathList := super pathParts. (pathList indexOf: '$') = 2 ifTrue: ["if the second atom is root ($) then stick $ on the first atom and drop the second. Yuck" ^ Array streamContents: [:a | a nextPut: (pathList at: 1), '/$'. 3 to: pathList size do: [:i | a nextPut: (pathList at: i)]]]. ^ pathList! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:16' prior: 16903456! isActiveDirectoryClass "Does this class claim to be that properly active subclass of FileDirectory for the current platform? On Acorn, the test is whether platformName is 'RiscOS' (on newer VMs) or if the primPathNameDelimiter is $. (on older ones), which is what we would like to use for a dirsep if only it would work out. See pathNameDelimiter for more woeful details - then just get on and enjoy Squeak" ^ SmalltalkImage current platformName = 'RiscOS' or: [self primPathNameDelimiter = $.]! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'tpr 8/1/2003 16:38'! isCaseSensitive "Risc OS ignores the case of file names" ^ false! ! !ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:12'! asActionSequence ^self! ! !ActionSequence methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'! asActionSequenceTrappingErrors ^WeakActionSequenceTrappingErrors withAll: self! ! !ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:28'! asMinimalRepresentation self size = 0 ifTrue: [^nil]. self size = 1 ifTrue: [^self first]. ^self! ! !ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:51'! value "Answer the result of evaluating the elements of the receiver." | answer | self do: [:each | answer := each value]. ^answer! ! !ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:52'! valueWithArguments: anArray | answer | self do: [:each | answer := each valueWithArguments: anArray]. ^answer! ! !ActionSequence methodsFor: 'printing' stamp: 'SqR 07/28/2001 18:25'! printOn: aStream self size < 2 ifTrue: [^super printOn: aStream]. aStream nextPutAll: '#('. self do: [:each | each printOn: aStream] separatedBy: [aStream cr]. aStream nextPut: $)! ! !ActorState methodsFor: 'pen' stamp: 'nk 6/12/2004 16:36' prior: 16912750! choosePenColor: evt owningPlayer costume changeColorTarget: owningPlayer costume selector: #penColor: originalColor: owningPlayer getPenColor hand: evt hand.! ! !ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:42'! getPenArrowheads ^ penArrowheads == true! ! !ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:43'! setPenArrowheads: aBoolean penArrowheads _ aBoolean! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/16/2003 12:26'! trailStyle "Answer the receiver's trailStyle. For backward compatibility, if the old penArrowheads slot is in found to be set, use it as a guide for initialization" ^ trailStyle ifNil: [trailStyle _ penArrowheads == true ifTrue: [#arrows] ifFalse: [#lines]]! ! !ActorState methodsFor: 'pen' stamp: 'sw 3/11/2003 11:28'! trailStyle: aSymbol "Set the trail style to the given symbol" trailStyle _ aSymbol! ! !AddedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'! isAdded ^true! ! !AddedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'! printEventKindOn: aStream aStream nextPutAll: 'Added'! ! !AddedEvent class methodsFor: 'accessing' stamp: 'rw 7/19/2003 09:52'! changeKind ^#Added! ! !AddedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:22'! supportedKinds "All the kinds of items that this event can take." ^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:49'! addGeeMailMenuItemsTo: menu self flag: #convertToBook. "<-- no longer used" menu addUpdating: #showPageBreaksString action: #togglePageBreaks; addUpdating: #keepScrollbarString action: #toggleKeepScrollbar; addLine; add: 'Print...' action: #printPSToFile; addLine. thePasteUp allTextPlusMorphs size = 1 ifTrue: [ menu add: 'make 1-column book' selector: #makeBookStyle: argument: 1. menu add: 'make 2-column book' selector: #makeBookStyle: argument: 2. menu add: 'make 3-column book' selector: #makeBookStyle: argument: 3. menu add: 'make 4-column book' selector: #makeBookStyle: argument: 4. ] ifFalse: [ menu add: 'make a galley of me' action: #makeGalleyStyle. ]. ^menu! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/30/2003 20:50' prior: 33717857! addGeeMailMenuItemsTo: menu self flag: #convertToBook. "<-- no longer used" menu addUpdating: #showPageBreaksString action: #togglePageBreaks; addUpdating: #keepScrollbarString action: #toggleKeepScrollbar; addLine; add: 'Print...' translated action: #printPSToFile; addLine. thePasteUp allTextPlusMorphs size = 1 ifTrue: [ menu add: 'make 1-column book' translated selector: #makeBookStyle: argument: 1. menu add: 'make 2-column book' translated selector: #makeBookStyle: argument: 2. menu add: 'make 3-column book' translated selector: #makeBookStyle: argument: 3. menu add: 'make 4-column book' translated selector: #makeBookStyle: argument: 4. ] ifFalse: [ menu add: 'make a galley of me' translated action: #makeGalleyStyle. ]. ^menu! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:42'! allTextPlusMorphs ^thePasteUp allTextPlusMorphs! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:57'! keepScrollBarAlways ^self valueOfProperty: #keepScrollBarAlways ifAbsent: [false]! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:59'! keepScrollbarString ^self keepScrollBarAlways ifTrue: ['scrollbar stays up'] ifFalse: ['scrollbar stays up']! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/5/2001 11:15'! makeBookStyle: nColumns | all totalWidth second columnWidth currY prev columnHeight currX currColumn pageBreakRectangles r rm columnGap pageGap starter | pageBreakRectangles _ OrderedCollection new. all _ thePasteUp allTextPlusMorphs. all size = 1 ifFalse: [^self]. Cursor wait show. starter _ prev _ all first. totalWidth _ self width - 16. columnGap _ 32. pageGap _ 16. columnWidth _ totalWidth - (columnGap * (nColumns - 1)) // nColumns. columnHeight _ self height - 12. currY _ 4. currX _ 4. currColumn _ 1. prev position: currX@currY; width: columnWidth. [ second _ prev makeSuccessorMorph. thePasteUp addMorphBack: second. prev setProperty: #autoFitContents toValue: false; height: columnHeight. (currColumn _ currColumn + 1) <= nColumns ifTrue: [ currX _ currX + columnWidth + columnGap. ] ifFalse: [ r _ 4@(prev bottom + 4) corner: (self right - 4 @ (prev bottom + pageGap - 4)). rm _ RectangleMorph new bounds: r; color: (Color gray alpha: 0.3); borderWidth: 0. pageBreakRectangles add: rm beSticky. thePasteUp addMorphBack: rm. currColumn _ 1. currX _ 4. currY _ prev bottom + pageGap. ]. second autoFit: true; position: currX@currY; width: columnWidth. prev recomposeChain. "was commented" prev _ second. prev height > columnHeight ] whileTrue. prev autoFit: true. thePasteUp height: (prev bottom + 20 - self top). self layoutChanged. self setProperty: #pageBreakRectangles toValue: pageBreakRectangles. thePasteUp allTextPlusMorphs do: [ :each | each repositionAnchoredMorphs ]. Cursor normal show. ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2001 12:12'! makeGalleyStyle | all first theRest | (self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]) do: [ :each | each delete ]. self removeProperty: #pageBreakRectangles. all _ thePasteUp allTextPlusMorphs. first _ all select: [ :x | x predecessor isNil]. first size = 1 ifFalse: [^self]. Cursor wait show. first _ first first. theRest _ all reject: [ :x | x predecessor isNil]. theRest do: [ :each | each delete]. first autoFit: true. first width: self width - 8. first recomposeChain. first repositionAnchoredMorphs. Cursor normal show. ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:25'! pageRectanglesForPrinting | pageBreaks prevBottom pageRects r | pageBreaks _ self valueOfProperty: #pageBreakRectangles ifAbsent: [^nil]. prevBottom _ 0. pageRects _ pageBreaks collect: [ :each | r _ 0@prevBottom corner: self width @ each top. prevBottom _ each bottom. r ]. pageRects add: (0@prevBottom corner: self width @ thePasteUp bottom). ^pageRects! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 09:21'! scrollSelectionIntoView: event alignTop: alignTop inTextMorph: tm "Scroll my text into view if necessary and return true, else return false" | selRects delta selRect rectToTest transform cpHere | selRects _ tm paragraph selectionRects. selRects isEmpty ifTrue: [^ false]. rectToTest _ selRects first merge: selRects last. transform _ scroller transformFrom: self. (event notNil and: [event isMouse and: [event anyButtonPressed]]) ifTrue: "Check for autoscroll" [cpHere _ transform localPointToGlobal: event cursorPoint. cpHere y <= self top ifTrue: [rectToTest _ selRects first topLeft extent: 2@2] ifFalse: [cpHere y >= self bottom ifTrue: [rectToTest _ selRects last bottomRight extent: 2@2] ifFalse: [^ false]]]. selRect _ transform localBoundsToGlobal: rectToTest. selRect height > bounds height ifTrue: [^ false]. "Would not fit, even if we tried to scroll" alignTop ifTrue: [ self scrollBy: 0@(bounds top - selRect top). ^ true ]. selRect bottom > bounds bottom ifTrue: [ self scrollBy: 0@(bounds bottom - selRect bottom - 30). ^ true ]. (delta _ selRect amountToTranslateWithin: self bounds) y ~= 0 ifTrue: [ "Scroll end of selection into view if necessary" self scrollBy: 0@delta y. ^ true]. ^ false! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 13:06'! scrollToPage: pageNumber | rects oneRect | rects _ self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]. oneRect _ rects at: pageNumber - 1 ifAbsent: [0@0 extent: 0@0]. self scrollToYAbsolute: oneRect bottom. ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 13:01'! scrollToYAbsolute: yValue | transform transformedPoint | transform _ scroller transformFrom: self. transformedPoint _ transform localPointToGlobal: 0@yValue. self scrollBy: 0@(bounds top - transformedPoint y). ! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:10'! showPageBreaksString ^(thePasteUp ifNil: [^'???']) showPageBreaksString! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:58'! toggleKeepScrollbar self setProperty: #keepScrollBarAlways toValue: self keepScrollBarAlways not! ! !AlansTextPlusMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:12'! togglePageBreaks (thePasteUp ifNil: [^self]) togglePageBreaks! ! !AlansTextPlusMorph methodsFor: 'event handling' stamp: 'RAA 5/3/2001 17:33'! handlesMouseDown: evt ^evt yellowButtonPressed ! ! !AlansTextPlusMorph methodsFor: 'geometry' stamp: 'JW 2/21/2001 22:54'! extraScrollRange ^ bounds height ! ! !AlansTextPlusMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !AlansTextPlusMorph methodsFor: 'initialization' stamp: 'RAA 5/2/2001 14:11'! initialize super initialize. color _ Color white. thePasteUp _ TextPlusPasteUpMorph new borderWidth: 0; color: color. scroller addMorph: thePasteUp. self position: 100@100. self extent: Display extent // 3. self useRoundedCorners. ! ! !AlansTextPlusMorph methodsFor: 'initialization' stamp: 'gm 3/10/2003 22:58' prior: 33725704! initialize "initialize the state of the receiver" super initialize. "" self initializeThePasteUp. self position: 100@100. self extent: Display extent // 3. self useRoundedCorners. ! ! !AlansTextPlusMorph methodsFor: 'initialization' stamp: 'jam 3/9/2003 16:38'! initializeThePasteUp "initialize the receiver's thePasteUp" thePasteUp _ TextPlusPasteUpMorph new borderWidth: 0; color: color. scroller addMorph: thePasteUp! ! !AlansTextPlusMorph methodsFor: 'layout' stamp: 'RAA 3/5/2001 23:19'! doLayoutIn: layoutBounds "layout has changed. update scroll deltas or whatever else" self adjustPasteUpSize. scroller ifNotNil: [self setScrollDeltas]. super doLayoutIn: layoutBounds. ! ! !AlansTextPlusMorph methodsFor: 'menu' stamp: 'RAA 5/3/2001 17:50'! getMenu: shiftKeyState | menu | self flag: #convertToBook. "<-- no longer used" menu _ MenuMorph new defaultTarget: self. self addGeeMailMenuItemsTo: menu. ^menu! ! !AlansTextPlusMorph methodsFor: 'menus' stamp: 'RAA 5/3/2001 17:50'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. self addGeeMailMenuItemsTo: aCustomMenu.! ! !AlansTextPlusMorph methodsFor: 'scroll bar events' stamp: 'RAA 5/3/2001 16:16'! scrollBarValue: scrollValue | newPt pageBreaks topOfPage | scroller hasSubmorphs ifFalse: [^ self]. newPt _ -3 @ (self leftoverScrollRange * scrollValue). pageBreaks _ self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]. pageBreaks isEmpty ifTrue: [ ^scroller offset: newPt. ]. topOfPage _ pageBreaks inject: (0@0 corner: 0@0) into: [ :closest :each | (each bottom - newPt y) abs < (closest bottom - newPt y) abs ifTrue: [ each ] ifFalse: [ closest ]. ]. topOfPage ifNotNil: [ newPt _ newPt x @ topOfPage bottom. scrollBar value: newPt y / self leftoverScrollRange. ]. scroller offset: newPt.! ! !AlansTextPlusMorph methodsFor: 'scroll bar events' stamp: 'nk 4/28/2004 10:22' prior: 33727291! scrollBarValue: scrollValue | newPt pageBreaks topOfPage | scroller hasSubmorphs ifFalse: [^ self]. newPt _ -3 @ (self vLeftoverScrollRange * scrollValue). pageBreaks _ self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]. pageBreaks isEmpty ifTrue: [ ^scroller offset: newPt. ]. topOfPage _ pageBreaks inject: (0@0 corner: 0@0) into: [ :closest :each | (each bottom - newPt y) abs < (closest bottom - newPt y) abs ifTrue: [ each ] ifFalse: [ closest ]. ]. topOfPage ifNotNil: [ newPt _ newPt x @ topOfPage bottom. scrollBar value: newPt y / self vLeftoverScrollRange. ]. scroller offset: newPt.! ! !AlansTextPlusMorph methodsFor: 'scrolling' stamp: 'nk 4/28/2004 10:14'! vHideScrollBar self keepScrollBarAlways ifTrue: [^self]. ^super vHideScrollBar! ! !AlansTextPlusMorph methodsFor: '*morphic-Postscript Canvases' stamp: 'RAA 5/7/2001 12:20'! printPSToFile thePasteUp printer geeMail: self; doPages! ! !AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'! defaultColor "answer the default color/fill style for the receiver" ^ Color red! ! !AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11' prior: 16933662! initialize "initialize the state of the receiver" super initialize. "" self extent: 25 @ 25. ! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'sw 8/12/2001 02:48'! basicInitialize "Do basic generic initialization of the instance variables" super basicInitialize. borderWidth _ 0. self layoutPolicy: TableLayout new. self listDirection: #leftToRight. self wrapCentering: #topLeft. self hResizing: #spaceFill. self vResizing: #spaceFill. self layoutInset: 2. color _ Color r: 0.8 g: 1.0 b: 0.8. self rubberBandCells: true.! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:02' prior: 33729549! basicInitialize "Do basic generic initialization of the instance variables" super basicInitialize. "" self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2; rubberBandCells: true! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.8! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:19' prior: 16989545! initialize "initialize the state of the receiver" super initialize. "" self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2; rubberBandCells: true! ! !AlignmentMorph methodsFor: 'object fileIn' stamp: 'gm 2/22/2003 13:12' prior: 16990771! convertOldAlignmentsNov2000: varDict using: smartRefStrm "major change - much of AlignmentMorph is now implemented more generally in Morph" "These are going away #('orientation' 'centering' 'hResizing' 'vResizing' 'inset' 'minCellSize' 'layoutNeeded' 'priorFullBounds')" | orientation centering hResizing vResizing inset minCellSize inAlignment | orientation := varDict at: 'orientation'. centering := varDict at: 'centering'. hResizing := varDict at: 'hResizing'. vResizing := varDict at: 'vResizing'. inset := varDict at: 'inset'. minCellSize := varDict at: 'minCellSize'. (orientation == #horizontal or: [orientation == #vertical]) ifTrue: [self layoutPolicy: TableLayout new]. self cellPositioning: #topLeft. self rubberBandCells: true. orientation == #horizontal ifTrue: [self listDirection: #leftToRight]. orientation == #vertical ifTrue: [self listDirection: #topToBottom]. centering == #topLeft ifTrue: [self wrapCentering: #topLeft]. centering == #bottomRight ifTrue: [self wrapCentering: #bottomRight]. centering == #center ifTrue: [self wrapCentering: #center. orientation == #horizontal ifTrue: [self cellPositioning: #leftCenter] ifFalse: [self cellPositioning: #topCenter]]. (inset isNumber or: [inset isPoint]) ifTrue: [self layoutInset: inset]. (minCellSize isNumber or: [minCellSize isPoint]) ifTrue: [self minCellSize: minCellSize]. (self hasProperty: #clipToOwnerWidth) ifTrue: [self clipSubmorphs: true]. "now figure out if our owner was an AlignmentMorph, even if it is reshaped..." inAlignment := false. owner isMorph ifTrue: [(owner isAlignmentMorph) ifTrue: [inAlignment := true]] ifFalse: ["e.g., owner may be reshaped" (owner class instanceVariablesString findString: 'orientation centering hResizing vResizing') > 0 ifTrue: ["this was an alignment morph being reshaped" inAlignment := true]]. "And check for containment in system windows" owner isSystemWindow ifTrue: [inAlignment := true]. (hResizing == #spaceFill and: [inAlignment not]) ifTrue: [self hResizing: #shrinkWrap] ifFalse: [self hResizing: hResizing]. (vResizing == #spaceFill and: [inAlignment not]) ifTrue: [self vResizing: #shrinkWrap] ifFalse: [self vResizing: vResizing]! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'sw 11/5/2001 15:11'! canHaveFillStyles "Return true if the receiver can have general fill styles; not just colors. This method is for gradually converting old morphs." ^ self class == AlignmentMorph "no subclasses"! ! !AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25' prior: 0! Used for layout. Since all morphs now support layoutPolicy the main use of this class is no longer needed. Kept around for compability. Supports a few methods not found elsewhere that can be convenient, eg. newRow ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/16/2001 09:34'! columnPrototype "Answer a prototypical column" | sampleMorphs aColumn | sampleMorphs _ #(red yellow green) collect: [:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself]. aColumn _ self inAColumn: sampleMorphs. aColumn setNameTo: 'Column'. aColumn color: Color veryVeryLightGray. aColumn cellInset: 4; layoutInset: 6. aColumn enableDragNDrop. aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!'. ^ aColumn! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05' prior: 33734018! columnPrototype "Answer a prototypical column" | sampleMorphs aColumn | sampleMorphs _ #(red yellow green) collect: [:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself]. aColumn _ self inAColumn: sampleMorphs. aColumn setNameTo: 'Column'. aColumn color: Color veryVeryLightGray. aColumn cellInset: 4; layoutInset: 6. aColumn enableDragNDrop. aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!' translated. ^ aColumn! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/2/2001 04:45'! inAColumn: aCollectionOfMorphs "Answer a columnar AlignmentMorph holding the given collection" | col | col _ self newColumn color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/5/2001 15:11'! inARow: aCollectionOfMorphs "Answer a row-oriented AlignmentMorph holding the given collection" | aRow | aRow _ self newRow color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | aRow addMorphBack: each]. ^ aRow! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/16/2001 09:36'! rowPrototype "Answer a prototypical row" | sampleMorphs aRow | sampleMorphs _ (1 to: (2 + 3 atRandom)) collect: [:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg', integer asString); yourself]. aRow _ self inARow: sampleMorphs. aRow setNameTo: 'Row'. aRow enableDragNDrop. aRow cellInset: 6. aRow layoutInset: 8. aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!'. aRow color: Color veryVeryLightGray. ^ aRow "AlignmentMorph rowPrototype openInHand"! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05' prior: 33736616! rowPrototype "Answer a prototypical row" | sampleMorphs aRow | sampleMorphs _ (1 to: (2 + 3 atRandom)) collect: [:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg', integer asString); yourself]. aRow _ self inARow: sampleMorphs. aRow setNameTo: 'Row'. aRow enableDragNDrop. aRow cellInset: 6. aRow layoutInset: 8. aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!' translated. aRow color: Color veryVeryLightGray. ^ aRow "AlignmentMorph rowPrototype openInHand"! ! !AlignmentMorph class methodsFor: 'parts bin' stamp: 'sw 11/16/2001 09:16'! supplementaryPartsDescriptions "Extra items for parts bins" ^ {DescriptionForPartsBin formalName: 'Column' categoryList: #('Presentation') documentation: 'An object that presents the things within it in a column' globalReceiverSymbol: #AlignmentMorph nativitySelector: #columnPrototype. DescriptionForPartsBin formalName: 'Row' categoryList: #('Presentation') documentation: 'An object that presents the things within it in a row' globalReceiverSymbol: #AlignmentMorph nativitySelector: #rowPrototype}! ! !AlignmentMorph class methodsFor: 'scripting' stamp: 'sw 11/16/2001 10:01'! additionsToViewerCategories "Answer viewer additions for the 'layout' category" ^#(( layout ( (slot cellInset 'The cell inset' Number readWrite Player getCellInset Player setCellInset:) (slot layoutInset 'The layout inset' Number readWrite Player getLayoutInset Player setLayoutInset:) (slot listCentering 'The list centering' ListCentering readWrite Player getListCentering Player setListCentering:) (slot hResizing 'Horizontal resizing' Resizing readWrite Player getHResizing Player setHResizing:) (slot vResizing 'Vertical resizing' Resizing readWrite Player getVResizing Player setVResizing:) (slot listDirection 'List direction' ListDirection readWrite Player getListDirection Player setListDirection:) (slot wrapDirection 'Wrap direction' ListDirection readWrite Player getWrapDirection Player setWrapDirection:) ))) ! ! !AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 3/10/2001 13:54'! acceptDroppingMorph: aMorph event: evt | handlerForDrops | handlerForDrops _ self valueOfProperty: #handlerForDrops ifAbsent: [ ^super acceptDroppingMorph: aMorph event: evt ]. (handlerForDrops acceptDroppingMorph: aMorph event: evt in: self) ifFalse: [ aMorph rejectDropMorphEvent: evt. "send it back where it came from" ].! ! !AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 12/30/2001 19:14'! fullDrawOn: aCanvas | mask | (aCanvas isVisible: self fullBounds) ifFalse:[^self]. super fullDrawOn: aCanvas. mask _ self valueOfProperty: #disabledMaskColor ifAbsent: [^self]. aCanvas fillRectangle: bounds color: mask. ! ! !AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 3/14/2001 08:36'! wantsDroppedMorph: aMorph event: evt | handlerForDrops | handlerForDrops _ self valueOfProperty: #handlerForDrops ifAbsent: [ ^super wantsDroppedMorph: aMorph event: evt ]. ^handlerForDrops wantsDroppedMorph: aMorph event: evt in: self! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'sw 11/14/2001 00:31'! addSecondLineOfControls "Add the second line of controls" | aRow outerButton aButton worldToUse | aRow _ AlignmentMorph newRow listCentering: #center; color: Color transparent. outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleWhetherShowingOnlyActiveScripts; getSelector: #showingOnlyActiveScripts. outerButton addTransparentSpacerOfSize: (4@0). outerButton addMorphBack: (StringMorph contents: 'tickers only') lock. outerButton setBalloonText: 'If checked, then only scripts that are paused or ticking will be shown'. aRow addMorphBack: outerButton. aRow addTransparentSpacerOfSize: 20@0. aRow addMorphBack: self helpButton. aRow addTransparentSpacerOfSize: 20@0. outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleWhetherShowingAllInstances; getSelector: #showingAllInstances. outerButton addTransparentSpacerOfSize: (4@0). outerButton addMorphBack: (StringMorph contents: 'all instances') lock. outerButton setBalloonText: 'If checked, then entries for all instances will be shown, but if not checked, scripts for only one representative of each different kind of object will be shown. Consult the help available by clicking on the purple ? for more information.'. aRow addMorphBack: outerButton. self addMorphBack: aRow. worldToUse _ self isInWorld ifTrue: [self world] ifFalse: [ActiveWorld]. worldToUse presenter reinvigorateAllScriptsTool: self. self layoutChanged.! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 9/19/2003 14:34' prior: 33740976! addSecondLineOfControls "Add the second line of controls" | aRow outerButton aButton worldToUse | aRow _ AlignmentMorph newRow listCentering: #center; color: Color transparent. outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleWhetherShowingOnlyActiveScripts; getSelector: #showingOnlyActiveScripts. outerButton addTransparentSpacerOfSize: (4@0). outerButton addMorphBack: (StringMorph contents: 'tickers only' translated) lock. outerButton setBalloonText: 'If checked, then only scripts that are paused or ticking will be shown' translated. aRow addMorphBack: outerButton. aRow addTransparentSpacerOfSize: 20@0. aRow addMorphBack: self helpButton. aRow addTransparentSpacerOfSize: 20@0. outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleWhetherShowingAllInstances; getSelector: #showingAllInstances. outerButton addTransparentSpacerOfSize: (4@0). outerButton addMorphBack: (StringMorph contents: 'all instances' translated) lock. outerButton setBalloonText: 'If checked, then entries for all instances will be shown, but if not checked, scripts for only one representative of each different kind of object will be shown. Consult the help available by clicking on the purple ? for more information.' translated. aRow addMorphBack: outerButton. self addMorphBack: aRow. worldToUse _ self isInWorld ifTrue: [self world] ifFalse: [ActiveWorld]. worldToUse presenter reinvigorateAllScriptsTool: self. self layoutChanged.! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'sw 11/13/2001 19:42'! dismissButton "Answer a button whose action would be to dismiss the receiver" | aButton | aButton _ super dismissButton. aButton setBalloonText: 'Click here to remove this tool from the screen; you can get another one any time you want from the Widgets flap'. ^ aButton! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 8/31/2003 19:43' prior: 33745120! dismissButton "Answer a button whose action would be to dismiss the receiver " | aButton | aButton := super dismissButton. aButton setBalloonText: 'Click here to remove this tool from the screen; you can get another one any time you want from the Widgets flap' translated. ^ aButton! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'sw 11/13/2001 19:43'! initializeFor: ignored "Initialize the receiver as a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the scope of the containing pasteup's presenter" | aRow | showingOnlyActiveScripts _ true. showingAllInstances _ true. showingOnlyTopControls _ true. self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap. self useRoundedCorners. self borderWidth: 4; borderColor: Color brown darker. aRow _ AlignmentMorph newRow. aRow listCentering: #justified; color: Color transparent. aRow addMorphFront: self dismissButton. aRow addMorphBack: ScriptingSystem scriptControlButtons. aRow addMorphBack: self openUpButton. self addMorphFront: aRow. ! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'sw 11/13/2001 16:51'! presentHelp "Sent when a Help button is hit; provide the user with some form of help for the tool at hand" | aString | aString _ 'This tool allows you to see all the scripts for all the objects in this project. Sometimes you are only interested in those scripts that are ticking, or that are *ready* to tick when you hit the GO button (which are said to be "paused.") Check "tickers only" if you only want to see such scripts -- i.e., scripts that are either paused or ticking. If "tickers only" is *not* checked, then all scripts will be shown, whatever their status. The other checkbox, labeled "all instances", only comes into play if you have created "multiple sibling instances" (good grief) of the same object, which share the same scripts; if you have such things, it is often convenient to see the scripts of just *one* such sibling, because it will take up less space and require less mindshare -- and note that you can control a script for an object *and* all its siblings from the menu of that one that you see, via menu items such as "propagate status to siblings". If "all instances" is checked, scripts for all sibling instances will be shown, whereas if "all instances" is *not* checked, only one of each group of siblings will be selected to have its scripts shown. But how do you get "multiple sibling instances" of the same object? There are several ways: (1) Use the "make a sibling instance" or the "make multiple siblings..." menu item in the halo menu of a scripted object (2) Use the "copy" tile in a script. (3) Request "give me a copy now" from the menu associated with the "copy" item in a Viewer If you have on your screen multiple sibling instances of the same object, then you may or may want to see them all in the All Scripts tool, and that is what the "all instances" checkbox governs. Set "all instances" if you want a separate entry for each instance, as opposed to a single representative of that kind of object. Note that if you obtain a copy of an object by using the green halo handle, it will *not* be a sibling instance of the original. It will in many ways seem to be, because it will start out its life having the same scripts as the original. But it will then lead an independent life, so that changes to scripts of the original will not be reflected in it, and vice-versa. This is an important distinction, and an unavoidable one because people sometimes want the deep sharing of sibling instances and sometimes they clearly do not. But the truly understandable description of these concepts and distinctions certainly lies *ahead* of us!!'. (StringHolder new contents: aString) openLabel: 'About the All Scripts tool'! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 9/19/2003 14:35' prior: 33746757! presentHelp "Sent when a Help button is hit; provide the user with some form of help for the tool at hand" | aString | aString _ 'This tool allows you to see all the scripts for all the objects in this project. Sometimes you are only interested in those scripts that are ticking, or that are *ready* to tick when you hit the GO button (which are said to be "paused.") Check "tickers only" if you only want to see such scripts -- i.e., scripts that are either paused or ticking. If "tickers only" is *not* checked, then all scripts will be shown, whatever their status. The other checkbox, labeled "all instances", only comes into play if you have created "multiple sibling instances" (good grief) of the same object, which share the same scripts; if you have such things, it is often convenient to see the scripts of just *one* such sibling, because it will take up less space and require less mindshare -- and note that you can control a script for an object *and* all its siblings from the menu of that one that you see, via menu items such as "propagate status to siblings". If "all instances" is checked, scripts for all sibling instances will be shown, whereas if "all instances" is *not* checked, only one of each group of siblings will be selected to have its scripts shown. But how do you get "multiple sibling instances" of the same object? There are several ways: (1) Use the "make a sibling instance" or the "make multiple siblings..." menu item in the halo menu of a scripted object (2) Use the "copy" tile in a script. (3) Request "give me a copy now" from the menu associated with the "copy" item in a Viewer If you have on your screen multiple sibling instances of the same object, then you may or may want to see them all in the All Scripts tool, and that is what the "all instances" checkbox governs. Set "all instances" if you want a separate entry for each instance, as opposed to a single representative of that kind of object. Note that if you obtain a copy of an object by using the green halo handle, it will *not* be a sibling instance of the original. It will in many ways seem to be, because it will start out its life having the same scripts as the original. But it will then lead an independent life, so that changes to scripts of the original will not be reflected in it, and vice-versa. This is an important distinction, and an unavoidable one because people sometimes want the deep sharing of sibling instances and sometimes they clearly do not. But the truly understandable description of these concepts and distinctions certainly lies *ahead* of us!!'. (StringHolder new contents: aString translated) openLabel: 'About the All Scripts tool' translated! ! !AllScriptsTool methodsFor: 'parts bin' stamp: 'sw 8/12/2001 02:57'! initializeToStandAlone super initializeToStandAlone. self layoutPolicy: TableLayout new; listDirection: #topToBottom; hResizing: #spaceFill; extent: 1@1; vResizing: #spaceFill; rubberBandCells: true; yourself. self initializeFor: self currentWorld presenter! ! !AllScriptsTool methodsFor: 'parts bin' stamp: 'dgd 2/22/2003 19:37' prior: 33752331! initializeToStandAlone super initializeToStandAlone. self layoutPolicy: TableLayout new; listDirection: #topToBottom; hResizing: #spaceFill; extent: 1 @ 1; vResizing: #spaceFill; rubberBandCells: true. self initializeFor: self currentWorld presenter! ! !AllScriptsTool methodsFor: 'stepping and presenter' stamp: 'sw 11/14/2001 00:31'! step "If the list of scripts to show has changed, refresh my contents" self showingOnlyTopControls ifFalse: [self presenter reinvigorateAllScriptsTool: self].! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/13/2001 18:35'! openUpButton "Answer a button whose action would be to open up the receiver or snap it back closed" | aButton | aButton _ SimpleButtonMorph new. aButton target: self topRendererOrSelf; color: (Color r: 0.452 g: 0.839 b: 0.935); label: 'º' font: Preferences standardButtonFont; actionSelector: #toggleWhetherShowingOnlyTopControls; setBalloonText: 'open or close the lower portion that shows individual scripts'. ^ aButton! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'dgd 9/19/2003 14:37' prior: 33753283! openUpButton "Answer a button whose action would be to open up the receiver or snap it back closed" | aButton | aButton _ SimpleButtonMorph new. aButton target: self topRendererOrSelf; color: (Color r: 0.452 g: 0.839 b: 0.935); label: 'º' font: Preferences standardButtonFont; actionSelector: #toggleWhetherShowingOnlyTopControls; setBalloonText: 'open or close the lower portion that shows individual scripts' translated. ^ aButton! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/13/2001 19:43'! showingOnlyTopControls "Answer whether the receiver is currently showing only the top controls" ^ showingOnlyTopControls ifNil: [showingOnlyTopControls _ true]! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'! toggleWhetherShowingAllInstances "Toggle whether the receiver is showing all instances or only one exemplar per uniclass" showingAllInstances _ showingAllInstances not. self presenter reinvigorateAllScriptsTool: self! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'! toggleWhetherShowingOnlyActiveScripts "Toggle whether the receiver is showing only active scripts" showingOnlyActiveScripts _ showingOnlyActiveScripts not. self presenter reinvigorateAllScriptsTool: self! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'! toggleWhetherShowingOnlyTopControls "Toggle whether the receiver is showing only the stop/step/go line or the full whammy" | aCenter | showingOnlyTopControls _ self showingOnlyTopControls not. aCenter _ self center x. self showingOnlyTopControls ifTrue: [self removeAllButFirstSubmorph] ifFalse: [self addSecondLineOfControls. self presenter reinvigorateAllScriptsTool: self]. WorldState addDeferredUIMessage: [self center: (aCenter @ self center y)] ! ! !AllScriptsTool commentStamp: '' prior: 0! A tool for controlling and viewing all scripts in a project. The tool has an open and a closed form. In the closed form, stop-step-go buttons are available, plus a control for opening the tool up. In the open form, it has a second row of controls that govern which scripts should be shown, followed by the individual script items.! !AllScriptsTool class methodsFor: 'instance creation' stamp: 'sw 6/12/2001 11:52'! allScriptsToolForActiveWorld "Launch an AllScriptsTool to view scripts of the active world" | aTool | aTool _ self newColumn. aTool initializeFor: ActiveWorld presenter. ^ aTool! ! !AllScriptsTool class methodsFor: 'parts bin' stamp: 'sw 11/13/2001 18:31'! descriptionForPartsBin "Answer a description for use in parts bins" ^ self partName: 'All Scripts' categories: #('Scripting') documentation: 'A tool allowing you to monitor and change the status of all scripts in your project'! ! !AllScriptsTool class methodsFor: 'printing' stamp: 'sw 11/13/2001 19:44'! defaultNameStemForInstances "Answer the default name stem for new instances of this class" ^ 'All Scripts'! ! !AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:28'! initialize self registerInFlapsRegistry. ! ! !AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:30'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'A tool that lets you see and control all the running scripts in your project') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'A tool that lets you control all the running scripts in your world') forFlapNamed: 'Scripting'. cl registerQuad: #(AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'A tool that lets you see and control all the running scripts in your project') forFlapNamed: 'Widgets']! ! !AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:30'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha ^alpha! ! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha: newAlpha alpha _ newAlpha.! ! !AlphaBlendingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:18'! on: aCanvas myCanvas _ aCanvas. alpha _ 1.0.! ! !AlphaBlendingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:24'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle." rule = Form paint ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: 31 alpha: alpha. ]. rule = Form over ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: 30 alpha: alpha. ].! ! !AlphaBlendingCanvas methodsFor: 'private' stamp: 'bf 10/28/2003 15:46' prior: 33758366! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle." rule = Form paint ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form paintAlpha alpha: alpha. ]. rule = Form over ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form blendAlpha alpha: alpha. ].! ! !AlphaBlendingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:23'! mapColor: aColor aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..." aColor isTransparent ifTrue:[^aColor]. aColor isOpaque ifTrue:[^aColor alpha: alpha]. ^aColor alpha: (aColor alpha * alpha)! ! !Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'! dependenciesForClass: aClass | r | r := Set new. aClass methodDict values do: [:cm | (cm literals select: [:l | l isKindOf: LookupKey]) do: [:ll | ll key ifNotNil: [r add: ll key]]]. ^ r! ! !Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'! externalReference ^ self ! ! !Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'! externalReferenceOf: aCollectionOfClass | r | r := Set new. aCollectionOfClass do: [:cls | r addAll: (self dependenciesForClass: cls)]. aCollectionOfClass do: [:clss | r remove: clss name ifAbsent: []]. ^ r! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'! doesClass: cls define: aSelector ^ cls methodDict includesKey: aSelector ! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'! methodsCalledAndCalleeForClass: aClass | r | r := Set new. aClass methodDict associationsDo: [:assoc | (assoc value literals select: [:l | l isKindOf: Symbol]) do: [:ll | r add: (Array with: assoc key with: ll)]]. ^ r! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'! methodsCalledForClass: aClass | r | r := Set new. aClass methodDict values do: [:cm | (cm literals select: [:l | l isKindOf: Symbol]) do: [:ll | r add: ll]]. ^ r! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'! methodsDefinedForClass: aClass ^ aClass methodDict keys ! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:40'! methodsIn: cls callingMethodsDefinedIn: classes "Give collection matching (m1, m2) where: - m1 is defined in C - m2 is defined in classes - m2 called in m1 of C, - and m2 not defined in C" "We made the following assumption: If a method foo is in defined in cls and in classes, then if cls call foo, then it calls its own" | methodsCalled allMethodsDefined ans | methodsCalled := self methodsCalledAndCalleeForClass: cls. allMethodsDefined := Set new. classes do: [:clss | allMethodsDefined addAll: (self methodsDefinedForClass: clss)]. ans := methodsCalled select: [:calleeCalled | (self doesClass: cls define: calleeCalled second) not and: [allMethodsDefined includes: calleeCalled second]]. ^ ans! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:40'! referingMethodsDefinedInSubclasses: aClass | r | r := self methodsCalledForClass: aClass. subclasses := aClass allSubclasses. subclasses remove: aClass! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example1 "self example1" Analyzer externalReferenceOf: (#(#Object #Behavior #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname]) inspect ! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example2 "self example2" (Analyzer externalReferenceOf: (#(#Behavior #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname])) inspect! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example3 "self example3" (((Analyzer externalReferenceOf: (#(#Behavior #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname])) select: [:clsName | (Smalltalk includesKey: clsName) and: [(Smalltalk at: clsName) isKindOf: Class]]) select: [:clssName | ((Smalltalk at: clssName) category asString beginsWith: 'Kernel') not]) inspect! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example4 "self example4" (((Analyzer externalReferenceOf: (#(#Object #Behavior #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname])) select: [:clsName | (Smalltalk includesKey: clsName) and: [(Smalltalk at: clsName) isKindOf: Class]]) select: [:clssName | ((Smalltalk at: clssName) category asString beginsWith: 'Kernel') not]) inspect! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example5 "self example5" | classes | classes := #(#ClassBuilder #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname]. (Analyzer methodsIn: Behavior callingMethodsDefinedIn: classes) inspect! ! !AnalyzerTest methodsFor: 'utility' stamp: 'ab 3/8/2003 13:55'! createClass: aClassname ^ self createClass: aClassname superclass: Object ! ! !AnalyzerTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:42'! createClass: aClassname superclass: aClass | r | r _ aClass subclass: aClassname instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-KCP'. classesCreated add: r. ^ r! ! !AnalyzerTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:41'! removeClassIfExists: aClassname Smalltalk at: aClassname ifPresent: [:cls | cls removeFromSystem] ! ! !AnalyzerTest methodsFor: 'utility' stamp: 'rw 5/12/2003 11:56'! removeClassNamedIfExists: aClassname Smalltalk at: aClassname ifPresent: [:cls| cls removeFromSystem]. Smalltalk at: aClassname ifPresent: [:clss| self error: 'Error !!!!']! ! !AnalyzerTest methodsFor: 'running' stamp: 'ab 3/8/2003 13:54'! setUp classesCreated _ OrderedCollection new! ! !AnalyzerTest methodsFor: 'running' stamp: 'sd 5/23/2003 14:51'! tearDown | name | classesCreated do: [:cls | name _ cls name. self removeClassNamedIfExists: name. ChangeSet current removeClassChanges: name]. classesCreated _ nil! ! !AnalyzerTest methodsFor: 'dependencies' stamp: 'ab 3/8/2003 14:04'! testDependenciesForClass | cls r | cls _ self createClass: #MyClass. "-------" cls compile: 'foo ^ Object'. cls compile: 'bar Transcript show: ''blah blah'''. cls compile: 'zork OrderedCollection new'. "-------" r _ Analyzer dependenciesForClass: cls. self assert: r size = 3. self assert: (r includesAllOf: #(#Object #Transcript #OrderedCollection )). ! ! !AnalyzerTest methodsFor: 'dependencies' stamp: 'ab 3/8/2003 14:04'! testExternalReferenceOf | r cls1 cls2 cls3 | cls1 _ self createClass: #MyClass1. cls2 _ self createClass: #MyClass2. cls3 _ self createClass: #MyClass3. "-------" cls1 compile: 'foo ^ MyClass2'. cls1 compile: 'bar MyClass1 show: ''blah blah'''. cls1 compile: 'zork OrderedCollection new'. cls1 compile: 'baz Morph new openInWorld'. "-------" cls2 compile: 'foo ^ Object'. cls2 compile: 'bar Transcript show: ''blah blah'''. cls2 compile: 'zork OrderedCollection new'. "-------" cls3 compile: 'foo ^ Object'. cls3 compile: 'bar Transcript show: ''blah blah'''. cls3 compile: 'zork MyClass3 new'. "-------" r _ Analyzer externalReferenceOf: (#(#MyClass1 #MyClass2 #MyClass3 ) collect: [:clsName | Smalltalk at: clsName]). self assert: r size = 4. self assert: (r includesAllOf: #(#Object #Transcript #OrderedCollection #Morph )). ! ! !AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'! testMethodCallDefinedInSubclasses | cls1 cls2 r | cls1 _ self createClass: #MyClass1. cls2 _ self createClass: #MyClass2 superclass: cls1. "-------" cls1 compile: 'foo ^ self bar'. cls2 compile: 'bar ^ true'. "-------" self assert: cls2 new foo. r _ Analyzer methodsIn: cls1 callingMethodsDefinedIn: (Array with: cls2). r _ r asOrderedCollection. self assert: r size = 1. self assert: r first size = 2. self assert: r first first == #foo. self assert: r first second == #bar. ! ! !AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'! testMethodCallDefinedInSubclasses2 | cls1 cls2 r cls3 cls4 | cls1 _ self createClass: #MyClass1. cls2 _ self createClass: #MyClass2 superclass: cls1. cls3 _ self createClass: #MyClass3. cls4 _ self createClass: #MyClass4 superclass: cls3. "-------" cls1 compile: 'foo ^ self f1; f2'. cls1 compile: 'bar ^ self f3; foo'. cls1 compile: 'zork ^ self bar; blah'. cls2 compile: 'f1 ^ true'. cls2 compile: 'f2 ^ true'. cls3 compile: 'f3 ^ true'. cls3 compile: 'foo ^ true'. cls4 compile: 'f3 ^ true'. cls4 compile: 'f4 ^ true'. cls4 compile: 'bleubleu ^ true'. cls4 compile: 'bouba ^ true'. "-------" r _ Analyzer methodsIn: cls1 callingMethodsDefinedIn: (Array with: cls2 with: cls3 with: cls4). r _ r asOrderedCollection. self assert: r size = 3. self assert: (r includesAllOf: #(#(#foo #f1) #(#foo #f2) #(#bar #f3) )). ! ! !AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'! testMethodsCalledAndCalleeForClass | cls r | cls _ self createClass: #MyClass. "-------" cls compile: 'foo ^ Object'. cls compile: 'bar Transcript show: ''blah blah'''. cls compile: 'zork OrderedCollection new'. cls compile: 'foobar Object new asMorph; beep'. "-------" r _ Analyzer methodsCalledAndCalleeForClass: cls. self assert: r size = 3. self assert: (r includesAllOf: #(#(#bar #show:) #(#foobar #asMorph) #(#foobar #asMorph) )). ! ! !AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'! testMethodsCalledForClass | cls r | cls _ self createClass: #MyClass. "-------" cls compile: 'foo ^ Object'. cls compile: 'bar Transcript show: ''blah blah'''. cls compile: 'zork OrderedCollection new'. cls compile: 'foobar Object new asMorph; beep'. "-------" r _ Analyzer methodsCalledForClass: cls. self assert: r size = 3. self assert: (r includesAllOf: #(#beep #show: #asMorph )). ! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 13:30'! allImages | body colorTable | stream class == ReadWriteStream ifFalse: [ (stream respondsTo: #binary) ifTrue: [stream binary]. self on: (ReadWriteStream with: (stream contentsOfEntireFile))]. localColorTable _ nil. forms _ OrderedCollection new. offsets _ OrderedCollection new. delays _ OrderedCollection new. comments _ OrderedCollection new. self readHeader. [(body _ self readBody) == nil] whileFalse: [colorTable _ localColorTable ifNil: [colorPalette]. transparentIndex ifNotNil: [transparentIndex + 1 > colorTable size ifTrue: [colorTable _ colorTable forceTo: transparentIndex + 1 paddingWith: Color white]. colorTable at: transparentIndex + 1 put: Color transparent]. body colors: colorTable. forms add: body. offsets add: offset. delays add: delay]. ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:15' prior: 33769038! allImages | body colorTable offset | stream class == ReadWriteStream ifFalse: [ stream binary. self on: (ReadWriteStream with: (stream contentsOfEntireFile))]. localColorTable _ nil. forms _ OrderedCollection new. offsets _ OrderedCollection new. delays _ OrderedCollection new. comments _ OrderedCollection new. self readHeader. [(body _ self readBody) == nil] whileFalse: [colorTable _ localColorTable ifNil: [colorPalette]. transparentIndex ifNotNil: [transparentIndex + 1 > colorTable size ifTrue: [colorTable _ colorTable forceTo: transparentIndex + 1 paddingWith: Color white]. colorTable at: transparentIndex + 1 put: Color transparent]. body colors: colorTable. forms add: body. offsets add: offset. delays add: delay]. ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! delays ^ delays! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! forms ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! offsets ^ offsets! ! !AnimatedGIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:21'! readBitData | form | form := super readBitData. form offset: offset. ^form! ! !AnimatedGIFReadWriter methodsFor: 'private' stamp: 'mir 11/19/2003 12:25'! comment: aString comments add: aString! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:44'! allTypicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^ Set with: 'gif'! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'mir 11/18/2003 17:00'! formsFromFileNamed: fileName | stream | stream _ FileStream readOnlyFileNamed: fileName. ^ self formsFromStream: stream! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'mir 11/18/2003 17:00'! formsFromStream: stream | reader | reader _ self new on: stream reset. Cursor read showWhile: [reader allImages. reader close]. ^reader! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:50'! typicalFileExtensions "this is called from one of my superclasses" ^ #( )! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! wantsToHandleGIFs ^true! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 14:16'! step images isEmpty ifTrue: [^ self]. nextTime > Time millisecondClockValue ifTrue: [^self]. imageIndex _ imageIndex \\ images size + 1. self image: (images at: imageIndex). self position: self position + (offsets at: imageIndex) - previousOffset. previousOffset _ offsets at: imageIndex. nextTime := Time millisecondClockValue + (delays at: imageIndex) ! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'asm 12/11/2003 22:33' prior: 33772436! step | d | images isEmpty ifTrue: [^ self]. nextTime > Time millisecondClockValue ifTrue: [^self]. imageIndex _ imageIndex \\ images size + 1. self image: (images at: imageIndex). self position: self position + (offsets at: imageIndex) - previousOffset. previousOffset _ offsets at: imageIndex. d _ (delays at: imageIndex) ifNil: [0]. nextTime := Time millisecondClockValue + d ! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 13:40'! stepTime ^stepTime ifNil: [super stepTime]! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 13:40'! stepTime: anInteger stepTime _ anInteger! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 14:16'! wantsSteps ^ true! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'asm 12/15/2003 19:44' prior: 33773664! wantsSteps ^(images size > 1) ! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'mir 11/19/2003 14:14'! fromGIFFileNamed: fileName | reader | reader _ AnimatedGIFReadWriter formsFromFileNamed: fileName. images _ reader forms. offsets _ reader offsets. delays _ reader delays. self step! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20' prior: 33773900! fromGIFFileNamed: fileName self fromReader: (AnimatedGIFReadWriter formsFromFileNamed: fileName)! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20'! fromReader: reader images _ reader forms. offsets _ reader offsets. delays _ reader delays. self step! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'asm 12/15/2003 19:35'! fromStream: aStream | reader | reader _ AnimatedGIFReadWriter formsFromStream: aStream. images _ reader forms. offsets _ reader offsets. delays _ reader delays. self step! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20' prior: 33774535! fromStream: aStream self fromReader: (AnimatedGIFReadWriter formsFromStream: aStream)! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'mir 11/19/2003 13:42'! images ^images! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'mir 11/19/2003 14:29'! initialize nextTime := Time millisecondClockValue. imageIndex := 1. previousOffset _ 0 @ 0. stepTime := 10. super initialize! ! !AnimatedImageMorph commentStamp: '' prior: 0! I am an ImageMorph that can hold more than one image. Each image has its own delay time.! !AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'mir 11/19/2003 13:45'! fromGIFFileNamed: fileName ^self new fromGIFFileNamed: fileName! ! !AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:23' prior: 33775432! fromGIFFileNamed: fileName | reader | reader _ AnimatedGIFReadWriter formsFromFileNamed: fileName. ^reader forms size = 1 ifTrue: [ ImageMorph new image: reader forms first ] ifFalse: [ self new fromReader: reader ]! ! !AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'asm 12/4/2003 23:20'! fromStream: aStream ^self new fromStream: aStream! ! !AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:27' prior: 33775919! fromStream: aStream | reader | reader _ AnimatedGIFReadWriter formsFromStream: aStream. ^reader forms size = 1 ifTrue: [ ImageMorph new image: reader forms first ] ifFalse: [ self new fromReader: reader ]! ! !AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'asm 12/11/2003 21:53'! openGIFInWindow: fileName ^(self new fromGIFFileNamed: fileName) openInWorld! ! !AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 16:57' prior: 33776382! openGIFInWindow: aStream ^(self fromStream: aStream binary) openInWorld! ! !AnimatedImageMorph class methodsFor: 'class initialization' stamp: 'asm 12/11/2003 21:05'! initialize "register the receiver in the global registries" self environment at: #FileList ifPresent: [:cl | cl registerFileReader: self]! ! !AnimatedImageMorph class methodsFor: 'class initialization' stamp: 'asm 12/11/2003 21:01'! unload "Unload the receiver from global registries" self environment at: #FileList ifPresent: [:cl | cl unregisterFileReader: self]! ! !AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'asm 12/11/2003 21:34'! fileReaderServicesForFile: fullName suffix: suffix ^((AnimatedGIFReadWriter allTypicalFileExtensions add: '*'; add: 'form'; yourself) includes: suffix) ifTrue: [ self services ] ifFalse: [#()] ! ! !AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'asm 12/11/2003 21:16'! serviceOpenGIFInWindow "Answer a service for opening a gif graphic in a window" ^ SimpleServiceEntry provider: self label: 'open graphic in a window' selector: #openGIFInWindow: description: 'open a gif graphic file in a window' buttonLabel: 'open'! ! !AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'nk 2/15/2004 15:34' prior: 33777488! serviceOpenGIFInWindow "Answer a service for opening a gif graphic in a window" ^ (SimpleServiceEntry provider: self label: 'open graphic in a window' selector: #openGIFInWindow: description: 'open a GIF graphic file in a window' buttonLabel: 'open') argumentGetter: [ :fileList | fileList directory readOnlyFileNamed: fileList fileName ]! ! !AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:35' prior: 33777852! serviceOpenGIFInWindow "Answer a service for opening a gif graphic in a window" ^ (SimpleServiceEntry provider: self label: 'open graphic in a window' selector: #openGIFInWindow: description: 'open a GIF graphic file in a window' buttonLabel: 'open') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'asm 12/11/2003 21:54'! services ^ Array with: self serviceOpenGIFInWindow with: Form serviceImageImports with: Form serviceImageAsBackground ! ! !AnotherDummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 21:19'! callingAThirdMethod self inform: ';lkl;'. self zoulouSymbol! ! !AnotherDummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 20:49'! zoulouSymbol self callingAThirdMethod! ! !AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:24'! isCarryingFood ^ isCarryingFood ! ! !AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:25'! isCarryingFood: aBoolean isCarryingFood _ aBoolean. ! ! !AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:24'! pheromoneDropSize ^ pheromoneDropSize ! ! !AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:25'! pheromoneDropSize: aNumber pheromoneDropSize _ aNumber. ! ! !AntColonyTurtle methodsFor: 'demons' stamp: 'jm 3/8/2001 14:26'! dropFoodInNest (isCarryingFood and: [(self get: 'isNest') > 0]) ifTrue: [ self color: Color black. isCarryingFood _ false. "turn around and go forward to try to pick up pheromone trail" self turnRight: 180. self forward: 3]. ! ! !AntColonyTurtle methodsFor: 'demons' stamp: 'jm 3/8/2001 14:22'! pickUpFood | newFood | (isCarryingFood not and: [(self get: 'food') > 0]) ifTrue: [ newFood _ (self get: 'food') - 1. self set: 'food' to: newFood. newFood = 0 ifTrue: [self patchColor: world backgroundColor]. isCarryingFood _ true. pheromoneDropSize _ 800. self color: Color red. "drop a blob of pheromone on the side of the food farthest from nest" self turnTowardsStrongest: 'nestScent'. self turnRight: 180. self forward: 4. self increment: 'pheromone' by: 5000]. ! ! !AntColonyTurtle methodsFor: 'demons' stamp: 'jm 2/7/2001 19:20'! returnToNest isCarryingFood ifTrue: [ "decrease size of pheromone drops to create a gradient back to food" pheromoneDropSize > 0 ifTrue: [ self increment: 'pheromone' by: pheromoneDropSize. pheromoneDropSize _ pheromoneDropSize - 20]. self turnTowardsStrongest: 'nestScent'. self forward: 1]. ! ! !AntColonyTurtle methodsFor: 'demons' stamp: 'jm 2/7/2001 08:12'! searchForFood "If you smell pheromone, go towards the strongest smell. Otherwise, wander aimlessly." isCarryingFood ifFalse: [ ((self get: 'pheromone') > 1) ifTrue: [self turnTowardsStrongest: 'pheromone'] ifFalse: [ self turnRight: (self random: 40). self turnLeft: (self random: 40)]. self forward: 1]. ! ! !AppRegistry methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:04'! seeClassSide "All the code for AppRegistry is on the class side."! ! !AppRegistry commentStamp: 'ads 4/2/2003 15:30' prior: 0! AppRegistry is a simple little class, not much more than a wrapper around a collection. It's intended to help break dependencies between packages. For example, if you'd like to be able to send e-mail, you could use the bare-bones MailComposition class, or you could use the full-blown Celeste e-mail client. Instead of choosing one or the other, you can call "MailSender default" (where MailSender is a subclass of AppRegistry), and thus avoid creating a hard-coded dependency on either of the two mail senders. This will only really be useful, of course, for applications that have a very simple, general, well-defined interface. Most of the time, you're probably better off just marking your package as being dependent on a specific other package, and avoiding the hassle of this whole AppRegistry thing. But for simple things like e-mail senders or web browsers, it might be useful. ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:36'! appName "Defaults to the class name, which is probably good enough, but you could override this in subclasses if you want to." ^ self name! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:31'! askForDefault | menu | self registeredClasses isEmpty ifTrue: [self inform: 'There are no ', self appName, ' applications registered.'. ^ default _ nil]. self registeredClasses size = 1 ifTrue: [^ default _ self registeredClasses anyOne]. menu _ CustomMenu new. self registeredClasses do: [:c | menu add: c name printString action: c]. ^ default _ menu startUpWithCaption: 'Which ', self appName, ' would you prefer?'! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:11'! default ^ default ifNil: [self askForDefault]! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:33'! default: aClassOrNil "Sets my default to aClassOrNil. Answers the old default." | oldDefault | oldDefault := default. aClassOrNil ifNotNil: [ self register: aClassOrNil ]. default := aClassOrNil. ^ oldDefault! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:35'! defaultOrNil ^ default! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:25'! register: aProviderClass (self registeredClasses includes: aProviderClass) ifFalse: [default _ nil. "so it'll ask for a new default, since if you're registering a new app you probably want to use it" self registeredClasses add: aProviderClass].! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:01'! registeredClasses ^ registeredClasses ifNil: [registeredClasses _ OrderedCollection new]! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:03'! unregister: aProviderClass (default = aProviderClass) ifTrue: [default _ nil]. self registeredClasses remove: aProviderClass ifAbsent: [].! ! !ArbitraryObjectSocket methodsFor: 'private' stamp: 'mir 5/15/2003 15:35' prior: 17046104! processInput "recieve some data" | inObjectData | "read as much data as possible" self addToInBuf: socket receiveAvailableData. "decode as many objects as possible" [self nextObjectLength ~~ nil and: [ self nextObjectLength <= (self inBufSize + 4) ]] whileTrue: [ "a new object has arrived" inObjectData _ inBuf copyFrom: (inBufIndex + 4) to: (inBufIndex + 3 + self nextObjectLength). inBufIndex := inBufIndex + 4 + self nextObjectLength. inObjects addLast: (RWBinaryOrTextStream with: inObjectData) reset fileInObjectAndCode ]. self shrinkInBuf.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addDirectory: aFileName ^self addDirectory: aFileName as: aFileName ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57'! addDirectory: aFileName as: anotherFileName | newMember | newMember _ self memberClass newFromDirectory: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57' prior: 33785281! addDirectory: aFileName as: anotherFileName | newMember | newMember _ self memberClass newFromDirectory: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:29'! addFile: aFileName ^self addFile: aFileName as: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! addFile: aFileName as: anotherFileName | newMember | newMember _ self memberClass newFromFile: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03' prior: 33785985! addFile: aFileName as: anotherFileName | newMember | newMember _ self memberClass newFromFile: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addMember: aMember ^members addLast: aMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! addString: aString as: aFileName | newMember | newMember _ self memberClass newFromString: aString named: aFileName. self addMember: newMember. newMember localFileName: aFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03' prior: 33786656! addString: aString as: aFileName | newMember | newMember _ self memberClass newFromString: aString named: aFileName. self addMember: newMember. newMember localFileName: aFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! addTree: aFileNameOrDirectory removingFirstCharacters: n | dir newMember fullPath relativePath | dir _ (aFileNameOrDirectory isString) ifTrue: [ FileDirectory on: aFileNameOrDirectory ] ifFalse: [ aFileNameOrDirectory ]. fullPath _ dir fullNameFor: ''. "this could be a bug..." relativePath _ fullPath copyFrom: n + 1 to: fullPath size. dir entries do: [ :ea | | fullName | fullName _ fullPath, ea name. newMember _ ea isDirectory ifTrue: [ self memberClass newFromDirectory: fullName ] ifFalse: [ self memberClass newFromFile: fullName ]. newMember localFileName: relativePath, ea name. self addMember: newMember. ea isDirectory ifTrue: [ self addTree: fullName removingFirstCharacters: n ]. ]. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03' prior: 33787216! addTree: aFileNameOrDirectory removingFirstCharacters: n | dir newMember fullPath relativePath | dir _ (aFileNameOrDirectory isString) ifTrue: [ FileDirectory on: aFileNameOrDirectory ] ifFalse: [ aFileNameOrDirectory ]. fullPath _ dir fullNameFor: ''. "this could be a bug..." relativePath _ fullPath copyFrom: n + 1 to: fullPath size. dir entries do: [ :ea | | fullName | fullName _ fullPath, ea name. newMember _ ea isDirectory ifTrue: [ self memberClass newFromDirectory: fullName ] ifFalse: [ self memberClass newFromFile: fullName ]. newMember localFileName: relativePath, ea name. self addMember: newMember. ea isDirectory ifTrue: [ self addTree: fullName removingFirstCharacters: n ]. ]. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:12'! canWriteToFileNamed: aFileName "Catch attempts to overwrite existing zip file" ^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! contentsOf: aMemberOrName | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. ^member contents! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'! extractMember: aMemberOrName | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: member localFileName inDirectory: FileDirectory default.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48' prior: 33789251! extractMember: aMemberOrName | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: member localFileName inDirectory: FileDirectory default.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! extractMember: aMemberOrName toFileNamed: aFileName | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'nk 11/11/2002 14:09'! extractMemberWithoutPath: aMemberOrName self extractMemberWithoutPath: aMemberOrName inDirectory: FileDirectory default.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 11/11/2002 14:09' prior: 33790037! extractMemberWithoutPath: aMemberOrName self extractMemberWithoutPath: aMemberOrName inDirectory: FileDirectory default.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'! extractMemberWithoutPath: aMemberOrName inDirectory: dir | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: (FileDirectory localNameFor: member localFileName) inDirectory: dir! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48' prior: 33790449! extractMemberWithoutPath: aMemberOrName inDirectory: dir | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: (FileDirectory localNameFor: member localFileName) inDirectory: dir! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! memberNamed: aString "Return the first member whose zip name or local file name matches aString, or nil" ^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50' prior: 33791073! memberNamed: aString "Return the first member whose zip name or local file name matches aString, or nil" ^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:00'! memberNames ^members collect: [ :ea | ea fileName ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'! members ^members! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! membersMatching: aString ^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50' prior: 33791866! membersMatching: aString ^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:59'! numberOfMembers ^members size! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! removeMember: aMemberOrName | member | member _ self member: aMemberOrName. member ifNotNil: [ members remove: member ]. ^member! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! replaceMember: aMemberOrName with: newMember | member | member _ self member: aMemberOrName. member ifNotNil: [ members replaceAll: member with: newMember ]. ^member! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 17:24'! setContentsOf: aMemberOrName to: aString | newMember oldMember | oldMember _ self member: aMemberOrName. newMember _ (self memberClass newFromString: aString named: oldMember fileName) copyFrom: oldMember. self replaceMember: oldMember with: newMember.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 20:58'! writeTo: aStream self subclassResponsibility! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:15'! writeToFileNamed: aFileName | stream | "Catch attempts to overwrite existing zip file" (self canWriteToFileNamed: aFileName) ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. stream _ StandardFileStream forceNewFileNamed: aFileName. self writeTo: stream. stream close.! ! !Archive methodsFor: 'initialization' stamp: 'nk 2/21/2001 17:58'! initialize members _ OrderedCollection new.! ! !Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'! member: aMemberOrName ^(members includes: aMemberOrName) ifTrue: [ aMemberOrName ] ifFalse: [ self memberNamed: aMemberOrName ].! ! !Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'! memberClass self subclassResponsibility! ! !Archive commentStamp: '' prior: 0! This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName ^fileName! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName: aName fileName _ aName! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:16'! isCorrupt ^isCorrupt ifNil: [ isCorrupt _ false ]! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'! isCorrupt: aBoolean "Mark this member as being corrupt." isCorrupt := aBoolean! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 12/20/2002 15:02'! localFileName: aString "Set my internal filename. Returns the (possibly new) filename. aString will be translated from local FS format into Unix format." ^fileName _ aString copyReplaceAll: FileDirectory slash with: '/'.! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 12/20/2002 15:02' prior: 33794779! localFileName: aString "Set my internal filename. Returns the (possibly new) filename. aString will be translated from local FS format into Unix format." ^fileName _ aString copyReplaceAll: FileDirectory slash with: '/'.! ! !ArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 19:43'! usesFileNamed: aFileName "Do I require aFileName? That is, do I care if it's clobbered?" ^false! ! !ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! close ! ! !ArchiveMember methodsFor: 'initialization' stamp: 'nk 2/22/2001 16:00'! initialize fileName _ ''! ! !ArchiveMember methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:05' prior: 33795648! initialize fileName _ ''. isCorrupt _ false.! ! !ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self fileName; nextPut: $)! ! !ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11' prior: 33795885! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self fileName; nextPut: $)! ! !ArchiveMember commentStamp: '' prior: 0! This is the abstract superclass for archive members, which are files or directories stored in archives.! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'! newDirectoryNamed: aString self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromFile: aFileName self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromString: aString self subclassResponsibility! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:03'! archive ^archive! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:36'! directory "For compatibility with file list." ^self error: 'should use readOnlyStream instead!!'! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:03'! fileName ^fileName! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:53'! fullName "For compatibility with FileList services. If this is called, it means that a service that requires a real filename has been requested. So extract the selected member to a temporary file and return that name." | fullName dir | self canExtractMember ifFalse: [ ^nil ]. dir _ FileDirectory default directoryNamed: '.archiveViewerTemp'. fullName _ dir fullNameFor: self selectedMember localFileName. self selectedMember extractInDirectory: dir. ^fullName! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 14:56'! members ^archive ifNil: [ #() asOrderedCollection ] ifNotNil: [ archive members asOrderedCollection ]! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:39'! readOnlyStream "Answer a read-only stream on the selected member. For the various stream-reading services." ^self selectedMember ifNotNilDo: [ :mem | mem contentStream ascii ]! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:17'! selectedMember ^memberIndex ifNil: [ nil ] ifNotNil: [ self members at: memberIndex ifAbsent: [ ] ]! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:54'! canCreateNewArchive ^true! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:56'! canExtractAll ^self members size > 0! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'dgd 2/21/2003 22:36' prior: 33798461! canExtractAll ^self members notEmpty! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 11:12'! canOpenNewArchive ^true! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:55'! canSaveArchive ^archive notNil! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:49'! commentArchive | newName | archive ifNil: [ ^self ]. newName _ FillInTheBlankMorph request: 'New comment for archive:' initialAnswer: archive zipFileComment centerAt: Sensor cursorPoint inWorld: self world onCancelReturn: archive zipFileComment acceptOnCR: true. archive zipFileComment: newName.! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 23:29'! createNewArchive self setLabel: '(new archive)'. archive _ ZipArchive new. self memberIndex: 0. self changed: #memberList.! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:42'! extractAll "Extracts all in a directory of the users' choosing." | directory | self canExtractAll ifFalse: [^ self]. directory _ FileList2 modalFolderSelector ifNil: [^ self]. [self extractAllPossibleInDirectory: directory] whileFalse: [self confirm: 'Try a different directory?']. [["first extract directories if any" self extractDirectoriesIntoDirectory: directory. "then files" self extractFilesIntoDirectory: directory] on: FileStreamException do: [:ex | (self confirm: ex class name, ': ' , ex messageText , '. Continue?') ifTrue: [ex resume] ifFalse: [^ self]]] on: Error do: [ :ex | self inform: 'Error: ', ex messageText ].! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:42' prior: 33799543! extractAll "Extracts all in a directory of the users' choosing." | directory | self canExtractAll ifFalse: [^ self]. directory _ FileList2 modalFolderSelector ifNil: [^ self]. [self extractAllPossibleInDirectory: directory] whileFalse: [self confirm: 'Try a different directory?']. [["first extract directories if any" self extractDirectoriesIntoDirectory: directory. "then files" self extractFilesIntoDirectory: directory] on: FileStreamException do: [:ex | (self confirm: ex class name, ': ' , ex messageText , '. Continue?') ifTrue: [ex resume] ifFalse: [^ self]]] on: Error do: [ :ex | self inform: 'Error: ', ex messageText ].! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'ar 2/6/2004 13:20' prior: 33800302! extractAll | directory | self canExtractAll ifFalse: [^ self]. directory _ FileList2 modalFolderSelector ifNil: [^ self]. archive extractAllTo: directory.! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:51'! extractAllPossibleInDirectory: directory "Answer true if I can extract all the files in the given directory safely. Inform the user as to problems." | conflicts | self canExtractAll ifFalse: [ ^false ]. conflicts _ Set new. self members do: [ :ea | | fullName | fullName _ directory fullNameFor: ea localFileName. (ea usesFileNamed: fullName) ifTrue: [ conflicts add: fullName ]. ]. conflicts notEmpty ifTrue: [ | str | str _ WriteStream on: (String new: 200). str nextPutAll: 'The following file(s) are needed by archive members and cannot be overwritten:'; cr. conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ]. self inform: str contents. ^false. ]. conflicts _ Set new. self members do: [ :ea | | fullName | fullName _ directory relativeNameFor: ea localFileName. (directory fileExists: fullName) ifTrue: [ conflicts add: fullName ]. ]. conflicts notEmpty ifTrue: [ | str | str _ WriteStream on: (String new: 200). str nextPutAll: 'The following file(s) will be overwritten:'; cr. conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ]. str cr; nextPutAll: 'Is this OK?'. ^PopUpMenu confirm: str contents. ]. ^true. ! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:51' prior: 33801301! extractAllPossibleInDirectory: directory "Answer true if I can extract all the files in the given directory safely. Inform the user as to problems." | conflicts | self canExtractAll ifFalse: [ ^false ]. conflicts _ Set new. self members do: [ :ea | | fullName | fullName _ directory fullNameFor: ea localFileName. (ea usesFileNamed: fullName) ifTrue: [ conflicts add: fullName ]. ]. conflicts notEmpty ifTrue: [ | str | str _ WriteStream on: (String new: 200). str nextPutAll: 'The following file(s) are needed by archive members and cannot be overwritten:'; cr. conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ]. self inform: str contents. ^false. ]. conflicts _ Set new. self members do: [ :ea | | fullName | fullName _ directory relativeNameFor: ea localFileName. (directory fileExists: fullName) ifTrue: [ conflicts add: fullName ]. ]. conflicts notEmpty ifTrue: [ | str | str _ WriteStream on: (String new: 200). str nextPutAll: 'The following file(s) will be overwritten:'; cr. conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ]. str cr; nextPutAll: 'Is this OK?'. ^PopUpMenu confirm: str contents. ]. ^true. ! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:14'! extractDirectoriesIntoDirectory: directory (self members select: [:ea | ea isDirectory]) do: [:ea | ea extractInDirectory: directory]! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:14' prior: 33803879! extractDirectoriesIntoDirectory: directory (self members select: [:ea | ea isDirectory]) do: [:ea | ea extractInDirectory: directory]! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:13'! extractFilesIntoDirectory: directory (self members reject: [:ea | ea isDirectory]) do: [:ea | ea extractInDirectory: directory]! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:13' prior: 33804337! extractFilesIntoDirectory: directory (self members reject: [:ea | ea isDirectory]) do: [:ea | ea extractInDirectory: directory]! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:27'! openNewArchive | menu result | menu _ StandardFileMenu oldFileMenu: (FileDirectory default) withPattern: '*.zip'. result := menu startUpWithCaption: 'Select Zip archive to open...'. result ifNil: [ ^self ]. self fileName: (result directory fullNameFor: result name). ! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 4/19/2002 09:08'! saveArchive | result name | self canSaveArchive ifFalse: [ ^self ]. result _ StandardFileMenu newFile. result ifNil: [ ^self ]. name _ result directory fullNameFor: result name. (archive canWriteToFileNamed: name) ifFalse: [ self inform: name, ' is used by one or more members in your archive, and cannot be overwritten. Try writing to another file name'. ^self ]. [ archive writeToFileNamed: name ] on: Error do: [ :ex | self inform: ex description. ]. self setLabel: name asString. self changed: #memberList "in case CRC's and compressed sizes got set"! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 3/27/2002 12:57'! writePrependingFile | result name prependedName | self canSaveArchive ifFalse: [ ^self ]. result _ (StandardFileMenu newFileMenu: FileDirectory default) startUpWithCaption: 'Destination Zip File Name:'. result ifNil: [ ^self ]. name _ result directory fullNameFor: result name. (archive canWriteToFileNamed: name) ifFalse: [ self inform: name, ' is used by one or more members in your archive, and cannot be overwritten. Try writing to another file name'. ^self ]. result _ (StandardFileMenu oldFileMenu: FileDirectory default) startUpWithCaption: 'Prepended File:'. result ifNil: [ ^self ]. prependedName _ result directory fullNameFor: result name. [ archive writeToFileNamed: name prependingFileNamed: prependedName ] on: Error do: [ :ex | self inform: ex description. ]. self changed: #memberList "in case CRC's and compressed sizes got set"! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 23:28'! archive: aZipArchive archive _ aZipArchive. self setLabel: 'New Zip Archive'. self memberIndex: 0. self changed: #memberList! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 10/24/2001 08:53'! backgroundColor ^self defaultBackgroundColor! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'KLC 12/6/2003 10:40'! briefContents "Trim to 5000 characters if longer then point out that it is trimmed" self selectedMember ifNil: [^ '']. ^self selectedMember contents size > 5000 ifTrue: [ | subContents lastLineEndingIndex tempIndex | subContents _ self selectedMember contentsFrom: 1 to: 5000. lastLineEndingIndex _ subContents lastIndexOf: Character cr. tempIndex _ subContents lastIndexOf: Character lf. tempIndex > lastLineEndingIndex ifTrue: [lastLineEndingIndex _ tempIndex]. lastLineEndingIndex = 0 ifFalse: [subContents _ subContents copyFrom: 1 to: lastLineEndingIndex]. 'File ''', self selectedMember fileName, ''' is ', self selectedMember contents size printString, ' bytes long. Toggle the ''View All Contents'' button above to see the entire file. Here are the first ', subContents size printString , ' characters... ------------------------------------------ ', subContents , ' ------------------------------------------ ... end of the first ', subContents size printString , ' characters.' ] ifFalse: [self selectedMember contents] ! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:43' prior: 33807064! briefContents "Trim to 5000 characters. If the member is longer, then point out that it is trimmed. Also warn if the member has a corrupt CRC-32." | stream subContents errorMessage | self selectedMember ifNil: [^ '']. errorMessage _ ''. stream _ WriteStream on: (String new: (self selectedMember uncompressedSize min: 5500)). [ self selectedMember uncompressedSize > 5000 ifTrue: [ | lastLineEndingIndex tempIndex | subContents _ self selectedMember contentsFrom: 1 to: 5000. lastLineEndingIndex _ subContents lastIndexOf: Character cr. tempIndex _ subContents lastIndexOf: Character lf. tempIndex > lastLineEndingIndex ifTrue: [lastLineEndingIndex _ tempIndex]. lastLineEndingIndex = 0 ifFalse: [subContents _ subContents copyFrom: 1 to: lastLineEndingIndex]] ifFalse: [ subContents _ self selectedMember contents ]] on: CRCError do: [ :ex | errorMessage _ String streamContents: [ :s | s nextPutAll: '[ '; nextPutAll: (ex messageText copyUpToLast: $( ); nextPutAll: ' ]' ]. ex proceed ]. (errorMessage isEmpty not or: [ self selectedMember isCorrupt ]) ifTrue: [ stream nextPutAll: '********** WARNING!! Member is corrupt!! '; nextPutAll: errorMessage; nextPutAll: ' **********'; cr ]. self selectedMember uncompressedSize > 5000 ifTrue: [ stream nextPutAll: 'File '; print: self selectedMember fileName; nextPutAll: ' is '; print: self selectedMember uncompressedSize; nextPutAll: ' bytes long.'; cr; nextPutAll: 'Click the ''View All Contents'' button above to see the entire file.'; cr; cr; nextPutAll: 'Here are the first '; print: subContents size; nextPutAll: ' characters...'; cr; next: 40 put: $-; cr; nextPutAll: subContents; next: 40 put: $-; cr; nextPutAll: '... end of the first '; print: subContents size; nextPutAll: ' characters.' ] ifFalse: [ stream nextPutAll: self selectedMember contents ]. ^stream contents ! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 09:48'! buttonColor ^self backgroundColor darker! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 09:49'! buttonOffColor ^self backgroundColor darker! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 09:49'! buttonOnColor ^self backgroundColor! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/5/2002 14:43'! contents self selectedMember ifNil: [^ '']. viewAllContents ifFalse: [^ self selectedMember contentsFrom: 1 to: 500]. ^ self selectedMember contents! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'KLC 12/6/2003 10:21' prior: 33810628! contents self selectedMember ifNil: [^ '']. viewAllContents ifFalse: [^ self briefContents]. ^ self selectedMember contents! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:45' prior: 33810876! contents | contents errorMessage | self selectedMember ifNil: [^ '']. viewAllContents ifFalse: [^ self briefContents]. [ contents _ self selectedMember contents ] on: CRCError do: [ :ex | errorMessage _ String streamContents: [ :stream | stream nextPutAll: '********** WARNING!! Member is corrupt!! [ '; nextPutAll: (ex messageText copyUpToLast: $( ); nextPutAll: '] **********'; cr ]. ex proceed ]. ^self selectedMember isCorrupt ifFalse: [ contents ] ifTrue: [ errorMessage, contents ]! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/25/2001 00:04'! contents: aText self shouldNotImplement.! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 5/9/2002 16:00'! createButtonBar | bar button narrowFont | narrowFont _ StrikeFont allSubInstances detectMin: [ :ea | ea widthOfString: 'Contents' from: 1 to: 8 ]. bar _ AlignmentMorph newRow. bar color: self backgroundColor; rubberBandCells: false; vResizing: #shrinkWrap; cellInset: 6@0. #( #( 'New\Archive' canCreateNewArchive createNewArchive 'Create a new, empty archive and discard this one' ) #( 'Load\Archive' canOpenNewArchive openNewArchive 'Open another archive and discard this one' ) #( 'Save\Archive As' canSaveArchive saveArchive 'Save this archive under a new name' ) #( 'Extract\All' canExtractAll extractAll 'Extract all this archive''s members into a directory' ) #( 'Add\File' canAddMember addMember 'Add a file to this archive' ) #( 'Add from\Clipboard' canAddMember addMemberFromClipboard 'Add the contents of the clipboard as a new file' ) #( 'Add\Directory' canAddMember addDirectory 'Add the entire contents of a directory, with all of its subdirectories' ) #( 'Extract\Member As' canExtractMember extractMember 'Extract the selected member to a file' ) #( 'Delete\Member' canDeleteMember deleteMember 'Remove the selected member from this archive' ) #( 'Rename\Member' canRenameMember renameMember 'Rename the selected member' ) #( 'View All\Contents' canViewAllContents changeViewAllContents 'Toggle the view of all the selected member''s contents' ) ) do: [:arr | | buttonLabel | buttonLabel _ (TextMorph new) string: arr first withCRs fontName: narrowFont familyName size: narrowFont pointSize wrap: false; hResizing: #shrinkWrap; lock; yourself. (button _ PluggableButtonMorph on: self getState: arr second action: arr third) vResizing: #shrinkWrap; hResizing: #spaceFill; onColor: self buttonOnColor offColor: self buttonOffColor; label: buttonLabel; setBalloonText: arr fourth; yourself. bar addMorphBack: button. buttonLabel composeToBounds]. ^ bar. ! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'dgd 2/22/2003 19:38' prior: 33811808! createButtonBar | bar button narrowFont | narrowFont := StrikeFont allSubInstances detectMin: [:ea | ea widthOfString: 'Contents' from: 1 to: 8]. bar := AlignmentMorph newRow. bar color: self backgroundColor; rubberBandCells: false; vResizing: #shrinkWrap; cellInset: 6 @ 0. #(#('New\Archive' #canCreateNewArchive #createNewArchive 'Create a new, empty archive and discard this one') #('Load\Archive' #canOpenNewArchive #openNewArchive 'Open another archive and discard this one') #('Save\Archive As' #canSaveArchive #saveArchive 'Save this archive under a new name') #('Extract\All' #canExtractAll #extractAll 'Extract all this archive''s members into a directory') #('Add\File' #canAddMember #addMember 'Add a file to this archive') #('Add from\Clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('Add\Directory' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('Extract\Member As' #canExtractMember #extractMember 'Extract the selected member to a file') #('Delete\Member' #canDeleteMember #deleteMember 'Remove the selected member from this archive') #('Rename\Member' #canRenameMember #renameMember 'Rename the selected member') #('View All\Contents' #canViewAllContents #changeViewAllContents 'Toggle the view of all the selected member''s contents')) do: [:arr | | buttonLabel | buttonLabel := (TextMorph new) string: arr first withCRs fontName: narrowFont familyName size: narrowFont pointSize wrap: false; hResizing: #shrinkWrap; lock; yourself. (button := PluggableButtonMorph on: self getState: arr second action: arr third) vResizing: #shrinkWrap; hResizing: #spaceFill; onColor: self buttonOnColor offColor: self buttonOffColor; label: buttonLabel; setBalloonText: arr fourth. bar addMorphBack: button. buttonLabel composeToBounds]. ^bar! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'di 12/10/2003 10:17' prior: 33813831! createButtonBar | bar button narrowFont registeredFonts | registeredFonts _ OrderedCollection new. TextStyle knownTextStyles do: [:st | (TextStyle named: st) fonts do: [:f | registeredFonts addLast: f]]. narrowFont := registeredFonts detectMin: [:ea | ea widthOfString: 'Contents' from: 1 to: 8]. bar := AlignmentMorph newRow. bar color: self backgroundColor; rubberBandCells: false; vResizing: #shrinkWrap; cellInset: 6 @ 0. #(#('New\Archive' #canCreateNewArchive #createNewArchive 'Create a new, empty archive and discard this one') #('Load\Archive' #canOpenNewArchive #openNewArchive 'Open another archive and discard this one') #('Save\Archive As' #canSaveArchive #saveArchive 'Save this archive under a new name') #('Extract\All' #canExtractAll #extractAll 'Extract all this archive''s members into a directory') #('Add\File' #canAddMember #addMember 'Add a file to this archive') #('Add from\Clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('Add\Directory' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('Extract\Member As' #canExtractMember #extractMember 'Extract the selected member to a file') #('Delete\Member' #canDeleteMember #deleteMember 'Remove the selected member from this archive') #('Rename\Member' #canRenameMember #renameMember 'Rename the selected member') #('View All\Contents' #canViewAllContents #changeViewAllContents 'Toggle the view of all the selected member''s contents')) do: [:arr | | buttonLabel | buttonLabel := (TextMorph new) string: arr first withCRs fontName: narrowFont familyName size: narrowFont pointSize wrap: false; hResizing: #shrinkWrap; lock; yourself. (button := PluggableButtonMorph on: self getState: arr second action: arr third) vResizing: #shrinkWrap; hResizing: #spaceFill; onColor: self buttonOnColor offColor: self buttonOffColor; label: buttonLabel; setBalloonText: arr fourth. bar addMorphBack: button. buttonLabel composeToBounds]. ^bar! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'yo 7/16/2003 15:40' prior: 33815933! createButtonBar | bar button narrowFont asciiFont | asciiFont := StrikeFont allSubInstances select: [:each | each maxAscii < 256]. narrowFont := asciiFont detectMin: [ :ea | ea widthOfString: 'Contents' from: 1 to: 8 ]. bar := AlignmentMorph newRow. bar color: self backgroundColor; rubberBandCells: false; vResizing: #shrinkWrap; cellInset: 6 @ 0. #(#('New\Archive' #canCreateNewArchive #createNewArchive 'Create a new, empty archive and discard this one') #('Load\Archive' #canOpenNewArchive #openNewArchive 'Open another archive and discard this one') #('Save\Archive As' #canSaveArchive #saveArchive 'Save this archive under a new name') #('Extract\All' #canExtractAll #extractAll 'Extract all this archive''s members into a directory') #('Add\File' #canAddMember #addMember 'Add a file to this archive') #('Add from\Clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('Add\Directory' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('Extract\Member As' #canExtractMember #extractMember 'Extract the selected member to a file') #('Delete\Member' #canDeleteMember #deleteMember 'Remove the selected member from this archive') #('Rename\Member' #canRenameMember #renameMember 'Rename the selected member') #('View All\Contents' #canViewAllContents #changeViewAllContents 'Toggle the view of all the selected member''s contents')) do: [:arr | | buttonLabel | buttonLabel := (TextMorph new) string: arr first withCRs fontName: narrowFont familyName size: narrowFont pointSize wrap: false; hResizing: #shrinkWrap; lock; yourself. (button := PluggableButtonMorph on: self getState: arr second action: arr third) vResizing: #shrinkWrap; hResizing: #spaceFill; onColor: self buttonOnColor offColor: self buttonOffColor; label: buttonLabel; setBalloonText: arr fourth. bar addMorphBack: button. buttonLabel composeToBounds]. ^bar! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 22:33'! createListHeadingUsingFont: font | sm | sm _ StringMorph contents: ' uncomp comp CRC-32 date time file name'. font ifNotNil: [ sm font: font ]. ^(AlignmentMorph newColumn) color: self backgroundColor; addMorph: sm; yourself.! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 5/9/2002 16:05'! createWindow | list heading font text buttonBar | self color: self backgroundColor. font _ (TextStyle named: #DefaultFixedTextStyle) ifNotNilDo: [ :ts | ts fontArray first]. buttonBar _ self createButtonBar. self addMorph: buttonBar fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.0) offsets: (0@0 corner: 0@44)). self minimumExtent: (buttonBar fullBounds width + 20) @ 230. self extent: self minimumExtent. heading _ self createListHeadingUsingFont: font. self addMorph: heading fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.0) offsets: (0@44 corner: 0@60)). (list _ PluggableListMorph new) on: self list: #memberList selected: #memberIndex changeSelected: #memberIndex: menu: #memberMenu:shifted: keystroke: nil. list color: self backgroundColor. font ifNotNil: [list font: font]. self addMorph: list fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.8) offsets: (0@60 corner: 0@0)). text _ PluggableTextMorph on: self text: #contents accept: nil readSelection: nil menu: nil. self addMorph: text frame: (0@0.8 corner: 1.0@1.0). text lock. self setLabel: 'Ned''s Zip Viewer'! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 23:28'! fileName: aString archive _ ZipArchive new readFrom: aString. self setLabel: aString. self memberIndex: 0. self changed: #memberList! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 23:46'! initialize super initialize. memberIndex _ 0. viewAllContents _ false.! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 12/16/2002 17:12'! windowIsClosing archive close.! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 12/16/2002 17:12' prior: 33822207! windowIsClosing archive close.! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 22:32'! displayLineFor: aMember | stream dateTime | stream _ WriteStream on: (String new: 60). dateTime _ Time dateAndTimeFromSeconds: aMember lastModTime. stream nextPutAll: (aMember uncompressedSize printString padded: #left to: 8 with: $ ); space; nextPutAll: (aMember compressedSize printString padded: #left to: 8 with: $ ); space; space; nextPutAll: (aMember crc32String ); space; space. dateTime first printOn: stream format: #(3 2 1 $- 2 1 2). stream space. dateTime second print24: true showSeconds: false on: stream. stream space; space; nextPutAll: (aMember fileName ). ^stream contents! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/23/2001 22:48'! highlightMemberList: list with: morphList (morphList at: self memberIndex) color: Color red! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 09:40'! memberIndex ^memberIndex! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 23:46'! memberIndex: n memberIndex _ n. viewAllContents _ false. self changed: #memberIndex. self changed: #contents.! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 11:51'! memberList ^ self members collect: [ :ea | self displayLineFor: ea ]! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 13:42'! memberMenu: menu shifted: shifted ^ menu add: 'Inspect member' target: self selector: #inspectMember; balloonTextForLastItem: 'Inspect the selected member'; add: 'Comment member' target: self selector: #commentMember; balloonTextForLastItem: 'Add a comment for the selected member'; add: 'Comment archive' target: self selector: #commentArchive; balloonTextForLastItem: 'Add a comment for the entire archive'; yourself! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 4/29/2004 10:20' prior: 33823728! memberMenu: menu shifted: shifted | services | menu add: 'Comment archive' target: self selector: #commentArchive; balloonTextForLastItem: 'Add a comment for the entire archive'. self selectedMember ifNotNilDo: [ :member | menu addLine; add: 'Inspect member' target: self selector: #inspectMember; balloonTextForLastItem: 'Inspect the selected member'; add: 'Comment member' target: self selector: #commentMember; balloonTextForLastItem: 'Add a comment for the selected member'; addLine. services _ FileList itemsForFile: member fileName. menu addServices2: services for: self extraLines: #(). ]. ^menu! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:28'! addDirectory | directory | self canAddMember ifFalse: [ ^self ]. directory _ FileList2 modalFolderSelector. directory ifNil: [^ self]. archive addTree: directory removingFirstCharacters: directory pathName size + 1. self memberIndex: 0. self changed: #memberList.! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:26'! addMember | result relative | self canAddMember ifFalse: [ ^self ]. result _ StandardFileMenu oldFile. result ifNil: [ ^self ]. relative _ result directory fullNameFor: result name. (relative beginsWith: FileDirectory default pathName) ifTrue: [ relative _ relative copyFrom: FileDirectory default pathName size + 2 to: relative size ]. (archive addFile: relative) desiredCompressionMethod: ZipArchive compressionDeflated. self memberIndex: self members size. self changed: #memberList.! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:29'! addMemberFromClipboard | string newName | self canAddMember ifFalse: [ ^self ]. string _ Clipboard clipboardText asString. newName _ FillInTheBlankMorph request: 'New name for member:' initialAnswer: 'clipboardText'. newName notEmpty ifTrue: [ (archive addString: string as: newName) desiredCompressionMethod: ZipArchive compressionDeflated. self memberIndex: self members size. self changed: #memberList. ] ! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 14:50'! canAddMember ^archive notNil! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'! canDeleteMember ^memberIndex > 0! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'! canExtractMember ^memberIndex > 0! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'! canRenameMember ^memberIndex > 0! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:50'! canViewAllContents ^memberIndex > 0 and: [ viewAllContents not ]! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:59'! changeViewAllContents (viewAllContents not and: [ self selectedMember uncompressedSize > 50000 ]) ifTrue: [ (PopUpMenu confirm: 'This member''s size is ', (self selectedMember uncompressedSize asString), '; do you really want to see all that data?') ifFalse: [ ^self ] ]. viewAllContents _ viewAllContents not. self changed: #contents! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 3/7/2004 16:47' prior: 33827010! changeViewAllContents (viewAllContents not and: [ self selectedMember notNil and: [ self selectedMember uncompressedSize > 50000 ]]) ifTrue: [ (PopUpMenu confirm: 'This member''s size is ', (self selectedMember uncompressedSize asString), '; do you really want to see all that data?') ifFalse: [ ^self ] ]. viewAllContents _ viewAllContents not. self changed: #contents! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 13:50'! commentMember | newName | newName _ FillInTheBlankMorph request: 'New comment for member:' initialAnswer: self selectedMember fileComment centerAt: Sensor cursorPoint inWorld: self world onCancelReturn: self selectedMember fileComment acceptOnCR: true. self selectedMember fileComment: newName.! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:29'! deleteMember self canDeleteMember ifFalse: [ ^self ]. archive removeMember: self selectedMember. self memberIndex: 0. self changed: #memberList. ! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 14:53'! extractMember | result name | self canExtractMember ifFalse: [ ^self ]. result _ StandardFileMenu newFile. result ifNil: [ ^self ]. name _ (result directory fullNameFor: result name). (archive canWriteToFileNamed: name) ifFalse: [ self inform: name, ' is used by one or more members in your archive, and cannot be overwritten. Try extracting to another file name'. ^self ]. self selectedMember extractToFileNamed: name.! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 4/29/2004 10:46' prior: 33828555! extractMember "Extract the member after prompting for a filename. Answer the filename, or nil if error." | result name | self canExtractMember ifFalse: [ ^nil ]. result _ StandardFileMenu newFile. result ifNil: [ ^nil ]. name _ (result directory fullNameFor: result name). (archive canWriteToFileNamed: name) ifFalse: [ self inform: name, ' is used by one or more members in your archive, and cannot be overwritten. Try extracting to another file name'. ^nil ]. self selectedMember extractToFileNamed: name. ^name! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 13:01'! inspectMember self selectedMember inspect! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 14:53'! renameMember | newName | self canRenameMember ifFalse: [ ^self ]. newName _ FillInTheBlankMorph request: 'New name for member:' initialAnswer: self selectedMember fileName. newName notEmpty ifTrue: [ self selectedMember fileName: newName. self changed: #memberList ]! ! !ArchiveViewer methodsFor: 'menu' stamp: 'nk 3/27/2002 12:48'! buildWindowMenu | menu | menu _ super buildWindowMenu. menu addLine. menu add: 'inspect archive' target: archive action: #inspect. menu add: 'write prepending file...' target: self action: #writePrependingFile. ^menu.! ! !ArchiveViewer methodsFor: 'message handling' stamp: 'nk 2/24/2001 13:16'! perform: selector orSendTo: otherTarget ^ self perform: selector! ! !ArchiveViewer methodsFor: 'panes' stamp: 'nk 10/24/2001 09:43'! paneColor ^self backgroundColor darker darker! ! !ArchiveViewer methodsFor: 'panes' stamp: 'nk 2/24/2001 10:09'! paneColorToUse ^self backgroundColor! ! !ArchiveViewer methodsFor: 'parts bin' stamp: 'dls 10/22/2001 07:40'! initializeToStandAlone self initialize createWindow.! ! !ArchiveViewer methodsFor: 'user interface' stamp: 'nk 10/24/2001 08:53'! defaultBackgroundColor ^Color white! ! !ArchiveViewer commentStamp: '' prior: 0! This is a viewer window that allows editing and viewing of Zip archives.! !ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 11:05'! deleteTemporaryDirectory " ArchiveViewer deleteTemporaryDirectory " | dir | (dir _ self temporaryDirectory) exists ifTrue: [ dir recursiveDelete ].! ! !ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 1/30/2002 10:13'! initialize "ArchiveViewer initialize" FileList registerFileReader: self! ! !ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 10:56' prior: 33831457! initialize "ArchiveViewer initialize" FileList registerFileReader: self. Smalltalk addToShutDownList: self.! ! !ArchiveViewer class methodsFor: 'class initialization' stamp: 'sw 2/17/2002 02:35'! serviceOpenInZipViewer "Answer a service for opening in a zip viewer" ^ SimpleServiceEntry provider: self label: 'open in zip viewer' selector: #openOn: description: 'open in zip viewer' buttonLabel: 'open zip'! ! !ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 11:06'! shutDown: quitting quitting ifTrue: [ self deleteTemporaryDirectory ].! ! !ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:46'! extractAllFrom: aFileName (self new) fileName: aFileName; extractAll! ! !ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:48'! serviceAddToNewZip "Answer a service for adding the file to a new zip" ^ FileModifyingSimpleServiceEntry provider: self label: 'add file to new zip' selector: #addFileToNewZip: description: 'add file to new zip' buttonLabel: 'to new zip'! ! !ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:15'! serviceExtractAll "Answer a service for opening in a zip viewer" ^ FileModifyingSimpleServiceEntry provider: self label: 'extract all to...' selector: #extractAllFrom: description: 'extract all files to a user-specified directory' buttonLabel: 'extract all'! ! !ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'nk 11/26/2002 13:15'! fileReaderServicesForFile: fullName suffix: suffix | services | services _ OrderedCollection new. services add: self serviceAddToNewZip. (suffix = 'zip' or: [suffix = 'sar']) ifTrue: [services add: self serviceOpenInZipViewer. services add: self serviceExtractAll]. ^ services! ! !ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:42' prior: 33833163! fileReaderServicesForFile: fullName suffix: suffix | services | services _ OrderedCollection new. services add: self serviceAddToNewZip. ({'zip'.'sar'.'pr'.'*'} includes: suffix) ifTrue: [services add: self serviceOpenInZipViewer. services add: self serviceExtractAll]. ^ services! ! !ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:18'! services ^ Array with: self serviceAddToNewZip with: self serviceOpenInZipViewer ! ! !ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:56'! temporaryDirectory "Answer a directory to use for unpacking files for the file list services." ^FileDirectory default directoryNamed: '.archiveViewerTemp'! ! !ArchiveViewer class methodsFor: 'initialize-release' stamp: 'nk 1/30/2002 10:13'! unload FileList unregisterFileReader: self ! ! !ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 1/30/2002 10:18'! addFileToNewZip: fullName "Add the currently selected file to a new zip" | zip | zip := (ZipArchive new) addFile: fullName as: (FileDirectory localNameFor: fullName); yourself. (self open) archive: zip ! ! !ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 2/23/2001 21:52'! open ^(self new) createWindow; openInWorld.! ! !ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 11/26/2002 12:45'! openOn: aFileName | newMe | newMe _ self new. newMe createWindow; fileName: aFileName; openInWorld. ^newMe! ! !ArchiveViewer class methodsFor: 'parts bin' stamp: 'nk 3/27/2002 11:41'! descriptionForPartsBin ^ self partName: 'Zip Tool' categories: #(Tools) documentation: 'A viewer and editor for Zip archive files' ! ! !Array methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:03'! literalEqual: other self class == other class ifFalse: [^ false]. self size = other size ifFalse: [^ false]. self with: other do: [:e1 :e2 | (e1 literalEqual: e2) ifFalse: [^ false]]. ^ true! ! !Array methodsFor: 'converting' stamp: 'ajh 9/8/2002 17:45' prior: 17052624! elementsExchangeIdentityWith: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array. The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation." otherArray class == Array ifFalse: [^ self error: 'arg must be array']. self size = otherArray size ifFalse: [^ self error: 'arrays must be same size']. (self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. (otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. "Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:). Do GC and try again only once" (Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect ifTrue: [^ self primitiveFailed]. ^ self elementsExchangeIdentityWith: otherArray! ! !Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:23' prior: 17053233! elementsForwardIdentityTo: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'brp 9/26/2003 08:09'! elementsForwardIdentityTo: otherArray copyHash: copyHash "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'yo 9/2/2002 18:23' prior: 17053709! evalStrings "Allows you to construct literal arrays. #(true false nil '5@6' 'Set new' '''text string''') evalStrings gives an array with true, false, nil, a Point, a Set, and a String instead of just a bunch of Symbols" | it | ^ self collect: [:each | it _ each. each == #true ifTrue: [it _ true]. each == #false ifTrue: [it _ false]. each == #nil ifTrue: [it _ nil]. ((each class == String) or: [each class == MultiString]) ifTrue: [ it _ Compiler evaluate: each]. each class == Array ifTrue: [it _ it evalStrings]. it]! ! !Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement self size = 0 ifTrue:[^DependentsArray with: newElement]. ^self copyWith: newElement! ! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:02'! atWrap: index "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1! ! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:03'! atWrap: index put: anObject "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1 put: anObject! ! !Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:09'! +* aCollection "Premultiply aCollection by self. aCollection should be an Array or Matrix. The name of this method is APL's +.x squished into Smalltalk syntax." ^aCollection preMultiplyByArray: self ! ! !Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:10'! preMultiplyByArray: a "Answer a+*self where a is an Array. Arrays are always understood as column vectors, so an n element Array is an n*1 Array. This multiplication is legal iff self size = 1." self size = 1 ifFalse: [self error: 'dimensions do not conform']. ^a * self first! ! !Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:08'! preMultiplyByMatrix: m "Answer m+*self where m is a Matrix." |s| m columnCount = self size ifFalse: [self error: 'dimensions do not conform']. ^(1 to: m rowCount) collect: [:row | s _ 0. 1 to: self size do: [:k | s _ (m at: row at: k) * (self at: k) + s]. s]! ! !ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:09'! tearDown self class removeSelector: #array! ! !ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:08'! testReservedIdentifiers self class compile: 'array ^ #(nil true false)'. self assert: self array = {nil. true. false}.! ! !ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:09'! testSymbols self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'. self assert: self array = {#nil. #true. #false. #nil. #true. #false}.! ! !ArrayTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:29'! setUp example1 := #(1 2 3 4 5).! ! !ArrayTest methodsFor: 'testing' stamp: 'md 4/21/2003 16:36'! testIsLiteral self assert: example1 isLiteral. example1 at: 1 put: self class. self deny: example1 isLiteral. example1 at: 1 put: 1.! ! !ArrayTest commentStamp: '' prior: 0! This is the unit test for the class Array. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:22'! byteSize ^self basicSize * self bytesPerBasicElement ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:28'! bytesPerBasicElement "Answer the number of bytes that each of my basic elements requires. In other words: self basicSize * self bytesPerBasicElement should equal the space required on disk by my variable sized representation." ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:51'! bytesPerElement ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]. ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'ar 1/25/2002 01:46'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ self]. Smalltalk endianness == #little ifTrue: [self swapBytesFrom: 1 to: self basicSize] ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'sd 6/28/2003 09:49' prior: 33842125! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ self]. Smalltalk isLittleEndian ifTrue: [Bitmap swapBytesIn: self from: 1 to: self basicSize] ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 17:45'! swapBytesFrom: start to: stop "Perform a bigEndian/littleEndian byte reversal of my words. We only intend this for non-pointer arrays. Do nothing if I contain pointers." | hack blt | self class isPointers | self class isWords not ifTrue: [^ self]. "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1. blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3" blt sourceX: 3; destX: 0; copyBits. blt sourceX: 0; destX: 3; copyBits. blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2" blt sourceX: 2; destX: 1; copyBits. blt sourceX: 1; destX: 2; copyBits. ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'sd 6/28/2003 09:50' prior: 33843140! swapBytesFrom: start to: stop "Perform a bigEndian/littleEndian byte reversal of my words. We only intend this for non-pointer arrays. Do nothing if I contain pointers." | hack blt | self deprecatedExplanation: 'Use BitMap class>>swapBytesIn:from:to:'. self class isPointers | self class isWords not ifTrue: [^ self]. "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1. blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3" blt sourceX: 3; destX: 0; copyBits. blt sourceX: 0; destX: 3; copyBits. blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2" blt sourceX: 2; destX: 1; copyBits. blt sourceX: 1; destX: 2; copyBits. ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'md 12/12/2003 17:01' prior: 33844023! swapBytesFrom: start to: stop "Perform a bigEndian/littleEndian byte reversal of my words. We only intend this for non-pointer arrays. Do nothing if I contain pointers." | hack blt | self deprecated: 'Use BitMap class>>swapBytesIn:from:to:'. self class isPointers | self class isWords not ifTrue: [^ self]. "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1. blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3" blt sourceX: 3; destX: 0; copyBits. blt sourceX: 0; destX: 3; copyBits. blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2" blt sourceX: 2; destX: 1; copyBits. blt sourceX: 1; destX: 2; copyBits. ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 17:36'! swapHalves "A normal switch in endianness (byte order in words) reverses the order of 4 bytes. That is not correct for SoundBuffers, which use 2-bytes units. If a normal switch has be done, this method corrects it further by swapping the two halves of the long word. This method is only used for 16-bit quanities in SoundBuffer, ShortIntegerArray, etc." | hack blt | "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 2. blt sourceX: 0; destX: 2; copyBits. "Exchange bytes 0&1 with 2&3" blt sourceX: 2; destX: 0; copyBits. blt sourceX: 0; destX: 2; copyBits.! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'ar 5/17/2001 19:50'! writeOn: aStream "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed). Always store in Big Endian (Mac) byte order. Do the writing at BitBlt speeds. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ super writeOn: aStream]. "super may cause an error, but will not be called." aStream nextInt32Put: self basicSize. aStream nextWordsPutAll: self.! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 18:07'! writeOnGZIPByteStream: aStream "We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream]. "super may cause an error, but will not be called." aStream nextPutAllWordArray: self! ! !ArrayedCollection commentStamp: '' prior: 0! I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'ar 5/17/2001 19:50'! newFromStream: s "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." | len | self isPointers | self isWords not ifTrue: [^ super newFromStream: s]. "super may cause an error, but will not be called." s next = 16r80 ifTrue: ["A compressed format. Could copy what BitMap does, or use a special sound compression format. Callers normally compress their own way." ^ self error: 'not implemented']. s skip: -1. len _ s nextInt32. ^ s nextWordsInto: (self basicNew: len)! ! !AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0! AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.! !AssignmentNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 21:17'! variable: aVariable value: expression from: encoder sourceRange: range encoder noteSourceRange: range forNode: self. ^self variable: aVariable value: expression from: encoder! ! !AssignmentNode methodsFor: 'code generation' stamp: 'di 9/5/2001 18:46'! emitForEffect: stack on: aStream variable emitLoad: stack on: aStream. value emitForValue: stack on: aStream. variable emitStorePop: stack on: aStream. pc _ aStream position! ! !AssignmentNode methodsFor: 'code generation' stamp: 'di 9/5/2001 21:26'! emitForValue: stack on: aStream variable emitLoad: stack on: aStream. value emitForValue: stack on: aStream. variable emitStore: stack on: aStream. pc _ aStream position! ! !AssignmentNode methodsFor: 'printing' stamp: 'brp 10/8/2003 14:55' prior: 17076704! printOn: aStream indent: level aStream dialect = #SQ00 ifTrue: [aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: 'Set ']. variable printOn: aStream indent: level. aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: ' to ']. value printOn: aStream indent: level + 2] ifFalse: [variable printOn: aStream indent: level. aStream nextPutAll: (Preferences ansiAssignmentOperatorWhenPrettyPrinting ifTrue: [' := '] ifFalse: [' _ ']). value printOn: aStream indent: level + 2]! ! !AssignmentNode methodsFor: 'tiles' stamp: 'RAA 2/26/2001 16:17'! asMorphicSyntaxIn: parent ^parent assignmentNode: self variable: variable value: value! ! !AssignmentTileMorph methodsFor: 'arrow' stamp: 'sw 9/27/2001 16:40'! addArrowsIfAppropriate "If the receiver's slot is of an appropriate type, add arrows to the tile." (Vocabulary vocabularyForType: dataType) ifNotNilDo: [:aVocab | aVocab wantsAssignmentTileVariants ifTrue: [self addArrows]]! ! !AssignmentTileMorph methodsFor: 'code generation' stamp: 'sw 2/6/2002 01:17'! assignmentReceiverTile "Answer the TilePadMorph that should be sent storeCodeOn:indent: to get the receiver of the assignment properly stored on the code stream" ^ owner submorphs first! ! !AssignmentTileMorph methodsFor: 'code generation' stamp: 'sw 2/6/2002 01:25'! operatorForAssignmentSuffix: aString "Answer the operator associated with the receiver, assumed to be one of the compound assignments" | toTest | toTest _ aString asString. #( ('Incr:' '+') ('Decr:' '-') ('Mult:' '*')) do: [:pair | toTest = pair first ifTrue: [^ pair second]]. ^ toTest "AssignmentTileMorph new operatorForAssignmentSuffix: 'Incr:'"! ! !AssignmentTileMorph methodsFor: 'code generation' stamp: 'sw 2/6/2002 01:26'! storeCodeOn: aStream indent: tabCount "Generate code for an assignment statement. The code generated looks presentable in the case of simple assignment, though the code generated for the increment/decrement/multiply cases is still the same old assignGetter... sort for now" assignmentSuffix = ':' ifTrue: "Simple assignment, don't need existing value" [aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot). aStream space] ifFalse: "Assignments that require that old values be retrieved" [aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot). aStream space. self assignmentReceiverTile storeCodeOn: aStream indent: tabCount. aStream space. aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot). aStream space. aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix). aStream space]! ! !AssignmentTileMorph methodsFor: 'code generation' stamp: 'aoy 2/15/2003 21:09' prior: 33851285! storeCodeOn: aStream indent: tabCount "Generate code for an assignment statement. The code generated looks presentable in the case of simple assignment, though the code generated for the increment/decrement/multiply cases is still the same old assignGetter... sort for now" aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot). aStream space."Simple assignment, don't need existing value" assignmentSuffix = ':' ifFalse: ["Assignments that require that old values be retrieved" self assignmentReceiverTile storeCodeOn: aStream indent: tabCount. aStream space. aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot). aStream space. aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix). aStream space]! ! !AssignmentTileMorph methodsFor: 'initialization' stamp: 'sw 9/12/2001 22:49'! computeOperatorOrExpression "Compute the operator or expression to use, and set the wording correectly on the tile face" | aSuffix wording anInterface getter doc | operatorOrExpression _ (assignmentRoot, assignmentSuffix) asSymbol. aSuffix _ self currentVocabulary translatedWordingFor: assignmentSuffix. getter _ Utilities getterSelectorFor: assignmentRoot. anInterface _ self currentVocabulary methodInterfaceAt: getter ifAbsent: [Vocabulary eToyVocabulary methodInterfaceAt: getter ifAbsent: [nil]]. wording _ anInterface ifNotNil: [anInterface elementWording] ifNil: [assignmentRoot copyWithout: $:]. (anInterface notNil and: [(doc _ anInterface documentation) notNil]) ifTrue: [self setBalloonText: doc]. operatorReadoutString _ wording, ' ', aSuffix. self line1: operatorReadoutString. self addArrowsIfAppropriate! ! !AssignmentTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44' prior: 17078865! initialize "initialize the state of the receiver" super initialize. "" type _ #operator. assignmentSuffix _ ':'! ! !AssignmentTileMorph methodsFor: 'initialization' stamp: 'yo 1/1/2004 19:50'! setRoot: aString "Establish the assignment root, and update the label on the tile" assignmentRoot _ aString. self updateLiteralLabel! ! !AssignmentTileMorph methodsFor: 'initialization' stamp: 'sw 9/12/2001 22:52'! updateWordingToMatchVocabulary "The current vocabulary has changed; change the wording on my face, if appropriate" self computeOperatorOrExpression! ! !AssignmentTileMorph methodsFor: 'player viewer' stamp: 'yo 1/1/2004 19:51'! assignmentRoot "Answer the assignment root" ^ assignmentRoot! ! !Association methodsFor: 'testing' stamp: 'ar 8/14/2001 23:06'! isSpecialWriteBinding "Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages" ^false! ! !Association methodsFor: 'testing' stamp: 'ar 8/14/2001 22:39'! isVariableBinding "Return true if I represent a literal variable binding" ^true! ! !Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:27'! = anAssociation ^ super = anAssociation and: [value = anAssociation value]! ! !Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:28'! hash "Hash is reimplemented because = is implemented." ^key hash bitXor: value hash.! ! !AssociationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 20:20'! testEquality | a b | a _ 1 -> 'one'. b _ 1 -> 'een'. self assert: (a key = b key); deny: (a value = b value); deny: (a = b) ! ! !AssociationTest methodsFor: 'testing' stamp: 'md 3/8/2004 16:37' prior: 33855546! testEquality self assert: (a key = b key); deny: (a value = b value); deny: (a = b) ! ! !AssociationTest methodsFor: 'testing' stamp: 'md 3/8/2004 16:38'! testHash self assert: (a hash = a copy hash); deny: (a hash = b hash)! ! !AssociationTest methodsFor: 'setup' stamp: 'md 3/8/2004 16:37'! setUp a _ 1 -> 'one'. b _ 1 -> 'een'.! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'JMM 11/24/2001 17:23'! test: byteCount fileName: fileName "AsyncFile new test: 10000 fileName: 'testData'" | buf1 buf2 bytesWritten bytesRead | buf1 _ String new: byteCount withAll: $x. buf2 _ String new: byteCount. self open: ( FileDirectory default fullNameFor: fileName) forWrite: true. self primWriteStart: fileHandle fPosition: 0 fromBuffer: buf1 at: 1 count: byteCount. semaphore wait. bytesWritten _ self primWriteResult: fileHandle. self close. self open: ( FileDirectory default fullNameFor: fileName) forWrite: false. self primReadStart: fileHandle fPosition: 0 count: byteCount. semaphore wait. bytesRead _ self primReadResult: fileHandle intoBuffer: buf2 at: 1 count: byteCount. self close. buf1 = buf2 ifFalse: [self error: 'buffers do not match']. ^ 'wrote ', bytesWritten printString, ' bytes; ', 'read ', bytesRead printString, ' bytes' ! ! !AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'! defaultColor "answer the default color/fill style for the receiver" ^ Color blue! ! !AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13' prior: 17099526! initialize "Make a new atom with a random position and velocity." super initialize. "" self extent: 8 @ 7. self randomPositionIn: (0 @ 0 corner: 300 @ 300) maxVelocity: 10! ! !AtomMorphTest methodsFor: 'initialize-release' stamp: 'md 4/17/2003 19:03'! setUp morph := AtomMorph new.! ! !AtomMorphTest methodsFor: 'initialize-release' stamp: 'md 4/17/2003 19:03'! tearDown morph delete.! ! !AtomMorphTest methodsFor: 'testing ' stamp: 'md 4/17/2003 19:06'! testVelocity morph velocity: 0@0. self assert: ( (morph velocity) = (0@0) ).! ! !AtomMorphTest commentStamp: '' prior: 0! This is the unit test for the class AtomMorph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !AttemptToWriteReadOnlyGlobal methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:02'! description "Return a textual description of the exception." | desc mt | desc := 'Error'. ^(mt := self messageText) == nil ifTrue: [desc] ifFalse: [desc, ': ', mt]! ! !AttemptToWriteReadOnlyGlobal methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:02'! isResumable ^true! ! !AttemptToWriteReadOnlyGlobal commentStamp: 'gh 5/2/2002 20:26' prior: 0! This is a resumable error you get if you try to assign a readonly variable a value. Name definitions in the module system can be read only and are then created using instances of ReadOnlyVariableBinding instead of Association. See also LookupKey>>beReadWriteBinding and LookupKey>>beReadOnlyBinding. ! !AttributedTextStream methodsFor: 'retrieving the text' stamp: 'ar 10/16/2001 22:39'! contents | ans | currentRun > 0 ifTrue:[ attributeValues nextPut: currentAttributes. attributeRuns nextPut: currentRun. currentRun _ 0]. ans _ Text new: characters size. "this is declared private, but it's exactly what I need, and it's declared as exactly what I want it to do...." ans setString: characters contents setRuns: (RunArray runs: attributeRuns contents values: attributeValues contents). ^ans! ! !AttributedTextStream methodsFor: 'stream protocol' stamp: 'ar 10/16/2001 22:38'! nextPut: aChar currentRun _ currentRun + 1. characters nextPut: aChar! ! !AttributedTextStream methodsFor: 'stream protocol' stamp: 'ar 10/16/2001 22:38'! nextPutAll: aString "add an entire string with the same attributes" currentRun _ currentRun + aString size. characters nextPutAll: aString.! ! !AttributedTextStream methodsFor: 'access' stamp: 'ar 10/16/2001 22:57'! currentAttributes: newAttributes "set the current attributes" (currentRun > 0 and:[currentAttributes ~= newAttributes]) ifTrue:[ attributeRuns nextPut: currentRun. attributeValues nextPut: currentAttributes. currentRun _ 0. ]. currentAttributes _ newAttributes. ! ! !AttributedTextStream methodsFor: 'private-initialization' stamp: 'ar 10/16/2001 22:40'! initialize characters _ WriteStream on: String new. currentAttributes _ OrderedCollection new. currentRun _ 0. attributeValues _ WriteStream on: (Array new: 50). attributeRuns _ WriteStream on: (Array new: 50). ! ! !AttributedTextStream class methodsFor: 'instance creation' stamp: 'gk 2/9/2004 18:50'! new "For this class we override Stream class>>new since this class actually is created using #new, even though it is a Stream." ^self basicNew initialize! ! !AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 4! ! !AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color yellow! ! !AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:48' prior: 17108065! initialize "initialize the state of the receiver" super initialize. "" transmitWhileRecording _ false. handsFreeTalking _ false. mycodec _ GSMCodec new. myrecorder _ ChatNotes new. mytargetip _ ''. self start2. self changeTalkButtonLabel! ! !AudioChatGUI methodsFor: 'stuff' stamp: 'aoy 2/17/2003 01:01' prior: 17103851! changeTalkButtonLabel | bText | self transmitWhileRecording. handsFreeTalking ifTrue: [theTalkButton labelUp: 'Talk'; labelDown: 'Release'; label: 'Talk'. bText := 'Click once to begin a message. Click again to end the message.'] ifFalse: [theTalkButton labelUp: 'Talk'; labelDown: (transmitWhileRecording ifTrue: ['TALKING'] ifFalse: ['RECORDING']); label: 'Talk'. bText := 'Press and hold to record a message.']. bText := transmitWhileRecording ifTrue: [bText , ' The message will be sent while you are speaking.'] ifFalse: [bText , ' The message will be sent when you are finished.']. theTalkButton setBalloonText: bText! ! !AudioChatGUI class methodsFor: 'parts bin' stamp: 'sw 10/24/2001 16:35'! descriptionForPartsBin "Answer a description of the receiver for use in a parts bin" ^ self partName: 'Audio chat' categories: #('Collaborative') documentation: 'A tool for talking to other Squeak uers' sampleImageForm: (Form extent: 110@70 depth: 8 fromArray: #( 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 3842048257 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 31843813 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 31843813 3857048833 16901605 3842106625 31843813 3842106625 31843813 3842048257 3857049061 16901605 16843237 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 3856990693 3856990693 16843237 3842106853 16843237 3842106853 31843813 31843585 3856990693 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3783321061 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 16843009 31785445 3857049061 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 3856990693 3857049061 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 31843813 31785445 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 31843585 3856990693 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 3842048257 3857048833 16901605 16843237 16843237 16843237 16843237 3842048257 3857049061 16901605 3856990693 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061 3857013637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3842048257 16901605 16901605 3857049061 3857049061 3857049061 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3856990693 3842106853 3857049061 3857049061 3857049061 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3856990693 3842106853 3842048257 3857048833 16901377 16901605 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3856990693 3842106853 31843813 31843813 31843813 31843813 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990465 16901605 3842106853 3842048257 31843813 3842106625 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3857049061 3842106853 31843813 31843813 3842106625 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3857049061 3842106853 31843813 31843813 3856990693 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3842048257 3857049061 16843237 3842048257 3842106853 3856990693 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16871572 1888776340 1895825407 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061 3857013637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16880752 2490406000 2499805183 2490406000 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 16871572 1888776340 1888776340 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3856990465 16843237 3857049061 3857048833 31843813 31843813 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3856990693 31785445 3857049061 3857049061 31843585 31843813 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 3857049061 31843813 31843585 31843813 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 31843813 31843813 16901605 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 31843813 31843813 31843813 31843585 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857048833 16901605 3842048257 3842106625 16901377 16901377 31843813 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248) offset: 0@0)! ! !Authorizer methodsFor: 'authentication' stamp: 'ar 8/17/2001 18:19'! user: userId "Return the requesting user." ^users at: userId ifAbsent: [ self error: (self class unauthorizedFor: realm) ]! ! !Authorizer class methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:19'! unauthorizedFor: realm ^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Squeak/',realm,'"', String crlfcrlf, 'Unauthorized

Unauthorized for ',realm, '

' ! ! !AutoStart class methodsFor: 'class initialization' stamp: 'ar 8/23/2001 22:56'! initialize "AutoStart initialize" "Order: ExternalSettings, SecurityManager, AutoStart" Smalltalk addToStartUpList: AutoStart after: SecurityManager.! ! !AutoStart class methodsFor: 'class initialization' stamp: 'nk 12/2/2003 09:00'! startUp: resuming "The image is either being newly started (resuming is true), or it's just been snapshotted. If this has just been a snapshot, skip all the startup stuff." | startupParameters launchers | resuming ifFalse: [ ^self ]. startupParameters _ AbstractLauncher extractParameters. (startupParameters includesKey: 'apiSupported' asUppercase ) ifTrue: [HTTPClient browserSupportsAPI: ((startupParameters at: 'apiSupported' asUppercase) asUppercase = 'TRUE')]. self checkForUpdates ifTrue: [^self]. self checkForPluginUpdate. launchers _ self installedLaunchers collect: [:launcher | launcher new]. launchers do: [:launcher | launcher parameters: startupParameters]. launchers do: [:launcher | Smalltalk at: #WorldState ifPresent: [ :ws | ws addDeferredUIMessage: [launcher startUp]]]! ! !AutoStart class methodsFor: 'class initialization' stamp: 'mir 3/5/2004 20:46' prior: 33884252! startUp: resuming "The image is either being newly started (resuming is true), or it's just been snapshotted. If this has just been a snapshot, skip all the startup stuff." | startupParameters launchers | resuming ifFalse: [ ^self ]. HTTPClient determineIfRunningInBrowser. startupParameters _ AbstractLauncher extractParameters. (startupParameters includesKey: 'apiSupported' asUppercase ) ifTrue: [ HTTPClient browserSupportsAPI: ((startupParameters at: 'apiSupported' asUppercase) asUppercase = 'TRUE'). HTTPClient isRunningInBrowser ifFalse: [HTTPClient isRunningInBrowser: true]]. self checkForUpdates ifTrue: [^self]. self checkForPluginUpdate. launchers _ self installedLaunchers collect: [:launcher | launcher new]. launchers do: [:launcher | launcher parameters: startupParameters]. launchers do: [:launcher | Smalltalk at: #WorldState ifPresent: [ :ws | ws addDeferredUIMessage: [launcher startUp]]]! ! !AutoStart class methodsFor: 'accessing'! addLauncherFirst: launcher self installedLaunchers addFirst: launcher! ! !AutoStart class methodsFor: 'updating' stamp: 'mir 7/14/2001 13:09'! checkForPluginUpdate | pluginVersion updateURL | World ifNotNil: [ World install. ActiveHand position: 100@100]. HTTPClient determineIfRunningInBrowser. HTTPClient isRunningInBrowser ifFalse: [^false]. pluginVersion _ AbstractLauncher extractParameters at: (Smalltalk platformName copyWithout: Character space) asUppercase ifAbsent: [^false]. updateURL _ AbstractLauncher extractParameters at: 'UPDATE_URL' ifAbsent: [^false]. ^SystemVersion check: pluginVersion andRequestPluginUpdate: updateURL! ! !AutoStart class methodsFor: 'updating' stamp: 'sd 9/30/2003 13:55' prior: 33886302! checkForPluginUpdate | pluginVersion updateURL | World ifNotNil: [ World install. ActiveHand position: 100@100]. HTTPClient determineIfRunningInBrowser. HTTPClient isRunningInBrowser ifFalse: [^false]. pluginVersion _ AbstractLauncher extractParameters at: (SmalltalkImage current platformName copyWithout: Character space) asUppercase ifAbsent: [^false]. updateURL _ AbstractLauncher extractParameters at: 'UPDATE_URL' ifAbsent: [^false]. ^SystemVersion check: pluginVersion andRequestPluginUpdate: updateURL! ! !AutoStart class methodsFor: 'updating' stamp: 'mir 3/5/2004 20:43' prior: 33886914! checkForPluginUpdate | pluginVersion updateURL | World ifNotNil: [ World install. ActiveHand position: 100@100]. HTTPClient isRunningInBrowser ifFalse: [^false]. pluginVersion _ AbstractLauncher extractParameters at: (SmalltalkImage current platformName copyWithout: Character space) asUppercase ifAbsent: [^false]. updateURL _ AbstractLauncher extractParameters at: 'UPDATE_URL' ifAbsent: [^false]. ^SystemVersion check: pluginVersion andRequestPluginUpdate: updateURL! ! !AutoStart class methodsFor: 'updating' stamp: 'mir 8/10/2001 12:31'! checkForUpdates | availableUpdate updateServer | World ifNotNil: [ World install. ActiveHand position: 100@100]. HTTPClient determineIfRunningInBrowser. HTTPClient isRunningInBrowser ifFalse: [^self processUpdates]. availableUpdate _ (AbstractLauncher extractParameters at: 'UPDATE' ifAbsent: [''] ) asInteger. availableUpdate ifNil: [^false]. updateServer _ AbstractLauncher extractParameters at: 'UPDATE_SERVER' ifAbsent: ['Squeakland']. Utilities setUpdateServer: updateServer. ^SystemVersion checkAndApplyUpdates: availableUpdate! ! !AutoStart class methodsFor: 'updating' stamp: 'mir 11/13/2003 19:09' prior: 33888108! checkForUpdates | availableUpdate updateServer | World ifNotNil: [ World install. ActiveHand position: 100@100]. HTTPClient isRunningInBrowser ifFalse: [^self processUpdates]. availableUpdate _ (AbstractLauncher extractParameters at: 'UPDATE' ifAbsent: [''] ) asInteger. availableUpdate ifNil: [^false]. updateServer _ AbstractLauncher extractParameters at: 'UPDATESERVER' ifAbsent: [AbstractLauncher extractParameters at: 'UPDATE_SERVER' ifAbsent: ['Squeakland']]. Utilities setUpdateServer: updateServer. ^SystemVersion checkAndApplyUpdates: availableUpdate! ! !AutoStart class methodsFor: 'updating' stamp: 'ar 4/24/2001 15:59'! processUpdates "Process update files from a well-known update server. This method is called at system startup time, Only if the preference #updateFromServerAtStartup is true is the actual update processing undertaken automatically" | choice | (Preferences valueOfFlag: #updateFromServerAtStartup) ifTrue: [choice _ (PopUpMenu labels: 'Yes, Update\No, Not now' withCRs) startUpWithCaption: 'Shall I look for new code\updates on the server?' withCRs. choice = 1 ifTrue: [Utilities updateFromServer]]. ^false! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:29'! test01metaclassName self assert: Dictionary class name = 'Dictionary class'. self assert: OrderedCollection class name = 'OrderedCollection class'. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:28'! test02metaclassNumberOfInstances self assert: Dictionary class allInstances size = 1. self assert: OrderedCollection class allInstances size = 1.! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:36'! test03superclass | s | self assert: Dictionary superclass == Set. self assert: OrderedCollection superclass == SequenceableCollection. s _ OrderedCollection new. s add: SequenceableCollection. s add: Collection. s add: Object. s add: ProtoObject. self assert: OrderedCollection allSuperclasses = s. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:39'! test04metaclassSuperclass | s | self assert: Dictionary class superclass == Set class. self assert: OrderedCollection class superclass == SequenceableCollection class. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:53'! test05metaclassSuperclassHierarchy | s | self assert: SequenceableCollection class instanceCount = 1. self assert: Collection class instanceCount = 1. self assert: Object class instanceCount = 1. self assert: ProtoObject class instanceCount = 1. s _ OrderedCollection new. s add: SequenceableCollection class. s add: Collection class. s add: Object class. s add: ProtoObject class. s add: Class. s add: ClassDescription. s add: Behavior. s add: Object. s add: ProtoObject. self assert: OrderedCollection class allSuperclasses = s. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:53'! test06ClassDescriptionAllSubInstances | cdNo clsNo metaclsNo | cdNo _ ClassDescription allSubInstances size. clsNo _ Class allSubInstances size . metaclsNo _ Metaclass allSubInstances size. self assert: cdNo = (clsNo + metaclsNo). ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 13:02'! test07bmetaclassPointOfCircularity self assert: Metaclass class instanceCount = 1. self assert: Metaclass class someInstance == Metaclass. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:16'! test07metaclass self assert: OrderedCollection class class == Metaclass. self assert: OrderedCollection class class = Metaclass. self assert: Dictionary class class == Metaclass. self assert: Dictionary class class = Metaclass. self assert: Object class class == Metaclass. self assert: Object class class = Metaclass. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:25'! test08BCCMhierarchy self assert: Class superclass == ClassDescription. self assert: Metaclass superclass == ClassDescription. self assert: ClassDescription superclass == Behavior. self assert: Behavior superclass = Object. self assert: Class class class == Metaclass. self assert: Metaclass class class == Metaclass. self assert: ClassDescription class class == Metaclass. self assert: Behavior class class == Metaclass. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:43'! test09ObjectAllSubclasses | n2 | n2 _ Object allSubclasses size. self assert: n2 = (Object allSubclasses select: [:cls | cls class class == Metaclass or: [cls class == Metaclass]]) size! ! !BCCMTest commentStamp: '' prior: 0! This class contains some tests regarding the classes Behavior ClassDescription Class Metaclass --- ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:45'! errorFileFormat self error: 'malformed bdf format'! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:46'! errorUnsupported self error: 'unsupported bdf'! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:43'! getLine ^self upTo: Character cr.! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:44'! initialize properties _ Dictionary new.! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/23/2000 18:58'! read | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width blt lastAscii pointSize ret dwidth cell cellBlt | form _ encoding _ bbx _ nil. self initialize. self readAttributes. height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. maxWidth _ 0. minAscii _ 9999. strikeWidth _ 0. maxAscii _ 0. charsNum _ Integer readFromString: (properties at: #CHARS) first. chars _ Set new: charsNum. 1 to: charsNum do: [:i | array _ self readOneCharacter. form _ array at: 1. encoding _ array at: 2. bbx _ array at: 3. dwidth _ array at: 4. "form isNil ifFalse: [form morphEdit]." "self halt." form ifNotNil: [ dwidth _ dwidth - 1. width _ dwidth max: (bbx at: 1). maxWidth _ maxWidth max: width. minAscii _ minAscii min: encoding. maxAscii _ maxAscii max: encoding. strikeWidth _ strikeWidth + width. chars add: array. ]. ]. chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. charsNum _ chars size. "undefined encodings make this different" xTable _ (Array new: 258) atAllPut: 0. glyphs _ Form extent: strikeWidth@height. blt _ BitBlt toForm: glyphs. lastAscii _ 0. 1 to: charsNum do: [:i | | unspliceArray | unspliceArray _ chars at: i. form _ unspliceArray at: 1. encoding _ unspliceArray at: 2. bbx _ unspliceArray at: 3. dwidth _ (unspliceArray at: 4). width _ dwidth max: (bbx at: 1). lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]. "I should be able to do all of this in one blit, but I'm too confused. Create a Form of the proper size for this glyph, render the BDF bitmap into it, then stamp it into the StrikeFont glyphs form." cell _ Form extent: width@height. cellBlt _ BitBlt toForm: cell. cellBlt copy: ((bbx at: 3)@((ascent - (bbx at: 2) - (bbx at: 4))) extent: (bbx at: 1)@(bbx at: 2)) from: 0@0 in: form. blt copyForm: cell to: (xTable at: encoding+1)@0 rule: Form over. "blt copy: (( ((xTable at: encoding+1)+(bbx at: 3))@(ascent - (bbx at: 2) - (bbx at: 4))) extent: (bbx at: 1)@(bbx at: 2)) from: 0@0 in: form." xTable at: encoding+2 put: (xTable at: encoding+1)+(width). lastAscii _ encoding. ]. ret _ Array new: 8. ret at: 1 put: xTable. ret at: 2 put: glyphs. ret at: 3 put: minAscii. ret at: 4 put: maxAscii. ret at: 5 put: maxWidth. ret at: 6 put: ascent. ret at: 7 put: descent. ret at: 8 put: pointSize. ^ret. " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}"! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 05:08' prior: 33894163! read | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width blt lastAscii pointSize ret stream | form _ encoding _ bbx _ nil. self initialize. self readAttributes. height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. maxWidth _ 0. minAscii _ 9999. strikeWidth _ 0. maxAscii _ 0. charsNum _ Integer readFromString: (properties at: #CHARS) first. chars _ Set new: charsNum. 1 to: charsNum do: [:i | array _ self readOneCharacter. stream _ ReadStream on: array. form _ stream next. encoding _ stream next. bbx _ stream next. form ifNotNil: [ width _ bbx at: 1. maxWidth _ maxWidth max: width. minAscii _ minAscii min: encoding. maxAscii _ maxAscii max: encoding. strikeWidth _ strikeWidth + width. chars add: array. ]. ]. chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. charsNum _ chars size. "undefined encodings make this different" charsNum > 256 ifTrue: [ "it should be 94x94 charset, and should be fixed width font" strikeWidth _ 94*94*maxWidth. maxAscii _ 94*94. minAscii _ 0. xTable _ XTableForFixedFont new. xTable maxAscii: 94*94. xTable width: maxWidth. ] ifFalse: [ xTable _ (Array new: 258) atAllPut: 0. ]. glyphs _ Form extent: strikeWidth@height. blt _ BitBlt toForm: glyphs. lastAscii _ 0. charsNum > 256 ifTrue: [ 1 to: charsNum do: [:i | stream _ ReadStream on: (chars at: i). form _ stream next. encoding _ stream next. bbx _ stream next. encoding _ ((encoding // 256) - 33) * 94 + ((encoding \\ 256) - 33). blt copy: ((encoding * maxWidth)@0 extent: maxWidth@height) from: 0@0 in: form. ]. ] ifFalse: [ 1 to: charsNum do: [:i | stream _ ReadStream on: (chars at: i). form _ stream next. encoding _ stream next. bbx _ stream next. lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]. blt copy: (((xTable at: encoding+1)@(ascent - (bbx at: 2) - (bbx at: 4))) extent: (bbx at: 1)@(bbx at: 2)) from: 0@0 in: form. xTable at: encoding+2 put: (xTable at: encoding+1)+(bbx at: 1). lastAscii _ encoding. ] ]. ret _ Array new: 8. ret at: 1 put: xTable. ret at: 2 put: glyphs. ret at: 3 put: minAscii. ret at: 4 put: maxAscii. ret at: 5 put: maxWidth. ret at: 6 put: ascent. ret at: 7 put: descent. ret at: 8 put: pointSize. ^ret. " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}" ! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:44'! readAttributes | str a | "I don't handle double-quotes correctly, but it works" self reset. [self atEnd] whileFalse: [ str _ self getLine. (str beginsWith: 'STARTCHAR') ifTrue: [self skip: (0 - str size - 1). ^self]. a _ str substrings. properties at: a first asSymbol put: a allButFirst. ]. self error: 'file seems corrupted'.! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 11:31'! readChars | strikeWidth ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width pointSize stream | form _ encoding _ bbx _ nil. self initialize. self readAttributes. height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. maxWidth _ 0. minAscii _ 9999. strikeWidth _ 0. maxAscii _ 0. charsNum _ Integer readFromString: (properties at: #CHARS) first. chars _ Set new: charsNum. 1 to: charsNum do: [:i | array _ self readOneCharacter. stream _ ReadStream on: array. form _ stream next. encoding _ stream next. bbx _ stream next. form ifNotNil: [ width _ bbx at: 1. maxWidth _ maxWidth max: width. minAscii _ minAscii min: encoding. maxAscii _ maxAscii max: encoding. strikeWidth _ strikeWidth + width. chars add: array. ]. ]. chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. ^ chars. ! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/22/2000 23:33'! readOneCharacter | str a encoding bbx form bits hi low pos char dwidth | ((str _ self getLine) beginsWith: 'STARTCHAR') ifFalse: [self errorFileFormat]. char _ str substrings second. ((str _ self getLine) beginsWith: 'ENCODING') ifFalse: [self errorFileFormat]. encoding _ Integer readFromString: str substrings second. (self getLine beginsWith: 'SWIDTH') ifFalse: [self errorFileFormat]. ((str _ self getLine) beginsWith: 'DWIDTH') ifFalse: [self errorFileFormat]. dwidth _ Integer readFromString: str substrings second. ((str _ self getLine) beginsWith: 'BBX') ifFalse: [self errorFileFormat]. a _ str substrings. bbx _ (2 to: 5) collect: [:i | Integer readFromString: (a at: i)]. ((str _ self getLine) beginsWith: 'ATTRIBUTES') ifTrue: [str _ self getLine]. (str beginsWith: 'BITMAP') ifFalse: [self errorFileFormat]. form _ Form extent: (bbx at: 1)@(bbx at: 2). bits _ form bits. pos _ 0. 1 to: (bbx at: 2) do: [:t | 1 to: (((bbx at: 1) - 1) // 8 + 1) do: [:i | hi _ (('0123456789ABCDEF' indexOf: (self next asUppercase)) - 1) bitShift: 4. low _ ('0123456789ABCDEF' indexOf: (self next asUppercase)) - 1. bits byteAt: (pos+i) put: (hi+low). ]. self next ~= Character cr ifTrue: [self errorFileFormat]. pos _ pos + ((((bbx at: 1) + 31) // 32) * 4). ]. (self getLine beginsWith: 'ENDCHAR') ifFalse: [self errorFileFormat]. encoding < 0 ifTrue: [^{nil. nil. nil. nil}]. ^{form. encoding. bbx. dwidth}. ! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 05:09' prior: 33901612! readOneCharacter | str a encoding bbx form bits hi low pos char | ((str _ self getLine) beginsWith: 'STARTCHAR') ifFalse: [self errorFileFormat]. char _ str substrings second. ((str _ self getLine) beginsWith: 'ENCODING') ifFalse: [self errorFileFormat]. encoding _ Integer readFromString: str substrings second. (self getLine beginsWith: 'SWIDTH') ifFalse: [self errorFileFormat]. (self getLine beginsWith: 'DWIDTH') ifFalse: [self errorFileFormat]. ((str _ self getLine) beginsWith: 'BBX') ifFalse: [self errorFileFormat]. a _ str substrings. bbx _ (2 to: 5) collect: [:i | Integer readFromString: (a at: i)]. ((str _ self getLine) beginsWith: 'ATTRIBUTES') ifTrue: [str _ self getLine]. (str beginsWith: 'BITMAP') ifFalse: [self errorFileFormat]. form _ Form extent: (bbx at: 1)@(bbx at: 2). bits _ form bits. pos _ 0. 1 to: (bbx at: 2) do: [:t | 1 to: (((bbx at: 1) - 1) // 8 + 1) do: [:i | hi _ (('0123456789ABCDEF' indexOf: (self next asUppercase)) - 1) bitShift: 4. low _ ('0123456789ABCDEF' indexOf: (self next asUppercase)) - 1. bits byteAt: (pos+i) put: (hi+low). ]. self next ~= Character cr ifTrue: [self errorFileFormat]. pos _ pos + ((((bbx at: 1) // 32) + 1) * 4). ]. (self getLine beginsWith: 'ENDCHAR') ifFalse: [self errorFileFormat]. encoding < 0 ifTrue: [^{nil. nil. nil}]. ^{form. encoding. bbx}. ! ! !BDFFontReader commentStamp: '' prior: 0! I am a conversion utility for reading X11 Bitmap Distribution Format fonts. My code is derived from the multilingual Squeak changeset written by OHSHIMA Yoshiki (ohshima@is.titech.ac.jp), although all support for fonts with more than 256 glyphs has been ripped out. See http://www.is.titech.ac.jp/~ohshima/squeak/squeak-multilingual-e.html . My class methods contain tools for fetching BDF source files from a well-known archive site, batch conversion to Squeak's .sf2 format, and installation of these fonts as TextStyles. Also, the legal notices for the standard 75dpi fonts I process this way are included as "x11FontLegalNotices'.! !BDFFontReader class methodsFor: 'file creation' stamp: 'nop 1/23/2000 19:00'! convertFilesNamed: fileName toFamilyNamed: familyName inDirectoryNamed: dirName "BDFFontReader convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: '' " "This utility converts X11 BDF font files to Squeak .sf2 StrikeFont files." "For this utility to work as is, the BDF files must be named 'familyNN.bdf', and must reside in the directory named by dirName (use '' for the current directory). The output StrikeFont files will be named familyNN.sf2, and will be placed in the current directory." | f allFontNames sizeChars dir | "Check for matching file names." dir _ dirName isEmpty ifTrue: [FileDirectory default] ifFalse: [FileDirectory default directoryNamed: dirName]. allFontNames _ dir fileNamesMatching: fileName , '##.bdf'. allFontNames isEmpty ifTrue: [^ self error: 'No files found like ' , fileName , 'NN.bdf']. Utilities informUserDuring: [:info | allFontNames do: [:fname | info value: 'Converting ', familyName, ' BDF file ', fname, ' to SF2 format'. sizeChars _ (fname copyFrom: fileName size + 1 to: fname size) copyUpTo: $. . f _ StrikeFont new readBDFFromFile: (dir fullNameFor: fname) name: familyName, sizeChars. f writeAsStrike2named: familyName, sizeChars, '.sf2'. ]. ]! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'nop 1/23/2000 18:43'! convertX11FontsToStrike2 "BDFFontReader convertX11FontsToStrike2" "Given a set of standard X11 BDF font files (probably downloaded via BDFFontReader downloadFonts), produce .sf2 format fonts. The source and destination directory is the current directory." "Charter currently tickles a bug in the BDF parser. Skip it for now." "self convertFilesNamed: 'charR' toFamilyNamed: 'Charter' inDirectoryNamed: ''." self convertFilesNamed: 'courR' toFamilyNamed: 'Courier' inDirectoryNamed: ''. self convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: ''. self convertFilesNamed: 'lubR' toFamilyNamed: 'LucidaBright' inDirectoryNamed: ''. self convertFilesNamed: 'luRS' toFamilyNamed: 'Lucida' inDirectoryNamed: ''. self convertFilesNamed: 'lutRS' toFamilyNamed: 'LucidaTypewriter' inDirectoryNamed: ''. self convertFilesNamed: 'ncenR' toFamilyNamed: 'NewCenturySchoolbook' inDirectoryNamed: ''. self convertFilesNamed: 'timR' toFamilyNamed: 'TimesRoman' inDirectoryNamed: ''.! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'nop 2/11/2001 00:24'! downloadFonts "BDFFontReader downloadFonts" "Download a standard set of BDF sources from x.org. The combined size of these source files is around 1.2M; after conversion to .sf2 format they may be deleted." | heads tails filenames baseUrl basePath newUrl newPath document f | heads _ #( 'charR' 'courR' 'helvR' 'lubR' 'luRS' 'lutRS' 'ncenR' 'timR' ). tails _ #( '08' '10' '12' '14' '18' '24'). filenames _ OrderedCollection new. heads do: [:head | filenames addAll: (tails collect: [:tail | head , tail , '.bdf']) ]. baseUrl _ Url absoluteFromText: 'http://ftp.x.org/pub/R6.4/xc/fonts/bdf/75dpi/'. basePath _ baseUrl path. filenames do: [:filename | newUrl _ baseUrl clone. newPath _ OrderedCollection newFrom: basePath. newPath addLast: filename. newUrl path: newPath. Utilities informUser: 'Fetching ' , filename during: [document _ newUrl retrieveContents]. f _ CrLfFileStream newFileNamed: filename. f nextPutAll: document content. f close. ]. ! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'nop 1/23/2000 18:44'! installX11Fonts "BDFFontReader installX11Fonts" "Installs previously-converted .sf2 fonts into the TextConstants dictionary. This makes them available as TextStyles everywhere in the image." | families fontArray textStyle | families _ #( 'Courier' 'Helvetica' 'LucidaBright' 'Lucida' 'LucidaTypewriter' 'NewCenturySchoolbook' 'TimesRoman' ). families do: [:family | fontArray _ StrikeFont readStrikeFont2Family: family. textStyle _ TextStyle fontArray: fontArray. TextConstants at: family asSymbol put: textStyle. ]. ! ! !BDFFontReader class methodsFor: 'documentation' stamp: 'nop 2/11/2001 00:22'! gettingAndInstallingTheFonts "Download the 1.3M of BDF font source files from x.org: BDFFontReader downloadFonts. Convert them to .sf2 StrikeFont files: BDFFontReader convertX11FontsToStrike2. Install them into the system as TextStyles: BDFFontReader installX11Fonts. Read the legal notices in 'BDFFontReader x11FontLegalNotices' before redistributing images containing these fonts."! ! !BDFFontReader class methodsFor: 'documentation' stamp: 'nop 1/23/2000 18:30'! x11FontLegalNotices ^ 'The X11 BDF fonts contain copyright and license information as comments in the font source code. For the font family files "cour" (Courier), "helv" (Helvetica), "ncen" (New Century Schoolbook), and "tim" (Times Roman) the notice reads: COMMENT Copyright 1984-1989, 1994 Adobe Systems Incorporated. COMMENT Copyright 1988, 1994 Digital Equipment Corporation. COMMENT COMMENT Adobe is a trademark of Adobe Systems Incorporated which may be COMMENT registered in certain jurisdictions. COMMENT Permission to use these trademarks is hereby granted only in COMMENT association with the images described in this file. COMMENT COMMENT Permission to use, copy, modify, distribute and sell this software COMMENT and its documentation for any purpose and without fee is hereby COMMENT granted, provided that the above copyright notices appear in all COMMENT copies and that both those copyright notices and this permission COMMENT notice appear in supporting documentation, and that the names of COMMENT Adobe Systems and Digital Equipment Corporation not be used in COMMENT advertising or publicity pertaining to distribution of the software COMMENT without specific, written prior permission. Adobe Systems and COMMENT Digital Equipment Corporation make no representations about the COMMENT suitability of this software for any purpose. It is provided "as COMMENT is" without express or implied warranty. For the font family files "char" (Charter), the notice reads: COMMENT Copyright 1988 Bitstream, Inc., Cambridge, Massachusetts, USA COMMENT Bitstream and Charter are registered trademarks of Bitstream, Inc. COMMENT COMMENT The names "Bitstream" and "Charter" are registered trademarks of COMMENT Bitstream, Inc. Permission to use these trademarks is hereby COMMENT granted only in association with the images described in this file. COMMENT COMMENT Permission to use, copy, modify, and distribute this software and COMMENT its documentation for any purpose and without fee is hereby COMMENT granted, provided that the above copyright notice appear in all COMMENT copies and that both that copyright notice and this permission COMMENT notice appear in supporting documentation, and that the name of COMMENT Bitstream not be used in advertising or publicity pertaining to COMMENT distribution of the software without specific, written prior COMMENT permission. Bitstream makes no representations about the COMMENT suitability of this software for any purpose. It is provided "as COMMENT is" without express or implied warranty. COMMENT COMMENT BITSTREAM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, COMMENT INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN COMMENT NO EVENT SHALL BITSTREAM BE LIABLE FOR ANY SPECIAL, INDIRECT OR COMMENT CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS COMMENT OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, COMMENT NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN COMMENT CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. For the font family files "lu" (Lucida), "lub" (Lucida Bright), and "lut" (Lucida Typewriter), the notice reads: COMMENT (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered COMMENT trademark of Bigelow & Holmes. See LEGAL NOTICE file for terms COMMENT of the license. The LEGAL NOTICE contains: This is the LEGAL NOTICE pertaining to the Lucida fonts from Bigelow & Holmes: NOTICE TO USER: The source code, including the glyphs or icons forming a par of the OPEN LOOK TM Graphic User Interface, on this tape and in these files is copyrighted under U.S. and international laws. Sun Microsystems, Inc. of Mountain View, California owns the copyright and has design patents pending on many of the icons. AT&T is the owner of the OPEN LOOK trademark associated with the materials on this tape. Users and possessors of this source code are hereby granted a nonexclusive, royalty-free copyright and design patent license to use this code in individual and commercial software. A royalty-free, nonexclusive trademark license to refer to the code and output as "OPEN LOOK" compatible is available from AT&T if, and only if, the appearance of the icons or glyphs is not changed in any manner except as absolutely necessary to accommodate the standard resolution of the screen or other output device, the code and output is not changed except as authorized herein, and the code and output is validated by AT&T. Bigelow & Holmes is the owner of the Lucida (R) trademark for the fonts and bit-mapped images associated with the materials on this tape. Users are granted a royalty-free, nonexclusive license to use the trademark only to identify the fonts and bit-mapped images if, and only if, the fonts and bit-mapped images are not modified in any way by the user. Any use of this source code must include, in the user documentation and internal comments to the code, notices to the end user as follows: (c) Copyright 1989 Sun Microsystems, Inc. Sun design patents pending in the U.S. and foreign countries. OPEN LOOK is a trademark of AT&T. Used by written permission of the owners. (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered trademark of Bigelow & Holmes. Permission to use the Lucida trademark is hereby granted only in association with the images and fonts described in this file. SUN MICROSYSTEMS, INC., AT&T, AND BIGELOW & HOLMES MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF THIS SOURCE CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND. SUN MICROSYSTEMS, INC., AT&T AND BIGELOW & HOLMES, SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOURCE CODE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS, INC., AT&T OR BIGELOW & HOLMES BE LIABLE FOR ANY SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOURCE CODE. '. ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:36'! nextImage | colors | stream binary. self readHeader. biBitCount = 24 ifTrue:[^self read24BmpFile]. "read the color map" colors := self readColorMap. ^self readIndexedBmpFile: colors! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 17:24'! read24BmpFile "Read 24-bit pixel data from the given a BMP stream." | form formBits pixelLine bitsIndex | form _ Form extent: biWidth@biHeight depth: 32. pixelLine := ByteArray new: (((24 * biWidth) + 31) // 32) * 4. bitsIndex := form height - 1 * biWidth + 1. formBits := form bits. 1 to: biHeight do: [:i | pixelLine := stream nextInto: pixelLine. self read24BmpLine: pixelLine into: formBits startingAt: bitsIndex width: biWidth. bitsIndex := bitsIndex - biWidth. ]. ^ form ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 18:47'! read24BmpLine: pixelLine into: formBits startingAt: formBitsIndex width: width | pixIndex rgb bitsIndex | pixIndex _ 0. "pre-increment" bitsIndex := formBitsIndex-1. "pre-increment" 1 to: width do: [:j | rgb := (pixelLine at: (pixIndex := pixIndex+1)) + ((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 8) + ((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 16). rgb = 0 ifTrue:[rgb := 16rFF000001] ifFalse:[rgb := rgb + 16rFF000000]. formBits at: (bitsIndex := bitsIndex+1) put: rgb. ]. ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 18:17'! readColorMap "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." | colorCount colors maxLevel b g r ccStream | colorCount _ (bfOffBits - 54) // 4. "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" biBitCount = 16 ifTrue:[^nil]. colorCount = 0 ifTrue: [ "this BMP file does not have a color map" "default monochrome color map" biBitCount = 1 ifTrue: [^ Array with: Color white with: Color black]. "default gray-scale color map" maxLevel _ (2 raisedTo: biBitCount) - 1. ^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]]. ccStream := ReadStream on: (stream next: colorCount*4). colors _ Array new: colorCount. 1 to: colorCount do: [:i | b _ ccStream next. g _ ccStream next. r _ ccStream next. ccStream next. "skip reserved" colors at: i put: (Color r: r g: g b: b range: 255)]. ^ colors ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:20'! readHeader | reserved | bfType _ stream nextLittleEndianNumber: 2. bfSize _ stream nextLittleEndianNumber: 4. reserved _ stream nextLittleEndianNumber: 4. bfOffBits _ stream nextLittleEndianNumber: 4. biSize _ stream nextLittleEndianNumber: 4. biWidth _ stream nextLittleEndianNumber: 4. biHeight _ stream nextLittleEndianNumber: 4. biPlanes _ stream nextLittleEndianNumber: 2. biBitCount _ stream nextLittleEndianNumber: 2. biCompression _ stream nextLittleEndianNumber: 4. biSizeImage _ stream nextLittleEndianNumber: 4. biXPelsPerMeter _ stream nextLittleEndianNumber: 4. biYPelsPerMeter _ stream nextLittleEndianNumber: 4. biClrUsed _ stream nextLittleEndianNumber: 4. biClrImportant _ stream nextLittleEndianNumber: 4. ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:35'! readIndexedBmpFile: colors "Read uncompressed pixel data of depth d from the given BMP stream, where d is 1, 4, 8, or 16" | form bytesPerRow pixelData pixelLine startIndex cm word formBits | colors ifNil:[form _ Form extent: biWidth@biHeight depth: biBitCount] ifNotNil:[form _ ColorForm extent: biWidth@biHeight depth: biBitCount. form colors: colors]. bytesPerRow _ (((biBitCount* biWidth) + 31) // 32) * 4. pixelData _ ByteArray new: bytesPerRow * biHeight. biHeight to: 1 by: -1 do: [:y | pixelLine _ stream next: bytesPerRow. startIndex _ ((y - 1) * bytesPerRow) + 1. pixelData replaceFrom: startIndex to: startIndex + bytesPerRow - 1 with: pixelLine startingAt: 1]. form bits copyFromByteArray: pixelData. biBitCount = 16 ifTrue:[ "swap red and blue components" cm _ Bitmap new: (1 << 15). word _ 0. 0 to: 31 do:[:r| 0 to: 31 do:[:g| 0 to: 31 do:[:b| cm at: (word _ word + 1) put: (b bitShift: 10) + (g bitShift: 5) + r]]]. cm at: 1 put: 1. formBits _ form bits. 1 to: formBits size do:[:i| word _ formBits at: i. word _ (cm at: (word bitAnd: 16r7FFF) + 1) + ((cm at: ((word bitShift: -16) bitAnd: 16r7FFF) +1) bitShift: 16). formBits at: i put: word. ]. ]. ^ form ! ! !BMPReadWriter methodsFor: 'writing' stamp: 'ar 6/16/2002 17:50'! nextPutImage: aForm | bhSize rowBytes rgb data colorValues depth image | depth := aForm depth. [#(1 4 8 32) includes: depth] whileFalse:[depth := depth + 1 asLargerPowerOfTwo]. image := aForm asFormOfDepth: depth. image unhibernate. bhSize _ 14. "# bytes in file header" biSize _ 40. "info header size in bytes" biWidth := image width. biHeight := image height. biClrUsed _ depth = 32 ifTrue: [0] ifFalse:[1 << depth]. "No. color table entries" bfOffBits _ biSize + bhSize + (4*biClrUsed). rowBytes _ ((depth min: 24) * biWidth + 31 // 32) * 4. biSizeImage _ biHeight * rowBytes. "Write the file header" stream position: 0. stream nextLittleEndianNumber: 2 put: 19778. "bfType = BM" stream nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage. "Entire file size in bytes" stream nextLittleEndianNumber: 4 put: 0. "bfReserved" stream nextLittleEndianNumber: 4 put: bfOffBits. "Offset of bitmap data from start of hdr (and file)" "Write the bitmap info header" stream position: bhSize. stream nextLittleEndianNumber: 4 put: biSize. "info header size in bytes" stream nextLittleEndianNumber: 4 put: image width. "biWidth" stream nextLittleEndianNumber: 4 put: image height. "biHeight" stream nextLittleEndianNumber: 2 put: 1. "biPlanes" stream nextLittleEndianNumber: 2 put: (depth min: 24). "biBitCount" stream nextLittleEndianNumber: 4 put: 0. "biCompression" stream nextLittleEndianNumber: 4 put: biSizeImage. "size of image section in bytes" stream nextLittleEndianNumber: 4 put: 2800. "biXPelsPerMeter" stream nextLittleEndianNumber: 4 put: 2800. "biYPelsPerMeter" stream nextLittleEndianNumber: 4 put: biClrUsed. stream nextLittleEndianNumber: 4 put: 0. "biClrImportant" biClrUsed > 0 ifTrue: [ "write color map; this works for ColorForms, too" colorValues _ image colormapIfNeededForDepth: 32. 1 to: biClrUsed do: [:i | rgb _ colorValues at: i. 0 to: 24 by: 8 do: [:j | stream nextPut: (rgb >> j bitAnd: 16rFF)]]]. 1 to: biHeight do:[:i | data _ (image copy: (0@(biHeight-i) extent: biWidth@1)) bits. depth = 32 ifTrue: [1 to: data size do: [:j | stream nextLittleEndianNumber: 3 put: (data at: j)]. 1 to: (data size*3)+3//4*4-(data size*3) do: [:j | stream nextPut: 0 "pad to 32-bits"]] ifFalse: [1 to: data size do: [:j | stream nextNumber: 4 put: (data at: j)]]]. stream position = (bfOffBits + biSizeImage) ifFalse: [self error:'Write failure']. stream close.! ! !BMPReadWriter methodsFor: 'testing' stamp: 'ar 6/16/2002 15:27'! understandsImageFormat stream size < 54 ifTrue:[^false]. "min size = BITMAPFILEHEADER+BITMAPINFOHEADER" self readHeader. bfType = 19778 "BM" ifFalse:[^false]. biSize = 40 ifFalse:[^false]. biPlanes = 1 ifFalse:[^false]. bfSize <= stream size ifFalse:[^false]. biCompression = 0 ifFalse:[^false]. ^true! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:55'! displayAllFrom: fd "BMPReadWriter displayAllFrom: FileDirectory default" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [(Form fromBinaryStream: (fd readOnlyFileNamed: fName)) display. Display forceDisplayUpdate] on: Error do:[:nix|]. ]. ]. fd directoryNames do:[:fdName| self displayAllFrom: (fd directoryNamed: fdName) ].! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:56'! readAllFrom: fd "MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory default]" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [Form fromBinaryStream: (fd readOnlyFileNamed: fName)] on: Error do:[:nix]. ]. ]. fd directoryNames do:[:fdName| self readAllFrom: (fd directoryNamed: fdName) ].! ! !BMPReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('bmp')! ! !BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/4/2001 16:19'! drawSubmorphsOnREAL: aCanvas | newClip | (self innerBounds intersects: aCanvas clipRect) ifFalse: [^self]. newClip _ ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) truncated. useRegularWarpBlt == true ifTrue: [ transform scale asFloat = 1.0 ifFalse: [ newClip _ self innerBounds. "avoids gribblies" ]. ^aCanvas transformBy: transform clippingTo: newClip during: [:myCanvas | submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] smoothing: smoothing ]. aCanvas transform2By: transform "#transformBy: for pure WarpBlt" clippingTo: newClip during: [:myCanvas | submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] smoothing: smoothing ! ! !BOBTransformationMorph methodsFor: 'drawing' stamp: 'RAA 6/4/2001 16:21'! drawSubmorphsOn: aCanvas | t | t _ [ self drawSubmorphsOnREAL: aCanvas ] timeToRun. "Q1 at: 3 put: t." ! ! !BOBTransformationMorph methodsFor: 'layout' stamp: 'dgd 2/21/2003 23:02' prior: 17737952! layoutChanged "use the version from Morph" | myGuy | fullBounds := nil. owner ifNotNil: [owner layoutChanged]. submorphs notEmpty ifTrue: [(myGuy := self firstSubmorph) isWorldMorph ifFalse: [worldBoundsToShow = myGuy bounds ifFalse: [self changeWorldBoundsToShow: (worldBoundsToShow := myGuy bounds)]] "submorphs do: [:m | m ownerChanged]" "<< I don't see any reason for this"]! ! !BackgroundMorph methodsFor: 'as yet unclassified' stamp: 'aoy 2/17/2003 01:20' prior: 17742337! subBounds "calculate the submorph bounds" | subBounds | subBounds := nil. self submorphsDo: [:m | subBounds := subBounds isNil ifTrue: [m fullBounds] ifFalse: [subBounds merge: m fullBounds]]. ^subBounds! ! !BackgroundMorph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:16'! fullDrawOn: aCanvas (aCanvas isVisible: self fullBounds) ifFalse:[^self]. running ifFalse: [ ^aCanvas clipBy: (bounds translateBy: aCanvas origin) during:[:clippedCanvas| super fullDrawOn: clippedCanvas]]. (aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self]. ! ! !BackgroundMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:43' prior: 17741438! initialize "initialize the state of the receiver" super initialize. "" offset _ 0 @ 0. delta _ 1 @ 0. running _ true! ! !BackgroundMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56' prior: 17739917! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. running ifTrue: [aCustomMenu add: 'stop' translated action: #stopRunning] ifFalse: [aCustomMenu add: 'start' translated action: #startRunning]! ! !BadEqualer methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! = other self class = other class ifFalse: [^ false]. ^ 100 atRandom < 30 ! ! !BadEqualer commentStamp: 'mjr 8/20/2003 13:28' prior: 0! I am an object that doesn't always report #= correctly. Used for testing the EqualityTester.! !BadHasher methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! hash "answer with a different hash some of the time" 100 atRandom < 30 ifTrue: [^ 1]. ^ 2! ! !BadHasher commentStamp: 'mjr 8/20/2003 13:28' prior: 0! I am an object that doesn't always hash correctly. I am used for testing the HashTester.! !Bag methodsFor: 'comparing' stamp: 'raok 6/10/2002 15:28'! = aBag "Two bags are equal if (a) they are the same 'kind' of thing. (b) they have the same size. (c) each element occurs the same number of times in both of them". (aBag isKindOf: Bag) ifFalse: [^false]. self size = aBag size ifFalse: [^false]. contents associationsDo: [:assoc| (aBag occurrencesOf: assoc key) = assoc value ifFalse: [^false]]. ^true ! ! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! contentsClass ^Dictionary! ! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! new: nElements ^ super new setContents: (self contentsClass new: nElements)! ! !BalloonBezierSimulation commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonBuffer commentStamp: '' prior: 0! BalloonBuffer is a repository for primitive data used by the BalloonEngine.! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 2/13/2001 21:07'! ensuredEngine engine ifNil:[ engine _ BalloonEngine new. "engine _ BalloonDebugEngine new" engine aaLevel: aaLevel. engine bitBlt: port. engine destOffset: origin. engine clipRect: clipRect. engine deferred: deferred. engine]. engine colorTransform: colorTransform. engine edgeTransform: transform. ^engine! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'nk 5/1/2004 12:25' prior: 17771501! frameRectangle: r width: w color: c "Draw a frame around the given rectangle" ^self frameAndFillRectangle: r fillColor: Color transparent borderWidth: w borderColor: c! ! !BalloonCanvas methodsFor: 'TODO' stamp: 'ar 12/31/2001 02:27'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c (self ifNoTransformWithIn: boundsRect) ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! ! !BalloonCanvas methodsFor: 'private' stamp: 'nk 5/1/2004 12:54' prior: 17778317! image: aForm at: aPoint sourceRect: sourceRect rule: rule | warp dstRect srcQuad dstOffset center | (self ifNoTransformWithIn: sourceRect) & false ifTrue:[^super image: aForm at: aPoint sourceRect: sourceRect rule: rule]. dstRect _ (transform localBoundsToGlobal: (aForm boundingBox translateBy: aPoint)). dstOffset _ 0@0. "dstRect origin." "dstRect _ 0@0 corner: dstRect extent." center _ 0@0."transform globalPointToLocal: dstRect origin." srcQuad _ transform globalPointsToLocal: (dstRect innerCorners). srcQuad _ srcQuad collect:[:pt| pt - aPoint]. warp _ (WarpBlt current toForm: form) sourceForm: aForm; cellSize: 2; "installs a new colormap if cellSize > 1" combinationRule: Form over. warp copyQuad: srcQuad toRect: (dstRect translateBy: dstOffset). self frameRectangle: (aForm boundingBox translateBy: aPoint) color: Color green. "... TODO ... create a bitmap fill style from the form and use it for a simple rectangle."! ! !BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 8/26/2001 22:14'! drawPolygon: vertices fillStyle: aFillStyle "Fill the given polygon." self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: nil! ! !BalloonCanvas commentStamp: '' prior: 0! BalloonCanvas is a canvas using the BalloonEngine for drawing wherever possible. It has various methods which other canvases do not support due to the extra features of the balloon engine.! !BalloonEngine methodsFor: 'initialize' stamp: 'nk 9/26/2003 10:52' prior: 17793378! initialize | w | w _ Display width > 2048 ifTrue: [ 4096 ] ifFalse: [ 2048 ]. externals _ OrderedCollection new: 100. span _ Bitmap new: w. bitBlt _ nil. self bitBlt: ((BitBlt toForm: Display) destRect: Display boundingBox; yourself). forms _ #(). deferred _ false.! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 3/6/2001 12:06'! copyBits (bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate]. self copyLoopFaster.! ! !BalloonEngine commentStamp: '' prior: 0! BalloonEngine is the representative for the Balloon engine inside Squeak. For most purposes it should not be used directly but via BalloonCanvas since this ensures proper initialization and is polymorphic with other canvas uses.! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:55'! initEdgeConstants "Initialize the edge constants" "Edge primitive types" GEPrimitiveEdge := 2. "External edge - not handled by the GE" GEPrimitiveWideEdge := 3. "Wide external edge" GEPrimitiveLine := 4. "Straight line" GEPrimitiveWideLine := 5. "Wide line" GEPrimitiveBezier := 6. "Quadratic bezier curve" GEPrimitiveWideBezier := 7. "Wide bezier curve" "Special flags" GEPrimitiveWide := 16r01. "Flag determining a wide primitive" GEPrimitiveWideMask := 16rFE. "Mask for clearing the wide flag" GEEdgeFillsInvalid := 16r10000. "Flag determining if left/right fills of an edge are invalid" GEEdgeClipFlag := 16r20000. "Flag determining if this is a clip edge" "General edge state constants" GEXValue := 4. "Current raster x" GEYValue := 5. "Current raster y" GEZValue := 6. "Current raster z" GENumLines := 7. "Number of scan lines remaining" GEFillIndexLeft := 8. "Left fill index" GEFillIndexRight := 9. "Right fill index" GEBaseEdgeSize := 10. "Basic size of each edge" "General fill state constants" GEBaseFillSize := 4. "Basic size of each fill" "General Line state constants" GLXDirection := 10. "Direction of edge (1: left-to-right; -1: right-to-left)" GLYDirection := 11. "Direction of edge (1: top-to-bottom; -1: bottom-to-top)" GLXIncrement := 12. "Increment at each scan line" GLError := 13. "Current error" GLErrorAdjUp := 14. "Error to add at each scan line" GLErrorAdjDown := 15. "Error to subtract on roll-over" "Note: The following entries are only needed before the incremental state is computed. They are therefore aliased to the error values above" GLEndX := 14. "End X of line" GLEndY := 15. "End Y of line" GLBaseSize := 16. "Basic size of each line" "Additional stuff for wide lines" GLWideFill := 16. "Current fill of line" GLWideWidth := 17. "Current width of line" GLWideEntry := 18. "Initial steps" GLWideExit := 19. "Final steps" GLWideExtent := 20. "Target width" GLWideSize := 21. "Size of wide lines" "General Bezier state constants" GBUpdateData := 10. "Incremental update data for beziers" GBUpdateX := 0. "Last computed X value (24.8)" GBUpdateY := 1. "Last computed Y value (24.8)" GBUpdateDX := 2. "Delta X forward difference step (8.24)" GBUpdateDY := 3. "Delta Y forward difference step (8.24)" GBUpdateDDX := 4. "Delta DX forward difference step (8.24)" GBUpdateDDY := 5. "Delta DY forward difference step (8.24)" "Note: The following four entries are only needed before the incremental state is computed. They are therefore aliased to the incremental values above" GBViaX := 12. "via x" GBViaY := 13. "via y" GBEndX := 14. "end x" GBEndY := 15. "end y" GBBaseSize := 16. "Basic size of each bezier. Note: MUST be greater or equal to the size of lines" "Additional stuff for wide beziers" GBWideFill := 16. "Current fill of line" GBWideWidth := 17. "Current width of line" GBWideEntry := 18. "Initial steps" GBWideExit := 19. "Final steps" GBWideExtent := 20. "Target extent" GBFinalX := 21. "Final X value" GBWideUpdateData := 22. "Update data for second curve" GBWideSize := 28. "Size of wide beziers" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! initFillConstants "Initialize the fill constants" "Fill primitive types" GEPrimitiveFill := 16r100. GEPrimitiveLinearGradientFill := 16r200. GEPrimitiveRadialGradientFill := 16r300. GEPrimitiveClippedBitmapFill := 16r400. GEPrimitiveRepeatedBitmapFill := 16r500. "General fill state constants" GEBaseFillSize := 4. "Basic size of each fill" "Oriented fill constants" GFOriginX := 4. "X origin of fill" GFOriginY := 5. "Y origin of fill" GFDirectionX := 6. "X direction of fill" GFDirectionY := 7. "Y direction of fill" GFNormalX := 8. "X normal of fill" GFNormalY := 9. "Y normal of fill" "Gradient fill constants" GFRampLength := 10. "Length of following color ramp" GFRampOffset := 12. "Offset of first ramp entry" GGBaseSize := 12. "Bitmap fill constants" GBBitmapWidth := 10. "Width of bitmap" GBBitmapHeight := 11. "Height of bitmap" GBBitmapDepth := 12. "Depth of bitmap" GBBitmapSize := 13. "Size of bitmap words" GBBitmapRaster := 14. "Size of raster line" GBColormapSize := 15. "Size of colormap, if any" GBTileFlag := 16. "True if the bitmap is tiled" GBColormapOffset := 18. "Offset of colormap, if any" GBMBaseSize := 18. "Basic size of bitmap fill" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:59'! initPrimitiveConstants "Initialize the primitive constants" "Primitive type constants" GEPrimitiveUnknown := 0. GEPrimitiveEdgeMask := 16rFF. GEPrimitiveFillMask := 16rFF00. GEPrimitiveTypeMask := 16rFFFF. "General state constants (Note: could be compressed later)" GEObjectType := 0. "Type of object" GEObjectLength := 1. "Length of object" GEObjectIndex := 2. "Index into external objects" GEObjectUnused := 3. "Currently unused" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:00'! initStateConstants "Initialize the state Constants" GEStateUnlocked := 0. "Buffer is unlocked and can be modified as wanted" GEStateAddingFromGET := 1. "Adding edges from the GET" GEStateWaitingForEdge := 2. "Waiting for edges added to GET" GEStateScanningAET := 3. "Scanning the active edge table" GEStateWaitingForFill := 4. "Waiting for a fill to mix in during AET scan" GEStateBlitBuffer := 5. "Blt the current scan line" GEStateUpdateEdges := 6. "Update edges to next scan line" GEStateWaitingChange := 7. "Waiting for a changed edge" GEStateCompleted := 8. "Rendering completed" "Error constants" GErrorNoMoreSpace := 1. "No more space in collection" GErrorBadState := 2. "Tried to call a primitive while engine in bad state" GErrorNeedFlush := 3. "Tried to call a primitive that requires flushing before" "Incremental error constants" GErrorGETEntry := 4. "Unknown entry in GET" GErrorFillEntry := 5. "Unknown FILL encountered" GErrorAETEntry := 6. "Unknown entry in AET" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:04'! initWorkBufferConstants "Initialize the work buffer constants" "General work buffer constants" GWMagicNumber := 16r416E6469. "Magic number" GWHeaderSize := 128. "Size of header" GWMinimalSize := 256. "Minimal size of work buffer" "Header entries" GWMagicIndex := 0. "Index of magic number" GWSize := 1. "Size of full buffer" GWState := 2. "Current state (e.g., locked or not." "Buffer entries" GWObjStart := 8. "objStart" GWObjUsed := 9. "objUsed" GWBufferTop := 10. "wbTop" GWGETStart := 11. "getStart" GWGETUsed := 12. "getUsed" GWAETStart := 13. "aetStart" GWAETUsed := 14. "aetUsed" "Transform entries" GWHasEdgeTransform := 16. "True if we have an edge transformation" GWHasColorTransform := 17. "True if we have a color transformation" GWEdgeTransform := 18. "2x3 edge transformation" GWColorTransform := 24. "8 word RGBA color transformation" "Span entries" GWSpanStart := 32. "spStart" GWSpanSize := 33. "spSize" GWSpanEnd := 34. "spEnd" GWSpanEndAA := 35. "spEndAA" "Bounds entries" GWFillMinX := 36. "fillMinX" GWFillMaxX := 37. "fillMaxX" GWFillMinY := 38. "fillMinY" GWFillMaxY := 39. "fillMaxY" GWFillOffsetX := 40. "fillOffsetX" GWFillOffsetY := 41. "fillOffsetY" GWClipMinX := 42. GWClipMaxX := 43. GWClipMinY := 44. GWClipMaxY := 45. GWDestOffsetX := 46. GWDestOffsetY := 47. "AA entries" GWAALevel := 48. "aaLevel" GWAAShift := 49. "aaShift" GWAAColorShift := 50. "aaColorShift" GWAAColorMask := 51. "aaColorMask" GWAAScanMask := 52. "aaScanMask" GWAAHalfPixel := 53. "aaHalfPixel" "Misc entries" GWNeedsFlush := 63. "True if the engine may need a flush" GWStopReason := 64. "stopReason" GWLastExportedEdge := 65. "last exported edge" GWLastExportedFill := 66. "last exported fill" GWLastExportedLeftX := 67. "last exported leftX" GWLastExportedRightX := 68. "last exported rightX" GWClearSpanBuffer := 69. "Do we have to clear the span buffer?" GWPointListFirst := 70. "First point list in buffer" GWPoint1 := 80. GWPoint2 := 82. GWPoint3 := 84. GWPoint4 := 86. GWCurrentY := 88. "Profile stats" GWTimeInitializing := 90. GWCountInitializing := 91. GWTimeFinishTest := 92. GWCountFinishTest := 93. GWTimeNextGETEntry := 94. GWCountNextGETEntry := 95. GWTimeAddAETEntry := 96. GWCountAddAETEntry := 97. GWTimeNextFillEntry := 98. GWCountNextFillEntry := 99. GWTimeMergeFill := 100. GWCountMergeFill := 101. GWTimeDisplaySpan := 102. GWCountDisplaySpan := 103. GWTimeNextAETEntry := 104. GWCountNextAETEntry := 105. GWTimeChangeAETEntry := 106. GWCountChangeAETEntry := 107. "Bezier stats" GWBezierMonotonSubdivisions := 108. "# of subdivision due to non-monoton beziers" GWBezierHeightSubdivisions := 109. "# of subdivisions due to excessive height" GWBezierOverflowSubdivisions := 110. "# of subdivisions due to possible int overflow" GWBezierLineConversions := 111. "# of beziers converted to lines" GWHasClipShapes := 112. "True if the engine contains clip shapes" GWCurrentZ := 113. "Current z value of primitives" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! initialize "BalloonEngineConstants initialize" self initStateConstants. self initWorkBufferConstants. self initPrimitiveConstants. self initEdgeConstants. self initFillConstants. self initializeInstVarNames: BalloonEngine prefixedBy: 'BE'. self initializeInstVarNames: BalloonEdgeData prefixedBy: 'ET'. self initializeInstVarNames: BalloonFillData prefixedBy: 'FT'.! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:07'! initializeInstVarNames: aClass prefixedBy: aString | token value | aClass instVarNames doWithIndex:[:instVarName :index| token _ (aString, instVarName first asUppercase asString, (instVarName copyFrom: 2 to: instVarName size),'Index') asSymbol. value _ index - 1. (self bindingOf: token) ifNil:[self addClassVarName: token]. (self bindingOf: token) value: value. ]. token _ (aString, aClass name,'Size') asSymbol. (self bindingOf: token) ifNil:[self addClassVarName: token]. (self bindingOf: token) value: aClass instSize.! ! !BalloonFillData commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonFontTest methodsFor: 'testing' stamp: 'sd 12/9/2001 21:44'! testDefaultFont "(self selector: #testDefaultFont) debug" self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.! ! !BalloonFontTest methodsFor: 'testing' stamp: 'sd 12/9/2001 21:55'! testSpecificFont "(self selector: #testSpecificFont) debug" | aMorph | aMorph := RectangleMorph new. self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont. aMorph balloonFont: (StrikeFont familyName: #ComicPlain size: 19). self assert: aMorph balloonFont = (StrikeFont familyName: #ComicPlain size: 19). "The next test is horrible because I do no know how to access the font with the appropiate interface" self assert: (((BalloonMorph getTextMorph: 'lulu' for: aMorph) text runs at: 1) at: 1) font = (StrikeFont familyName: #ComicPlain size: 19)! ! !BalloonLineSimulation commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color black! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ self class balloonColor! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:20' prior: 18113931! initialize "initialize the state of the receiver" super initialize. "" self beSmoothCurve. offsetFromTarget _ 0 @ 0! ! !BalloonMorph methodsFor: 'initialization' stamp: 'RAA 7/1/2001 18:48'! popUpForHand: aHand "Pop up the receiver as balloon help for the given hand" | worldBounds | self lock. self fullBounds. "force layout" self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber. aHand world addMorphFront: self. "So that if the translation below makes it overlap the receiver, it won't interfere with the rootMorphsAt: logic and hence cause flashing. Without this, flashing happens, believe me!!" ((worldBounds _ aHand world bounds) containsRect: self bounds) ifFalse: [self bounds: (self bounds translatedToBeWithin: worldBounds)]. aHand balloonHelp: self. ! ! !BalloonMorph class methodsFor: 'instance creation' stamp: 'sd 12/5/2001 20:27'! string: str for: morph corner: cornerName "Make up and return a balloon for morph. Find the quadrant that clips the text the least, using cornerName as a tie-breaker. tk 9/12/97" | tm vertices | tm _ self getTextMorph: str for: morph. vertices _ self getVertices: tm bounds. vertices _ self getBestLocation: vertices for: morph corner: cornerName. ^ self new color: morph balloonColor; setVertices: vertices; addMorph: tm; setTarget: morph! ! !BalloonMorph class methodsFor: 'utility' stamp: 'laza 3/25/2004 23:09' prior: 18119164! chooseBalloonFont "BalloonMorph chooseBalloonFont" Preferences chooseFontWithPrompt: 'Select the font to be used for balloon help' andSendTo: self withSelector: #setBalloonFontTo: highlight: BalloonFont! ! !BalloonMorph class methodsFor: 'private' stamp: 'sd 12/5/2001 20:28'! getTextMorph: aStringOrMorph for: balloonOwner "Construct text morph." | m text | aStringOrMorph isMorph ifTrue: [m _ aStringOrMorph] ifFalse: [BalloonFont ifNil: [text _ aStringOrMorph] ifNotNil: [text _ Text string: aStringOrMorph attribute: (TextFontReference toFont: balloonOwner balloonFont)]. m _ (TextMorph new contents: text) centered]. m setToAdhereToEdge: #adjustedCenter. ^ m! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ GradientFillStyle ramp: {0.0 -> Color black. 1.0 -> Color white}! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 10! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" | result | result _ GradientFillStyle ramp: {0.0 -> Color green. 0.5 -> Color yellow. 1.0 -> Color red}. result radial: true. ^ result! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:41' prior: 18119868! initialize "initialize the state of the receiver" super initialize. "" self extent: 100 @ 100! ! !BalloonRectangleMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'! canDrawBorder: aBorderStyle ^aBorderStyle style == #simple! ! !BalloonRectangleMorph commentStamp: '' prior: 0! BalloonRectangleMorph is an example for drawing using the BalloonEngine.! !BalloonSolidFillSimulation commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonState commentStamp: '' prior: 0! This class is a repository for data which needs to be preserved during certain operations of BalloonCanvas.! !Base64MimeConverter methodsFor: 'conversion' stamp: 'ls 2/10/2001 13:26'! mimeEncode "Convert from data to 6 bit characters." | phase1 phase2 raw nib lineLength | phase1 _ phase2 _ false. lineLength := 0. [dataStream atEnd] whileFalse: [ lineLength >= 70 ifTrue: [ mimeStream cr. lineLength := 0. ]. data _ raw _ dataStream next asInteger. nib _ (data bitAnd: 16rFC) bitShift: -2. mimeStream nextPut: (ToCharTable at: nib+1). (raw _ dataStream next) ifNil: [raw _ 0. phase1 _ true]. data _ ((data bitAnd: 3) bitShift: 8) + raw asInteger. nib _ (data bitAnd: 16r3F0) bitShift: -4. mimeStream nextPut: (ToCharTable at: nib+1). (raw _ dataStream next) ifNil: [raw _ 0. phase2 _ true]. data _ ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger). nib _ (data bitAnd: 16rFC0) bitShift: -6. mimeStream nextPut: (ToCharTable at: nib+1). nib _ (data bitAnd: 16r3F). mimeStream nextPut: (ToCharTable at: nib+1). lineLength := lineLength + 4.]. phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=. ^ mimeStream]. phase2 ifTrue: [mimeStream skip: -1; nextPut: $=. ^ mimeStream]. ! ! !Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:37'! setUp message _ ReadWriteStream on: (String new: 10). message nextPutAll: 'Hi There!!'.! ! !Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:34'! tearDown "I am called whenever your test ends. I am the place where you release the ressources"! ! !Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:45'! testMimeEncodeDecode | encoded | encoded _ Base64MimeConverter mimeEncode: message. self should: [encoded contents = 'SGkgVGhlcmUh']. self should: [(Base64MimeConverter mimeDecodeToChars: encoded) contents = message contents].! ! !Base64MimeConverterTest commentStamp: '' prior: 0! This is the unit test for the class Base64MimeConverter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !BaseSoundSystem methodsFor: 'misc' stamp: 'gk 2/24/2004 23:13'! randomBitsFromSoundInput: bitCount "Answer a positive integer with the given number of random bits of 'noise' from a sound input source. Typically, one would use a microphone or line input as the sound source, although many sound cards have enough thermal noise that you get random low-order sample bits even with no microphone connected. Only the least signficant bit of the samples is used. Since not all sound cards support 16-bits of sample resolution, we use the lowest bit that changes." "(1 to: 10) collect: [:i | BaseSoundSystem new randomBitsFromSoundInput: 512]" | recorder buf mid samples bitMask randomBits bit | "collect some sound data" recorder _ SoundRecorder new clearRecordedSound. recorder resumeRecording. (Delay forSeconds: 1) wait. recorder stopRecording. buf _ recorder condensedSamples. "grab bitCount samples from the middle" mid _ buf monoSampleCount // 2. samples _ buf copyFrom: mid to: mid + bitCount - 1. "find the least significant bit that varies" bitMask _ 1. [bitMask < 16r10000 and: [(samples collect: [:s | s bitAnd: bitMask]) asSet size < 2]] whileTrue: [bitMask _ bitMask bitShift: 1]. bitMask = 16r10000 ifTrue: [^ self error: 'sound samples do not vary']. "pack the random bits into a positive integer" randomBits _ 0. 1 to: samples size do: [:i | bit _ ((samples at: i) bitAnd: bitMask) = 0 ifTrue: [0] ifFalse: [1]. randomBits _ (randomBits bitShift: 1) + bit]. ^ randomBits ! ! !BaseSoundSystem methodsFor: 'misc' stamp: 'ads 7/30/2003 22:18'! sampledSoundChoices ^ SampledSound soundNames! ! !BaseSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'! shutDown SoundPlayer shutDown ! ! !BaseSoundSystem methodsFor: 'misc' stamp: 'ads 7/30/2003 23:17'! soundNamed: soundName ^ SampledSound soundNamed: soundName! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:20'! beep "There is sound support, so we use the default sampled sound for a beep." Preferences soundsEnabled ifTrue: [ SampledSound beep]! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:20'! playSampledSound: samples rate: rate Preferences soundsEnabled ifTrue: [ (SampledSound samples: samples samplingRate: rate) play]! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:23'! playSoundNamed: soundName "There is sound support, so we play the given sound." Preferences soundsEnabled ifTrue: [ SampledSound playSoundNamed: soundName asString]! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:22'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName Preferences soundsEnabled ifTrue: [ (SampledSound soundNames includes: soundName) ifFalse: [ (FileDirectory default fileExists: aifFileName) ifTrue: [ SampledSound addLibrarySoundNamed: soundName fromAIFFfileNamed: aifFileName]]. (SampledSound soundNames includes: soundName) ifTrue: [ SampledSound playSoundNamed: soundName]]! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:23'! playSoundNamedOrBeep: soundName "There is sound support, so we play the given sound instead of beeping." Preferences soundsEnabled ifTrue: [ ^self playSoundNamed: soundName]! ! !BaseSoundSystem commentStamp: 'gk 2/24/2004 08:35' prior: 0! This is the normal sound system in Squeak and is registered in SoundService - an AppRegistry - so that a small highlevel protocol for playing sounds can be used in a pluggable fashion. More information available in superclass.! !BaseSoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'! initialize SoundService register: self new.! ! !BaseSoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'! unload SoundService registeredClasses do: [:ss | (ss isKindOf: self) ifTrue: [SoundService unregister: ss]].! ! !BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color yellow darker! ! !BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color yellow! ! !BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:52' prior: 18131735! initialize "initialize the state of the receiver" super initialize. "" self label: 'Button'; useRoundedCorners! ! !BasicButton methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56' prior: 18131492! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'change label...' translated action: #setLabel! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:02'! classComment classComment ifNil: [^ '']. ^ classComment text ifNil: ['']! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! classComment: aString "Store the comment, aString, associated with the object that refers to the receiver." (aString isKindOf: RemoteString) ifTrue: [classComment _ aString] ifFalse: [(aString == nil or: [aString size = 0]) ifTrue: [classComment _ nil] ifFalse: [ self error: 'use aClass classComment:'. classComment _ RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! classComment: aString stamp: aStamp "Store the comment, aString, associated with the object that refers to the receiver." self commentStamp: aStamp. (aString isKindOf: RemoteString) ifTrue: [classComment _ aString] ifFalse: [(aString == nil or: [aString size = 0]) ifTrue: [classComment _ nil] ifFalse: [self error: 'use aClass classComment:'. classComment _ RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentRemoteStr ^ classComment! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentStamp "Answer the comment stamp for the class" ^ commentStamp! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentStamp: aStamp commentStamp _ aStamp! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! dateCommentLastSubmitted "Answer a Date object indicating when my class comment was last submitted. If there is no date stamp, or one of the old-time guys, return nil" "RecentMessageSet organization dateCommentLastSubmitted" | aStamp tokens | (aStamp _ self commentStamp) isEmptyOrNil ifTrue: [^ nil]. tokens _ aStamp findBetweenSubStrs: ' '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" ^ tokens size > 1 ifTrue: [[tokens second asDate] ifError: [nil]] ifFalse: [nil]! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! hasNoComment "Answer whether the class classified by the receiver has a comment." ^classComment == nil! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! hasSubject ^ self subject notNil! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! subject ^ subject.! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:03'! fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." | fileComment | classComment ifNotNil: [aFileStream cr. fileComment _ RemoteString newString: classComment text onFileNumber: fileIndex toFile: aFileStream. moveSource ifTrue: [classComment _ fileComment]]! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! moveChangedCommentToFile: aFileStream numbered: fileIndex "If the comment is in the changes file, then move it to a new file." (classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! objectForDataStream: refStrm | dp | "I am about to be written on an object file. Write a path to me in the other system instead." self hasSubject ifTrue: [ (refStrm insideASegment and: [self subject isSystemDefined not]) ifTrue: [ ^ self]. "do trace me" (self subject isKindOf: Class) ifTrue: [ dp _ DiskProxy global: self subject name selector: #organization args: #(). refStrm replace: self with: dp. ^ dp]]. ^ self "in desparation" ! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass "Store the comment about the class onto file, aFileStream." | header | classComment ifNotNil: [aFileStream cr; nextPut: $!!. header _ String streamContents: [:strm | strm nextPutAll: aClass name; nextPutAll: ' commentStamp: '. commentStamp ifNil: [commentStamp _ '']. commentStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: '0']. aFileStream nextChunkPut: header. aClass organization fileOutCommentOn: aFileStream moveSource: moveSource toFile: sourceIndex. aFileStream cr]! ! !BasicClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 16:04'! setSubject: aClassDescription subject _ aClassDescription! ! !BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! class: aClassDescription ^ self new setSubject: aClassDescription! ! !BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! class: aClassDescription defaultList: aSortedCollection | inst | inst _ self defaultList: aSortedCollection. inst setSubject: aClassDescription. ^ inst! ! !BasicInspector methodsFor: 'as yet unclassified' stamp: 'ajh 1/31/2003 15:49'! inspect: anObject "Initialize the receiver so that it is inspecting anObject. There is no current selection." self initialize. object _ anObject. selectionIndex _ 0. contents _ ''! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:28'! testBecome "Test the two way become. Note. we cannot use string literals for this test" | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a become: b. self assert: a = 'cd'; assert: b = 'ab'; assert: c = 'cd'; assert: d = 'ab'. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:28'! testBecomeForward "Test the forward become." | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a becomeForward: b. self assert: a = 'cd'; assert: b = 'cd'; assert: c = 'cd'; assert: d = 'cd'. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 17:36'! testBecomeForwardDontCopyIdentityHash "Check that 1. the argument to becomeForward: is NOT modified to have the receiver's identity hash. 2. the receiver's identity hash is unchanged." | a b hb | a := 'ab' copy. b := 'cd' copy. hb := b identityHash. a becomeForward: b copyHash: false. self assert: a identityHash = hb; assert: b identityHash = hb. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:29'! testBecomeForwardHash | a b c hb | a := 'ab' copy. b := 'cd' copy. c := a. hb := b hash. a becomeForward: b. self assert: a hash = hb; assert: b hash = hb; assert: c hash = hb. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:27'! testBecomeForwardIdentityHash "Check that 1. the argument to becomeForward: is modified to have the receiver's identity hash. 2. the receiver's identity hash is unchanged." | a b ha | a := 'ab' copy. b := 'cd' copy. ha := a identityHash. a becomeForward: b. self assert: a identityHash = ha; assert: b identityHash = ha. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:30'! testBecomeHash | a b c d ha hb | a := 'ab' copy. b := 'cd' copy. c := a. d := b. ha := a hash. hb := b hash. a become: b. self assert: a hash = hb; assert: b hash = ha; assert: c hash = hb; assert: d hash = ha. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:31'! testBecomeIdentityHash "Note. The identity hash of both objects seems to change after the become:" | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a become: b. self assert: a identityHash = c identityHash; assert: b identityHash = d identityHash; deny: a identityHash = b identityHash. ! ! !Beeper methodsFor: 'play interface' stamp: 'nb 6/17/2003 12:25'! play self beep! ! !Beeper methodsFor: 'play interface' stamp: 'gk 2/24/2004 23:25' prior: 33964107! play "This is how the default Beeper makes a beep, by sending beep to the default sound service. The sound system will check if sounds are enabled." SoundService default beep! ! !Beeper commentStamp: 'gk 2/26/2004 22:44' prior: 0! Beeper provides simple audio (or in some other way) feedback to the user. The recommended use is "Beeper beep" to give the user the equivalence of a beep. If you want to force the beep to use the primitive in the VM for beeping, then use "Beeper beepPrimitive". In either case, if sounds are disabled there will be no beep. The actual beeping, when you use "Beeper beep", is done by sending a #play message to a registered playable object. You can register your own playable object by invoking the class side method #setDefault: passing in an object that responds to the #play message. The default playable object is an instance of Beeper itself which implements #play on the instance side. That implementation delegates the playing of the beep to the default SoundService. Note that #play is introduced as a common interface between AbstractSound and Beeper. This way we can register instances of AbstractSound as playable entities, for example: Beeper setDefault: (SampledSound new setSamples: self coffeeCupClink samplingRate: 12000). Then "Beeper beep" will play the coffeeCup sound.! !Beeper class methodsFor: 'customize' stamp: 'nb 6/17/2003 12:25'! clearDefault "Set the primitive beep as the default beep." default := nil! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:51' prior: 33965622! clearDefault "Clear the default playable. Will be lazily initialized in Beeper class >>default." default := nil! ! !Beeper class methodsFor: 'customize' stamp: 'nb 6/17/2003 12:25'! default "When the default is not defined, it is myself." default isNil ifTrue: [default := self newDefault ]. ^ default! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:55' prior: 33965974! default "When the default is not defined it is initialized using #newDefault." default isNil ifTrue: [default := self newDefault ]. ^ default! ! !Beeper class methodsFor: 'customize' stamp: 'nb 6/17/2003 12:25'! newDefault "Subclasses may override me to provide a default beep." ^ self new! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/24/2004 22:12' prior: 33966408! newDefault "Subclasses may override me to provide a default beep. This base implementation returns an instance of Beeper which uses the pluggable sound service." ^ self new! ! !Beeper class methodsFor: 'customize' stamp: 'nb 6/17/2003 12:25'! setDefault: aPlayableEntity "aBeepingEntity should implement the message #play." default := aPlayableEntity! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:54' prior: 33966825! setDefault: aPlayableEntity "Set the playable entity used when making a beep. The playable entity should implement the message #play." default := aPlayableEntity! ! !Beeper class methodsFor: 'beeping' stamp: 'nb 6/17/2003 12:25'! beep "The preferred way of producing an audible feedback" Preferences soundsEnabled ifTrue: [self default play] ! ! !Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38' prior: 33967258! beep "The preferred way of producing an audible feedback. The default playable entity (an instance of Beeper) also uses the pluggable SoundService mechanism, so it will use the primitive beep only if there is no other sound mechanism available." self default play ! ! !Beeper class methodsFor: 'beeping' stamp: 'nb 6/17/2003 12:25'! beepPrimitive "Beep in the absence of sound support" self primitiveFailed! ! !Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38' prior: 33967803! beepPrimitive "Make a primitive beep. Only use this if you want to force this to be a primitive beep. Otherwise use Beeper class>>beep since this method bypasses the current registered playable entity." Preferences soundsEnabled ifTrue: [ self primitiveBeep]! ! !Beeper class methodsFor: 'private' stamp: 'gk 2/24/2004 23:51'! primitiveBeep "Make a primitive beep. Not to be called directly. It is much better to use Beeper class>>beep or Beeper class>>beepPrimitive since this method bypasses the current registered playable entity and does not check Preferences class>>soundsEnabled." self primitiveFailed! ! !Behavior methodsFor: 'initialize-release' stamp: 'NS 1/28/2004 11:17' prior: 18133988! forgetDoIts "get rid of old DoIt methods" self basicRemoveSelector: #DoIt; basicRemoveSelector: #DoItIn:! ! !Behavior methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:07' prior: 18134178! nonObsoleteClass "Attempt to find and return the current version of this obsolete class" | obsName | obsName _ self name. [obsName beginsWith: 'AnObsolete'] whileTrue: [obsName _ obsName copyFrom: 'AnObsolete' size + 1 to: obsName size]. ^ self environment at: obsName asSymbol! ! !Behavior methodsFor: 'accessing' stamp: 'ajh 9/19/2001 17:30'! classDepth superclass ifNil: [^ 1]. ^ superclass classDepth + 1! ! !Behavior methodsFor: 'accessing' stamp: 'di 3/7/2001 17:05'! methodDict methodDict == nil ifTrue: [self recoverFromMDFaultWithTrace]. ^ methodDict! ! !Behavior methodsFor: 'testing' stamp: 'sw 1/26/2001 20:06'! fullyImplementsVocabulary: aVocabulary "Answer whether instances of the receiver respond to all the messages in aVocabulary" (aVocabulary encompassesAPriori: self) ifTrue: [^ true]. aVocabulary allSelectorsInVocabulary do: [:aSelector | (self canUnderstand: aSelector) ifFalse: [^ false]]. ^ true! ! !Behavior methodsFor: 'testing' stamp: 'sw 5/4/2001 07:44'! implementsVocabulary: aVocabulary "Answer whether instances of the receiver respond to the messages in aVocabulary." (aVocabulary isKindOf: FullVocabulary orOf: ScreenedVocabulary) ifTrue: [^ true]. ^ self fullyImplementsVocabulary: aVocabulary! ! !Behavior methodsFor: 'testing' stamp: 'ab 3/12/2003 17:44'! isMeta ^ false! ! !Behavior methodsFor: 'testing' stamp: 'sd 3/28/2003 15:07' prior: 18140626! shouldNotBeRedefined "Return true if the receiver should not be redefined. The assumption is that compact classes, classes in Smalltalk specialObjects and Behaviors should not be redefined" ^(self environment compactClassesArray includes: self) or:[(self environment specialObjectsArray includes: self) or:[self isKindOf: self]]! ! !Behavior methodsFor: 'printing' stamp: 'ar 8/16/2001 13:31'! literalScannedAs: scannedLiteral notifying: requestor "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). If scannedLiteral is not an association, answer it. Else, if it is of the form: nil->#NameOfMetaclass answer nil->theMetaclass, if any has that name, else report an error. Else, if it is of the form: #NameOfGlobalVariable->anythiEng answer the global, class, or pool association with that nameE, if any, else add it to Undeclared a answer the new Association." | key value | (scannedLiteral isVariableBinding) ifFalse: [^ scannedLiteral]. key _ scannedLiteral key. value _ scannedLiteral value. key isNil ifTrue: "###" [self scopeHas: value ifTrue: [:assoc | (assoc value isKindOf: Behavior) ifTrue: [^ nil->assoc value class]]. requestor notify: 'No such metaclass'. ^false]. (key isMemberOf: Symbol) ifTrue: "##" [(self scopeHas: key ifTrue: [:assoc | ^assoc]) ifFalse: [Undeclared at: key put: nil. ^ Undeclared associationAt: key]]. requestor notify: '## must be followed by a non-local variable name'. ^false " Form literalScannedAs: 14 notifying: nil 14 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form Form literalScannedAs: ##Form notifying: nil Form->Form Form literalScannedAs: ###Form notifying: nil nilE->Form class "! ! !Behavior methodsFor: 'printing' stamp: 'ar 5/17/2003 14:11' prior: 33970749! literalScannedAs: scannedLiteral notifying: requestor "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). If scannedLiteral is not an association, answer it. Else, if it is of the form: nil->#NameOfMetaclass answer nil->theMetaclass, if any has that name, else report an error. Else, if it is of the form: #NameOfGlobalVariable->anythiEng answer the global, class, or pool association with that nameE, if any, else add it to Undeclared a answer the new Association." | key value | (scannedLiteral isVariableBinding) ifFalse: [^ scannedLiteral]. key _ scannedLiteral key. value _ scannedLiteral value. key isNil ifTrue: "###" [(self bindingOf: value) ifNotNilDo:[:assoc| (assoc value isKindOf: Behavior) ifTrue: [^ nil->assoc value class]]. requestor notify: 'No such metaclass'. ^false]. (key isMemberOf: Symbol) ifTrue: "##" [(self bindingOf: key) ifNotNilDo:[:assoc | ^assoc]. Undeclared at: key put: nil. ^Undeclared bindingOf: key]. requestor notify: '## must be followed by a non-local variable name'. ^false " Form literalScannedAs: 14 notifying: nil 14 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form Form literalScannedAs: ##Form notifying: nil Form->Form Form literalScannedAs: ###Form notifying: nil nilE->Form class "! ! !Behavior methodsFor: 'printing' stamp: 'tk 10/16/2001 19:35'! longPrintOn: aStream "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary." aStream nextPutAll: '<>'; cr.! ! !Behavior methodsFor: 'printing' stamp: 'ar 8/16/2001 13:31'! storeLiteral: aCodeLiteral on: aStream "Store aCodeLiteral on aStream, changing an Association to ##GlobalName or ###MetaclassSoleInstanceName format if appropriate" | key value | (aCodeLiteral isVariableBinding) ifFalse: [aCodeLiteral storeOn: aStream. ^self]. key _ aCodeLiteral key. (key isNil and: [(value _ aCodeLiteral value) isMemberOf: Metaclass]) ifTrue: [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. ^self]. ((key isMemberOf: Symbol) and: [self scopeHas: key ifTrue: [:ignore]]) ifTrue: [aStream nextPutAll: '##'; nextPutAll: key. ^self]. aCodeLiteral storeOn: aStream! ! !Behavior methodsFor: 'printing' stamp: 'ar 5/17/2003 14:11' prior: 33974109! storeLiteral: aCodeLiteral on: aStream "Store aCodeLiteral on aStream, changing an Association to ##GlobalName or ###MetaclassSoleInstanceName format if appropriate" | key value | (aCodeLiteral isVariableBinding) ifFalse: [aCodeLiteral storeOn: aStream. ^self]. key _ aCodeLiteral key. (key isNil and: [(value _ aCodeLiteral value) isMemberOf: Metaclass]) ifTrue: [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. ^self]. ((key isMemberOf: Symbol) and: [(self bindingOf: key) notNil]) ifTrue: [aStream nextPutAll: '##'; nextPutAll: key. ^self]. aCodeLiteral storeOn: aStream! ! !Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 13:59' prior: 18146187! compile: code notifying: requestor "Compile the argument, code, as source code in the context of the receiver and insEtall the result in the receiver's method dictionary. The second argument, requestor, is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream. This method also saves the source code." | methodAndNode | methodAndNode _ self basicCompile: code "a Text" notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. ^ methodAndNode selector! ! !Behavior methodsFor: 'compiling' stamp: 'sd 3/28/2003 15:07' prior: 18147146! compileAllFrom: oldClass "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set" "ar 7/10/1999: Use oldClass selectors not self selectors" oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].! ! !Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 11:32'! defaultMethodTrailer ^ #(0 0 0 0)! ! !Behavior methodsFor: 'compiling' stamp: 'ar 8/16/2001 11:44'! recompile: selector "Compile the method associated with selector in the receiver's method dictionary." ^self recompile: selector from: self! ! !Behavior methodsFor: 'compiling' stamp: 'di 5/24/2000 16:05'! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method _ oldClass compiledMethodAt: selector. trailer _ (method endPC + 1 to: method size) collect: [:i | method at: i]. methodNode _ self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: [^ self]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self addSelector: selector withMethod: (methodNode generate: trailer). ! ! !Behavior methodsFor: 'compiling' stamp: 'ajh 6/11/2001 16:59' prior: 33977240! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method _ oldClass compiledMethodAt: selector. trailer _ method trailer. methodNode _ self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: [^ self]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self addSelector: selector withMethod: (methodNode generate: trailer). ! ! !Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 09:22' prior: 33978006! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method _ oldClass compiledMethodAt: selector. trailer _ method trailer. methodNode _ self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: [^ self]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self addSelectorSilently: selector withMethod: (methodNode generate: trailer). ! ! !Behavior methodsFor: 'compiling' stamp: 'ajh 6/11/2001 17:05' prior: 18150117! recompileNonResidentMethod: method atSelector: selector from: oldClass "Recompile the method supplied in the context of this class." | trailer methodNode | trailer _ method trailer. methodNode _ self compilerClass new compile: (method getSourceFor: selector in: oldClass) in: self notifying: nil ifFail: ["We're in deep doo-doo if this fails (syntax error). Presumably the user will correct something and proceed, thus installing the result in this methodDict. We must retrieve that new method, and restore the original (or remove) and then return the method we retrieved." ^ self error: 'see comment']. selector == methodNode selector ifFalse: [self error: 'selector changed!!']. ^ methodNode generate: trailer ! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06' prior: 18151256! basicNew "Primitive. Answer an instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable. Essential. See Object documentation whatIsAPrimitive." self isVariable ifTrue: [ ^ self basicNew: 0 ]. "space must be low" self environment signalLowSpace. ^ self basicNew "retry if user proceeds" ! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06' prior: 18151686! basicNew: sizeRequested "Primitive. Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. Fail if this class is not indexable or if the argument is not a positive Integer, or if there is not enough memory available. Essential. See Object documentation whatIsAPrimitive." self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: ["arg okay; space must be low." self environment signalLowSpace. ^ self basicNew: sizeRequested "retry if user proceeds"]. self primitiveFailed! ! !Behavior methodsFor: 'instance creation' stamp: 'Noury Bouraqadi 8/23/2003 14:51' prior: 18152905! new "Answer a new initialized instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable." ^ self basicNew initialize ! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 5/20/2004 11:20' prior: 18153241! new: sizeRequested "Answer an initialized instance of this class with the number of indexable variables specified by the argument, sizeRequested." ^ (self basicNew: sizeRequested) initialize ! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'nb 5/6/2003 17:11'! allSubclasses "Answer a Set of the receiver's and the receiver's descendent's subclasses. " | scan scanTop | scan _ OrderedCollection withAll: self subclasses. scanTop _ 1. [scanTop > scan size] whileFalse: [scan addAll: (scan at: scanTop) subclasses. scanTop _ scanTop + 1]. ^ scan asSet! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:06' prior: 18153587! allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level "Walk the tree of subclasses, giving the class and its level" | subclassNames | classAndLevelBlock value: self value: level. self == Class ifTrue: [^ self]. "Don't visit all the metaclasses" "Visit subclasses in alphabetical order" subclassNames _ SortedCollection new. self subclassesDo: [:subC | subclassNames add: subC name]. subclassNames do: [:name | (self environment at: name) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level+1]! ! !Behavior methodsFor: 'accessing class hierarchy' prior: 18154182! allSuperclasses "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses. The first element is the receiver's immediate superclass, followed by its superclass; the last element is Object." | temp | ^ superclass == nil ifTrue: [ OrderedCollection new] ifFalse: [temp _ superclass allSuperclasses. temp addFirst: superclass. temp]! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/14/2004 18:09'! subclasses "slow implementation since Behavior does not keep trace of subclasses" ^ self class allInstances select: [:each | each superclass = self ]! ! !Behavior methodsFor: 'accessing class hierarchy'! withAllSubclasses "Answer a Set of the receiver, the receiver's descendent's, and the receiver's descendent's subclasses." ^ self allSubclasses add: self; yourself! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 09:34' prior: 18145308! addSelector: selector withMethod: compiledMethod ^ self addSelector: selector withMethod: compiledMethod notifying: nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 09:34'! addSelector: selector withMethod: compiledMethod notifying: requestor ^ self addSelectorSilently: selector withMethod: compiledMethod! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:27'! addSelectorSilently: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary. Do this without sending system change notifications" | oldMethodOrNil | oldMethodOrNil _ self lookupSelector: selector. self methodDict at: selector put: compiledMethod. "Now flush Squeak's method cache, either by selector or by method" oldMethodOrNil == nil ifFalse: [oldMethodOrNil flushCache]. selector flushCache.! ! !Behavior methodsFor: 'accessing method dictionary' prior: 18155416! allSelectors "Answer a Set of all the message selectors that instances of the receiver can understand." "Point allSelectors" | temp | ^ superclass == nil ifTrue: [self selectors] ifFalse: [temp _ superclass allSelectors. temp addAll: self selectors. temp]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 12/12/2003 15:57' prior: 33985003! allSelectors "Answer all selectors understood by instances of the receiver" | coll | coll _ OrderedCollection new. self withAllSuperclasses do: [:aClass | coll addAll: aClass selectors]. ^ coll asIdentitySet! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 6/20/2001 15:46'! firstPrecodeCommentFor: selector "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil" | parser source tree | "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" (MessageSet isPseudoSelector: selector) ifTrue: ["Not really a selector" ^ nil]. source _ self sourceCodeAt: selector asSymbol ifAbsent: [^ nil]. parser _ self parserClass new. tree _ parser parse: (ReadStream on: source) class: self noPattern: false context: nil notifying: nil ifFail: [^ nil]. ^ (tree comment ifNil: [^ nil]) first! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 8/19/2001 12:45'! "popeye" formalHeaderPartsFor: "olive oil" aSelector "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header The result will have 3 elements for a simple, argumentless selector. 5 elements for a single-argument selector 9 elements for a two-argument selector 13 elements for a three-argument, selector etc... The syntactic elements are: 1 comment preceding initial selector fragment 2 first selector fragment 3 comment following first selector fragment (nil if selector has no arguments) ---------------------- (ends here for, e.g., #copy) 4 first formal argument 5 comment following first formal argument (nil if selector has only one argument) ---------------------- (ends here for, e.g., #copyFrom:) 6 second keyword 7 comment following second keyword 8 second formal argument 9 comment following second formal argument (nil if selector has only two arguments) ---------------------- (ends here for, e.g., #copyFrom:to:) Any nil element signifies an absent comment. NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil." ^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector) " Behavior class formalHeaderPartsFor: #formalHeaderPartsFor: " ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'ar 12/27/2001 22:29'! methodHeaderFor: selector "Answer the string corresponding to the method header for the given selector" | sourceString parser | sourceString _ self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. (parser _ self parserClass new) parseSelector: sourceString. ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) "Behavior methodHeaderFor: #methodHeaderFor: " ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 6/6/2001 13:26'! precodeCommentOrInheritedCommentFor: selector "Answer a string representing the first comment in the method associated with selector, considering however only comments that occur before the beginning of the actual code. If the version recorded in the receiver is uncommented, look up the inheritance chain. Return nil if none found." | aSuper aComment | ^ (aComment _ self firstPrecodeCommentFor: selector) isEmptyOrNil ifFalse: [aComment] ifTrue: [(self == Behavior or: [superclass == nil or: [(aSuper _ superclass classThatUnderstands: selector) == nil]]) ifTrue: [nil] ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector]] "ActorState precodeCommentOrInheritedCommentFor: #printOn:"! ! !Behavior methodsFor: 'accessing method dictionary' prior: 33988859! precodeCommentOrInheritedCommentFor: selector "Answer a string representing the first comment in the method associated with selector, considering however only comments that occur before the beginning of the actual code. If the version recorded in the receiver is uncommented, look up the inheritance chain. Return nil if none found." | aSuper aComment | ^ (aComment _ self firstPrecodeCommentFor: selector) isEmptyOrNil ifTrue: [(self == Behavior or: [superclass == nil or: [(aSuper _ superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector] "ActorState precodeCommentOrInheritedCommentFor: #printOn:"] ifFalse: [aComment]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:17' prior: 18151015! removeSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." ^ self basicRemoveSelector: selector! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:28'! removeSelectorSilently: selector "Remove selector without sending system change notifications" ^ SystemChangeNotifier doSilently: [self basicRemoveSelector: selector].! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 3/4/2004 21:04' prior: 33990772! removeSelectorSilently: selector "Remove selector without sending system change notifications" ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'rw 5/12/2003 11:19' prior: 18163179! selectorAtMethod: method setClass: classResultBlock "Answer both the message selector associated with the compiled method and the class in which that selector is defined." | sel | sel _ self methodDict keyAtIdentityValue: method ifAbsent: [superclass == nil ifTrue: [classResultBlock value: self. ^method defaultSelector]. sel _ superclass selectorAtMethod: method setClass: classResultBlock. "Set class to be self, rather than that returned from superclass. " sel == method defaultSelector ifTrue: [classResultBlock value: self]. ^sel]. classResultBlock value: self. ^sel! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'ar 12/27/2001 22:29'! standardMethodHeaderFor: aSelector | args | args _ (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. args size = 0 ifTrue:[^aSelector asString]. args size = 1 ifTrue:[^aSelector,' arg1']. ^String streamContents:[:s| (aSelector findTokens:':') with: args do:[:tok :arg| s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. ]. ]. ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 6/28/2001 12:37'! supermostPrecodeCommentFor: selector "Answer a string representing the precode comment in the most distant superclass's implementation of the selector. Return nil if none found." | aSuper superComment | (self == Behavior or: [superclass == nil or: [(aSuper _ superclass classThatUnderstands: selector) == nil]]) ifFalse: "There is a super implementor" [superComment _ aSuper supermostPrecodeCommentFor: selector]. ^ superComment ifNil: [self firstPrecodeCommentFor: selector] "ActorState supermostPrecodeCommentFor: #printOn:"! ! !Behavior methodsFor: 'accessing method dictionary' prior: 33992507! supermostPrecodeCommentFor: selector "Answer a string representing the precode comment in the most distant superclass's implementation of the selector. Return nil if none found." | aSuper superComment | (self == Behavior or: [superclass == nil or: [(aSuper _ superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: ["There is a super implementor" superComment _ aSuper supermostPrecodeCommentFor: selector]. ^ superComment ifNil: [self firstPrecodeCommentFor: selector "ActorState supermostPrecodeCommentFor: #printOn:"]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 2/1/2004 19:41'! zapAllMethods "Remove all methods in this class which is assumed to be obsolete" methodDict _ MethodDictionary new. self class isMeta ifTrue: [self class zapAllMethods]! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'tpr 5/30/2003 13:04' prior: 18166959! allSharedPools "Answer a Set of the names of the pools (Dictionaries or SharedPool subclasses) that the receiver and the receiver's ancestors share." ^superclass allSharedPools! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'ajh 10/17/2002 11:03'! allowsSubInstVars "Classes that allow instances to change classes among its subclasses will want to override this and return false, so inst vars are not accidentally added to its subclasses." ^ true! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! inspectAllInstances "Inpsect all instances of the receiver. 1/26/96 sw" | all allSize prefix | all _ self allInstances. (allSize _ all size) == 0 ifTrue: [^ self inform: 'There are no instances of ', self name]. prefix _ allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name)! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! inspectSubInstances "Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!! 1/26/96 sw" | all allSize prefix | all _ self allSubInstances. (allSize _ all size) == 0 ifTrue: [^ self inform: 'There are no instances of ', self name, ' or any of its subclasses']. prefix _ allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! ! !Behavior methodsFor: 'testing class hierarchy' prior: 18170788! kindOfSubclass "Answer a String that is the keyword that describes the receiver's kind of subclass, either a regular subclass, a variableSubclass, a variableByteSubclass, a variableWordSubclass, or a weakSubclass." self isWeak ifTrue: [^ ' weakSubclass: ']. ^ self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [ ' variableByteSubclass: '] ifFalse: [ ' variableWordSubclass: ']] ifFalse: [ ' variableSubclass: ']] ifFalse: [ ' subclass: ']! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/17/2003 14:06'! bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" ^superclass bindingOf: varName! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/18/2003 18:13'! classBindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver's class" ^self bindingOf: varName! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/17/2003 14:20' prior: 18172865! scopeHas: varName ifTrue: aBlock "Obsolete. Kept around for possible spurios senders which we don't know about" (self bindingOf: varName) ifNotNilDo:[:binding| aBlock value: binding. ^true]. ^false! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 8/16/2001 13:31'! thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal. Dives into the compact literal notation, making it slow but thorough " | who | who _ Set new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isVariableBinding) not or: [method sendsToSuper not or: [method literals allButLast includes: literal]]) ifTrue: [who add: sel]]]. ^ who! ! !Behavior methodsFor: 'testing method dictionary' prior: 18173806! whichClassIncludesSelector: aSymbol "Answer the class on the receiver's superclass chain where the argument, aSymbol (a message selector), will be found. Answer nil if none found." "Rectangle whichClassIncludesSelector: #inspect." (self includesSelector: aSymbol) ifTrue: [^ self]. superclass == nil ifTrue: [^ nil]. ^ superclass whichClassIncludesSelector: aSymbol! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'sd 3/28/2003 15:07' prior: 18174799! whichSelectorsReferTo: literal "Answer a Set of selectors whose methods access the argument as a literal." | special byte | special _ self environment hasSpecialSelector: literal ifTrueSetByte: [:b | byte _ b]. ^self whichSelectorsReferTo: literal special: special byte: byte "Rectangle whichSelectorsReferTo: #+."! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 8/16/2001 13:31'! whichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal." | who | who _ Set new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isVariableBinding) not or: [method sendsToSuper not or: [method literals allButLast includes: literal]]) ifTrue: [who add: sel]]]. ^ who! ! !Behavior methodsFor: 'enumerating' stamp: 'nk 2/14/2001 12:09'! withAllSuperAndSubclassesDoGently: aBlock self allSuperclassesDo: aBlock. aBlock value: self. self allSubclassesDoGently: aBlock! ! !Behavior methodsFor: 'user interface' stamp: 'nk 5/23/2001 20:34'! allLocalCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." | aSet special byte cls | aSet _ Set new. cls _ self theNonMetaClass. special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. cls withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]]. cls class withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]]. ^aSet! ! !Behavior methodsFor: 'user interface' stamp: 'sd 3/28/2003 15:05' prior: 33999290! allLocalCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." | aSet special byte cls | aSet _ Set new. cls _ self theNonMetaClass. special _ self environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. cls withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]]. cls class withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]]. ^aSet! ! !Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 12:00'! withAllSubAndSuperclassesDo: aBlock self withAllSubclassesDo: aBlock. self allSuperclassesDo: aBlock. ! ! !Behavior methodsFor: 'private' stamp: 'NS 1/28/2004 13:59'! basicCompile: code notifying: requestor trailer: bytes ifFail: failBlock "Compile code without logging the source in the changes file" | methodNode | methodNode _ self compilerClass new compile: code in: self notifying: requestor ifFail: failBlock. methodNode encoder requestor: requestor. ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! ! !Behavior methodsFor: 'private' stamp: 'NS 1/28/2004 10:29'! basicRemoveSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | oldMethod | oldMethod _ self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethod flushCache. selector flushCache.! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06' prior: 18183980! becomeCompact "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct index | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct _ self environment compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. index _ cct indexOf: nil ifAbsent: [^ self halt: 'compact class table is full']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format _ format + (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Purge any old instances" Smalltalk garbageCollect.! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06' prior: 18184999! becomeCompactSimplyAt: index "Make me compact, but don't update the instances. For importing segments." "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct _ self environment compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format _ format + (index bitShift: 11). "Caller must convert the instances" ! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06' prior: 18185966! becomeUncompact | cct index | cct _ self environment compactClassesArray. (index _ self indexIfCompact) = 0 ifTrue: [^ self]. (cct includes: self) ifFalse: [^ self halt "inconsistent state"]. "Update instspec so future instances will not be compact" format _ format - (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Make sure there are no compact ones left around" Smalltalk garbageCollect. "Remove this class from the compact class table" cct at: index put: nil. ! ! !Behavior methodsFor: 'private' stamp: 'sd 2/1/2004 15:14'! spaceUsed "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." | space method | space _ 0. self selectorsDo: [:sel | space _ space + 16. "dict and org'n space" method _ self compiledMethodAt: sel. space _ space + (method size + 6 "hdr + avg pad"). method literals do: [:lit | (lit isMemberOf: Array) ifTrue: [space _ space + ((lit size + 1) * 4)]. (lit isMemberOf: Float) ifTrue: [space _ space + 12]. (lit isMemberOf: String) ifTrue: [space _ space + (lit size + 6)]. (lit isMemberOf: LargeNegativeInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]. (lit isMemberOf: LargePositiveInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]]]. ^ space! ! !Behavior methodsFor: 'system startup' stamp: 'tk 10/26/2001 16:06'! startUpFrom: anImageSegment "Override this when a per-instance startUp message needs to be sent. For example, to correct the order of 16-bit non-pointer data when it came from a different endian machine." ^ nil! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'ar 3/2/2001 00:58'! addObsoleteSubclass: aClass "Weakly remember that aClass was a subclass of the receiver and is now obsolete" | obs | ObsoleteSubclasses finalizeValues. "clean up if need be" obs _ ObsoleteSubclasses at: self ifAbsent:[WeakArray new]. (obs includes: aClass) ifTrue:[^self]. obs _ obs copyWithout: nil. obs _ obs copyWith: aClass. ObsoleteSubclasses at: self put: obs. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'ar 3/2/2001 00:58'! obsoleteSubclasses "Return all the weakly remembered obsolete subclasses of the receiver" | obs | ObsoleteSubclasses finalizeValues. "clean up if need be" obs _ ObsoleteSubclasses at: self ifAbsent:[^#()]. obs _ obs copyWithout: nil. obs isEmpty ifTrue:[ObsoleteSubclasses removeKey: self ifAbsent:[]] ifFalse:[ObsoleteSubclasses at: self put: obs]. ^obs! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'NS 2/19/2002 11:13'! removeAllObsoleteSubclasses "Remove all the obsolete subclasses of the receiver" ObsoleteSubclasses finalizeValues. "clean up if need be" ObsoleteSubclasses removeKey: self ifAbsent: []. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'NS 2/19/2002 11:16'! removeObsoleteSubclass: aClass "Remove aClass from the weakly remembered obsolete subclasses" | obs | ObsoleteSubclasses finalizeValues. "clean up if need be" obs _ ObsoleteSubclasses at: self ifAbsent:[^ self]. (obs includes: aClass) ifFalse:[^self]. obs _ obs copyWithout: aClass. obs _ obs copyWithout: nil. obs isEmpty ifTrue: [ObsoleteSubclasses removeKey: self ifAbsent: []] ifFalse: [ObsoleteSubclasses at: self put: obs].! ! !Behavior methodsFor: 'deprecated' stamp: 'sw 12/1/2000 20:11'! allSelectorsUnderstood "Answer a list of all selectors understood by instances of the receiver" | aList | aList _ OrderedCollection new. self withAllSuperclasses do: [:aClass | aList addAll: aClass selectors]. ^ aList asSet asArray "SketchMorph allSelectorsUnderstood size"! ! !Behavior methodsFor: 'deprecated' stamp: 'NS 12/12/2003 16:00' prior: 34007407! allSelectorsUnderstood "Answer a list of all selectors understood by instances of the receiver" | aList | self deprecated: 'Use allSelectors instead.'. aList _ OrderedCollection new. self withAllSuperclasses do: [:aClass | aList addAll: aClass selectors]. ^ aList asSet asArray "SketchMorph allSelectorsUnderstood size"! ! !Behavior methodsFor: 'deprecated' stamp: 'NS 1/28/2004 11:29' prior: 18187247! removeSelectorSimply: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | oldMethod | self deprecated: 'Use basicRemoveSelector: instead.'. oldMethod _ self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethod flushCache. selector flushCache.! ! !Behavior methodsFor: '*system-support' stamp: 'tpr 12/17/2003 16:04'! allCallsOn "Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict." ^ (self systemNavigation allCallsOn: (self environment associationAt: self theNonMetaClass name)), (self systemNavigation allCallsOn: self theNonMetaClass name) ! ! !Behavior methodsFor: '*system-support' stamp: 'RAA 5/28/2001 13:29'! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." | aSortedCollection special byte | aSortedCollection _ SortedCollection new. special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. self withAllSubclassesDo: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel == #DoIt ifFalse: [ aSortedCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ^aSortedCollection! ! !Behavior methodsFor: '*system-support' stamp: 'sd 3/28/2003 15:05' prior: 34009082! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." | aSortedCollection special byte | aSortedCollection _ SortedCollection new. special _ self environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. self withAllSubclassesDo: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel == #DoIt ifFalse: [ aSortedCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ^aSortedCollection! ! !Behavior methodsFor: '*system-support' stamp: 'sd 3/28/2003 17:45' prior: 34009718! allCallsOn: aSymbol self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allCallsOn:from: instead'! ! !Behavior methodsFor: '*system-support' stamp: 'rw 5/13/2003 15:12' prior: 34010361! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." | aSortedCollection special byte | self deprecatedExplanation: 'Method Deprecated: Use SystemNavigation>>allCallsOn:from: instead'. aSortedCollection _ SortedCollection new. special _ self environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. self withAllSubclassesDo: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel == #DoIt ifFalse: [ aSortedCollection add: ( MethodReference new setStandardClass: class methodSymbol: sel ) ] ] ]. ^aSortedCollection! ! !Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43' prior: 34010577! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." ^ self systemNavigation allCallsOn: aSymbol from: self . ! ! !Behavior methodsFor: '*system-support' stamp: 'sd 3/28/2003 15:06' prior: 18171335! allUnsentMessages "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system. 5/8/96 sw" ^ self environment allUnSentMessagesIn: self selectors! ! !Behavior methodsFor: '*system-support' stamp: 'sd 4/29/2003 20:25' prior: 34011560! allUnsentMessages "this method was not used at all, required a reference to systemNavigation and systemNavigation had the same functionality" self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnsentMessagesIn: instead'! ! !Behavior methodsFor: '*system-support' stamp: 'rw 5/13/2003 15:13' prior: 34011840! allUnsentMessages "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system. 5/8/96 sw" self deprecatedExplanation: 'Method Deprecated: Use SystemNavigation>>allUnsentMessagesIn: instead'. ^ self environment allUnSentMessagesIn: self selectors! ! !Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43' prior: 34012184! allUnsentMessages "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system." ^ self environment allUnSentMessagesIn: self selectors! ! !Behavior methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:46'! sunitAllSelectors ^self allSelectors asSortedCollection asOrderedCollection! ! !Behavior methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:46' prior: 34012819! sunitAllSelectors ^self allSelectors asSortedCollection asOrderedCollection! ! !Behavior methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:46'! sunitSelectors ^self selectors asSortedCollection asOrderedCollection! ! !Behavior methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:46' prior: 34013153! sunitSelectors ^self selectors asSortedCollection asOrderedCollection! ! !Behavior class methodsFor: 'class initialization' stamp: 'ar 3/3/2001 00:30'! flushObsoleteSubclasses "Behavior flushObsoleteSubclasses" ObsoleteSubclasses keys "need a copy" do:[:obs| obs ifNotNil:[obs obsoleteSubclasses]]. "remove themselves" ObsoleteSubclasses finalizeValues.! ! !Behavior class methodsFor: 'class initialization' stamp: 'ar 3/2/2001 00:47'! initialize "Behavior initialize" "Never called for real" ObsoleteSubclasses ifNil:[self initializeObsoleteSubclasses].! ! !Behavior class methodsFor: 'class initialization' stamp: 'ar 3/2/2001 00:48'! initializeObsoleteSubclasses ObsoleteSubclasses _ WeakIdentityKeyDictionary new.! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 3/14/2004 18:11'! testBehaviorSubclasses "self run: #testBehaviorSubclasses" | b b2 | b := Behavior new. b superclass: OrderedCollection. b methodDictionary: MethodDictionary new. self shouldnt: [b subclasses ] raise: Error. self shouldnt: [b withAllSubclasses] raise: Error. self shouldnt: [b allSubclasses] raise: Error. b2 := Behavior new. b2 superclass: b. b2 methodDictionary: MethodDictionary new. self assert: (b subclasses includes: b2). self assert: (b withAllSubclasses includes: b).! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 12/30/2001 20:31'! clipBy: aRectangle | aPoint right bottom | right _ clipX + clipWidth. bottom _ clipY + clipHeight. aPoint _ aRectangle origin. aPoint x > clipX ifTrue:[clipX _ aPoint x]. aPoint y > clipY ifTrue:[clipY _ aPoint y]. aPoint _ aRectangle corner. aPoint x < right ifTrue:[right _ aPoint x]. aPoint y < bottom ifTrue:[bottom _ aPoint y]. clipWidth _ right - clipX. clipHeight _ bottom - clipY. clipWidth < 0 ifTrue:[clipWidth _ 0]. clipHeight < 0 ifTrue:[clipHeight _ 0].! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 12/30/2001 20:33'! clipByX1: x1 y1: y1 x2: x2 y2: y2 | right bottom | right _ clipX + clipWidth. bottom _ clipY + clipHeight. x1 > clipX ifTrue:[clipX _ x1]. y1 > clipY ifTrue:[clipY _ y1]. x2 < right ifTrue:[right _ x2]. y2 < bottom ifTrue:[bottom _ y2]. clipWidth _ right - clipX. clipHeight _ bottom - clipY. clipWidth < 0 ifTrue:[clipWidth _ 0]. clipHeight < 0 ifTrue:[clipHeight _ 0].! ! !BitBlt methodsFor: 'accessing' stamp: 'tk 8/15/2001 10:56'! color "Return the current fill color as a Color. Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." halftoneForm ifNil: [^ Color black]. ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/4/2001 15:45'! colorMap: map "See last part of BitBlt comment. 6/18/96 tk" colorMap _ map.! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/14/2001 23:25'! fillColor: aColorOrPattern "The destForm will be filled with this color or pattern of colors. May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form. 6/18/96 tk" aColorOrPattern == nil ifTrue: [halftoneForm _ nil. ^ self]. destForm == nil ifTrue: [self error: 'Must set destForm first']. halftoneForm _ destForm bitPatternFor: aColorOrPattern ! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'! copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule "Specify a Color to fill, not a Form. 6/18/96 tk" | destOrigin | sourceForm _ srcForm. self fillColor: hf. "sets halftoneForm" combinationRule _ rule. destOrigin _ destRectangle origin. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourcePt x. sourceY _ sourcePt y. width _ destRectangle width. height _ destRectangle height. srcForm == nil ifFalse: [colorMap _ srcForm colormapIfNeededFor: destForm]. ^ self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:27'! copyBits "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type (Integer, Float, or Form) or if the combination rule is not implemented. In addition to the original 16 combination rules, this BitBlt supports 16 fail (to simulate paint) 17 fail (to simulate mask) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 rgbDiff: sourceWord with: destinationWord 23 tallyIntoMap: destinationWord 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord " "Check for compressed source, destination or halftone forms" (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: ["No alpha specified -- re-run with alpha = 1.0" ^ self copyBitsTranslucent: 255]. ((sourceForm isKindOf: Form) and: [sourceForm unhibernate]) ifTrue: [^ self copyBits]. ((destForm isKindOf: Form) and: [destForm unhibernate]) ifTrue: [^ self copyBits]. ((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBits]. "Check for unimplmented rules" combinationRule = Form oldPaint ifTrue: [^ self paintBits]. combinationRule = Form oldErase1bitShape ifTrue: [^ self eraseBits]. "Check if BitBlt doesn't support full color maps" (colorMap notNil and:[colorMap isColormap]) ifTrue:[ colorMap _ colorMap colors. ^self copyBits]. self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'. "Convert all numeric parameters to integers and try again." destX _ destX asInteger. destY _ destY asInteger. width _ width asInteger. height _ height asInteger. sourceX _ sourceX asInteger. sourceY _ sourceY asInteger. clipX _ clipX asInteger. clipY _ clipY asInteger. clipWidth _ clipWidth asInteger. clipHeight _ clipHeight asInteger. ^ self copyBitsAgain! ! !BitBlt methodsFor: 'copying' stamp: 'ar 3/7/2003 23:57' prior: 34017169! copyBits "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type (Integer, Float, or Form) or if the combination rule is not implemented. In addition to the original 16 combination rules, this BitBlt supports 16 fail (to simulate paint) 17 fail (to simulate mask) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 rgbDiff: sourceWord with: destinationWord 23 tallyIntoMap: destinationWord 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord " "Check for compressed source, destination or halftone forms" (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: ["No alpha specified -- re-run with alpha = 1.0" ^ self copyBitsTranslucent: 255]. ((sourceForm isKindOf: Form) and: [sourceForm unhibernate]) ifTrue: [^ self copyBits]. ((destForm isKindOf: Form) and: [destForm unhibernate]) ifTrue: [^ self copyBits]. ((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBits]. "Check for unimplmented rules" combinationRule = Form oldPaint ifTrue: [^ self paintBits]. combinationRule = Form oldErase1bitShape ifTrue: [^ self eraseBits]. "Check if BitBlt doesn't support full color maps" (colorMap notNil and:[colorMap isColormap]) ifTrue:[ colorMap _ colorMap colors. ^self copyBits]. "Check if clipping gots us way out of range" self clipRange ifTrue:[^self copyBits]. self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'. "Convert all numeric parameters to integers and try again." destX _ destX asInteger. destY _ destY asInteger. width _ width asInteger. height _ height asInteger. sourceX _ sourceX asInteger. sourceY _ sourceY asInteger. clipX _ clipX asInteger. clipY _ clipY asInteger. clipWidth _ clipWidth asInteger. clipHeight _ clipHeight asInteger. ^ self copyBitsAgain! ! !BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:41' prior: 34019420! copyBits "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type (Integer, Float, or Form) or if the combination rule is not implemented. In addition to the original 16 combination rules, this BitBlt supports 16 fail (to simulate paint) 17 fail (to simulate mask) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 rgbDiff: sourceWord with: destinationWord 23 tallyIntoMap: destinationWord 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord " "Check for compressed source, destination or halftone forms" (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: ["No alpha specified -- re-run with alpha = 1.0" ^ self copyBitsTranslucent: 255]. ((sourceForm isForm) and: [sourceForm unhibernate]) ifTrue: [^ self copyBits]. ((destForm isForm) and: [destForm unhibernate]) ifTrue: [^ self copyBits]. ((halftoneForm isForm) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBits]. "Check for unimplmented rules" combinationRule = Form oldPaint ifTrue: [^ self paintBits]. combinationRule = Form oldErase1bitShape ifTrue: [^ self eraseBits]. "Check if BitBlt doesn't support full color maps" (colorMap notNil and:[colorMap isColormap]) ifTrue:[ colorMap _ colorMap colors. ^self copyBits]. "Check if clipping gots us way out of range" self clipRange ifTrue:[^self copyBits]. self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'. "Convert all numeric parameters to integers and try again." destX _ destX asInteger. destY _ destY asInteger. width _ width asInteger. height _ height asInteger. sourceX _ sourceX asInteger. sourceY _ sourceY asInteger. clipX _ clipX asInteger. clipY _ clipY asInteger. clipWidth _ clipWidth asInteger. clipHeight _ clipHeight asInteger. ^ self copyBitsAgain! ! !BitBlt methodsFor: 'copying' stamp: 'ar 2/13/2001 21:12'! copyBitsSimulated ^Smalltalk at: #BitBltSimulation ifPresent:[:bb| bb copyBitsFrom: self].! ! !BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:42' prior: 18214279! copyBitsTranslucent: factor "This entry point to BitBlt supplies an extra argument to specify translucency for operations 30 and 31. The argument must be an integer between 0 and 255." "Check for compressed source, destination or halftone forms" ((sourceForm isForm) and: [sourceForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((destForm isForm) and: [destForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((halftoneForm isForm) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. self primitiveFailed "Later do nicer error recovery -- share copyBits recovery"! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'! copyForm: srcForm to: destPt rule: rule ^ self copyForm: srcForm to: destPt rule: rule colorMap: (srcForm colormapIfNeededFor: destForm)! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'! copyFrom: sourceRectangle in: srcForm to: destPt | sourceOrigin | sourceForm _ srcForm. halftoneForm _ nil. combinationRule _ 3. "store" destX _ destPt x. destY _ destPt y. sourceOrigin _ sourceRectangle origin. sourceX _ sourceOrigin x. sourceY _ sourceOrigin y. width _ sourceRectangle width. height _ sourceRectangle height. colorMap _ srcForm colormapIfNeededFor: destForm. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'yo 9/29/2002 08:44' prior: 18216838! displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta destY _ aPoint y. destX _ aPoint x. "the following are not really needed, but theBitBlt primitive will fail if not set" sourceX ifNil: [sourceX _ 100]. width ifNil: [width _ 100]. (aString class == MultiString) ifTrue: [^ font characters: (startIndex to: stopIndex) in: aString displayAt: aPoint clippedBy: (clipX@clipY extent: clipWidth@clipHeight) rule: combinationRule fillColor: sourceForm kernDelta: kernDelta.]. ^self primDisplayString: aString from: startIndex to: stopIndex map: font characterToGlyphMap xTable: font xTable kern: kernDelta.! ! !BitBlt methodsFor: 'copying' stamp: 'ar 3/1/2004 13:49' prior: 18217657! pixelAt: aPoint "Assumes this BitBlt has been set up specially (see the init message, BitBlt bitPeekerFromForm:. Returns the pixel at aPoint." sourceX _ aPoint x. sourceY _ aPoint y. destForm unhibernate. "before poking" destForm bits at: 1 put: 0. "Just to be sure" self copyBits. ^ destForm bits at: 1! ! !BitBlt methodsFor: 'copying' stamp: 'ar 3/1/2004 13:49' prior: 18217967! pixelAt: aPoint put: pixelValue "Assumes this BitBlt has been set up specially (see the init message, BitBlt bitPokerToForm:. Overwrites the pixel at aPoint." destX _ aPoint x. destY _ aPoint y. sourceForm unhibernate. "before poking" sourceForm bits at: 1 put: pixelValue. self copyBits " | bb | bb _ (BitBlt bitPokerToForm: Display). [Sensor anyButtonPressed] whileFalse: [bb pixelAt: Sensor cursorPoint put: 55] "! ! !BitBlt methodsFor: 'private' stamp: 'ar 3/8/2003 00:34'! clipRange "clip and adjust source origin and extent appropriately" "first in x" | sx sy dx dy bbW bbH | "fill in the lazy state if needed" destX ifNil:[destX := 0]. destY ifNil:[destY := 0]. width ifNil:[width := destForm width]. height ifNil:[height := destForm height]. sourceX ifNil:[sourceX := 0]. sourceY ifNil:[sourceY := 0]. clipX ifNil:[clipX := 0]. clipY ifNil:[clipY := 0]. clipWidth ifNil:[clipWidth := destForm width]. clipHeight ifNil:[clipHeight := destForm height]. destX >= clipX ifTrue: [sx _ sourceX. dx _ destX. bbW _ width] ifFalse: [sx _ sourceX + (clipX - destX). bbW _ width - (clipX - destX). dx _ clipX]. (dx + bbW) > (clipX + clipWidth) ifTrue: [bbW _ bbW - ((dx + bbW) - (clipX + clipWidth))]. "then in y" destY >= clipY ifTrue: [sy _ sourceY. dy _ destY. bbH _ height] ifFalse: [sy _ sourceY + clipY - destY. bbH _ height - (clipY - destY). dy _ clipY]. (dy + bbH) > (clipY + clipHeight) ifTrue: [bbH _ bbH - ((dy + bbH) - (clipY + clipHeight))]. sourceForm ifNotNil:[ sx < 0 ifTrue: [dx _ dx - sx. bbW _ bbW + sx. sx _ 0]. sx + bbW > sourceForm width ifTrue: [bbW _ bbW - (sx + bbW - sourceForm width)]. sy < 0 ifTrue: [dy _ dy - sy. bbH _ bbH + sy. sy _ 0]. sy + bbH > sourceForm height ifTrue: [bbH _ bbH - (sy + bbH - sourceForm height)]. ]. (bbW <= 0 or:[bbH <= 0]) ifTrue:[ sourceX := sourceY := destX := destY := clipX := clipY := width := height := 0. ^true]. (sx = sourceX and:[sy = sourceY and:[dx = destX and:[dy = destY and:[bbW = width and:[bbH = height]]]]]) ifTrue:[^false]. sourceX := sx. sourceY := sy. destX := dx. destY := dy. width := bbW. height := bbH. ^true! ! !BitBlt methodsFor: 'private' stamp: 'ar 5/14/2001 23:43'! installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor | lastSourceDepth | sourceForm ifNotNil:[lastSourceDepth _ sourceForm depth]. sourceForm _ aStrikeFont glyphs. (colorMap notNil and:[lastSourceDepth = sourceForm depth]) ifFalse: ["Set up color map for a different source depth (color font)" "Uses caching for reasonable efficiency" colorMap _ self cachedFontColormapFrom: sourceForm depth to: destForm depth. colorMap at: 1 put: (destForm pixelValueFor: backgroundColor)]. sourceForm depth = 1 ifTrue: [colorMap at: 2 put: (destForm pixelValueFor: foregroundColor). "Ignore any halftone pattern since we use a color map approach here" halftoneForm _ nil]. sourceY _ 0. height _ aStrikeFont height. ! ! !BitBlt methodsFor: 'private' stamp: 'yo 6/23/2003 18:07'! installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor "Set up the parameters. Since the glyphs in a TTCFont is 32bit depth form, it tries to use rule=34 to get better AA result if possible." ((aTTCFont depth = 32)) ifTrue: [ destForm depth <= 8 ifTrue: [ self colorMap: (self cachedFontColormapFrom: aTTCFont depth to: destForm depth). self combinationRule: Form paint. ] ifFalse: [ self colorMap: nil. self combinationRule: 34. ]. halftoneForm _ nil. sourceY _ 0. height _ aTTCFont height. ^ self. ]. ! ! !BitBlt methodsFor: 'private' stamp: 'ar 5/14/2001 23:32'! setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect | aPoint | destForm _ df. sourceForm _ sf. self fillColor: hf. "sets halftoneForm" combinationRule _ cr. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourceOrigin x. sourceY _ sourceOrigin y. width _ extent x. height _ extent y. aPoint _ clipRect origin. clipX _ aPoint x. clipY _ aPoint y. aPoint _ clipRect corner. clipWidth _ aPoint x - clipX. clipHeight _ aPoint y - clipY. sourceForm == nil ifFalse: [colorMap _ sourceForm colormapIfNeededFor: destForm]! ! !BitBlt commentStamp: '' prior: 0! I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm. The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm. If both are specified, their pixel values are combined with a logical AND function prior to transfer. In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule. The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows: 8: if source is 0 and destination is 0 4: if source is 0 and destination is 1 2: if source is 1 and destination is 0 1: if source is 1 and destination is 1. At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions; if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero. Forms may be of different depths, see the comment in class Form. In addition to the original 16 combination rules, this BitBlt supports 16 fails (to simulate paint bits) 17 fails (to simulate erase bits) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord. Sum of color components 21 rgbSub: sourceWord with: destinationWord. Difference of color components 22 OLDrgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 23 OLDtallyIntoMap: destinationWord. Tallies pixValues into a colorMap these old versions don't do bitwise dest clipping. Use 32 and 33 now. 24 alphaBlend: sourceWord with: destinationWord. 32-bit source and dest only 25 pixPaint: sourceWord with: destinationWord. Wherever the sourceForm is non-zero, it replaces the destination. Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1. 26 pixMask: sourceWord with: destinationWord. Like pixPaint, but fills with 0. 27 rgbMax: sourceWord with: destinationWord. Max of each color component. 28 rgbMin: sourceWord with: destinationWord. Min of each color component. 29 rgbMin: sourceWord bitInvert32 with: destinationWord. Min with (max-source) 30 alphaBlendConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 31 alphaPaintConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 32 rgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 33 tallyIntoMap: destinationWord. Tallies pixValues into a colorMap 34 alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord. The color specified by halftoneForm may be either a Color or a Pattern. A Color is converted to a pixelValue for the depth of the destinationForm. If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. Within each scan line the 32-bit value is repeated from left to right across the form. If the value repeats on pixels boudaries, the effect will be a constant color; if not, it will produce a halftone that repeats on 32-bit boundaries. Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms. To make a small Form repeat and fill a big form, use an InfiniteForm as the source. To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source. Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. The colorMap, if specified, must be a either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, and select the corresponding pixelValue and mask it to the destination pixel size before storing. When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation. This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color. Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped. The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1. Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color). Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors. Colors can be remapped at the same depth. Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file. Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of. MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)! !BitBlt class methodsFor: 'examples' stamp: 'ar 5/4/2001 16:02'! exampleColorMap "BitBlt exampleColorMap" "This example shows what one can do with the fixed part of a color map. The color map, as setup below, rotates the bits of a pixel all the way around. Thus you'll get a (sometime strange looking ;-) animation of colors which will end up exactly the way it looked at the beginning. The example is given to make you understand that the masks and shifts can be used for a lot more than simply color converting pixels. In this example, for instance, we use only two of the four independent shifters." | cc bb | cc _ ColorMap masks: { 1 << (Display depth-1). "mask out high bit of color component" 1 << (Display depth-1) - 1. "mask all other bits" 0. 0} shifts: { 1 - Display depth. "shift right to bottom most position" 1. "shift all other pixels one bit left" 0. 0}. bb _ BitBlt toForm: Display. bb sourceForm: Display; combinationRule: 3; colorMap: cc. 1 to: Display depth do:[:i| bb copyBits. Display forceDisplayUpdate. ]. ! ! !BitBlt class methodsFor: 'examples' stamp: 'dew 9/18/2001 02:30'! exampleOne "This tests BitBlt by displaying the result of all sixteen combination rules that BitBlt is capable of using. (Please see the comment in BitBlt for the meaning of the combination rules). This only works at Display depth of 1. (Rule 15 does not work?)" | path displayDepth | displayDepth _ Display depth. Display newDepth: 1. path _ Path new. 0 to: 3 do: [:i | 0 to: 3 do: [:j | path add: j * 100 @ (i * 75)]]. Display fillWhite. path _ path translateBy: 60 @ 40. 1 to: 16 do: [:index | BitBlt exampleAt: (path at: index) rule: index - 1 fillColor: nil]. [Sensor anyButtonPressed] whileFalse: []. Display newDepth: displayDepth. "BitBlt exampleOne"! ! !BitBlt class methodsFor: 'examples' stamp: 'jrm 2/21/2001 23:43'! exampleTwo "This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for a while and then automatically stops. This only works at Depth of 1." | f aBitBlt displayDepth | "create a small black Form source as a brush. " displayDepth _ Display depth. Display newDepth: 1. f _ Form extent: 20 @ 20. f fillBlack. "create a BitBlt which will OR gray into the display. " aBitBlt _ BitBlt destForm: Display sourceForm: f fillColor: Color gray combinationRule: Form over destOrigin: Sensor cursorPoint sourceOrigin: 0 @ 0 extent: f extent clipRect: Display computeBoundingBox. "paint the gray Form on the screen for a while. " [Sensor anyButtonPressed] whileFalse: [aBitBlt destOrigin: Sensor cursorPoint. aBitBlt copyBits]. Display newDepth: displayDepth. "BitBlt exampleTwo"! ! !BitBlt class methodsFor: 'private' stamp: 'jrm 2/21/2001 23:45'! exampleAt: originPoint rule: rule fillColor: mask "This builds a source and destination form and copies the source to the destination using the specifed rule and mask. It is called from the method named exampleOne. Only works with Display depth of 1" | s d border aBitBlt | border_Form extent: 32@32. border fillBlack. border fill: (1@1 extent: 30@30) fillColor: Color white. s _ Form extent: 32@32. s fillWhite. s fillBlack: (7@7 corner: 25@25). d _ Form extent: 32@32. d fillWhite. d fillBlack: (0@0 corner: 32@16). s displayOn: Display at: originPoint. border displayOn: Display at: originPoint rule: Form under. d displayOn: Display at: originPoint + (s width @0). border displayOn: Display at: originPoint + (s width @0) rule: Form under. d displayOn: Display at: originPoint + (s extent // (2 @ 1)). aBitBlt _ BitBlt destForm: Display sourceForm: s fillColor: mask combinationRule: rule destOrigin: originPoint + (s extent // (2 @ 1)) sourceOrigin: 0 @ 0 extent: s extent clipRect: Display computeBoundingBox. aBitBlt copyBits. border displayOn: Display at: originPoint + (s extent // (2 @ 1)) rule: Form under. "BitBlt exampleAt: 100@100 rule: 0 fillColor: nil" ! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 4/24/2001 23:49'! benchDiffsFrom: before to: afterwards "Given two outputs of BitBlt>>benchmark show the relative improvements." | old new log oldLine newLine oldVal newVal improvement | log _ WriteStream on: String new. old _ ReadStream on: before. new _ ReadStream on: afterwards. [old atEnd or:[new atEnd]] whileFalse:[ oldLine _ old upTo: Character cr. newLine _ new upTo: Character cr. (oldLine includes: Character tab) ifTrue:[ oldLine _ ReadStream on: oldLine. newLine _ ReadStream on: newLine. Transcript cr; show: (oldLine upTo: Character tab); tab. log cr; nextPutAll: (newLine upTo: Character tab); tab. [oldLine skipSeparators. newLine skipSeparators. oldLine atEnd] whileFalse:[ oldVal _ Integer readFrom: oldLine. newVal _ Integer readFrom: newLine. improvement _ oldVal asFloat / newVal asFloat roundTo: 0.01. Transcript show: improvement printString; tab; tab. log print: improvement; tab; tab]. ] ifFalse:[ Transcript cr; show: oldLine. log cr; nextPutAll: oldLine. ]. ]. ^log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 5/14/2001 23:31'! benchmark "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log _ WriteStream on: String new. destRect _ 0@0 extent: 600@600. "Form paint/Form over - the most common rules" #( 25 3 ) do:[:rule| Transcript cr; show:'---- Combination rule: ', rule printString,' ----'. log cr; nextPutAll:'---- Combination rule: ', rule printString,' ----'. #(1 2 4 8 16 32) do:[:destDepth| dest _ nil. dest _ Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32) do:[:sourceDepth| Transcript cr; show: sourceDepth printString, ' => ', destDepth printString. log cr; nextPutAll: sourceDepth printString, ' => ', destDepth printString. source _ nil. bb _ nil. source _ Form extent: destRect extent depth: sourceDepth. (source getCanvas) fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb _ WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededFor: dest). bb combinationRule: rule. "Measure speed of copyBits" t _ Time millisecondsToRun:[bb copyBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. ]. ]. ]. ^log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 5/14/2001 23:31'! benchmark2 "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log _ WriteStream on: String new. destRect _ 0@0 extent: 600@600. "Form paint/Form over - the most common rules" #( 25 3 ) do:[:rule| Transcript cr; show:'---- Combination rule: ', rule printString,' ----'. log cr; nextPutAll:'---- Combination rule: ', rule printString,' ----'. #(1 2 4 8 16 32) do:[:destDepth| dest _ nil. dest _ Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32) do:[:sourceDepth| Transcript cr; show: sourceDepth printString, ' => ', destDepth printString. log cr; nextPutAll: sourceDepth printString, ' => ', destDepth printString. source _ nil. bb _ nil. source _ Form extent: destRect extent depth: sourceDepth. (source getCanvas) fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb _ WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededFor: dest). bb combinationRule: rule. "Measure speed of copyBits" t _ Time millisecondsToRun:[1 to: 10 do:[:i| bb copyBits]]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t _ Time millisecondsToRun:[1 to: 4 do:[:i| bb warpBits]]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. ]. ]. ]. ^log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 4/26/2001 21:04'! benchmark3 "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log _ WriteStream on: String new. destRect _ 0@0 extent: 600@600. "Form paint/Form over - the most common rules" #( 25 3 ) do:[:rule| Transcript cr; show:'---- Combination rule: ', rule printString,' ----'. log cr; nextPutAll:'---- Combination rule: ', rule printString,' ----'. #(1 2 4 8 16 32) do:[:destDepth| dest _ nil. dest _ Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32) do:[:sourceDepth| Transcript cr; show: sourceDepth printString, ' => ', destDepth printString. log cr; nextPutAll: sourceDepth printString, ' => ', destDepth printString. source _ nil. bb _ nil. source _ Form extent: destRect extent depth: sourceDepth. (source getCanvas) fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb _ WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededFor: dest). bb combinationRule: rule. "Measure speed of copyBits" t _ Time millisecondsToRun:[1 to: 10 do:[:i| bb copyBits]]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t _ Time millisecondsToRun:[1 to: 4 do:[:i| bb warpBits]]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. ]. ]. ]. ^log contents! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! testDrawingWayOutside | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! testDrawingWayOutside2 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: 0@0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! testDrawingWayOutside3 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! testDrawingWayOutside4 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. bb sourceOrigin: SmallInteger maxVal squared asPoint. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! testDrawingWayOutside5 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: 0@0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb sourceOrigin: SmallInteger maxVal squared asPoint. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! testDrawingWayOutside6 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb sourceOrigin: SmallInteger maxVal squared asPoint. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! testFillingWayOutside | f1 bb | f1 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! testFillingWayOutside2 | f1 bb | f1 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: 0@0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! testFillingWayOutside3 | f1 bb | f1 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltTest methodsFor: 'bugs' stamp: 'ar 4/6/2003 19:04'! testAlphaCompositing | bb f1 f2 mixColor result eps | f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color blue. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBits. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. self assert: result alpha = 1.0. ].! ! !BitBltTest methodsFor: 'bugs' stamp: 'ar 4/6/2003 19:04'! testAlphaCompositing2 | bb f1 f2 mixColor result eps | f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color transparent. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBits. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: result alpha = mixColor alpha. ].! ! !BitBltTest methodsFor: 'bugs' stamp: 'tpr 8/15/2003 19:00'! testAlphaCompositing2Simulated | bb f1 f2 mixColor result eps | Smalltalk at: #BitBltSimulation ifPresent: [:bitblt| f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color transparent. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBitsSimulated. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: result alpha = mixColor alpha. ].]! ! !BitBltTest methodsFor: 'bugs' stamp: 'tpr 8/15/2003 19:02'! testAlphaCompositingSimulated | bb f1 f2 mixColor result eps | Smalltalk at: #BitBltSimulation ifPresent:[:bitblt| f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color blue. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBitsSimulated. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. self assert: result alpha = 1.0. ]].! ! !BitBltTest methodsFor: 'bugs' stamp: 'ar 3/1/2004 13:49'! testPeekerUnhibernateBug | bitBlt | bitBlt := BitBlt bitPeekerFromForm: Display. bitBlt destForm hibernate. self shouldnt:[bitBlt pixelAt: 1@1] raise: Error.! ! !BitBltTest methodsFor: 'bugs' stamp: 'ar 3/1/2004 13:49'! testPokerUnhibernateBug | bitBlt | bitBlt := BitBlt bitPokerToForm: Display. bitBlt sourceForm hibernate. self shouldnt:[bitBlt pixelAt: 1@1 put: 0] raise: Error.! ! !BitEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 13:53'! getCurrentColor | formExtent form c | c := Color colorFromPixelValue: color depth: Display depth. formExtent _ 30@30" min: 10@ 10//(2+1@2)". "compute this better" form _ Form extent: formExtent depth: Display depth. form borderWidth: 5. form border: form boundingBox width: 4 fillColor: Color white. form fill: form boundingBox fillColor: c. ^form! ! !BitEditor methodsFor: 'menu messages' stamp: 'btr 11/18/2002 14:57'! setColor: aColor "Set the color that the next edited dots of the model to be the argument, aSymbol. aSymbol can be any color changing message understood by a Form, such as white or black." color _ aColor pixelValueForDepth: Display depth. squareForm fillColor: aColor! ! !BitEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 13:21' prior: 34056381! setColor: aColor "Set the color that the next edited dots of the model to be the argument, aSymbol. aSymbol can be any color changing message understood by a Form, such as white or black." color _ aColor pixelValueForDepth: Display depth. squareForm fillColor: aColor. self changed: #getCurrentColor! ! !BitEditor class methodsFor: 'private' stamp: 'BG 12/4/2003 10:18' prior: 18375281! bitEdit: aForm at: magnifiedFormLocation scale: scaleFactor remoteView: remoteView "Create a BitEditor on aForm. That is, aForm is a small image that will change as a result of the BitEditor changing a second and magnified view of me. magnifiedFormLocation is where the magnified form is to be located on the screen. scaleFactor is the amount of magnification. This method implements a scheduled view containing both a small and magnified view of aForm. Upon accept, aForm is updated." | aFormView scaledFormView bitEditor topView extent menuView lowerRightExtent | scaledFormView _ FormHolderView new model: aForm. scaledFormView scaleBy: scaleFactor. bitEditor _ self new. scaledFormView controller: bitEditor. bitEditor setColor: Color black. topView _ ColorSystemView new. remoteView == nil ifTrue: [topView label: 'Bit Editor']. topView borderWidth: 2. topView addSubView: scaledFormView. remoteView == nil ifTrue: "If no remote view, then provide a local view of the form" [aFormView _ FormView new model: scaledFormView workingForm. aFormView controller: NoController new. aForm height < 50 ifTrue: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 2] ifFalse: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 0]. topView addSubView: aFormView below: scaledFormView] ifFalse: "Otherwise, the remote one should view the same form" [remoteView model: scaledFormView workingForm]. lowerRightExtent _ remoteView == nil ifTrue: [(scaledFormView viewport width - aFormView viewport width) @ (aFormView viewport height max: 50)] ifFalse: [scaledFormView viewport width @ 50]. menuView _ self buildColorMenu: lowerRightExtent colorCount: 1. menuView model: bitEditor. menuView borderWidthLeft: 0 right: 0 top: 2 bottom: 0. topView addSubView: menuView align: menuView viewport topRight with: scaledFormView viewport bottomRight. extent _ scaledFormView viewport extent + (0 @ lowerRightExtent y) + (4 @ 4). "+4 for borders" topView minimumSize: extent. topView maximumSize: extent. topView translateBy: magnifiedFormLocation. topView insideColor: Color white. ^topView! ! !BitEditor class methodsFor: 'private' stamp: 'BG 12/5/2003 13:40' prior: 18377524! buildColorMenu: extent colorCount: nColors "See BitEditor magnifyWithSmall." | menuView form aSwitchView button formExtent highlightForm color leftOffset | menuView _ FormMenuView new. menuView window: (0@0 corner: extent). formExtent _ 30@30 min: extent//(nColors*2+1@2). "compute this better" leftOffset _ extent x-(nColors*2-1*formExtent x)//2. highlightForm _ Form extent: formExtent. highlightForm borderWidth: 4. 1 to: nColors do: [:index | color _ (nColors = 1 ifTrue: [#(black)] ifFalse: [#(black gray)]) at: index. form _ Form extent: formExtent. form fill: form boundingBox fillColor: (Color perform: color). form borderWidth: 5. form border: form boundingBox width: 4 fillColor: Color white. button _ Button new. aSwitchView _ PluggableButtonView on: button getState: #isOn action: #turnOn label: #getCurrentColor. index = 1 ifTrue: [button onAction: [menuView model setColor: Color fromUser. aSwitchView label: menuView model getCurrentColor; displayView ] ] ifFalse: [button onAction: [menuView model setTransparentColor]]. aSwitchView shortcutCharacter: ((nColors=3 ifTrue: ['xvn'] ifFalse: ['xn']) at: index); label: form; window: (0@0 extent: form extent); translateBy: (((index - 1) * 2 * form width) + leftOffset)@(form height // 2); borderWidth: 1. menuView addSubView: aSwitchView]. ^ menuView ! ! !Bitmap methodsFor: 'filing' stamp: 'nk 12/31/2003 16:02' prior: 18389619! storeBits: startBit to: stopBit on: aStream "Store my bits as a hex string, breaking the lines every 100 bytes or so to comply with the maximum line length limits of Postscript (255 bytes). " | lineWidth | lineWidth := 0. self do: [:word | startBit to: stopBit by: -4 do: [:shift | aStream nextPut: (word >> shift bitAnd: 15) asHexDigit. lineWidth := lineWidth + 1]. (lineWidth > 100) ifTrue: [aStream cr. lineWidth := 0]]. lineWidth > 0 ifTrue: [ aStream cr ].! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:11'! atAllPut: value "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." super atAllPut: value.! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 9/21/2001 23:06' prior: 18392299! byteAt: byteAddress put: byte "Insert a byte into a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:put:. See Form pixelAt:put: 7/1/96 tk" | longWord shift lowBits longAddr | (byte < 0 or:[byte > 255]) ifTrue:[^self errorImproperStore]. lowBits _ byteAddress - 1 bitAnd: 3. longWord _ self at: (longAddr _ (byteAddress - 1 - lowBits) // 4 + 1). shift _ (3 - lowBits) * 8. longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) + (byte bitShift: shift). self at: longAddr put: longWord. ^ byte! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:18'! byteSize ^self size * 4! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 6/16/2002 18:49'! copyFromByteArray: byteArray "This method should work with either byte orderings" | myHack byteHack | myHack := Form new hackBits: self. byteHack := Form new hackBits: byteArray. Smalltalk isLittleEndian ifTrue:[byteHack swapEndianness]. byteHack displayOn: myHack. ! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:41'! integerAt: index "Return the integer at the given index" | word | word _ self basicAt: index. word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" ^word >= 16r80000000 "Negative?!!" ifTrue:["word - 16r100000000" (word bitInvert32 + 1) negated] ifFalse:[word]! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:42'! integerAt: index put: anInteger "Store the integer at the given index" | word | anInteger < 0 ifTrue:["word _ 16r100000000 + anInteger" word _ (anInteger + 1) negated bitInvert32] ifFalse:[word _ anInteger]. self basicAt: index put: word. ^anInteger! ! !Bitmap class methodsFor: 'utilities' stamp: 'sd 6/28/2003 09:33'! swapBytesIn: aNonPointerThing from: start to: stop "Perform a bigEndian/littleEndian byte reversal of my words. We only intend this for non-pointer arrays. Do nothing if I contain pointers." | hack blt | "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: aNonPointerThing. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1. blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3" blt sourceX: 3; destX: 0; copyBits. blt sourceX: 0; destX: 3; copyBits. blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2" blt sourceX: 2; destX: 1; copyBits. blt sourceX: 1; destX: 2; copyBits. ! ! !BitmapBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/2/2003 19:21'! testBitmapByteAt | bm | bm := Bitmap new: 1. 1 to: 4 do:[:i| self should:[bm byteAt: i put: 1000] raise: Error. ].! ! !BitmapFillStyle methodsFor: 'Morphic menu' stamp: 'dgd 10/17/2003 22:34' prior: 18397248! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" aMenu add: 'choose new graphic' translated target: self selector: #chooseNewGraphicIn:event: argument: aMorph. aMenu add: 'grab new graphic' translated target: self selector: #grabNewGraphicIn:event: argument: aMorph. super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! ! !BitmapFillStyle methodsFor: 'Morphic menu' stamp: 'sd 5/11/2003 22:18' prior: 18397708! chooseNewGraphicIn: aMorph event: evt "Used by any morph that can be represented by a graphic" | reasonableForms aGraphicalMenu myGraphic | reasonableForms _ (SketchMorph allSubInstances collect: [:m | m form]) asOrderedCollection. reasonableForms addAll: Imports default images. reasonableForms addAll: (BitmapFillStyle allSubInstances collect:[:f| f form]). reasonableForms _ reasonableForms asSet asOrderedCollection. (reasonableForms includes: (myGraphic _ self form)) ifTrue: [reasonableForms remove: myGraphic]. reasonableForms addFirst: myGraphic. aGraphicalMenu _ GraphicalMenu new initializeFor: self withForms: reasonableForms coexist: true. aGraphicalMenu selector: #newForm:forMorph:; argument: aMorph. evt hand attachMorph: aGraphicalMenu.! ! !BitmapFillStyle commentStamp: '' prior: 0! A BitmapFillStyle fills using any kind of form. Instance variables: form
The form to be used as fill. tileFlag If true, then the form is repeatedly drawn to fill the area.! !BitmapFillStyle class methodsFor: 'instance creation' stamp: 'KLC 1/27/2004 13:33' prior: 18399324! fromForm: aForm | fs | fs _ self form: aForm. fs origin: 0@0. fs direction: aForm width @ 0. fs normal: 0 @ aForm height. fs tileFlag: true. ^fs! ! !BitmapStreamTests methodsFor: 'Running' stamp: 'nk 7/5/2003 15:22'! setUp random _ Random new.! ! !BitmapStreamTests methodsFor: 'Running' stamp: 'nk 7/5/2003 15:22' prior: 34066554! setUp random _ Random new.! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/17/2004 17:05'! testShortIntegerArrayReadRefStream2 |refStrm| refStrm _ ReferenceStream on: ((RWBinaryOrTextStream with: (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3))) reset; binary). self assert: (refStrm next = (ShortIntegerArray with: 0 with: 1 with: 2 with: 3)).! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:06'! testShortIntegerArrayWithImageSegment array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:06' prior: 34067206! testShortIntegerArrayWithImageSegment array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:17'! testShortIntegerArrayWithRefStream array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/17/2004 18:44' prior: 34067728! testShortIntegerArrayWithRefStream array _ ShortIntegerArray with: 0 with: 1 with: 2 with: 3. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/16/2004 16:03'! testShortIntegerArrayWithRefStream2 array _ ShortIntegerArray with: 0 with: 1 with: 2 with: 3. self validateRefStream. self assert: stream byteStream contents = (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3)) ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:22'! testShortIntegerArrayWithRefStreamOnDisk array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:22' prior: 34068580! testShortIntegerArrayWithRefStreamOnDisk array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 16:32'! testShortIntegerArrayWithSmartRefStream array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 16:32' prior: 34069114! testShortIntegerArrayWithSmartRefStream array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/16/2004 16:04'! testShortIntegerArrayWithSmartRefStream2 array _ ShortIntegerArray with: 0 with: 1 with: 2 with: 3. self validateSmartRefStream. self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13)) ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:31'! testShortIntegerArrayWithSmartRefStreamOnDisk array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:31' prior: 34069987! testShortIntegerArrayWithSmartRefStreamOnDisk array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:12'! testShortPointArrayWithImageSegment array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:12' prior: 34070539! testShortPointArrayWithImageSegment array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:17'! testShortPointArrayWithRefStream array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:17' prior: 34071055! testShortPointArrayWithRefStream array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 3/12/2004 22:07'! testShortPointArrayWithRefStream2 array _ ShortPointArray with: 0@1 with: 2@3. self validateRefStream. self assert: stream byteStream contents = (ByteArray withAll: #(20 6 15 83 104 111 114 116 80 111 105 110 116 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3 )) ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:22'! testShortPointArrayWithRefStreamOnDisk array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:22' prior: 34071915! testShortPointArrayWithRefStreamOnDisk array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 15:57'! testShortPointArrayWithSmartRefStream array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 15:57' prior: 34072441! testShortPointArrayWithSmartRefStream array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 3/12/2004 22:07'! testShortPointArrayWithSmartRefStream2 array _ ShortPointArray with: 0@1 with: 2@3. self validateSmartRefStream. self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13)) ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:31'! testShortPointArrayWithSmartRefStreamOnDisk array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:31' prior: 34073287! testShortPointArrayWithSmartRefStreamOnDisk array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-misc' stamp: 'nk 3/17/2004 16:48'! testOtherClasses #(WordArrayForSegment FloatArray PointArray IntegerArray SoundBuffer String ShortPointArray ShortIntegerArray WordArray Array DependentsArray ByteArray Bitmap ColorArray ) do: [:s | | a | a _ (Smalltalk at: s) new: 3. self assert: (a basicSize * a bytesPerBasicElement = a byteSize). ] ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39'! createSampleShortRunArray ^ShortRunArray newFrom: { 0. 1. 1. 2. 2. 2. 3. 3. 3. 3 }! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 7/5/2003 18:12'! testShortRunArrayWithImageSegment array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]). self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39' prior: 34074390! testShortRunArrayWithImageSegment array _ self createSampleShortRunArray. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 7/5/2003 18:17'! testShortRunArrayWithRefStream array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]). self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39' prior: 34074830! testShortRunArrayWithRefStream array _ self createSampleShortRunArray. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 7/5/2003 18:22'! testShortRunArrayWithRefStreamOnDisk array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]). self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39' prior: 34075258! testShortRunArrayWithRefStreamOnDisk array _ self createSampleShortRunArray. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 7/5/2003 16:40'! testShortRunArrayWithSmartRefStream array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]). self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39' prior: 34075708! testShortRunArrayWithSmartRefStream array _ self createSampleShortRunArray. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:44'! testShortRunArrayWithSmartRefStream2 array _ self createSampleShortRunArray. self validateSmartRefStream. self assert: (stream contents asByteArray last: 23) = (ByteArray withAll: #(0 0 0 4 0 1 0 0 0 2 0 1 0 3 0 2 0 4 0 3 33 13 13)) ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 7/5/2003 18:31'! testShortRunArrayWithSmartRefStreamOnDisk array _ ShortRunArray newFrom: ((1 to: 10) collect: [ :i | self randomShortInt ]). self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:40' prior: 34076480! testShortRunArrayWithSmartRefStreamOnDisk array _ self createSampleShortRunArray. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:23'! testMatrixTransform2x3WithImageSegment array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:24'! testMatrixTransform2x3WithRefStream array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:24'! testMatrixTransform2x3WithRefStreamOnDisk array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:25'! testMatrixTransform2x3WithSmartRefStream array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:25'! testMatrixTransform2x3WithSmartRefStreamOnDisk array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:25'! testWordArrayWithImageSegment array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:25' prior: 34078205! testWordArrayWithImageSegment array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27'! testWordArrayWithRefStream array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27' prior: 34078671! testWordArrayWithRefStream array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27'! testWordArrayWithRefStreamOnDisk array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27' prior: 34079125! testWordArrayWithRefStreamOnDisk array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27'! testWordArrayWithSmartRefStream array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27' prior: 34079603! testWordArrayWithSmartRefStream array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:31'! testWordArrayWithSmartRefStreamOnDisk array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:31' prior: 34080077! testWordArrayWithSmartRefStreamOnDisk array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 3/7/2004 14:22'! randomFloat "Answer a random 32-bit float" | w | random seed: (w _ random nextValue). ^w! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:33'! randomShortInt ^((random next * 65536) - 32768) truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:33' prior: 34080733! randomShortInt ^((random next * 65536) - 32768) truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:00'! randomShortPoint ^(((random next * 65536) @ (random next * 65536)) - (32768 @ 32768)) truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:00' prior: 34081013! randomShortPoint ^(((random next * 65536) @ (random next * 65536)) - (32768 @ 32768)) truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:26'! randomWord "Answer a random 32-bit integer" | w | random seed: (w _ random nextValue). ^w truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:26' prior: 34081369! randomWord "Answer a random 32-bit integer" | w | random seed: (w _ random nextValue). ^w truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:11'! validateImageSegment "array is set up with an array." | other filename | filename _ 'bitmapStreamTest.extSeg'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. (ImageSegment new copyFromRootsForExport: (Array with: array)) writeForExport: filename. other _ (FileDirectory default readOnlyFileNamed: filename) fileInObjectAndCode. self assert: array = other originalRoots first! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:11' prior: 34081739! validateImageSegment "array is set up with an array." | other filename | filename _ 'bitmapStreamTest.extSeg'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. (ImageSegment new copyFromRootsForExport: (Array with: array)) writeForExport: filename. other _ (FileDirectory default readOnlyFileNamed: filename) fileInObjectAndCode. self assert: array = other originalRoots first! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:17'! validateRefStream "array is set up with an array." | other rwstream | rwstream _ RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). stream _ ReferenceStream on: rwstream. stream nextPut: array; close. rwstream position: 0. stream _ ReferenceStream on: rwstream. other _ stream next. stream close. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:17' prior: 34082727! validateRefStream "array is set up with an array." | other rwstream | rwstream _ RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). stream _ ReferenceStream on: rwstream. stream nextPut: array; close. rwstream position: 0. stream _ ReferenceStream on: rwstream. other _ stream next. stream close. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:22'! validateRefStreamOnDisk "array is set up with an array." | other filename | filename _ 'bitmapStreamTest.ref'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. stream _ ReferenceStream fileNamed: filename. stream nextPut: array; close. stream _ ReferenceStream fileNamed: filename. other _ stream next. stream close. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:22' prior: 34083587! validateRefStreamOnDisk "array is set up with an array." | other filename | filename _ 'bitmapStreamTest.ref'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. stream _ ReferenceStream fileNamed: filename. stream nextPut: array; close. stream _ ReferenceStream fileNamed: filename. other _ stream next. stream close. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:43'! validateSmartRefStream "array is set up with an array." | other | stream _ RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). stream binary. stream fileOutClass: nil andObject: array. stream position: 0. stream binary. other _ stream fileInObjectAndCode. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:43' prior: 34084493! validateSmartRefStream "array is set up with an array." | other | stream _ RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). stream binary. stream fileOutClass: nil andObject: array. stream position: 0. stream binary. other _ stream fileInObjectAndCode. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:32'! validateSmartRefStreamOnDisk "array is set up with an array." | other filename | filename _ 'bitmapStreamTest.ref'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. stream _ FileDirectory default fileNamed: filename. stream fileOutClass: nil andObject: array. stream close. stream _ FileDirectory default fileNamed: filename. other _ stream fileInObjectAndCode. stream close. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:32' prior: 34085261! validateSmartRefStreamOnDisk "array is set up with an array." | other filename | filename _ 'bitmapStreamTest.ref'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. stream _ FileDirectory default fileNamed: filename. stream fileOutClass: nil andObject: array. stream close. stream _ FileDirectory default fileNamed: filename. other _ stream fileInObjectAndCode. stream close. self assert: array = other! ! !BitmapStreamTests commentStamp: 'nk 3/7/2004 14:26' prior: 0! This is an incomplete test suite for storing and reading various word- and short-word subclasses of ArrayedCollection. It demonstrates some problems with filing in of certain kinds of arrayed objects, including: ShortPointArray ShortIntegerArray ShortRunArray WordArray MatrixTransform2x3 In 3.6b-5331, I get 8 passed/6 failed/6 errors (not counting the MatrixTransform2x3 tests, which were added later). I ran into problems when trying to read back the SqueakLogo flash character morph, after I'd done a 'save morph to disk' from its debug menu. The words within the ShortPointArrays and ShortRunArrays were reversed. ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 16:02'! form ^form! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 16:02'! form: aForm form _ aForm! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 12/19/2000 16:01'! movieDrawArea ^movieDrawArea! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 15:54'! mpegLogic ^mpegLogic! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 15:54'! mpegLogic: aValue mpegLogic _ aValue! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 12/19/2000 15:45'! primary ^primary! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 12/19/2000 21:52'! quadNumber ^quadNumber! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 1/4/2001 10:53'! quadNumber: aNumber quadNumber _ aNumber! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 15:59'! stream ^0! ! !BlobMPEGMorph methodsFor: 'drawing' stamp: 'JMM 1/4/2001 11:18'! drawOn: aCanvas "Display the receiver, a spline curve, approximated by straight line segments. Fill with the MPEG movie" | cm f filled quadRect | cm _ Bitmap new: 2. cm at: 1 put: 0. cm at: 2 put: 32767. f _ Form extent: self extent depth: 16. filled _ self filledForm. (BitBlt toForm: f) sourceForm: filled; sourceRect: filled boundingBox; destRect: (0 @ 0 extent: filled extent); colorMap: cm; combinationRule: Form over; copyBits. quadNumber = 1 ifTrue: [quadRect _ Rectangle origin: form boundingBox topLeft corner: form boundingBox center]. quadNumber = 2 ifTrue: [quadRect _ Rectangle origin: form boundingBox topCenter corner: form boundingBox rightCenter]. quadNumber = 3 ifTrue: [quadRect _ Rectangle origin: form boundingBox leftCenter corner: form boundingBox bottomCenter]. quadNumber = 4 ifTrue: [quadRect _ Rectangle origin: form boundingBox center corner: form boundingBox bottomRight]. (BitBlt toForm: f) sourceForm: form; sourceRect: quadRect; destRect: (0 @ 0 extent: f extent); combinationRule: Form and; copyBits. aCanvas image: f at: self position. self drawBorderOn: aCanvas. self drawArrowsOn: aCanvas! ! !BlobMPEGMorph methodsFor: 'drawing' stamp: 'JMM 1/4/2001 11:07'! playStream: aStream mpegLogic playStream: aStream. ! ! !BlobMPEGMorph methodsFor: 'drawing' stamp: 'JMM 12/19/2000 16:41'! playVideoStream: aStream mpegLogic playVideoStream: aStream. ! ! !BlobMPEGMorph methodsFor: 'initialization' stamp: 'JMM 1/4/2001 11:06'! initialize: primaryFlag mpegPlayer: aMpegPlayerOrFileName | rect sizeToOverLapBoundary | primary _ primaryFlag. rect _ self bounds. sizeToOverLapBoundary _ 3.0. primary ifTrue: [form _ Form extent: ((sizeToOverLapBoundary * rect width) @ (sizeToOverLapBoundary * rect height)) truncated depth: 32. movieDrawArea _ SketchMorph withForm: form. mpegLogic _ MPEGPlayer playFile: aMpegPlayerOrFileName onMorph: movieDrawArea] ifFalse: [form _ aMpegPlayerOrFileName form. movieDrawArea _ aMpegPlayerOrFileName movieDrawArea. mpegLogic _ aMpegPlayerOrFileName mpegLogic] ! ! !BlobMPEGMorph methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:43' prior: 34089353! initialize: primaryFlag mpegPlayer: aMpegPlayerOrFileName | rect sizeToOverLapBoundary | primary := primaryFlag. rect := self bounds. sizeToOverLapBoundary := 3.0. mpegLogic := primary ifTrue: [form := Form extent: ((sizeToOverLapBoundary * rect width) @ (sizeToOverLapBoundary * rect height)) truncated depth: 32. movieDrawArea := SketchMorph withForm: form. MPEGPlayer playFile: aMpegPlayerOrFileName onMorph: movieDrawArea] ifFalse: [form := aMpegPlayerOrFileName form. movieDrawArea := aMpegPlayerOrFileName movieDrawArea. aMpegPlayerOrFileName mpegLogic]! ! !BlobMPEGMorph methodsFor: 'initialization' stamp: 'JMM 1/4/2001 11:02'! initializeBlobShape | verts modifier | verts _ {59@40. 74@54. 79@74. 77@93. 57@97. 37@97. 22@83. 15@67. 22@50. 33@35. 47@33}. modifier _ 0 @ 0. (self quadNumber = 2) ifTrue: [ modifier _ 0 @ 75]. (self quadNumber = 3) ifTrue: [ modifier _ 75 @ 0]. (self quadNumber = 4) ifTrue: [ modifier _ 75 @ 75]. verts _ verts + modifier. self vertices: verts color: self color borderWidth: 1 borderColor: Color black! ! !BlobMPEGMorph methodsFor: 'initialization' stamp: 'JMM 1/4/2001 10:54'! initializeChildMpegPlayer: aMpegPlayerOrFileName self initialize: false mpegPlayer: aMpegPlayerOrFileName ! ! !BlobMPEGMorph methodsFor: 'initialization' stamp: 'JMM 1/4/2001 10:54'! initializePrimaryMpegPlayer: aMpegPlayerOrFileName self initialize: true mpegPlayer: aMpegPlayerOrFileName ! ! !BlobMPEGMorph methodsFor: 'stepping' stamp: 'JMM 10/19/2000 15:57'! adjustColors ^self! ! !BlobMPEGMorph methodsFor: 'stepping' stamp: 'JMM 12/19/2000 15:39'! limitRange: verts " limit radius to range 20-120; limit interpoint angle to surrounding angles with max of twice of average separation. " | cent new prevn nextn prevDeg nextDeg thisDeg dincr | cent := self bounds center. new := Array new: verts size. dincr := 360 // verts size. verts doWithIndex: [ :pt :n | "Find prev/next points, allowing for wrapping around " prevn := n-1 < 1 ifTrue: [new size] ifFalse: [n-1]. nextn := n+1 > new size ifTrue: [1] ifFalse: [n+1]. "Get prev/this/next point's angles " prevDeg := ((verts at: prevn)-cent) degrees. thisDeg := ((verts at: n)-cent) degrees. nextDeg := ((verts at: nextn)-cent) degrees. "Adjust if this is where angles wrap from 0 to 360" (thisDeg - prevDeg) abs > 180 ifTrue: [ prevDeg := prevDeg - 360 ]. (thisDeg - nextDeg) abs > 180 ifTrue: [ nextDeg := nextDeg + 360 ]. "Put adjusted point into new collection" new at: n put: cent + (self selfPolarPointRadius: ((((pt - cent) r) min: 60) max: 20) "was min: 80" degrees: (((thisDeg min: nextDeg-5) max: prevDeg+5) min: dincr*2+prevDeg)) ]. ^ new ! ! !BlobMPEGMorph methodsFor: 'stepping' stamp: 'JMM 12/19/2000 15:29'! mergeBlobs ^self! ! !BlobMPEGMorph methodsFor: 'testing' stamp: 'JMM 10/19/2000 16:29'! stepTime ^1.0 / (self mpegLogic videoFrameRate: self stream) * 1000! ! !BlobMPEGMorph commentStamp: '' prior: 0! Ok this is a little follow on to David's BlobMorph. Why not embedded a movie in the blob I thought. So with a few minutes of help from John Maloney we have something very interesting. Enjoy John M McIntosh Dec 2000. (Christmas early)! !BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'JMM 1/4/2001 11:10'! buildMorphics: aFileName | primary child | primary _ (self basicNew quadNumber: 1) initialize. self remember: primary. primary initializePrimaryMpegPlayer: aFileName. primary openInWorld. 2 to: 4 do: [:i | child _ (self basicNew quadNumber: i) initialize. self remember: child. child initializeChildMpegPlayer: primary. child openInWorld]. ^primary ! ! !BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'JMM 1/4/2001 11:11'! newWithMovie: aFileName | primary | primary _ self buildMorphics: aFileName. primary playStream: 0. ^primary ! ! !BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'JMM 1/4/2001 11:12'! newWithMovieNoSound: aFileName | primary | primary _ self buildMorphics: aFileName. primary playVideoStream: 0. ^primary ! ! !BlobMorph methodsFor: 'geometry' stamp: 'tk 7/14/2001 11:06'! setConstrainedPosition: aPoint hangOut: partiallyOutside "Deal with dragging the blob over another blob which results in spontaneous deletations." self owner ifNil: [^ self]. super setConstrainedPosition: aPoint hangOut: false. "note that we keep them from overlapping"! ! !BlobMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ random next < 0.25 ifTrue: [Color random] ifFalse: [Color random alpha: random next * 0.4 + 0.4]! ! !BlobMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:42' prior: 18401133! initialize "initialize the state of the receiver" random _ Random new. sneaky _ random next < 0.75. super initialize. "" self beSmoothCurve; initializeBlobShape; setVelocity! ! !BlobMorph methodsFor: 'stepping' stamp: 'ccn 8/28/2001 20:51'! mergeBlobs "See if we need to merge by checking our bounds against all other Blob bounds, then all our vertices against any Blob with overlapping bounds. If we find a need to merge, then someone else does all the work." (AllBlobs isNil or: [AllBlobs size < 2]) ifTrue: [^ self]. AllBlobs do: [:aBlob | aBlob owner == self owner ifTrue: [(self bounds intersects: aBlob bounds) ifTrue: [vertices do: [:aPoint | (aBlob containsPoint: aPoint) ifTrue: [^ self mergeSelfWithBlob: aBlob atPoint: aPoint]]]]] without: self! ! !BlobMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:20'! descriptionForPartsBin ^ self partName: 'Blob' categories: #('Demo') documentation: 'A patch of primordial slime'! ! !BlobMorphTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:26'! setUp morph := BlobMorph new.! ! !BlobMorphTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:26'! tearDown morph delete.! ! !BlobMorphTest methodsFor: 'testing' stamp: 'md 4/21/2003 16:26'! testOpenInWorld self shouldnt: [morph openInWorld] raise: Error.! ! !BlobMorphTest commentStamp: '' prior: 0! This is the unit test for the class BlobMorph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome ^ deadHome! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome: context deadHome _ context! ! !BlockContext methodsFor: 'initialize-release' stamp: 'ajh 1/23/2003 20:27'! privRefresh "Reinitialize the receiver so that it is in the state it was at its creation." nargs = 0 ifFalse: [self error: 'can only refresh block contexts that have zero arguments']. pc _ startpc. self stackp: 0. ! ! !BlockContext methodsFor: 'initialize-release' stamp: 'ajh 7/18/2003 21:49' prior: 34096985! privRefresh "Reinitialize the receiver so that it is in the state it was at its creation." pc _ startpc. self stackp: 0. nargs timesRepeat: [ "skip arg popping" self nextInstruction selector = #popIntoTemporaryVariable: ifFalse: [self halt: 'unexpected bytecode instruction'] ]. ! ! !BlockContext methodsFor: 'accessing' stamp: 'RAH 4/25/2000 19:49'! argumentCount "Answers the number of arguments needed to evaluate the receiver." #Valuable. ^ self numArgs! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/24/2003 12:35'! blockHome ^ self home! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 23:29'! finalBlockHome ^ self home! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! isBlock ^ true! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 12:12'! isExecutingBlock ^ true! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 9/28/2001 02:16'! isMethodContext ^ false! ! !BlockContext methodsFor: 'accessing' stamp: 'mdr 4/10/2001 10:34'! numArgs "Answer the number of arguments that must be used to evaluate this block" ^nargs! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/30/2003 15:45'! reentrant "Copy before calling so multiple activations can exist" ^ self copy! ! !BlockContext methodsFor: 'evaluating' stamp: 'brp 9/25/2003 13:49'! durationToRun "Answer the duration taken to execute this block." ^ Duration milliSeconds: self timeToRun ! ! !BlockContext methodsFor: 'evaluating' stamp: 'mdr 4/10/2001 13:08'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept either no parameters, or two (the error message and the receiver). The receiver should not contain an explicit return statement as this would leave an obsolete error handler hanging around." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. [1 / 0] ifError: [:err :rcvr | 'ZeroDivide' = err ifTrue: [Float infinity] ifFalse: [self error: err]] " | lastHandler val activeProcess errBlockArgs | errBlockArgs _ errorHandlerBlock numArgs. (errBlockArgs = 2) | (errBlockArgs = 0) ifFalse: [self error: 'error block must accept zero or two arguments (err rcvr)']. activeProcess _ Processor activeProcess. lastHandler _ activeProcess errorHandler. activeProcess errorHandler: [:aString :aReceiver | activeProcess errorHandler: lastHandler. (errBlockArgs = 2) ifTrue: [^ errorHandlerBlock value: aString value: aReceiver ] ifFalse: [^ errorHandlerBlock value ]]. val _ self on: Error do: [:ex | activeProcess errorHandler: lastHandler. (errBlockArgs = 2) ifTrue: [^ errorHandlerBlock value: ex description value: ex receiver ] ifFalse: [^ errorHandlerBlock value ]]. activeProcess errorHandler: lastHandler. ^ val ! ! !BlockContext methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:36' prior: 34098836! ifError: errorHandlerBlock "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. [1 / 0] ifError: [:err :rcvr | 'ZeroDivide' = err ifTrue: [Float infinity] ifFalse: [self error: err]] " ^ self on: Error do: [:ex | errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! ! !BlockContext methodsFor: 'evaluating'! valueWithArguments: anArray "Primitive. Evaluate the block represented by the receiver. The argument is an Array whose elements are the arguments for the block. Fail if the length of the Array is not the same as the the number of arguments that the block was expecting. Fail if the block is already being executed. Essential. See Object documentation whatIsAPrimitive." self numArgs = anArray size ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.'] ifFalse: [self error: 'This block requires ' , self numArgs printString , ' arguments.']! ! !BlockContext methodsFor: 'evaluating' stamp: 'mjr 9/10/2003 22:42' prior: 34100959! valueWithArguments: anArray "Primitive. Evaluate the block represented by the receiver. The argument is an Array whose elements are the arguments for the block. Fail if the length of the Array is not the same as the the number of arguments that the block was expecting. Fail if the block is already being executed. Essential. See Object documentation whatIsAPrimitive." self numArgs = anArray size ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.'] ifFalse: [self error: 'This block accepts ' ,self numArgs printString, ' argument', (self numArgs = 1 ifTrue:[''] ifFalse:['s']) , ', but was called with ', anArray size printString, '.'] ! ! !BlockContext methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:45'! doWhileFalse: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is false." | result | [result _ self value. conditionBlock value] whileFalse. ^ result! ! !BlockContext methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:39'! doWhileTrue: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is true." | result | [result _ self value. conditionBlock value] whileTrue. ^ result! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'! forkAndWait "Suspend current process and execute self in new process, when it completes resume current process" | semaphore | semaphore _ Semaphore new. [self ensure: [semaphore signal]] fork. semaphore wait. ! ! !BlockContext methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkAt: priority named: name "Create and schedule a Process running the code in the receiver at the given priority and having the given name. Answer the newly created process." | forkedProcess | forkedProcess := self newProcess. forkedProcess priority: priority. forkedProcess name: name. ^ forkedProcess resume! ! !BlockContext methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkNamed: aString "Create and schedule a Process running the code in the receiver and having the given name." ^ self newProcess name: aString; resume! ! !BlockContext methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:35' prior: 18421169! blockReturnTop "Simulate the interpreter's action when a ReturnTopOfStack bytecode is encountered in the receiver." | save dest | save _ home. "Needed because return code will nil it" dest _ self return: self pop from: self. home _ save. sender _ nil. ^ dest! ! !BlockContext methodsFor: 'printing' stamp: 'LC 1/6/2002 11:59'! decompile ^ Decompiler new decompileBlock: self! ! !BlockContext methodsFor: 'printing' stamp: 'LC 1/6/2002 13:07'! fullPrintOn: aStream aStream print: self; cr. (self decompile ifNil: ['--source missing--']) fullPrintOn: aStream ! ! !BlockContext methodsFor: 'printing' stamp: 'dew 11/11/2003 01:15' prior: 18421485! printOn: aStream | blockString truncatedBlockString | home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil']. aStream nextPutAll: '[] in '. super printOn: aStream. aStream nextPutAll: ' '. blockString _ ((self decompile ifNil: ['--source missing--']) printString replaceAll: Character cr with: Character space) replaceAll: Character tab with: Character space. truncatedBlockString _ blockString truncateWithElipsisTo: 80. truncatedBlockString size < blockString size ifTrue: [truncatedBlockString _ truncatedBlockString, ']}']. aStream nextPutAll: truncatedBlockString. ! ! !BlockContext methodsFor: 'private' stamp: 'tpr 2/16/2001 18:24'! aboutToReturn: result through: firstUnwindContext "Use the passed in context as the first marked context; evaluate the unwind block and then scan upwards for the next unwind marked method context" | ctx unwindBlock | ctx _ firstUnwindContext. [ctx isNil] whileFalse: [unwindBlock _ ctx tempAt: 1. unwindBlock == nil ifFalse: [unwindBlock value]. ctx _ ctx findNextUnwindContextUpTo: home]. thisContext swapSender: home sender. ^ result! ! !BlockContext methodsFor: 'private' stamp: 'ajh 1/24/2003 20:36' prior: 34105280! aboutToReturn: result through: firstUnwindContext "Called from VM when an unwindBlock is found between self and its home. Return to home's sender, executing unwind blocks on the way." self home return: result! ! !BlockContext methodsFor: 'private' stamp: 'ajh 1/27/2003 21:18'! copyTo: aContext blocks: dict "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home." | copy | self == aContext ifTrue: [^ nil]. copy _ self copy. (dict at: self home ifAbsentPut: [OrderedCollection new]) add: copy. self sender ifNotNil: [ copy privSender: (self sender copyTo: aContext blocks: dict)]. ^ copy! ! !BlockContext methodsFor: 'private' stamp: 'ajh 1/27/2003 21:08'! privHome: context home _ context! ! !BlockContext methodsFor: 'private' stamp: 'ar 3/2/2001 01:16'! valueUnpreemptively "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! After you've done all that thinking, go right ahead and use it..." | activeProcess oldPriority result | activeProcess _ Processor activeProcess. oldPriority _ activeProcess priority. activeProcess priority: Processor highestPriority. result _ self ensure: [activeProcess priority: oldPriority]. "Yield after restoring priority to give the preempted processes a chance to run" Processor yield. ^result! ! !BlockContext methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 18:03'! stepToSendOrReturn pc = startpc ifTrue: [ "pop args first" self numArgs timesRepeat: [self step]]. ^super stepToSendOrReturn! ! !BlockContext methodsFor: 'exceptions' stamp: 'ar 3/6/2001 14:24'! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." | returnValue | returnValue := self valueUninterruptably. "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" aBlock == nil ifFalse: [aBlock value]. ^returnValue! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 23:40' prior: 34107958! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." | returnValue | returnValue := self value. "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" aBlock == nil ifFalse: [aBlock value]. ^returnValue! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 3/4/2004 22:36' prior: 34108517! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." | returnValue b | returnValue := self value. "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" aBlock == nil ifFalse: [ "nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns" b _ aBlock. thisContext tempAt: 1 put: nil. "aBlock _ nil" b value. ]. ^ returnValue! ! !BlockContext methodsFor: 'exceptions' stamp: 'ar 3/6/2001 14:25'! ifCurtailed: aBlock "Evaluate the receiver with an abnormal termination action." ^self valueUninterruptably! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:43' prior: 34109758! ifCurtailed: aBlock "Evaluate the receiver with an abnormal termination action." ^ self value! ! !BlockContext methodsFor: 'exceptions' stamp: 'ar 3/6/2001 14:25'! on: exception do: handlerAction "Evaluate the receiver in the scope of an exception handler." | handlerActive | handlerActive _ true. ^self value! ! !BlockContext methodsFor: 'exceptions' stamp: 'ar 3/6/2001 14:25' prior: 34110161! on: exception do: handlerAction "Evaluate the receiver in the scope of an exception handler." | handlerActive | handlerActive _ true. ^self value! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 10/9/2001 16:51'! onDNU: selector do: handleBlock "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" ^ self on: MessageNotUnderstood do: [:exception | exception message selector = selector ifTrue: [handleBlock valueWithPossibleArgs: {exception}] ifFalse: [exception pass] ]! ! !BlockContext methodsFor: 'exceptions' stamp: 'ar 3/6/2001 14:55'! valueUninterruptably "Temporarily make my home Context unable to return control to its sender, to guard against circumlocution of the ensured behavior." | sendingContext result homeSender | "The above indicates new EH primitives supported. In this case is identical to #value." sendingContext := thisContext sender sender. homeSender _ home swapSender: nil. [[result := self on: BlockCannotReturn do: [:ex | thisContext unwindTo: sendingContext. sendingContext home answer: ex result. ex return: ex result]] on: ExceptionAboutToReturn do: [:ex | home sender == nil ifTrue: [home swapSender: homeSender. ex resume: homeSender] ifFalse: [ex resume: nil]]] on: Exception do: [:ex | home swapSender: homeSender. ex pass]. home swapSender: homeSender. ^result! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:53' prior: 34111060! valueUninterruptably "Temporarily make my home Context unable to return control to its sender, to guard against circumlocution of the ensured behavior." ^ self ifCurtailed: [^ self]! ! !BlockContext methodsFor: 'private-exceptions' stamp: 'ar 3/9/2001 01:18'! ifProperUnwindSupportedElseSignalAboutToReturn "A really ugly hack to simulate the necessary unwind behavior for VMs not having proper unwind support" "The above indicates new EH primitives supported. In this case is identical to #value. Sender is expected to use [nil] ifProperUnwindSupportedElseSignalAboutToReturn." ^ExceptionAboutToReturn signal.! ! !BlockContext methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:56'! sunitEnsure: aBlock ^self ensure: aBlock! ! !BlockContext methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:56' prior: 34112743! sunitEnsure: aBlock ^self ensure: aBlock! ! !BlockContext methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57'! sunitOn: anException do: aHandlerBlock ^self on: anException do: aHandlerBlock! ! !BlockContext methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57' prior: 34113015! sunitOn: anException do: aHandlerBlock ^self on: anException do: aHandlerBlock! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 14:00'! testBlockIsBottomContext self should: [aBlockContext client ] raise: Error. "block's sender is nil, a block has no client" self assert: aBlockContext bottomContext = aBlockContext. self assert: aBlockContext secondFromBottom isNil.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 13:49'! testCopyStack self assert: aBlockContext copyStack printString = aBlockContext printString.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 13:55'! testFindContextSuchThat self assert: (aBlockContext findContextSuchThat: [:each| true]) printString = aBlockContext printString. self assert: (aBlockContext hasContext: aBlockContext). ! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 13:13'! testNew self should: [ContextPart new: 5] raise: Error. [ContextPart new: 5] ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. [ContextPart new] ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. [ContextPart basicNew] ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. ! ! !BlockContextTest methodsFor: 'testing' stamp: 'mjr 8/24/2003 18:27'! testNoArguments [10 timesRepeat: [:arg | 1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.']. [10 timesRepeat: [:arg1 :arg2 | 1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! ! !BlockContextTest methodsFor: 'testing' stamp: 'mjr 8/24/2003 18:25'! testOneArgument | c | c _ OrderedCollection new. c add: 'hello'. [c do: [1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.']. [c do: [:arg1 :arg2 | 1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:50'! testRunSimulated self assert: (ContextPart runSimulated: aBlockContext) class = Rectangle.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 13:59'! testSetUp "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" self deny: aBlockContext isBlockClosure. self deny: aBlockContext isMethodContext. self deny: aBlockContext isPseudoContext. self deny: aBlockContext isDead. self assert: aBlockContext home = contextOfaBlockContext. self assert: aBlockContext blockHome = contextOfaBlockContext. self assert: aBlockContext receiver = self. self assert: (aBlockContext method isKindOf: CompiledMethod). self assert: aBlockContext methodNode selector = 'setUp'. self assert: (aBlockContext methodNodeFormattedAndDecorated: true) selector = 'setUp'.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:32'! testTallyInstructions self assert: (ContextPart tallyInstructions: aBlockContext) size = 17.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:30'! testTallyMethods self assert: (ContextPart tallyMethods: aBlockContext) size = 4.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:48'! testTrace self assert: (ContextPart trace: aBlockContext) class = Rectangle.! ! !BlockContextTest methodsFor: 'testing' stamp: 'mjr 9/10/2003 23:01'! testValueWithArguments self should: [[3 + 4] valueWithArguments: #(1 )] raise: Error. self shouldnt: [[3 + 4] valueWithArguments: #()] raise: Error. [[3 + 4] valueWithArguments: #(1 )] ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 0 arguments, but was called with 1.']. [[:i | 3 + 4] valueWithArguments: #(1 2)] ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 1 argument, but was called with 2.']! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 17:14' prior: 34116753! testValueWithArguments self should: [aBlockContext valueWithArguments: #(1 )] raise: Error. self shouldnt: [aBlockContext valueWithArguments: #()] raise: Error. [aBlockContext valueWithArguments: #(1 )] ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 0 arguments, but was called with 1.']. [[:i | 3 + 4] valueWithArguments: #(1 2)] ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 1 argument, but was called with 2.']! ! !BlockContextTest methodsFor: 'Running' stamp: 'tlk 5/31/2004 12:36'! setUp super setUp. aBlockContext _ [100@100 corner: 200@200]. contextOfaBlockContext _ thisContext.! ! !BlockContextTest commentStamp: 'tlk 5/31/2004 12:15' prior: 0! I am an SUnit Test of BlockContext and its supertype ContextPart. See also MethodContextTest. My fixtures are: aBlockContext - just some trivial block, i.e., [100@100 corner: 200@200] ! !BlockNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 22:23'! arguments: argNodes statements: statementsCollection returns: returnBool from: encoder sourceRange: range "Compile." encoder noteSourceRange: range forNode: self. ^self arguments: argNodes statements: statementsCollection returns: returnBool from: encoder! ! !BlockNode methodsFor: 'code generation' stamp: 'hmm 7/17/2001 21:02'! emitForValue: stack on: aStream aStream nextPut: LdThisContext. stack push: 1. nArgsNode emitForValue: stack on: aStream. remoteCopyNode emit: stack args: 1 on: aStream. "Force a two byte jump." self emitLong: size code: JmpLong on: aStream. stack push: arguments size. arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream]. self emitForEvaluatedValue: stack on: aStream. self returns ifFalse: [ aStream nextPut: EndRemote. pc _ aStream position. ]. stack pop: 1! ! !BlockNode methodsFor: 'tiles' stamp: 'RAA 2/27/2001 09:48'! asMorphicCollectSyntaxIn: parent ^parent blockNodeCollect: self arguments: arguments statements: statements! ! !BlockNode methodsFor: 'tiles' stamp: 'RAA 2/16/2001 09:08'! asMorphicSyntaxIn: parent ^parent blockNode: self arguments: arguments statements: statements! ! !BookMorph methodsFor: 'accessing' stamp: 'tk 12/12/2001 15:36'! cardsOrPages "The turnable and printable entities" ^ pages! ! !BookMorph methodsFor: 'caching' stamp: 'tk 3/11/2002 12:05'! releaseCachedState "Release the cached state of all my pages." super releaseCachedState. self removeProperty: #allText. "the cache for text search" pages do: [:page | page == currentPage ifFalse: [page fullReleaseCachedState]]. ! ! !BookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !BookMorph methodsFor: 'initialization' stamp: 'dgd 2/21/2003 23:10' prior: 18438846! fromRemoteStream: strm "Make a book from an index and a bunch of pages on a server. NOT showing any page!! Index and pages must live in the same directory. If the book has moved, save the current correct urls for each of the pages. Self must already have a url stored in property #url." | remote dict bookUrl oldStem stem oldUrl endPart | remote := strm fileInObjectAndCode. bookUrl := (SqueakPage new) url: (self valueOfProperty: #url); url. "expand a relative url" oldStem := SqueakPage stemUrl: (remote second) url. oldStem := oldStem copyUpToLast: $/. stem := SqueakPage stemUrl: bookUrl. stem := stem copyUpToLast: $/. oldStem = stem ifFalse: ["Book is in new directory, fix page urls" 2 to: remote size do: [:ii | oldUrl := (remote at: ii) url. endPart := oldUrl copyFrom: oldStem size + 1 to: oldUrl size. (remote at: ii) url: stem , endPart]]. self initialize. pages := OrderedCollection new. 2 to: remote size do: [:ii | pages add: (remote at: ii)]. currentPage fullReleaseCachedState; delete. "the blank one" currentPage := remote second. dict := remote first. self setProperty: #modTime toValue: (dict at: #modTime). dict at: #allText ifPresent: [:val | self setProperty: #allText toValue: val]. dict at: #allTextUrls ifPresent: [:val | self setProperty: #allTextUrls toValue: val]. #(#color #borderWidth #borderColor #pageSize) with: #(#color: #borderWidth: #borderColor: #pageSize:) do: [:key :sel | dict at: key ifPresent: [:val | self perform: sel with: val]]. ^self! ! !BookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:09' prior: 18440840! initialize "initialize the state of the receiver" super initialize. "" self setInitialState. pages _ OrderedCollection new. self showPageControls. self class turnOffSoundWhile: [self insertPage]! ! !BookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:07' prior: 18441843! setInitialState self listDirection: #topToBottom; wrapCentering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 5. pageSize _ 160 @ 300. self enableDragNDrop! ! !BookMorph methodsFor: 'insert and delete' stamp: 'dgd 9/21/2003 17:45' prior: 18447087! deletePage | message | message _ 'Are you certain that you want to delete this page and everything that is on it? ' translated. (self confirm: message) ifTrue: [self deletePageBasic]. ! ! !BookMorph methodsFor: 'insert and delete' stamp: 'mdr 8/13/2001 10:14'! insertPage: aPage pageSize: aPageSize atIndex: anIndex | sz predecessor | sz _ aPageSize ifNil: [currentPage == nil ifTrue: [pageSize] ifFalse: [currentPage extent]] ifNotNil: [aPageSize]. aPage extent: sz. ((pages isEmpty | anIndex isNil) or: [anIndex > pages size]) ifTrue: [pages add: aPage] ifFalse: [anIndex <= 1 ifTrue: [pages addFirst: aPage] ifFalse: [predecessor _ anIndex == nil ifTrue: [currentPage] ifFalse: [pages at: anIndex]. self pages add: aPage after: predecessor]]. self goToPageMorph: aPage ! ! !BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:10' prior: 34122699! insertPage: aPage pageSize: aPageSize atIndex: anIndex | sz predecessor | sz := aPageSize ifNil: [currentPage isNil ifTrue: [pageSize] ifFalse: [currentPage extent]] ifNotNil: [aPageSize]. aPage extent: sz. (pages isEmpty | anIndex isNil or: [anIndex > pages size]) ifTrue: [pages add: aPage] ifFalse: [anIndex <= 1 ifTrue: [pages addFirst: aPage] ifFalse: [predecessor := anIndex isNil ifTrue: [currentPage] ifFalse: [pages at: anIndex]. self pages add: aPage after: predecessor]]. self goToPageMorph: aPage! ! !BookMorph methodsFor: 'insert and delete' stamp: 'tk 10/30/2001 18:40'! insertPageColored: aColor "Insert a new page for the receiver, using the given color as its background color" | sz newPage bw bc | currentPage == nil ifTrue: [sz _ pageSize. bw _ 0. bc _ Color blue muchLighter] ifFalse: [sz _ currentPage extent. bw _ currentPage borderWidth. bc _ currentPage borderColor]. newPagePrototype ifNil: [newPage _ PasteUpMorph new extent: sz; color: aColor. newPage borderWidth: bw; borderColor: bc] ifNotNil: [Cursor wait showWhile: [newPage _ newPagePrototype veryDeepCopy]]. newPage setNameTo: self defaultNameStemForNewPages. newPage vResizeToFit: false. pages isEmpty ifTrue: [pages add: (currentPage _ newPage)] ifFalse: [pages add: newPage after: currentPage]. self nextPage ! ! !BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:11' prior: 34124031! insertPageColored: aColor "Insert a new page for the receiver, using the given color as its background color" | sz newPage bw bc | bc := currentPage isNil ifTrue: [sz := pageSize. bw := 0. Color blue muchLighter] ifFalse: [sz := currentPage extent. bw := currentPage borderWidth. currentPage borderColor]. newPagePrototype ifNil: [newPage := (PasteUpMorph new) extent: sz; color: aColor. newPage borderWidth: bw; borderColor: bc] ifNotNil: [Cursor wait showWhile: [newPage := newPagePrototype veryDeepCopy]]. newPage setNameTo: self defaultNameStemForNewPages. newPage vResizeToFit: false. pages isEmpty ifTrue: [pages add: (currentPage := newPage)] ifFalse: [pages add: newPage after: currentPage]. self nextPage! ! !BookMorph methodsFor: 'insert and delete' stamp: 'tk 10/30/2001 18:40'! insertPageSilentlyAtEnd "Create a new page at the end of the book. Do not turn to it." | sz newPage bw bc cc | currentPage == nil ifTrue: [sz _ pageSize. bw _ 0. bc _ Color blue muchLighter. cc _ color] ifFalse: [sz _ currentPage extent. bw _ currentPage borderWidth. bc _ currentPage borderColor. cc _ currentPage color]. newPagePrototype ifNil: [newPage _ PasteUpMorph new extent: sz; color: cc. newPage borderWidth: bw; borderColor: bc] ifNotNil: [Cursor wait showWhile: [newPage _ newPagePrototype veryDeepCopy]]. newPage setNameTo: self defaultNameStemForNewPages. newPage vResizeToFit: false. pages isEmpty ifTrue: [pages add: (currentPage _ newPage)] "had been none" ifFalse: [pages add: newPage after: pages last]. ^ newPage! ! !BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:11' prior: 34125761! insertPageSilentlyAtEnd "Create a new page at the end of the book. Do not turn to it." | sz newPage bw bc cc | cc := currentPage isNil ifTrue: [sz := pageSize. bw := 0. bc := Color blue muchLighter. color] ifFalse: [sz := currentPage extent. bw := currentPage borderWidth. bc := currentPage borderColor. currentPage color]. newPagePrototype ifNil: [newPage := (PasteUpMorph new) extent: sz; color: cc. newPage borderWidth: bw; borderColor: bc] ifNotNil: [Cursor wait showWhile: [newPage := newPagePrototype veryDeepCopy]]. newPage setNameTo: self defaultNameStemForNewPages. newPage vResizeToFit: false. pages isEmpty ifTrue: [pages add: (currentPage := newPage) "had been none"] ifFalse: [pages add: newPage after: pages last]. ^newPage! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:13' prior: 18457153! addBookMenuItemsTo: aMenu hand: aHandMorph | controlsShowing subMenu | subMenu _ MenuMorph new defaultTarget: self. subMenu add: 'previous page' translated action: #previousPage. subMenu add: 'next page' translated action: #nextPage. subMenu add: 'goto page' translated action: #goToPage. subMenu add: 'insert a page' translated action: #insertPage. subMenu add: 'delete this page' translated action: #deletePage. controlsShowing _ self hasSubmorphWithProperty: #pageControl. controlsShowing ifTrue: [subMenu add: 'hide page controls' translated action: #hidePageControls. subMenu add: 'fewer page controls' translated action: #fewerPageControls] ifFalse: [subMenu add: 'show page controls' translated action: #showPageControls]. self isInFullScreenMode ifTrue: [ subMenu add: 'exit full screen' translated action: #exitFullScreen. ] ifFalse: [ subMenu add: 'show full screen' translated action: #goFullScreen. ]. subMenu addLine. subMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:. subMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:. subMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:. subMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:. subMenu addLine. subMenu add: 'sort pages' translated action: #sortPages:. subMenu add: 'uncache page sorter' translated action: #uncachePageSorter. (self hasProperty: #dontWrapAtEnd) ifTrue: [subMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true] ifFalse: [subMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false]. subMenu addLine. subMenu add: 'search for text' translated action: #textSearch. (aHandMorph pasteBuffer class isKindOf: PasteUpMorph class) ifTrue: [subMenu add: 'paste book page' translated action: #pasteBookPage]. subMenu add: 'send all pages to server' translated action: #savePagesOnURL. subMenu add: 'send this page to server' translated action: #saveOneOnURL. subMenu add: 'reload all from server' translated action: #reload. subMenu add: 'copy page url to clipboard' translated action: #copyUrl. subMenu add: 'keep in one file' translated action: #keepTogether. subMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype. newPagePrototype ifNotNil: [subMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype]. aMenu add: 'book...' translated subMenu: subMenu ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:03' prior: 18459445! bookmarkForThisPage "If this book exists on a server, make the reference via a URL" | bb url um | (url _ self url) ifNil: [ bb _ SimpleButtonMorph new target: self. bb actionSelector: #goToPageMorph:fromBookmark:. bb label: 'Bookmark' translated. bb arguments: (Array with: currentPage with: bb). self primaryHand attachMorph: bb. ^ bb]. currentPage url ifNil: [currentPage saveOnURLbasic]. um _ URLMorph newForURL: currentPage url. um setURL: currentPage url page: currentPage sqkPage. (SqueakPage stemUrl: url) = (SqueakPage stemUrl: currentPage url) ifTrue: [um book: true] ifFalse: [um book: url]. "remember which book" um isBookmark: true; label: 'Bookmark' translated. um borderWidth: 1; borderColor: #raised. um color: (Color r: 0.4 g: 0.8 b: 0.6). self primaryHand attachMorph: um. ^ um! ! !BookMorph methodsFor: 'menu' stamp: 'RAA 2/24/2001 13:16'! buildThreadOfProjects | thisPVM projectNames threadName | projectNames _ pages collect: [ :each | (thisPVM _ each findA: ProjectViewMorph) ifNil: [ nil ] ifNotNil: [ {thisPVM project name}. ]. ]. projectNames _ projectNames reject: [ :each | each isNil]. threadName _ FillInTheBlank request: 'Please name this thread.' initialAnswer: ( self valueOfProperty: #nameOfThreadOfProjects ifAbsent: ['Projects on Parade'] ). threadName isEmptyOrNil ifTrue: [^self]. InternalThreadNavigationMorph know: projectNames as: threadName; openThreadNamed: threadName atIndex: nil. ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:04' prior: 34131057! buildThreadOfProjects | thisPVM projectNames threadName | projectNames _ pages collect: [ :each | (thisPVM _ each findA: ProjectViewMorph) ifNil: [ nil ] ifNotNil: [ {thisPVM project name}. ]. ]. projectNames _ projectNames reject: [ :each | each isNil]. threadName _ FillInTheBlank request: 'Please name this thread.' translated initialAnswer: ( self valueOfProperty: #nameOfThreadOfProjects ifAbsent: ['Projects on Parade' translated] ). threadName isEmptyOrNil ifTrue: [^self]. InternalThreadNavigationMorph know: projectNames as: threadName; openThreadNamed: threadName atIndex: nil. ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:05' prior: 18460968! copyUrl "Copy this page's url to the clipboard" | str | str _ currentPage url ifNil: [str _ 'Page does not have a url. Send page to server first.' translated]. Clipboard clipboardText: str asText. ! ! !BookMorph methodsFor: 'menu' stamp: 'tk 5/23/2001 16:52'! findText: keys inStrings: rawStrings startAt: startIndex container: oldContainer pageNum: pageNum "Call once to search a page of the book. Return true if found and highlight the text. oldContainer should be NIL. (oldContainer is only non-nil when (1) doing a 'search again' and (2) the page is in memory and (3) keys has just one element. oldContainer is a TextMorph.)" | good thisWord index insideOf place container start wasIn strings old | good _ true. start _ startIndex. strings _ oldContainer ifNil: [rawStrings] "normal case" ifNotNil: [(pages at: pageNum) isInMemory ifFalse: [rawStrings] ifTrue: [(pages at: pageNum) allStringsAfter: oldContainer]]. keys do: [:searchString | "each key" good ifTrue: [thisWord _ false. strings do: [:longString | (index _ longString findString: searchString startingAt: start caseSensitive: false) > 0 ifTrue: [ thisWord not & (searchString == (keys at: 1)) ifTrue: [ insideOf _ longString. place _ index]. thisWord _ true]. start _ 1]. "only first key on first container" good _ thisWord]]. good ifTrue: ["all are on this page" wasIn _ (pages at: pageNum) isInMemory. self goToPage: pageNum. wasIn ifFalse: ["search again, on the real current text. Know page is in." ^ self findText: keys inStrings: ((pages at: pageNum) allStringsAfter: nil) "recompute" startAt: startIndex container: oldContainer pageNum: pageNum]]. (old _ self valueOfProperty: #searchContainer) ifNotNil: [ (old respondsTo: #editor) ifTrue: [ old editor selectFrom: 1 to: 0. "trying to remove the previous selection!!" old changed]]. good ifTrue: ["have the exact string object" (container _ oldContainer) ifNil: [container _ self highlightText: (keys at: 1) at: place in: insideOf] ifNotNil: [ container userString == insideOf ifFalse: [ container _ self highlightText: (keys at: 1) at: place in: insideOf] ifTrue: [(container isKindOf: TextMorph) ifTrue: [ container editor selectFrom: place to: (keys at: 1) size - 1 + place. container changed]. ]]. self setProperty: #searchContainer toValue: container. self setProperty: #searchOffset toValue: place. self setProperty: #searchKey toValue: keys. "override later" ActiveHand newKeyboardFocus: container. ^ true]. ^ false! ! !BookMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 13:17' prior: 34132715! findText: keys inStrings: rawStrings startAt: startIndex container: oldContainer pageNum: pageNum "Call once to search a page of the book. Return true if found and highlight the text. oldContainer should be NIL. (oldContainer is only non-nil when (1) doing a 'search again' and (2) the page is in memory and (3) keys has just one element. oldContainer is a TextMorph.)" | good thisWord index insideOf place container start wasIn strings old | good := true. start := startIndex. strings := oldContainer ifNil: ["normal case" rawStrings] ifNotNil: [(pages at: pageNum) isInMemory ifFalse: [rawStrings] ifTrue: [(pages at: pageNum) allStringsAfter: oldContainer]]. keys do: [:searchString | "each key" good ifTrue: [thisWord := false. strings do: [:longString | (index := longString findString: searchString startingAt: start caseSensitive: false) > 0 ifTrue: [thisWord not & (searchString == keys first) ifTrue: [insideOf := longString. place := index]. thisWord := true]. start := 1]. "only first key on first container" good := thisWord]]. good ifTrue: ["all are on this page" wasIn := (pages at: pageNum) isInMemory. self goToPage: pageNum. wasIn ifFalse: ["search again, on the real current text. Know page is in." ^self findText: keys inStrings: ((pages at: pageNum) allStringsAfter: nil) startAt: startIndex container: oldContainer pageNum: pageNum "recompute"]]. (old := self valueOfProperty: #searchContainer) ifNotNil: [(old respondsTo: #editor) ifTrue: [old editor selectFrom: 1 to: 0. "trying to remove the previous selection!!" old changed]]. good ifTrue: ["have the exact string object" (container := oldContainer) ifNil: [container := self highlightText: keys first at: place in: insideOf] ifNotNil: [container userString == insideOf ifFalse: [container := self highlightText: keys first at: place in: insideOf] ifTrue: [(container isTextMorph) ifTrue: [container editor selectFrom: place to: keys first size - 1 + place. container changed]]]. self setProperty: #searchContainer toValue: container. self setProperty: #searchOffset toValue: place. self setProperty: #searchKey toValue: keys. "override later" ActiveHand newKeyboardFocus: container. ^true]. ^false! ! !BookMorph methodsFor: 'menu' stamp: 'ar 3/17/2001 23:44'! getStemUrl "Try to find the old place where this book was stored. Confirm with the user. Else ask for new place." | initial pg url knownURL | knownURL _ false. initial _ ''. (pg _ currentPage valueOfProperty: #SqueakPage) ifNotNil: [pg contentsMorph == currentPage ifTrue: [initial _ pg url. knownURL _ true]]. "If this page has a url" pages doWithIndex: [:aPage :ind | initial isEmpty ifTrue: [aPage isInMemory ifTrue: [(pg _ aPage valueOfProperty: #SqueakPage) ifNotNil: [initial _ pg url]]]]. "any page with a url" initial isEmpty ifTrue: [initial _ ServerDirectory defaultStemUrl , '1.sp']. "A new legal place" url _ knownURL ifTrue: [initial] ifFalse: [FillInTheBlank request: 'url of the place to store a typical page in this book. Must begin with file:// or ftp://' initialAnswer: initial]. ^ SqueakPage stemUrl: url! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:06' prior: 34137843! getStemUrl "Try to find the old place where this book was stored. Confirm with the user. Else ask for new place." | initial pg url knownURL | knownURL _ false. initial _ ''. (pg _ currentPage valueOfProperty: #SqueakPage) ifNotNil: [pg contentsMorph == currentPage ifTrue: [initial _ pg url. knownURL _ true]]. "If this page has a url" pages doWithIndex: [:aPage :ind | initial isEmpty ifTrue: [aPage isInMemory ifTrue: [(pg _ aPage valueOfProperty: #SqueakPage) ifNotNil: [initial _ pg url]]]]. "any page with a url" initial isEmpty ifTrue: [initial _ ServerDirectory defaultStemUrl , '1.sp']. "A new legal place" url _ knownURL ifTrue: [initial] ifFalse: [FillInTheBlank request: 'url of the place to store a typical page in this book. Must begin with file:// or ftp://' translated initialAnswer: initial]. ^ SqueakPage stemUrl: url! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 12:59' prior: 18468374! goToPage | pageNum | pageNum _ FillInTheBlank request: 'Page?' translated initialAnswer: '0'. pageNum isEmptyOrNil ifTrue: [^true]. self goToPage: pageNum asNumber. ! ! !BookMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 13:17' prior: 18468596! highlightText: stringToHilite at: index in: insideOf "Find the container with this text and highlight it. May not be able to do it for stringMorphs." "Find the container with that text" | container | self allMorphsDo: [:sub | insideOf == sub userString ifTrue: [container := sub]]. container ifNil: [self allMorphsDo: [:sub | insideOf = sub userString ifTrue: [container := sub]]]. "any match" container ifNil: [^nil]. "Order it highlighted" (container isTextMorph) ifTrue: [container editor selectFrom: index to: stringToHilite size - 1 + index]. container changed. ^container! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 9/19/2003 11:06' prior: 18469274! invokeBookMenu "Invoke the book's control panel menu." | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addStayUpItem. aMenu add: 'find...' translated action: #textSearch. aMenu add: 'go to page...' translated action: #goToPage. aMenu addLine. aMenu addList: { {'sort pages' translated. #sortPages}. {'uncache page sorter' translated. #uncachePageSorter}}. (self hasProperty: #dontWrapAtEnd) ifTrue: [aMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true] ifFalse: [aMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false]. aMenu addList: { {'make bookmark' translated. #bookmarkForThisPage}. {'make thumbnail' translated. #thumbnailForThisPage}}. aMenu addUpdating: #showingPageControlsString action: #toggleShowingOfPageControls. aMenu addUpdating: #showingFullScreenString action: #toggleFullScreen. aMenu addLine. aMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:. aMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:. aMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:. aMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:. aMenu addLine. (self primaryHand pasteBuffer class isKindOf: PasteUpMorph class) ifTrue: [aMenu add: 'paste book page' translated action: #pasteBookPage]. aMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype. newPagePrototype ifNotNil: [ aMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype]. aMenu add: (self dragNDropEnabled ifTrue: ['close dragNdrop'] ifFalse: ['open dragNdrop']) translated action: #toggleDragNDrop. aMenu add: 'make all pages this size' translated action: #makeUniformPageSize. aMenu add: 'send all pages to server' translated action: #savePagesOnURL. aMenu add: 'send this page to server' translated action: #saveOneOnURL. aMenu add: 'reload all from server' translated action: #reload. aMenu add: 'copy page url to clipboard' translated action: #copyUrl. aMenu add: 'keep in one file' translated action: #keepTogether. aMenu addLine. aMenu add: 'load PPT images from slide #1' translated action: #loadImagesIntoBook. aMenu add: 'background color for all pages...' translated action: #setPageColor. aMenu add: 'make a thread of projects in this book' translated action: #buildThreadOfProjects. aMenu popUpEvent: self world activeHand lastEvent in: self world ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 3/3/2004 18:40' prior: 34140709! invokeBookMenu "Invoke the book's control panel menu." | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: 'Book' translated. aMenu addStayUpItem. aMenu add: 'find...' translated action: #textSearch. aMenu add: 'go to page...' translated action: #goToPage. aMenu addLine. aMenu addList: { {'sort pages' translated. #sortPages}. {'uncache page sorter' translated. #uncachePageSorter}}. (self hasProperty: #dontWrapAtEnd) ifTrue: [aMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true] ifFalse: [aMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false]. aMenu addList: { {'make bookmark' translated. #bookmarkForThisPage}. {'make thumbnail' translated. #thumbnailForThisPage}}. aMenu addUpdating: #showingPageControlsString action: #toggleShowingOfPageControls. aMenu addUpdating: #showingFullScreenString action: #toggleFullScreen. aMenu addLine. aMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:. aMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:. aMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:. aMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:. aMenu addLine. (self primaryHand pasteBuffer class isKindOf: PasteUpMorph class) ifTrue: [aMenu add: 'paste book page' translated action: #pasteBookPage]. aMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype. newPagePrototype ifNotNil: [ aMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype]. aMenu add: (self dragNDropEnabled ifTrue: ['close dragNdrop'] ifFalse: ['open dragNdrop']) translated action: #toggleDragNDrop. aMenu add: 'make all pages this size' translated action: #makeUniformPageSize. aMenu addUpdating: #keepingUniformPageSizeString target: self action: #toggleMaintainUniformPageSize. aMenu addLine. aMenu add: 'send all pages to server' translated action: #savePagesOnURL. aMenu add: 'send this page to server' translated action: #saveOneOnURL. aMenu add: 'reload all from server' translated action: #reload. aMenu add: 'copy page url to clipboard' translated action: #copyUrl. aMenu add: 'keep in one file' translated action: #keepTogether. aMenu addLine. aMenu add: 'load PPT images from slide #1' translated action: #loadImagesIntoBook. aMenu add: 'background color for all pages...' translated action: #setPageColor. aMenu add: 'make a thread of projects in this book' translated action: #buildThreadOfProjects. aMenu popUpEvent: self world activeHand lastEvent in: self world ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:11' prior: 18471972! loadImagesIntoBook "PowerPoint stores GIF presentations as individual slides named Slide1, Slide2, etc. Load these into the book. mjg 9/99" | directory filenumber form newpage | directory := ((StandardFileMenu oldFileFrom: FileDirectory default) ifNil: [^nil]) directory. directory isNil ifTrue: [^nil]. "Start loading 'em up!!" filenumber := 1. [directory fileExists: 'Slide' , filenumber asString] whileTrue: [Transcript show: 'Slide' , filenumber asString; cr. Smalltalk bytesLeft < 1000000 ifTrue: ["Make some room" (self valueOfProperty: #url) isNil ifTrue: [self savePagesOnURL] ifFalse: [self saveAsNumberedURLs]]. form := Form fromFileNamed: (directory fullNameFor: 'Slide' , filenumber asString). newpage := PasteUpMorph new extent: form extent. newpage addMorph: (SketchMorph withForm: form). self pages addLast: newpage. filenumber := filenumber + 1]. "After adding all, delete the first page." self goToPage: 1. self deletePageBasic. "Save the book" (self valueOfProperty: #url) isNil ifTrue: [self savePagesOnURL] ifFalse: [self saveAsNumberedURLs]! ! !BookMorph methodsFor: 'menu' stamp: 'nb 6/17/2003 12:25' prior: 18473157! makeUniformPageSize "Make all pages be of the same size as the current page." currentPage ifNil: [^ Beeper beep]. self resizePagesTo: currentPage extent. newPagePrototype ifNotNil: [newPagePrototype extent: currentPage extent]! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:39' prior: 18473452! menuPageSoundFor: target event: evt | tSpec menu | tSpec _ self transitionSpecFor: target. menu _ (MenuMorph entitled: ('Choose a sound (it is now {1})' translated format:{tSpec first asString translated})) defaultTarget: target. SampledSound soundNames do: [:soundName | menu add: soundName asString translated target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (tSpec copy at: 1 put: soundName; yourself))]. menu popUpEvent: evt in: self world! ! !BookMorph methodsFor: 'menu' stamp: 'gk 2/23/2004 21:08' prior: 34147701! menuPageSoundFor: target event: evt | tSpec menu | tSpec _ self transitionSpecFor: target. menu _ (MenuMorph entitled: 'Choose a sound (it is now ' , tSpec first , ')') defaultTarget: target. SoundService default sampledSoundChoices do: [:soundName | menu add: soundName target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (tSpec copy at: 1 put: soundName; yourself))]. menu popUpEvent: evt in: self world! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:39' prior: 18474275! menuPageVisualFor: target event: evt | tSpec menu subMenu directionChoices | tSpec _ self transitionSpecFor: target. menu _ (MenuMorph entitled: ('Choose an effect (it is now {1})' translated format:{tSpec second asString translated})) defaultTarget: target. TransitionMorph allEffects do: [:effect | directionChoices _ TransitionMorph directionsForEffect: effect. directionChoices isEmpty ifTrue: [menu add: effect asString translated target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: #none))] ifFalse: [subMenu _ MenuMorph new. directionChoices do: [:dir | subMenu add: dir asString translated target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: dir))]. menu add: effect asString translated subMenu: subMenu]]. menu popUpEvent: evt in: self world! ! !BookMorph methodsFor: 'menu' stamp: 'ar 3/17/2001 23:44'! reload "Fetch the pages of this book from the server again. For all pages that have not been modified, keep current ones. Use new pages. For each, look up in cache, if time there is equal to time of new, and its in, use the current morph. Later do fancy things when a page has changed here, and also on the server." | url onServer onPgs sq which | (url _ self valueOfProperty: #url) ifNil: ["for .bo index file" url _ FillInTheBlank request: 'url of the place where this book''s index is stored. Must begin with file:// or ftp://' initialAnswer: (self getStemUrl, '.bo'). url size > 0 ifTrue: [self setProperty: #url toValue: url] ifFalse: [^ self]]. onServer _ self class new fromURL: url. "Later: test book times?" onPgs _ onServer pages collect: [:out | sq _ SqueakPageCache pageCache at: out url ifAbsent: [nil]. (sq ~~ nil and: [sq contentsMorph isInMemory]) ifTrue: [((out sqkPage lastChangeTime > sq lastChangeTime) or: [sq contentsMorph == nil]) ifTrue: [SqueakPageCache atURL: out url put: out sqkPage. out] ifFalse: [sq contentsMorph]] ifFalse: [SqueakPageCache atURL: out url put: out sqkPage. out]]. which _ (onPgs findFirst: [:pg | pg url = currentPage url]) max: 1. self newPages: onPgs currentIndex: which. "later stay at current page" self setProperty: #modTime toValue: (onServer valueOfProperty: #modTime). self setProperty: #allText toValue: (onServer valueOfProperty: #allText). self setProperty: #allTextUrls toValue: (onServer valueOfProperty: #allTextUrls). ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:49' prior: 34149914! reload "Fetch the pages of this book from the server again. For all pages that have not been modified, keep current ones. Use new pages. For each, look up in cache, if time there is equal to time of new, and its in, use the current morph. Later do fancy things when a page has changed here, and also on the server." | url onServer onPgs sq which | (url := self valueOfProperty: #url) ifNil: ["for .bo index file" url := FillInTheBlank request: 'url of the place where this book''s index is stored. Must begin with file:// or ftp://' initialAnswer: self getStemUrl , '.bo'. url notEmpty ifTrue: [self setProperty: #url toValue: url] ifFalse: [^self]]. onServer := self class new fromURL: url. "Later: test book times?" onPgs := onServer pages collect: [:out | sq := SqueakPageCache pageCache at: out url ifAbsent: [nil]. (sq notNil and: [sq contentsMorph isInMemory]) ifTrue: [(out sqkPage lastChangeTime > sq lastChangeTime or: [sq contentsMorph isNil]) ifTrue: [SqueakPageCache atURL: out url put: out sqkPage. out] ifFalse: [sq contentsMorph]] ifFalse: [SqueakPageCache atURL: out url put: out sqkPage. out]]. which := (onPgs findFirst: [:pg | pg url = currentPage url]) max: 1. self newPages: onPgs currentIndex: which. "later stay at current page" self setProperty: #modTime toValue: (onServer valueOfProperty: #modTime). self setProperty: #allText toValue: (onServer valueOfProperty: #allText). self setProperty: #allTextUrls toValue: (onServer valueOfProperty: #allTextUrls)! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:14' prior: 34151548! reload "Fetch the pages of this book from the server again. For all pages that have not been modified, keep current ones. Use new pages. For each, look up in cache, if time there is equal to time of new, and its in, use the current morph. Later do fancy things when a page has changed here, and also on the server." | url onServer onPgs sq which | (url _ self valueOfProperty: #url) ifNil: ["for .bo index file" url _ FillInTheBlank request: 'url of the place where this book''s index is stored. Must begin with file:// or ftp://' translated initialAnswer: (self getStemUrl, '.bo'). url notEmpty ifTrue: [self setProperty: #url toValue: url] ifFalse: [^ self]]. onServer _ self class new fromURL: url. "Later: test book times?" onPgs _ onServer pages collect: [:out | sq _ SqueakPageCache pageCache at: out url ifAbsent: [nil]. (sq notNil and: [sq contentsMorph isInMemory]) ifTrue: [((out sqkPage lastChangeTime > sq lastChangeTime) or: [sq contentsMorph isNil]) ifTrue: [SqueakPageCache atURL: out url put: out sqkPage. out] ifFalse: [sq contentsMorph]] ifFalse: [SqueakPageCache atURL: out url put: out sqkPage. out]]. which _ (onPgs findFirst: [:pg | pg url = currentPage url]) max: 1. self newPages: onPgs currentIndex: which. "later stay at current page" self setProperty: #modTime toValue: (onServer valueOfProperty: #modTime). self setProperty: #allText toValue: (onServer valueOfProperty: #allText). self setProperty: #allTextUrls toValue: (onServer valueOfProperty: #allTextUrls). ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:12' prior: 18477586! reserveUrls "Save a dummy version of the book first, assign all pages URLs, write dummy files to reserve the url, and write the index. Good when I have pages with interpointing bookmarks." | stem | (stem := self getStemUrl) isEmpty ifTrue: [^self]. pages doWithIndex: [:pg :ind | "does write the current page too" pg url ifNil: [pg reserveUrl: stem , ind printString , '.sp']] "self saveIndexOnURL."! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:12' prior: 18478648! saveAsNumberedURLs "Write out all pages in this book that are not showing, onto a server. The local disk could be the server. For any page that does not have a SqueakPage and a url already, name that page file by its page number. Any pages that are already totally out will stay that way." | stem list firstTime | firstTime := (self valueOfProperty: #url) isNil. stem := self getStemUrl. "user must approve" stem isEmpty ifTrue: [^self]. firstTime ifTrue: [self setProperty: #futureUrl toValue: stem , '.bo']. self reserveUrlsIfNeeded. pages doWithIndex: [:aPage :ind | "does write the current page too" aPage isInMemory ifTrue: ["not out now" aPage presenter ifNotNil: [aPage presenter flushPlayerListCache]. aPage saveOnURL: stem , ind printString , '.sp']]. list := pages collect: [:aPage | aPage sqkPage prePurge]. "knows not to purge the current page" list := (list select: [:each | each notNil]) asArray. "do bulk become:" (list collect: [:each | each contentsMorph]) elementsExchangeIdentityWith: (list collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]). self saveIndexOnURL. self presenter ifNotNil: [self presenter flushPlayerListCache]. firstTime ifTrue: ["Put a thumbnail into the hand" URLMorph grabForBook: self. self setProperty: #futureUrl toValue: nil "clean up"]! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:12' prior: 18480030! saveIndexOfOnly: aPage "Modify the index of this book on a server. Read the index, modify the entry for just this page, and write back. See saveIndexOnURL. (page file names must be unique even if they live in different directories.)" | mine sf remoteFile strm remote pageURL num pre index after dict allText allTextUrls fName | mine := self valueOfProperty: #url. mine ifNil: [^self saveIndexOnURL]. Cursor wait showWhile: [strm := ServerFile new fullPath: mine]. strm ifNil: [^self saveIndexOnURL]. strm class == String ifTrue: [^self saveIndexOnURL]. strm exists ifFalse: [^self saveIndexOnURL]. "write whole thing if missing" strm := strm asStream. strm class == String ifTrue: [^self saveIndexOnURL]. remote := strm fileInObjectAndCode. dict := remote first. allText := dict at: #allText ifAbsent: [nil]. "remote, not local" allTextUrls := dict at: #allTextUrls ifAbsent: [nil]. allText size + 1 ~= remote size ifTrue: [self error: '.bo size mismatch. Please tell Ted what you just did to this book.']. (pageURL := aPage url) ifNil: [self error: 'just had one!!']. fName := pageURL copyAfterLast: $/. 2 to: remote size do: [:ii | ((remote at: ii) url findString: fName startingAt: 1 caseSensitive: false) > 0 ifTrue: [index := ii]. "fast" (remote at: ii) xxxReset]. index ifNil: ["new page, what existing page does it follow?" num := self pageNumberOf: aPage. 1 to: num - 1 do: [:ii | (pages at: ii) url ifNotNil: [pre := (pages at: ii) url]]. pre ifNil: [after := remote size + 1] ifNotNil: ["look for it on disk, put me after" pre := pre copyAfterLast: $/. 2 to: remote size do: [:ii | ((remote at: ii) url findString: pre startingAt: 1 caseSensitive: false) > 0 ifTrue: [after := ii + 1]]. after ifNil: [after := remote size + 1]]. remote := remote copyReplaceFrom: after to: after - 1 with: #(1). allText ifNotNil: [dict at: #allText put: (allText copyReplaceFrom: after - 1 to: after - 2 with: #(#())). dict at: #allTextUrls put: (allTextUrls copyReplaceFrom: after - 1 to: after - 2 with: #(#()))]. index := after]. remote at: index put: aPage sqkPage copyForSaving. (dict at: #modTime ifAbsent: [0]) < Time totalSeconds ifTrue: [dict at: #modTime put: Time totalSeconds]. allText ifNotNil: [(dict at: #allText) at: index - 1 put: (aPage allStringsAfter: nil). (dict at: #allTextUrls) at: index - 1 put: pageURL]. sf := ServerDirectory new fullPath: mine. Cursor wait showWhile: [remoteFile := sf fileNamed: mine. remoteFile fileOutClass: nil andObject: remote "remoteFile close"]! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:16' prior: 34156850! saveIndexOfOnly: aPage "Modify the index of this book on a server. Read the index, modify the entry for just this page, and write back. See saveIndexOnURL. (page file names must be unique even if they live in different directories.)" | mine sf remoteFile strm remote pageURL num pre index after dict allText allTextUrls fName | mine _ self valueOfProperty: #url. mine ifNil: [^ self saveIndexOnURL]. Cursor wait showWhile: [strm _ (ServerFile new fullPath: mine)]. strm ifNil: [^ self saveIndexOnURL]. strm class == String ifTrue: [^ self saveIndexOnURL]. strm exists ifFalse: [^ self saveIndexOnURL]. "write whole thing if missing" strm _ strm asStream. strm class == String ifTrue: [^ self saveIndexOnURL]. remote _ strm fileInObjectAndCode. dict _ remote first. allText _ dict at: #allText ifAbsent: [nil]. "remote, not local" allTextUrls _ dict at: #allTextUrls ifAbsent: [nil]. allText size + 1 ~= remote size ifTrue: [self error: '.bo size mismatch. Please tell Ted what you just did to this book.' translated]. (pageURL _ aPage url) ifNil: [self error: 'just had one!!' translated]. fName _ pageURL copyAfterLast: $/. 2 to: remote size do: [:ii | ((remote at: ii) url findString: fName startingAt: 1 caseSensitive: false) > 0 ifTrue: [index _ ii]. "fast" (remote at: ii) xxxReset]. index ifNil: ["new page, what existing page does it follow?" num _ self pageNumberOf: aPage. 1 to: num-1 do: [:ii | (pages at: ii) url ifNotNil: [pre _ (pages at: ii) url]]. pre ifNil: [after _ remote size+1] ifNotNil: ["look for it on disk, put me after" pre _ pre copyAfterLast: $/. 2 to: remote size do: [:ii | ((remote at: ii) url findString: pre startingAt: 1 caseSensitive: false) > 0 ifTrue: [after _ ii+1]]. after ifNil: [after _ remote size+1]]. remote _ remote copyReplaceFrom: after to: after-1 with: #(1). allText ifNotNil: [ dict at: #allText put: (allText copyReplaceFrom: after-1 to: after-2 with: #(())). dict at: #allTextUrls put: (allTextUrls copyReplaceFrom: after-1 to: after-2 with: #(()))]. index _ after]. remote at: index put: (aPage sqkPage copyForSaving). (dict at: #modTime ifAbsent: [0]) < Time totalSeconds ifTrue: [dict at: #modTime put: Time totalSeconds]. allText ifNotNil: [ (dict at: #allText) at: index-1 put: (aPage allStringsAfter: nil). (dict at: #allTextUrls) at: index-1 put: pageURL]. sf _ ServerDirectory new fullPath: mine. Cursor wait showWhile: [ remoteFile _ sf fileNamed: mine. remoteFile fileOutClass: nil andObject: remote. "remoteFile close"]. ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:12' prior: 18482661! saveIndexOnURL "Make up an index to the pages of this book, with thumbnails, and store it on the server. (aDictionary, aMorphObjectOut, aMorphObjectOut, aMorphObjectOut). The last part corresponds exactly to what pages looks like when they are all out. Each holds onto a SqueakPage, which holds a url and a thumbnail." | dict list mine sf remoteFile urlList | pages isEmpty ifTrue: [^self]. dict := Dictionary new. dict at: #modTime put: Time totalSeconds. "self getAllText MUST have been called at start of this operation." dict at: #allText put: (self valueOfProperty: #allText). #(#color #borderWidth #borderColor #pageSize) do: [:sel | dict at: sel put: (self perform: sel)]. self reserveUrlsIfNeeded. "should already be done" list := pages copy. "paste dict on front below" "Fix up the entries, should already be done" list doWithIndex: [:out :ind | out isInMemory ifTrue: [(out valueOfProperty: #SqueakPage) ifNil: [out saveOnURLbasic]. list at: ind put: out sqkPage copyForSaving]]. urlList := list collect: [:ppg | ppg url]. self setProperty: #allTextUrls toValue: urlList. dict at: #allTextUrls put: urlList. list := (Array with: dict) , list. mine := self valueOfProperty: #url. mine ifNil: [mine := self getStemUrl , '.bo'. self setProperty: #url toValue: mine]. sf := ServerDirectory new fullPath: mine. Cursor wait showWhile: [remoteFile := sf fileNamed: mine. remoteFile dataIsValid. remoteFile fileOutClass: nil andObject: list "remoteFile close"]! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:13' prior: 18484235! saveOnUrlPage: pageMorph "Write out this single page in this book onto a server. See savePagesOnURL. (Don't compute the texts, only this page's is written.)" | stem ind response rand newPlace dir | (self valueOfProperty: #keepTogether) ifNotNil: [self inform: 'This book is marked ''keep in one file''. Several pages use a common Player. Save the owner of the book instead.'. ^self]. "Don't give the chance to put in a different place. Assume named by number" ((self valueOfProperty: #url) isNil and: [pages first url notNil]) ifTrue: [response := (PopUpMenu labels: 'Old book\New book sharing old pages' withCRs) startUpWithCaption: 'Modify the old book, or make a new\book sharing its pages?' withCRs. response = 2 ifTrue: ["Make up new url for .bo file and confirm with user." "Mark as shared" [rand := String new: 4. 1 to: rand size do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. (newPlace := self getStemUrl) isEmpty ifTrue: [^self]. newPlace := (newPlace copyUpToLast: $/) , '/BK' , rand , '.bo'. dir := ServerFile new fullPath: newPlace. dir includesKey: dir fileName] whileTrue. "keep doing until a new file" self setProperty: #url toValue: newPlace]. response = 0 ifTrue: [^self]]. stem := self getStemUrl. "user must approve" stem isEmpty ifTrue: [^self]. ind := pages identityIndexOf: pageMorph ifAbsent: [self error: 'where is the page?']. pageMorph isInMemory ifTrue: ["not out now" pageMorph saveOnURL: stem , ind printString , '.sp']. self saveIndexOfOnly: pageMorph! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:18' prior: 34163998! saveOnUrlPage: pageMorph "Write out this single page in this book onto a server. See savePagesOnURL. (Don't compute the texts, only this page's is written.)" | stem ind response rand newPlace dir | (self valueOfProperty: #keepTogether) ifNotNil: [ self inform: 'This book is marked ''keep in one file''. Several pages use a common Player. Save the owner of the book instead.' translated. ^ self]. "Don't give the chance to put in a different place. Assume named by number" ((self valueOfProperty: #url) isNil and: [pages first url notNil]) ifTrue: [ response _ (PopUpMenu labels: 'Old book New book sharing old pages' translated) startUpWithCaption: 'Modify the old book, or make a new book sharing its pages?' translated. response = 2 ifTrue: [ "Make up new url for .bo file and confirm with user." "Mark as shared" [rand _ String new: 4. 1 to: rand size do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. (newPlace _ self getStemUrl) isEmpty ifTrue: [^ self]. newPlace _ (newPlace copyUpToLast: $/), '/BK', rand, '.bo'. dir _ ServerFile new fullPath: newPlace. (dir includesKey: dir fileName)] whileTrue. "keep doing until a new file" self setProperty: #url toValue: newPlace]. response = 0 ifTrue: [^ self]]. stem _ self getStemUrl. "user must approve" stem isEmpty ifTrue: [^ self]. ind _ pages identityIndexOf: pageMorph ifAbsent: [self error: 'where is the page?' translated]. pageMorph isInMemory ifTrue: ["not out now" pageMorph saveOnURL: stem,(ind printString),'.sp']. self saveIndexOfOnly: pageMorph.! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:13' prior: 18486104! savePagesOnURL "Write out all pages in this book onto a server. For any page that does not have a SqueakPage and a url already, ask the user for one. Give the option of naming all page files by page number. Any pages that are not in memory will stay that way. The local disk could be the server." | response list firstTime newPlace rand dir bookUrl | (self valueOfProperty: #keepTogether) ifNotNil: [self inform: 'This book is marked ''keep in one file''. Several pages use a common Player. Save the owner of the book instead.'. ^self]. self getAllText. "stored with index later" response := (PopUpMenu labels: 'Use page numbers\Type in file names\Save in a new place (using page numbers)\Save in a new place (typing names)\Save new book sharing old pages' withCRs) startUpWithCaption: 'Each page will be a file on the server. \Do you want to page numbers be the names of the files? \or name each one yourself?' withCRs. response = 1 ifTrue: [self saveAsNumberedURLs. ^self]. response = 3 ifTrue: [self forgetURLs; saveAsNumberedURLs. ^self]. response = 4 ifTrue: [self forgetURLs]. response = 5 ifTrue: ["Make up new url for .bo file and confirm with user." "Mark as shared" [rand := String new: 4. 1 to: rand size do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. (newPlace := self getStemUrl) isEmpty ifTrue: [^self]. newPlace := (newPlace copyUpToLast: $/) , '/BK' , rand , '.bo'. dir := ServerFile new fullPath: newPlace. dir includesKey: dir fileName] whileTrue. "keep doing until a new file" self setProperty: #url toValue: newPlace. self saveAsNumberedURLs. bookUrl := self valueOfProperty: #url. (SqueakPage stemUrl: bookUrl) = (SqueakPage stemUrl: currentPage url) ifTrue: [bookUrl := true]. "not a shared book" (URLMorph grabURL: currentPage url) book: bookUrl. ^self]. response = 0 ifTrue: [^self]. "self reserveUrlsIfNeeded. Need two passes here -- name on one, write on second" pages do: [:aPage | "does write the current page too" aPage isInMemory ifTrue: ["not out now" aPage presenter ifNotNil: [aPage presenter flushPlayerListCache]. aPage saveOnURLbasic]]. "ask user if no url" list := pages collect: [:aPage | aPage sqkPage prePurge]. "knows not to purge the current page" list := (list select: [:each | each notNil]) asArray. "do bulk become:" (list collect: [:each | each contentsMorph]) elementsExchangeIdentityWith: (list collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]). firstTime := (self valueOfProperty: #url) isNil. self saveIndexOnURL. self presenter ifNotNil: [self presenter flushPlayerListCache]. firstTime ifTrue: ["Put a thumbnail into the hand" URLMorph grabForBook: self. self setProperty: #futureUrl toValue: nil "clean up"]! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:20' prior: 34167406! savePagesOnURL "Write out all pages in this book onto a server. For any page that does not have a SqueakPage and a url already, ask the user for one. Give the option of naming all page files by page number. Any pages that are not in memory will stay that way. The local disk could be the server." | response list firstTime newPlace rand dir bookUrl | (self valueOfProperty: #keepTogether) ifNotNil: [ self inform: 'This book is marked ''keep in one file''. Several pages use a common Player. Save the owner of the book instead.' translated. ^ self]. self getAllText. "stored with index later" response _ (PopUpMenu labels: 'Use page numbers Type in file names Save in a new place (using page numbers) Save in a new place (typing names) Save new book sharing old pages' translated) startUpWithCaption: 'Each page will be a file on the server. Do you want to page numbers be the names of the files? or name each one yourself?' translated. response = 1 ifTrue: [self saveAsNumberedURLs. ^ self]. response = 3 ifTrue: [self forgetURLs; saveAsNumberedURLs. ^ self]. response = 4 ifTrue: [self forgetURLs]. response = 5 ifTrue: [ "Make up new url for .bo file and confirm with user." "Mark as shared" [rand _ String new: 4. 1 to: rand size do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. (newPlace _ self getStemUrl) isEmpty ifTrue: [^ self]. newPlace _ (newPlace copyUpToLast: $/), '/BK', rand, '.bo'. dir _ ServerFile new fullPath: newPlace. (dir includesKey: dir fileName)] whileTrue. "keep doing until a new file" self setProperty: #url toValue: newPlace. self saveAsNumberedURLs. bookUrl _ self valueOfProperty: #url. (SqueakPage stemUrl: bookUrl) = (SqueakPage stemUrl: currentPage url) ifTrue: [ bookUrl _ true]. "not a shared book" (URLMorph grabURL: currentPage url) book: bookUrl. ^ self]. response = 0 ifTrue: [^ self]. "self reserveUrlsIfNeeded. Need two passes here -- name on one, write on second" pages do: [:aPage | "does write the current page too" aPage isInMemory ifTrue: ["not out now" aPage presenter ifNotNil: [aPage presenter flushPlayerListCache]. aPage saveOnURLbasic. ]]. "ask user if no url" list _ pages collect: [:aPage | aPage sqkPage prePurge]. "knows not to purge the current page" list _ (list select: [:each | each notNil]) asArray. "do bulk become:" (list collect: [:each | each contentsMorph]) elementsExchangeIdentityWith: (list collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]). firstTime _ (self valueOfProperty: #url) isNil. self saveIndexOnURL. self presenter ifNotNil: [self presenter flushPlayerListCache]. firstTime ifTrue: ["Put a thumbnail into the hand" URLMorph grabForBook: self. self setProperty: #futureUrl toValue: nil]. "clean up" ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:13' prior: 18489589! textSearch "search the text on all pages of this book" | wanted wants list str | list := self valueOfProperty: #searchKey ifAbsent: [#()]. str := String streamContents: [:strm | list do: [:each | strm nextPutAll: each; space]]. wanted := FillInTheBlank request: 'words to search for. Order is not important. Beginnings of words are OK.' initialAnswer: str. wants := wanted findTokens: Character separators. wants isEmpty ifTrue: [^self]. self getAllText. "save in allText, allTextUrls" ^self findText: wants "goes to the page and highlights the text"! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 12:58' prior: 34173284! textSearch "search the text on all pages of this book" | wanted wants list str | list _ self valueOfProperty: #searchKey ifAbsent: [#()]. str _ String streamContents: [:strm | list do: [:each | strm nextPutAll: each; space]]. wanted _ FillInTheBlank request: 'words to search for. Order is not important. Beginnings of words are OK.' translated initialAnswer: str. wants _ wanted findTokens: Character separators. wants isEmpty ifTrue: [^ self]. self getAllText. "save in allText, allTextUrls" ^ self findText: wants "goes to the page and highlights the text"! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:14' prior: 18490220! textSearch: stringWithKeys "search the text on all pages of this book" | wants | wants := stringWithKeys findTokens: Character separators. wants isEmpty ifTrue: [^self]. self getAllText. "save in allText, allTextUrls" ^self findText: wants "goes to the page and highlights the text"! ! !BookMorph methodsFor: 'navigation' stamp: 'sw 11/8/2002 13:31'! goToPage: pageNumber transitionSpec: transitionSpec runTransitionScripts: aBoolean "Go the the given page number; use the transitionSpec supplied, and if the boolean parameter is true, run opening and closing scripts as appropriate" | pageMorph | pages isEmpty ifTrue: [^ self]. pageMorph _ (self hasProperty: #dontWrapAtEnd) ifTrue: [pages atPin: pageNumber] ifFalse: [pages atWrap: pageNumber]. ^ self goToPageMorph: pageMorph transitionSpec: transitionSpec runTransitionScripts: aBoolean! ! !BookMorph methodsFor: 'navigation' stamp: 'sw 11/8/2002 21:30'! goToPageMorph: aMorph "Set the given morph as the current page; run closing and opening scripts as appropriate" self goToPageMorph: aMorph runTransitionScripts: true! ! !BookMorph methodsFor: 'navigation' stamp: 'sw 11/8/2002 13:34'! goToPageMorph: aMorph runTransitionScripts: aBoolean "Set the given morph as the current page. If the boolean parameter is true, then opening and closing scripts will be run" self goToPage: (pages identityIndexOf: aMorph ifAbsent: [^ self "abort"]) transitionSpec: nil runTransitionScripts: aBoolean ! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/22/2003 18:49' prior: 18452298! goToPageMorph: newPage transitionSpec: transitionSpec | pageIndex aWorld oldPageIndex ascending tSpec readIn | pages isEmpty ifTrue: [^self]. self setProperty: #searchContainer toValue: nil. "forget previous search" self setProperty: #searchOffset toValue: nil. self setProperty: #searchKey toValue: nil. pageIndex := pages identityIndexOf: newPage ifAbsent: [^self "abort"]. readIn := newPage isInMemory not. oldPageIndex := pages identityIndexOf: currentPage ifAbsent: [nil]. ascending := (oldPageIndex isNil or: [newPage == currentPage]) ifTrue: [nil] ifFalse: [oldPageIndex < pageIndex]. tSpec := transitionSpec ifNil: ["If transition not specified by requestor..." newPage valueOfProperty: #transitionSpec ifAbsent: [" ... then consult new page" self transitionSpecFor: self " ... otherwise this is the default"]]. self flag: #arNote. "Probably unnecessary" (aWorld := self world) ifNotNil: [self primaryHand releaseKeyboardFocus]. currentPage ifNotNil: [currentPage updateCachedThumbnail]. self currentPage notNil ifTrue: [(((pages at: pageIndex) owner isKindOf: TransitionMorph) and: [(pages at: pageIndex) isInWorld]) ifTrue: [^self "In the process of a prior pageTurn"]. self currentPlayerDo: [:aPlayer | aPlayer runAllClosingScripts]. ascending ifNotNil: ["Show appropriate page transition and start new page when done" currentPage stopStepping. (pages at: pageIndex) position: currentPage position. ^(TransitionMorph effect: tSpec second direction: tSpec third inverse: (ascending or: [transitionSpec notNil]) not) showTransitionFrom: currentPage to: (pages at: pageIndex) in: self whenStart: [self playPageFlipSound: tSpec first] whenDone: [currentPage delete; fullReleaseCachedState. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]. (aWorld := self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrlInBook: self url. currentPage sqkPage computeThumbnail "just store it"]]]. "No transition, but at least decommission current page" currentPage delete; fullReleaseCachedState]. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]. (aWorld := self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrl. currentPage sqkPage computeThumbnail "just store it"]! ! !BookMorph methodsFor: 'navigation' stamp: 'sw 11/8/2002 13:07'! goToPageMorph: newPage transitionSpec: transitionSpec runTransitionScripts: aBoolean "Install the given page as the new current page; use the given transition spec, and if the boolean parameter is true, run closing and opening scripts on the outgoing and incoming players" | pageIndex aWorld oldPageIndex ascending tSpec readIn | pages isEmpty ifTrue: [^ self]. self setProperty: #searchContainer toValue: nil. "forget previous search" self setProperty: #searchOffset toValue: nil. self setProperty: #searchKey toValue: nil. pageIndex _ pages identityIndexOf: newPage ifAbsent: [^ self "abort"]. readIn _ newPage isInMemory not. oldPageIndex _ pages identityIndexOf: currentPage ifAbsent: [nil]. ascending _ ((oldPageIndex == nil) or: [newPage == currentPage]) ifTrue: [nil] ifFalse: [oldPageIndex < pageIndex]. tSpec _ transitionSpec ifNil: "If transition not specified by requestor..." [newPage valueOfProperty: #transitionSpec " ... then consult new page" ifAbsent: [self transitionSpecFor: self " ... otherwise this is the default"]]. self flag: #arNote. "Probably unnecessary" (aWorld _ self world) ifNotNil: [self primaryHand releaseKeyboardFocus]. currentPage ifNotNil: [currentPage updateCachedThumbnail]. self currentPage ~~ nil ifTrue: [(((pages at: pageIndex) owner isKindOf: TransitionMorph) and: [(pages at: pageIndex) isInWorld]) ifTrue: [^ self "In the process of a prior pageTurn"]. aBoolean ifTrue: [self currentPlayerDo: [:aPlayer | aPlayer runAllClosingScripts]]. ascending ifNotNil: ["Show appropriate page transition and start new page when done" currentPage stopStepping. (pages at: pageIndex) position: currentPage position. ^ (TransitionMorph effect: tSpec second direction: tSpec third inverse: (ascending or: [transitionSpec notNil]) not) showTransitionFrom: currentPage to: (pages at: pageIndex) in: self whenStart: [self playPageFlipSound: tSpec first] whenDone: [currentPage delete; fullReleaseCachedState. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. aBoolean ifTrue: [self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]]. (aWorld _ self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrlInBook: self url. currentPage sqkPage computeThumbnail]. "just store it" ]]. "No transition, but at least decommission current page" currentPage delete; fullReleaseCachedState]. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]. (aWorld _ self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrl. currentPage sqkPage computeThumbnail]. "just store it" ! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/22/2003 18:49' prior: 34179268! goToPageMorph: newPage transitionSpec: transitionSpec runTransitionScripts: aBoolean "Install the given page as the new current page; use the given transition spec, and if the boolean parameter is true, run closing and opening scripts on the outgoing and incoming players" | pageIndex aWorld oldPageIndex ascending tSpec readIn | pages isEmpty ifTrue: [^self]. self setProperty: #searchContainer toValue: nil. "forget previous search" self setProperty: #searchOffset toValue: nil. self setProperty: #searchKey toValue: nil. pageIndex := pages identityIndexOf: newPage ifAbsent: [^self "abort"]. readIn := newPage isInMemory not. oldPageIndex := pages identityIndexOf: currentPage ifAbsent: [nil]. ascending := (oldPageIndex isNil or: [newPage == currentPage]) ifTrue: [nil] ifFalse: [oldPageIndex < pageIndex]. tSpec := transitionSpec ifNil: ["If transition not specified by requestor..." newPage valueOfProperty: #transitionSpec ifAbsent: [" ... then consult new page" self transitionSpecFor: self " ... otherwise this is the default"]]. self flag: #arNote. "Probably unnecessary" (aWorld := self world) ifNotNil: [self primaryHand releaseKeyboardFocus]. currentPage ifNotNil: [currentPage updateCachedThumbnail]. self currentPage notNil ifTrue: [(((pages at: pageIndex) owner isKindOf: TransitionMorph) and: [(pages at: pageIndex) isInWorld]) ifTrue: [^self "In the process of a prior pageTurn"]. aBoolean ifTrue: [self currentPlayerDo: [:aPlayer | aPlayer runAllClosingScripts]]. ascending ifNotNil: ["Show appropriate page transition and start new page when done" currentPage stopStepping. (pages at: pageIndex) position: currentPage position. ^(TransitionMorph effect: tSpec second direction: tSpec third inverse: (ascending or: [transitionSpec notNil]) not) showTransitionFrom: currentPage to: (pages at: pageIndex) in: self whenStart: [self playPageFlipSound: tSpec first] whenDone: [currentPage delete; fullReleaseCachedState. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. aBoolean ifTrue: [self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]]. (aWorld := self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrlInBook: self url. currentPage sqkPage computeThumbnail "just store it"]]]. "No transition, but at least decommission current page" currentPage delete; fullReleaseCachedState]. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]. (aWorld := self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrl. currentPage sqkPage computeThumbnail "just store it"]! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/21/2003 23:10' prior: 18455200! goToPageUrl: aUrl | pp short | pp := pages detect: [:pg | pg url = aUrl] ifNone: [nil]. pp ifNil: [short := (aUrl findTokens: '/') last. pp := pages detect: [:pg | pg url ifNil: [false] ifNotNil: [(pg url findTokens: '/') last = short] "it moved"] ifNone: [pages first]]. self goToPageMorph: pp! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/21/2003 23:11' prior: 18455968! nextPage currentPage isNil ifTrue: [^self goToPage: 1]. self goToPage: (self pageNumberOf: currentPage) + 1! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/21/2003 23:11' prior: 18456268! previousPage currentPage isNil ifTrue: [^self goToPage: 1]. self goToPage: (self pageNumberOf: currentPage) - 1! ! !BookMorph methodsFor: 'other' stamp: 'sw 6/6/2003 13:55' prior: 18492236! adjustCurrentPageForFullScreen "Adjust current page to conform to whether or not I am in full-screen mode. Also, enforce uniform page size constraint if appropriate" self isInFullScreenMode ifTrue: [(currentPage hasProperty: #sizeWhenNotFullScreen) ifFalse: [currentPage setProperty: #sizeWhenNotFullScreen toValue: currentPage extent]. currentPage extent: Display extent] ifFalse: [(currentPage hasProperty: #sizeWhenNotFullScreen) ifTrue: [currentPage extent: (currentPage valueOfProperty: #sizeWhenNotFullScreen). currentPage removeProperty: #sizeWhenNotFullScreen]. self uniformPageSize ifNotNilDo: [:anExtent | currentPage extent: anExtent]]. (self valueOfProperty: #floatingPageControls) ifNotNilDo: [:pc | pc isInWorld ifFalse: [pc openInWorld]]! ! !BookMorph methodsFor: 'other' stamp: 'tk 2/19/2001 18:35'! makeMinimalControlsWithColor: aColor title: aString | aButton aColumn aRow but | aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor; borderWidth: 0. aColumn _ AlignmentMorph newColumn. aColumn color: aButton color; borderWidth: 0; layoutInset: 0. aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. aRow _ AlignmentMorph newRow. aRow color: aButton color; borderWidth: 0; layoutInset: 0. aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. aRow addTransparentSpacerOfSize: 40@0. aRow addMorphBack: (but _ aButton label: ' < ' ; actionSelector: #previousPage). "copy is OK, since we just made it and it can't own any Players" but setBalloonText: 'Go to previous page'. aRow addTransparentSpacerOfSize: 82@0. aRow addMorphBack: (StringMorph contents: aString) lock. aRow addTransparentSpacerOfSize: 82@0. aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor; borderWidth: 0. aRow addMorphBack: (but _ aButton label: ' > ' ; actionSelector: #nextPage). but setBalloonText: 'Go to next page'. aRow addTransparentSpacerOfSize: 40@0. aColumn addMorphBack: aRow. aColumn setNameTo: 'Page Controls'. ^ aColumn! ! !BookMorph methodsFor: 'other' stamp: 'sw 6/6/2003 17:21'! setExtentFromHalo: anExtent "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed. For a BookMorph, we assume any resizing attempt is a request that the book-page currently being viewed be resized accoringly; this will typically not affect unseen book pages, though there is a command that can be issued to harmonize all book-page sizes, and also an option to set that will maintain all pages at the same size no matter what." currentPage isInWorld ifFalse: "doubtful case mostly" [super setExtentFromHalo: anExtent] ifTrue: [currentPage width: anExtent x. currentPage height: (anExtent y - (self innerBounds height - currentPage height)). self maintainsUniformPageSize ifTrue: [self setProperty: #uniformPageSize toValue: currentPage extent]]! ! !BookMorph methodsFor: 'parts bin' stamp: 'sw 8/2/2001 16:52'! initializeToStandAlone self initialize. self removeEverything; pageSize: 360@228; color: (Color gray: 0.9). self borderWidth: 1; borderColor: Color black. self beSticky. self showPageControls; insertPage. ^ self! ! !BookMorph methodsFor: 'printing' stamp: 'dgd 2/21/2003 23:11' prior: 18496535! printPSToFile "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName := 'MyBook' asFileName. fileName := FillInTheBlank request: 'File name? (".ps" will be added to end)' initialAnswer: fileName. fileName isEmpty ifTrue: [^self beep]. (fileName endsWith: '.ps') ifFalse: [fileName := fileName , '.ps']. rotateFlag := ((PopUpMenu labels: 'portrait (tall) landscape (wide)') startUpWithCaption: 'Choose orientation...') = 2. (FileStream newFileNamed: fileName) nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close! ! !BookMorph methodsFor: 'printing' stamp: 'md 10/22/2003 16:10' prior: 34189992! printPSToFile "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName := 'MyBook' asFileName. fileName := FillInTheBlank request: 'File name? (".ps" will be added to end)' initialAnswer: fileName. fileName isEmpty ifTrue: [^Beeper beep]. (fileName endsWith: '.ps') ifFalse: [fileName := fileName , '.ps']. rotateFlag := ((PopUpMenu labels: 'portrait (tall) landscape (wide)') startUpWithCaption: 'Choose orientation...') = 2. (FileStream newFileNamed: fileName) nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close! ! !BookMorph methodsFor: 'printing' stamp: 'sd 11/13/2003 21:04' prior: 34190691! printPSToFile "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName _ ('MyBook') translated asFileName. fileName _ FillInTheBlank request: 'File name? (".ps" will be added to end)' translated initialAnswer: fileName. fileName isEmpty ifTrue: [^ Beeper beep]. (fileName endsWith: '.ps') ifFalse: [fileName _ fileName,'.ps']. rotateFlag _ ((PopUpMenu labels: 'portrait (tall) landscape (wide)') translated startUpWithCaption: 'Choose orientation...' translated) = 2. (FileStream newFileNamed: fileName) nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close. ! ! !BookMorph methodsFor: 'printing' stamp: 'nk 12/30/2003 16:40' prior: 34191392! printPSToFile "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName _ ('MyBook') translated asFileName. fileName _ FillInTheBlank request: 'File name? (".ps" will be added to end)' translated initialAnswer: fileName. fileName isEmpty ifTrue: [^ Beeper beep]. (fileName endsWith: '.ps') ifFalse: [fileName _ fileName,'.ps']. rotateFlag _ ((PopUpMenu labels: 'portrait (tall) landscape (wide)' translated) startUpWithCaption: 'Choose orientation...' translated) = 2. (FileStream newFileNamed: fileName) nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close. ! ! !BookMorph methodsFor: 'sorting' stamp: 'dgd 2/21/2003 23:09' prior: 18442227! acceptSortedContentsFrom: aHolder "Update my page list from the given page sorter." | goodPages rejects toAdd sqPage | goodPages := OrderedCollection new. rejects := OrderedCollection new. aHolder submorphs doWithIndex: [:m :i | toAdd := nil. (m isKindOf: PasteUpMorph) ifTrue: [toAdd := m]. (m isKindOf: BookPageThumbnailMorph) ifTrue: [toAdd := m page. m bookMorph == self ifFalse: ["borrowed from another book. preserve the original" toAdd := toAdd veryDeepCopy. "since we came from elsewhere, cached strings are wrong" self removeProperty: #allTextUrls. self removeProperty: #allText]]. toAdd class == String ifTrue: ["a url" toAdd := pages detect: [:aPage | aPage url = toAdd] ifNone: [toAdd]]. toAdd class == String ifTrue: [sqPage := SqueakPageCache atURL: toAdd. toAdd := sqPage contentsMorph ifNil: [sqPage copyForSaving "a MorphObjectOut"] ifNotNil: [sqPage contentsMorph]]. toAdd ifNil: [rejects add: m] ifNotNil: [goodPages add: toAdd]]. self newPages: goodPages. goodPages isEmpty ifTrue: [self insertPage]. rejects notEmpty ifTrue: [self inform: rejects size printString , ' objects vanished in this process.']! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 3/3/2004 18:39'! keepingUniformPageSizeString "Answer a string characterizing whether I am currently maintaining uniform page size" ^ (self maintainsUniformPageSize ifTrue: [''] ifFalse: ['']), 'keep all pages the same size' translated! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:56'! maintainsUniformPageSize "Answer whether I am currently set up to maintain uniform page size" ^ self uniformPageSize notNil! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:56'! maintainsUniformPageSize: aBoolean "Set the property governing whether I maintain uniform page size" aBoolean ifFalse: [self removeProperty: #uniformPageSize] ifTrue: [self setProperty: #uniformPageSize toValue: currentPage extent]! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:57'! toggleMaintainUniformPageSize "Toggle whether or not the receiver should maintain uniform page size" self maintainsUniformPageSize: self maintainsUniformPageSize not! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:57'! uniformPageSize "Answer the uniform page size to maintain, or nil if the option is not set" ^ self valueOfProperty: #uniformPageSize ifAbsent: [nil]! ! !BookMorph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 17:37'! initialize FileList registerFileReader: self! ! !BookMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:31' prior: 34195557! initialize FileList registerFileReader: self. self registerInFlapsRegistry. ! ! !BookMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:37'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(BookMorph nextPageButton 'NextPage' 'A button that takes you to the next page') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(BookMorph previousPageButton 'PreviousPage' 'A button that takes you to the previous page') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(BookMorph authoringPrototype 'Book' 'A multi-paged structure') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(BookMorph nextPageButton 'NextPage' 'A button that takes you to the next page') forFlapNamed: 'Supplies'. cl registerQuad: #(BookMorph previousPageButton 'PreviousPage' 'A button that takes you to the previous page') forFlapNamed: 'Supplies'. cl registerQuad: #(BookMorph authoringPrototype 'Book' 'A multi-paged structure') forFlapNamed: 'Supplies']! ! !BookMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:28'! fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'bo') | (suffix = '*') ifTrue: [ Array with: self serviceLoadAsBook] ifFalse: [#()] ! ! !BookMorph class methodsFor: 'fileIn/Out' stamp: 'LEG 10/25/2001 00:06'! openFromFile: fullName "Reconstitute a Morph from the selected file, presumed to be represent a Morph saved via the SmartRefStream mechanism, and open it in an appropriate Morphic world" | book aFileStream | Smalltalk verifyMorphicAvailability ifFalse: [^ self]. aFileStream _ FileStream oldFileNamed: fullName. book _ BookMorph new. book setProperty: #url toValue: aFileStream url. book fromRemoteStream: aFileStream. aFileStream close. Smalltalk isMorphic ifTrue: [ActiveWorld addMorphsAndModel: book] ifFalse: [book isMorph ifFalse: [^self inform: 'Can only load a single morph into an mvc project via this mechanism.']. book openInWorld]. book goToPage: 1! ! !BookMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:33'! serviceLoadAsBook ^ SimpleServiceEntry provider: self label: 'load as book' selector: #openFromFile: description: 'open as bookmorph'! ! !BookMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:33'! services ^ Array with: self serviceLoadAsBook! ! !BookMorph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:20'! unload FileList unregisterFileReader: self ! ! !BookMorph class methodsFor: 'initialize-release' stamp: 'asm 4/11/2003 12:31' prior: 34198270! unload "Unload the receiver from global registries" self environment at: #FileList ifPresent: [:cl | cl unregisterFileReader: self]. self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self]! ! !BookMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:20'! descriptionForPartsBin ^ self partName: 'Book' categories: #('Presentation') documentation: 'Multi-page structures'! ! !BookMorph class methodsFor: 'scripting' stamp: 'sw 11/7/2002 13:20'! additionsToViewerCategories "Answer a list of ( ) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #((#'book navigation' ((command goto: 'go to the given page' Player) (command nextPage 'go to next page') (command previousPage 'go to previous page') (command firstPage 'go to first page') (command lastPage 'go to last page') (slot pageNumber 'The ordinal number of the current page' Number readWrite Player getPageNumber Player setPageNumber:))))! ! !BookMorph class methodsFor: 'scripting' stamp: 'sw 6/13/2001 17:14'! nextPageButton "Answer a button that will take the user to the next page of its enclosing book" | aButton | aButton _ SimpleButtonMorph new. aButton target: aButton; actionSelector: #nextOwnerPage; label: '->'; color: Color yellow. aButton setNameTo: 'next'. ^ aButton! ! !BookMorph class methodsFor: 'scripting' stamp: 'sw 6/13/2001 17:13'! previousPageButton "Answer a button that will take the user to the previous page of its enclosing book" | aButton | aButton _ SimpleButtonMorph new. aButton target: aButton; actionSelector: #previousOwnerPage; color: Color yellow; label: '<-'. aButton setNameTo: 'previous'. ^ aButton! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/19/2001 18:27'! addControls | bb r aButton str | r _ AlignmentMorph newRow color: Color transparent; borderWidth: 0; layoutInset: 0. r wrapCentering: #center; cellPositioning: #topCenter; hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. bb _ SimpleButtonMorph new target: self; borderColor: Color black. r addMorphBack: (self wrapperFor: (bb label: 'Okay'; actionSelector: #acceptSort)). bb _ SimpleButtonMorph new target: self; borderColor: Color black. r addMorphBack: (self wrapperFor: (bb label: 'Cancel'; actionSelector: #delete)). r addTransparentSpacerOfSize: 8 @ 0. r addMorphBack: (self wrapperFor: (aButton _ UpdatingThreePhaseButtonMorph checkBox)). aButton target: self; actionSelector: #togglePartsBinStatus; arguments: #(); getSelector: #getPartsBinStatus. str _ StringMorph contents: 'Parts bin'. r addMorphBack: (self wrapperFor: str lock). self addMorphFront: r. ! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/26/2003 13:21' prior: 34200278! addControls | bb r aButton str | r _ AlignmentMorph newRow color: Color transparent; borderWidth: 0; layoutInset: 0. r wrapCentering: #center; cellPositioning: #topCenter; hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. bb _ SimpleButtonMorph new target: self; borderColor: Color black. r addMorphBack: (self wrapperFor: (bb label: 'Okay' translated; actionSelector: #acceptSort)). bb _ SimpleButtonMorph new target: self; borderColor: Color black. r addMorphBack: (self wrapperFor: (bb label: 'Cancel' translated; actionSelector: #delete)). r addTransparentSpacerOfSize: 8 @ 0. r addMorphBack: (self wrapperFor: (aButton _ UpdatingThreePhaseButtonMorph checkBox)). aButton target: self; actionSelector: #togglePartsBinStatus; arguments: #(); getSelector: #getPartsBinStatus. str _ StringMorph contents: 'Parts bin' translated. r addMorphBack: (self wrapperFor: str lock). self addMorphFront: r. ! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/17/2003 19:56' prior: 18505568! changeExtent: aPoint self extent: aPoint. pageHolder extent: self extent - self borderWidth! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/14/2001 13:38'! closeButtonOnly "Replace my default control panel with one that has only a close button." | b r | self firstSubmorph delete. "remove old control panel" b _ SimpleButtonMorph new target: self; borderColor: Color black. r _ AlignmentMorph newRow. r color: b color; borderWidth: 0; layoutInset: 0. r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. r wrapCentering: #topLeft. r addMorphBack: (b label: 'Close'; actionSelector: #delete). self addMorphFront: r. ! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/26/2003 13:22' prior: 34202515! closeButtonOnly "Replace my default control panel with one that has only a close button." | b r | self firstSubmorph delete. "remove old control panel" b _ SimpleButtonMorph new target: self; borderColor: Color black. r _ AlignmentMorph newRow. r color: b color; borderWidth: 0; layoutInset: 0. r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. r wrapCentering: #topLeft. r addMorphBack: (b label: 'Close' translated; actionSelector: #delete). self addMorphFront: r. ! ! !BookPageSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:55'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !BookPageSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:55'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightGray! ! !BookPageSorterMorph methodsFor: 'initialization' stamp: 'RAA 5/25/2001 17:58'! initialize super initialize. self extent: Display extent - 100; listDirection: #topToBottom; wrapCentering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 3; color: Color lightGray; borderWidth: 2. pageHolder _ PasteUpMorph new behaveLikeHolder extent: self extent - borderWidth. pageHolder hResizing: #shrinkWrap. "pageHolder cursor: 0." "causes a walkback as of 5/25/2000" self addControls. self addMorphBack: pageHolder. ! ! !BookPageSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:56' prior: 34204010! initialize "initialize the state of the receiver" super initialize. "" self extent: Display extent - 100; listDirection: #topToBottom; wrapCentering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 3. pageHolder _ PasteUpMorph new behaveLikeHolder extent: self extent -self borderWidth. pageHolder hResizing: #shrinkWrap. "pageHolder cursor: 0." "causes a walkback as of 5/25/2000" self addControls. self addMorphBack: pageHolder! ! !BookPageThumbnailMorph methodsFor: 'event handling' stamp: 'tk 7/25/2001 18:09'! mouseDown: event "turn the book to that page" "May need to lie to it so mouseUp won't go to menu that may come up during fetch of a page in doPageFlip. (Is this really true? --tk)" self doPageFlip. ! ! !BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'dgd 2/21/2003 23:07' prior: 18508964! objectForDataStream: refStrm "I am about to be written on an object file. It would be bad to write a whole BookMorph out. Store a string that is the url of the book or page in my inst var." | clone bookUrl bb stem ind | bookMorph class == String & (page class == String) ifTrue: [^super objectForDataStream: refStrm]. bookMorph isNil & (page class == String) ifTrue: [^super objectForDataStream: refStrm]. bookMorph isNil & (page url notNil) ifTrue: [^super objectForDataStream: refStrm]. bookMorph isNil & page url isNil ifTrue: [self error: 'page should already have a url' "find page's book, and remember it" "bookMorph _ "]. clone := self clone. (bookUrl := bookMorph url) ifNil: [bookUrl := self valueOfProperty: #futureUrl]. bookUrl ifNil: [bb := RectangleMorph new. "write out a dummy" bb bounds: bounds. refStrm replace: self with: bb. ^bb] ifNotNil: [clone instVarNamed: 'bookMorph' put: bookUrl]. page url ifNil: ["Need to assign a url to a page that will be written later. It might have bookmarks too. Don't want to recurse deeply. Have that page write out a dummy morph to save its url on the server." stem := SqueakPage stemUrl: bookUrl. ind := bookMorph pages identityIndexOf: page. page reserveUrl: stem , ind printString , '.sp']. clone instVarNamed: 'page' put: page url. refStrm replace: self with: clone. ^clone! ! !BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'dgd 10/26/2003 13:23' prior: 34205450! objectForDataStream: refStrm "I am about to be written on an object file. It would be bad to write a whole BookMorph out. Store a string that is the url of the book or page in my inst var." | clone bookUrl bb stem ind | (bookMorph class == String) & (page class == String) ifTrue: [ ^ super objectForDataStream: refStrm]. (bookMorph isNil) & (page class == String) ifTrue: [ ^ super objectForDataStream: refStrm]. (bookMorph isNil) & (page url notNil) ifTrue: [ ^ super objectForDataStream: refStrm]. (bookMorph isNil) & (page url isNil) ifTrue: [ self error: 'page should already have a url' translated. "find page's book, and remember it" "bookMorph _ "]. clone _ self clone. (bookUrl _ bookMorph url) ifNil: [bookUrl _ self valueOfProperty: #futureUrl]. bookUrl ifNil: [ bb _ RectangleMorph new. "write out a dummy" bb bounds: bounds. refStrm replace: self with: bb. ^ bb] ifNotNil: [clone instVarNamed: 'bookMorph' put: bookUrl]. page url ifNil: [ "Need to assign a url to a page that will be written later. It might have bookmarks too. Don't want to recurse deeply. Have that page write out a dummy morph to save its url on the server." stem _ SqueakPage stemUrl: bookUrl. ind _ bookMorph pages identityIndexOf: page. page reserveUrl: stem,(ind printString),'.sp']. clone instVarNamed: 'page' put: page url. refStrm replace: self with: clone. ^ clone! ! !BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'dgd 2/21/2003 23:07' prior: 18510460! objectsInMemory "See if page or bookMorph need to be brought in from a server." | bookUrl bk wld try | bookMorph ifNil: ["fetch the page" page class == String ifFalse: [^self]. "a morph" try := (SqueakPageCache atURL: page) fetchContents. try ifNotNil: [page := try]. ^self]. bookMorph class == String ifTrue: [bookUrl := bookMorph. (wld := self world) ifNil: [wld := Smalltalk currentWorld]. bk := BookMorph isInWorld: wld withUrl: bookUrl. bk == #conflict ifTrue: [^self inform: 'This book is already open in some other project']. bk == #out ifTrue: [(bk := BookMorph new fromURL: bookUrl) ifNil: [^self]]. bookMorph := bk]. page class == String ifTrue: [page := bookMorph pages detect: [:pg | pg url = page] ifNone: [bookMorph pages first]]! ! !BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'dgd 10/26/2003 13:23' prior: 34208481! objectsInMemory "See if page or bookMorph need to be brought in from a server." | bookUrl bk wld try | bookMorph ifNil: ["fetch the page" page class == String ifFalse: [^ self]. "a morph" try _ (SqueakPageCache atURL: page) fetchContents. try ifNotNil: [page _ try]. ^ self]. bookMorph class == String ifTrue: [ bookUrl _ bookMorph. (wld _ self world) ifNil: [wld _ Smalltalk currentWorld]. bk _ BookMorph isInWorld: wld withUrl: bookUrl. bk == #conflict ifTrue: [ ^ self inform: 'This book is already open in some other project' translated]. bk == #out ifTrue: [ (bk _ BookMorph new fromURL: bookUrl) ifNil: [^ self]]. bookMorph _ bk]. page class == String ifTrue: [ page _ (bookMorph pages detect: [:pg | pg url = page] ifNone: [bookMorph pages first])]. ! ! !BookPageThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightGray! ! !BookPageThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:53' prior: 18514735! initialize "initialize the state of the receiver" | f | super initialize. "" flipOnClick _ false. f _ Form extent: 60 @ 80 depth: Display depth. f fill: f boundingBox fillColor: color. self form: f! ! !BookPageThumbnailMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:57' prior: 18512334! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'make a flex morph' translated selector: #makeFlexMorphFor: argument: aHandMorph. flipOnClick ifTrue: [aCustomMenu add: 'disable bookmark action' translated action: #toggleBookmark] ifFalse: [aCustomMenu add: 'enable bookmark action' translated action: #toggleBookmark]. (bookMorph isKindOf: BookMorph) ifTrue: [aCustomMenu add: 'set page sound' translated action: #setPageSound:. aCustomMenu add: 'set page visual' translated action: #setPageVisual:] ! ! !BooklikeMorph methodsFor: 'misc' stamp: 'dgd 8/30/2003 21:13' prior: 18523107! addBookMenuItemsTo: aCustomMenu hand: aHandMorph (self hasSubmorphWithProperty: #pageControl) ifTrue: [aCustomMenu add: 'hide page controls' translated action: #hidePageControls] ifFalse: [aCustomMenu add: 'show page controls' translated action: #showPageControls]! ! !BooklikeMorph methodsFor: 'misc' stamp: 'gk 2/24/2004 08:27' prior: 18523990! playPageFlipSound: soundName self presenter ifNil: [^ self]. "Avoid failures when called too early" PageFlipSoundOn "mechanism to suppress sounds at init time" ifTrue: [self playSoundNamed: soundName]. ! ! !BooklikeMorph methodsFor: 'misc' stamp: 'dgd 9/19/2003 11:04' prior: 18524325! showingFullScreenString ^ (self isInFullScreenMode ifTrue: ['exit full screen'] ifFalse: ['show full screen']) translated! ! !BooklikeMorph methodsFor: 'misc' stamp: 'dgd 9/19/2003 11:04' prior: 18524512! showingPageControlsString ^ (self pageControlsVisible ifTrue: ['hide page controls'] ifFalse: ['show page controls']) translated! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 14:10'! addPageControlMorph: aMorph "Add the morph provided as a page control, at the appropriate place" aMorph setProperty: #pageControl toValue: true. self addMorph: aMorph asElementNumber: self indexForPageControls! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'dgd 9/19/2003 11:34' prior: 18518227! fullControlSpecs ^ { #spacer. #variableSpacer. {'-'. #deletePage. 'Delete this page' translated}. #spacer. {'«'. #firstPage. 'First page' translated}. #spacer. {'<'. #previousPage. 'Previous page' translated}. #spacer. {'•'. #invokeBookMenu. 'Click here to get a menu of options for this book.' translated}. #spacer. {'>'. #nextPage. 'Next page' translated}. #spacer. { '»'. #lastPage. 'Final page' translated}. #spacer. {'+'. #insertPage. 'Add a new page after this one' translated}. #variableSpacer. {'³'. #fewerPageControls. 'Fewer controls' translated} } ! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 17:00'! indexForPageControls "Answer which submorph should hold the page controls" ^ (submorphs size > 0 and: [submorphs first hasProperty: #header]) ifTrue: [2] ifFalse: [1]! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'tk 2/19/2001 18:34'! makePageControlsFrom: controlSpecs "From the controlSpecs, create a set of page control and return them -- this method does *not* add the controls to the receiver." | c col row b lastGuy | c _ (color saturation > 0.1) ifTrue: [color slightlyLighter] ifFalse: [color slightlyDarker]. col _ AlignmentMorph newColumn. col color: c; borderWidth: 0; layoutInset: 0. col hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5. row _ AlignmentMorph newRow. row color: c; borderWidth: 0; layoutInset: 0. row hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5. controlSpecs do: [:spec | spec == #spacer ifTrue: [row addTransparentSpacerOfSize: (10 @ 0)] ifFalse: [spec == #variableSpacer ifTrue: [row addMorphBack: AlignmentMorph newVariableTransparentSpacer] ifFalse: [b _ SimpleButtonMorph new target: self; borderWidth: 1; borderColor: Color veryLightGray; color: c. b label: spec first; actionSelector: spec second; borderWidth: 0; setBalloonText: spec third. row addMorphBack: b. (((lastGuy _ spec last asLowercase) includesSubString: 'menu') or: [lastGuy includesSubString: 'designations']) ifTrue: [b actWhen: #buttonDown]]]]. "pop up menu on mouseDown" col addMorphBack: row. ^ col! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 22:44'! setEventHandlerForPageControls: controls "Set the controls' event handler if appropriate. Default is to let the tool be dragged by the controls" controls eventHandler: (EventHandler new on: #mouseDown send: #move to: self)! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'dgd 9/19/2003 11:35' prior: 18520394! shortControlSpecs ^ { #spacer. #variableSpacer. {'<'. #previousPage. 'Previous page' translated}. #spacer. {'•'. #invokeBookMenu. 'Click here to get a menu of options for this book.' translated}. #spacer. {'>'. #nextPage. 'Next page' translated}. #spacer. #variableSpacer. {'³'. #showMoreControls. 'More controls' translated} } ! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'dgd 2/22/2003 14:14' prior: 18520883! showPageControls: controlSpecs | spacer pageControls anIndex | self hidePageControls. anIndex := (submorphs notEmpty and: [submorphs first hasProperty: #header]) ifTrue: [2] ifFalse: [1]. spacer := (Morph new) color: color; extent: 0 @ 10. spacer setProperty: #pageControl toValue: true. self privateAddMorph: spacer atIndex: anIndex. pageControls := self makePageControlsFrom: controlSpecs. pageControls borderWidth: 0; layoutInset: 4. pageControls setProperty: #pageControl toValue: true. pageControls setNameTo: 'Page Controls'. pageControls eventHandler: (EventHandler new on: #mouseDown send: #move to: self). self privateAddMorph: pageControls beSticky atIndex: anIndex! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 13:58' prior: 34215962! showPageControls: controlSpecs "Remove any existing page controls, and add fresh controls at the top of the receiver (or in position 2 if the receiver's first submorph is one with property #header). Add a single column of controls." | pageControls column | self hidePageControls. column _ AlignmentMorph newColumn beTransparent. pageControls _ self makePageControlsFrom: controlSpecs. pageControls borderWidth: 0; layoutInset: 4. pageControls beSticky. pageControls setNameTo: 'Page Controls'. self setEventHandlerForPageControls: pageControls. column addMorphBack: pageControls. self addPageControlMorph: column! ! !Boolean methodsFor: 'logical operations' stamp: 'hg 1/2/2002 13:57'! ==> aBlock "this is logical implicature, a ==> b, also known as b iff a (if and only if)" ^self not or: [aBlock value]! ! !Boolean methodsFor: 'logical operations' stamp: 'PH 10/3/2003 08:10' prior: 34217490! ==> aBlock "this is material implication, a ==> b, also known as: b if a a implies b if a then b b is a consequence of a a therefore b (but note: 'it is raining therefore it is cloudy' is implication; 'it is autumn therefore the leaves are falling' is equivalence). Here is the truth table for material implication (view in a monospaced font): p | q | p ==> q -------|-------|------------- T | T | T T | F | F F | T | T F | F | T " ^self not or: [aBlock value]! ! !Boolean methodsFor: 'controlling' stamp: 'di 12/5/2001 10:50'! and: block1 and: block2 "Nonevaluating conjunction without deep nesting. The reciever is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44' prior: 34218331! and: block1 and: block2 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'di 12/5/2001 10:49'! and: block1 and: block2 and: block3 "Nonevaluating conjunction without deep nesting. The reciever is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. block3 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44' prior: 34219256! and: block1 and: block2 and: block3 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. block3 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'di 12/5/2001 10:49'! and: block1 and: block2 and: block3 and: block4 "Nonevaluating conjunction without deep nesting. The reciever is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. block3 value ifFalse: [^ false]. block4 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44' prior: 34220273! and: block1 and: block2 and: block3 and: block4 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. block3 value ifFalse: [^ false]. block4 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'di 12/5/2001 10:52'! or: block1 or: block2 "Nonevaluating alternation without deep nesting. The reciever is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45' prior: 34221382! or: block1 or: block2 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'di 12/5/2001 10:52'! or: block1 or: block2 or: block3 "Nonevaluating alternation without deep nesting. The reciever is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. block3 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45' prior: 34222293! or: block1 or: block2 or: block3 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. block3 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'di 12/5/2001 10:52'! or: block1 or: block2 or: block3 or: block4 "Nonevaluating alternation without deep nesting. The reciever is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. block3 value ifTrue: [^ true]. block4 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45' prior: 34223290! or: block1 or: block2 or: block3 or: block4 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. block3 value ifTrue: [^ true]. block4 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'printing' stamp: 'sw 9/27/2001 17:19'! basicType "Answer a symbol representing the inherent type of the receiver" ^ #Boolean! ! !BooleanScriptEditor methodsFor: 'dropping/grabbing' stamp: 'sw 6/3/2002 18:00'! wantsDroppedMorph: aMorph event: evt "Answer whether the receiver would be interested in accepting the morph" (submorphs detect: [:m | m isKindOf: AlignmentMorph] ifNone: [nil]) ifNotNil: [^ false]. ^ (aMorph isKindOf: PhraseTileMorph) and: [(#(Command Unknown) includes: aMorph resultType capitalized) not] ! ! !BooleanScriptEditor methodsFor: 'dropping/grabbing' stamp: 'gm 2/22/2003 13:14' prior: 34224544! wantsDroppedMorph: aMorph event: evt "Answer whether the receiver would be interested in accepting the morph" (submorphs detect: [:m | m isAlignmentMorph] ifNone: [nil]) ifNotNil: [^false]. ^(aMorph isKindOf: PhraseTileMorph) and: [(#(#Command #Unknown) includes: aMorph resultType capitalized) not]! ! !BooleanScriptEditor methodsFor: 'other' stamp: 'tk 3/1/2001 11:24'! hibernate "do nothing"! ! !BooleanScriptEditor methodsFor: 'other' stamp: 'dgd 2/22/2003 14:44' prior: 18531277! storeCodeOn: aStream indent: tabCount (submorphs notEmpty and: [submorphs first submorphs notEmpty]) ifTrue: [aStream nextPutAll: '(('. super storeCodeOn: aStream indent: tabCount. aStream nextPutAll: ') ~~ false)'. ^self]. aStream nextPutAll: ' true '! ! !BooleanScriptEditor methodsFor: 'other' stamp: 'tk 2/28/2001 21:07'! unhibernate "do nothing"! ! !BooleanTest methodsFor: 'testing-printing' stamp: 'md 3/5/2003 00:43'! testBasicType self should: [true basicType = #Boolean]. self should: [false basicType = #Boolean].! ! !BooleanTest methodsFor: 'testing' stamp: 'md 3/5/2003 00:29'! testBooleanInitializedInstance self should:[Boolean initializedInstance = nil].! ! !BooleanTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:52'! testBooleanNew self should: [Boolean new] raise: TestResult error. self should: [True new] raise: TestResult error. self should: [False new] raise: TestResult error. ! ! !BooleanTest methodsFor: 'testing' stamp: 'md 3/25/2003 23:09'! testNew self should: [Boolean new] raise: TestResult error. ! ! !BooleanTest methodsFor: 'testing-misc' stamp: 'md 3/6/2003 15:22'! testNewTileMorphRepresentative self should: [false newTileMorphRepresentative isKindOf: TileMorph]. self should: [false newTileMorphRepresentative literal = false]. self should: [true newTileMorphRepresentative literal = true].! ! !BooleanTest commentStamp: '' prior: 0! This is the unit test for the class Boolean. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category ! !BooleanTile methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:19'! resultType "Answer the result type of the receiver" ^ #Boolean! ! !BooleanType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:20'! defaultArgumentTile "Answer a tile to represent the type" ^ true newTileMorphRepresentative typeColor: self typeColor! ! !BooleanType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:20'! initialValueForASlotFor: aPlayer "Answer the value to give initially to a newly created slot of the given type in the given player" ^ true! ! !BooleanType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:23'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #Boolean! ! !BooleanType methodsFor: 'color' stamp: 'sw 9/27/2001 17:20'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(0.94 1.0 0.06)! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor ^Color transparent! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor: aColor "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color ^Color transparent! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color: aColor "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:22'! colorsAtCorners ^Array new: 4 withAll: self color! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! dotOfSize: diameter forDirection: aDirection | form | form _ Form extent: diameter@diameter depth: Display depth. form getCanvas fillOval: form boundingBox color: self color. ^form! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! style ^#none! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width ^0! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width: aNumber "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:08'! widthForRounding ^self width! ! !BorderStyle methodsFor: 'color tracking' stamp: 'ar 8/25/2001 17:29'! trackColorFrom: aMorph "If necessary, update our color to reflect a change in aMorphs color"! ! !BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 18:38'! = aBorderStyle ^self species = aBorderStyle species and:[self style == aBorderStyle style and:[self width = aBorderStyle width and:[self color = aBorderStyle color]]].! ! !BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 16:08'! hash "hash is implemented because #= is implemented" ^self species hash bitXor: (self width hash bitXor: self color hash)! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:01'! drawLineFrom: startPoint to: stopPoint on: aCanvas ^aCanvas line: startPoint to: stopPoint width: self width color: self color! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! frameOval: aRectangle on: aCanvas "Frame the given rectangle on aCanvas" aCanvas frameOval: aRectangle width: self width color: self color! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:57'! framePolygon: vertices on: aCanvas "Frame the given rectangle on aCanvas" self framePolyline: vertices on: aCanvas. self drawLineFrom: vertices last to: vertices first on: aCanvas.! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:05'! framePolyline: vertices on: aCanvas "Frame the given rectangle on aCanvas" | prev next | prev _ vertices at: 1. 2 to: vertices size do:[:i| next _ vertices at: i. self drawLineFrom: prev to: next on: aCanvas. prev _ next].! ! !BorderStyle methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:59' prior: 34230668! framePolyline: vertices on: aCanvas "Frame the given rectangle on aCanvas" | prev next | prev := vertices first. 2 to: vertices size do: [:i | next := vertices at: i. self drawLineFrom: prev to: next on: aCanvas. prev := next]! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! frameRectangle: aRectangle on: aCanvas "Frame the given rectangle on aCanvas" aCanvas frameRectangle: aRectangle width: self width color: self color! ! !BorderStyle methodsFor: 'initialize' stamp: 'ar 8/25/2001 16:06'! releaseCachedState "Release any associated cached state"! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/25/2001 16:08'! isBorderStyle ^true! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! isComplex ^false! ! !BorderStyle commentStamp: 'kfr 10/27/2003 10:19' prior: 0! See BorderedMorph BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.! !BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/26/2001 16:05'! borderStyleChoices "Answer the superset of all supported borderStyle symbols" ^ #(simple inset raised complexAltFramed complexAltInset complexAltRaised complexFramed complexInset complexRaised)! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/26/2001 15:58'! borderStyleForSymbol: sym "Answer a border style corresponding to the given symbol" | aSymbol | aSymbol _ sym == #none ifTrue: [#simple] ifFalse: [sym]. ^ self perform: aSymbol! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 23:52'! color: aColor width: aNumber ^self width: aNumber color: aColor! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! complexAltFramed ^ComplexBorder style: #complexAltFramed! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! complexAltInset ^ComplexBorder style: #complexAltInset! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexAltRaised ^ComplexBorder style: #complexAltRaised! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexFramed ^ComplexBorder style: #complexFramed! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexInset ^ComplexBorder style: #complexInset! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexRaised ^ComplexBorder style: #complexRaised! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 17:26'! default ^Default ifNil:[Default _ self new]! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! inset ^InsetBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! raised ^RaisedBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/27/2001 15:22'! simple "Answer a simple border style" ^ SimpleBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! width: aNumber ^self width: aNumber color: Color black! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! width: aNumber color: aColor ^SimpleBorder new color: aColor; width: aNumber; yourself! ! !BorderedMorph methodsFor: 'accessing' stamp: 'ar 8/17/2001 16:52'! borderColor: colorOrSymbolOrNil self doesBevels ifFalse:[ colorOrSymbolOrNil isColor ifFalse:[^self]]. borderColor = colorOrSymbolOrNil ifFalse: [ borderColor _ colorOrSymbolOrNil. self changed]. ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:04'! borderStyle "Work around the borderWidth/borderColor pair" | style | borderColor ifNil:[^BorderStyle default]. borderWidth isZero ifTrue:[^BorderStyle default]. style _ self valueOfProperty: #borderStyle ifAbsent:[BorderStyle default]. (borderWidth = style width and:[ "Hah!! Try understanding this..." borderColor == style style "#raised/#inset etc" or:[ #simple == style style and:[borderColor = style color]]]) ifFalse:[ borderColor isColor ifTrue:[style _ BorderStyle width: borderWidth color: borderColor] ifFalse:[style _ (BorderStyle perform: borderColor "argh.") width: borderWidth]. self setProperty: #borderStyle toValue: style. ]. ^style trackColorFrom: self! ! !BorderedMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:19' prior: 34234614! borderStyle "Work around the borderWidth/borderColor pair" | style | borderColor ifNil: [^BorderStyle default]. borderWidth isZero ifTrue: [^BorderStyle default]. style := self valueOfProperty: #borderStyle ifAbsent: [BorderStyle default]. (borderWidth = style width and: ["Hah!! Try understanding this..." borderColor == style style or: ["#raised/#inset etc" #simple == style style and: [borderColor = style color]]]) ifFalse: [style := borderColor isColor ifTrue: [BorderStyle width: borderWidth color: borderColor] ifFalse: [(BorderStyle perform: borderColor) width: borderWidth "argh."]. self setProperty: #borderStyle toValue: style]. ^style trackColorFrom: self! ! !BorderedMorph methodsFor: 'accessing' stamp: 'ar 12/11/2001 22:14'! borderStyle: aBorderStyle "Work around the borderWidth/borderColor pair" aBorderStyle = self borderStyle ifTrue:[^self]. "secure against invalid border styles" (self canDrawBorder: aBorderStyle) ifFalse:[ "Replace the suggested border with a simple one" ^self borderStyle: (BorderStyle width: aBorderStyle width color: (aBorderStyle trackColorFrom: self) color)]. aBorderStyle width = self borderStyle width ifFalse:[self changed]. (aBorderStyle == nil or:[aBorderStyle == BorderStyle default]) ifTrue:[ self removeProperty: #borderStyle. borderWidth _ 0. ^self changed]. self setProperty: #borderStyle toValue: aBorderStyle. borderWidth _ aBorderStyle width. aBorderStyle style == #simple ifTrue:[borderColor _ aBorderStyle color] ifFalse:[borderColor _ aBorderStyle style]. self changed. ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:42' prior: 34236186! borderStyle: aBorderStyle "Work around the borderWidth/borderColor pair" aBorderStyle = self borderStyle ifTrue: [^self]. "secure against invalid border styles" (self canDrawBorder: aBorderStyle) ifFalse: ["Replace the suggested border with a simple one" ^self borderStyle: (BorderStyle width: aBorderStyle width color: (aBorderStyle trackColorFrom: self) color)]. aBorderStyle width = self borderStyle width ifFalse: [self changed]. (aBorderStyle isNil or: [aBorderStyle == BorderStyle default]) ifTrue: [self removeProperty: #borderStyle. borderWidth := 0. ^self changed]. self setProperty: #borderStyle toValue: aBorderStyle. borderWidth := aBorderStyle width. borderColor := aBorderStyle style == #simple ifTrue: [aBorderStyle color] ifFalse: [aBorderStyle style]. self changed! ! !BorderedMorph methodsFor: 'drawing' stamp: 'dgd 2/17/2003 19:57' prior: 18535398! areasRemainingToFill: aRectangle (color isColor and: [color isTranslucent]) ifTrue: [^ Array with: aRectangle]. self wantsRoundedCorners ifTrue: [(self borderWidth > 0 and: [self borderColor isColor and: [self borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners)] ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]] ifFalse: [(self borderWidth > 0 and: [self borderColor isColor and: [self borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: self innerBounds] ifFalse: [^ aRectangle areasOutside: self bounds]]! ! !BorderedMorph methodsFor: 'geometry' stamp: 'sw 5/18/2001 22:52'! acquireBorderWidth: aBorderWidth "Gracefully acquire the new border width, keeping the interior area intact and not seeming to shift" | delta | (delta _ aBorderWidth- self borderWidth) == 0 ifTrue: [^ self]. self bounds: ((self bounds origin - (delta @ delta)) corner: (self bounds corner + (delta @ delta))). self borderWidth: aBorderWidth. self layoutChanged! ! !BorderedMorph methodsFor: 'initialization' stamp: 'sw 8/12/2001 02:11'! basicInitialize "Do basic generic initialization of the instance variables" super basicInitialize. borderColor _ Color black. borderWidth _ 2! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:00' prior: 34239188! basicInitialize "Do basic generic initialization of the instance variables" super basicInitialize. "" self borderInitialize! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:53'! borderInitialize "initialize the receiver state related to border" borderColor_ self defaultBorderColor. borderWidth _ self defaultBorderWidth! ]style[(16 2 49 15 4 22 11 3 4 19)f2b,f2,f2c148046000,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color black! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:07' prior: 18532829! initialize "initialize the state of the receiver" super initialize. "" self borderInitialize! ! !BorderedMorph methodsFor: 'menu' stamp: 'sw 11/27/2001 15:20'! addBorderStyleMenuItems: aMenu hand: aHandMorph "Add border-style menu items" | subMenu | subMenu _ MenuMorph new defaultTarget: self. subMenu addTitle: 'border'. subMenu addStayUpItemSpecial. subMenu addList: #(('border color...' changeBorderColor:) ('border width...' changeBorderWidth:)). subMenu addLine. BorderStyle borderStyleChoices do: [:sym | (self borderStyleForSymbol: sym) ifNotNil: [subMenu add: sym target: self selector: #setBorderStyle: argument: sym]]. aMenu add: 'border style...' subMenu: subMenu ! ! !BorderedMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:47' prior: 34240469! addBorderStyleMenuItems: aMenu hand: aHandMorph "Add border-style menu items" | subMenu | subMenu _ MenuMorph new defaultTarget: self. subMenu addTitle: 'border' translated. subMenu addStayUpItemSpecial. subMenu addList: {{'border color...' translated. #changeBorderColor:}. {'border width...' translated. #changeBorderWidth:}}. subMenu addLine. BorderStyle borderStyleChoices do: [:sym | (self borderStyleForSymbol: sym) ifNotNil: [subMenu add: sym target: self selector: #setBorderStyle: argument: sym]]. aMenu add: 'border style...' translated subMenu: subMenu ! ! !BorderedMorph methodsFor: 'menu' stamp: 'dgd 8/26/2003 21:44' prior: 18539060! changeBorderWidth: evt | handle origin aHand newWidth oldWidth | aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin _ aHand position. oldWidth _ borderWidth. handle _ HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. handle addMorph: (LineMorph from: origin to: newPoint color: Color black width: 1). newWidth _ (newPoint - origin) r asInteger // 5. self borderWidth: newWidth] lastPointDo: [:newPoint | handle deleteBalloon. self halo doIfNotNil: [:halo | halo addHandles]. self rememberCommand: (Command new cmdWording: 'border change' translated; undoTarget: self selector: #borderWidth: argument: oldWidth; redoTarget: self selector: #borderWidth: argument: newWidth)]. aHand attachMorph: handle. handle setProperty: #helpAtCenter toValue: true. handle showBalloon: 'Move cursor farther from this point to increase border width. Click when done.' hand: evt hand. handle startStepping! ! !BorderedMorph methodsFor: 'menu' stamp: 'md 12/12/2003 16:21' prior: 34241767! changeBorderWidth: evt | handle origin aHand newWidth oldWidth | aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin _ aHand position. oldWidth _ borderWidth. handle _ HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. handle addMorph: (LineMorph from: origin to: newPoint color: Color black width: 1). newWidth _ (newPoint - origin) r asInteger // 5. self borderWidth: newWidth] lastPointDo: [:newPoint | handle deleteBalloon. self halo ifNotNilDo: [:halo | halo addHandles]. self rememberCommand: (Command new cmdWording: 'border change' translated; undoTarget: self selector: #borderWidth: argument: oldWidth; redoTarget: self selector: #borderWidth: argument: newWidth)]. aHand attachMorph: handle. handle setProperty: #helpAtCenter toValue: true. handle showBalloon: 'Move cursor farther from this point to increase border width. Click when done.' hand: evt hand. handle startStepping! ! !BorderedMorph commentStamp: 'kfr 10/27/2003 11:17' prior: 0! BorderedMorph introduce borders to morph. Borders have the instanceVariables borderWidth and borderColor. BorderedMorph new borderColor: Color red; borderWidth: 10; openInWorld. BorderedMorph also have a varaity of border styles: simple, inset, raised, complexAltFramed, complexAltInset, complexAltRaised, complexFramed, complexInset, complexRaised. These styles are set using the classes BorderStyle, SimpleBorder, RaisedBorder, InsetBorder and ComplexBorder. BorderedMorph new borderStyle: (SimpleBorder width: 1 color: Color white); openInWorld. BorderedMorph new borderStyle: (BorderStyle inset width: 2); openInWorld. ! !BorderedStringMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 03:03'! measureContents ^super measureContents +2.! ! !BorderedStringMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:34'! drawOn: aCanvas | nameForm | font _ self fontToUse. nameForm _ Form extent: bounds extent depth: 8. nameForm getCanvas drawString: contents at: 0@0 font: self fontToUse color: Color black. (bounds origin + 1) eightNeighbors do: [ :pt | aCanvas stencil: nameForm at: pt color: self borderColor. ]. aCanvas stencil: nameForm at: bounds origin + 1 color: color. ! ! !BorderedStringMorph methodsFor: 'initialization' stamp: 'ar 12/14/2001 20:02'! initWithContents: aString font: aFont emphasis: emphasisCode super initWithContents: aString font: aFont emphasis: emphasisCode. self borderStyle: (SimpleBorder width: 1 color: Color white).! ! !BorderedStringMorph methodsFor: 'initialization' stamp: 'ar 12/12/2001 03:03'! initialize super initialize. self borderStyle: (SimpleBorder width: 1 color: Color white).! ! !BorderedStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42' prior: 34245446! initialize "initialize the state of the receiver" super initialize. "" self borderStyle: (SimpleBorder width: 1 color: Color white)! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! firstEnter: evt "The first time this divider is activated, find its window and redirect further interaction there." | window | window := self firstOwnerSuchThat: [:m | m respondsTo: #secondaryPaneTransition:divider:]. window ifNil: [ self suspendEventHandler. ^ self ]. "not working out" window secondaryPaneTransition: evt divider: self. self on: #mouseEnter send: #secondaryPaneTransition:divider: to: window. ! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! horizontal self hResizing: #spaceFill.! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! resizingEdge ^resizingEdge ! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! resizingEdge: edgeSymbol (#(top bottom) includes: edgeSymbol) ifFalse: [ self error: 'resizingEdge must be #top or #bottom' ]. resizingEdge := edgeSymbol. self on: #mouseEnter send: #firstEnter: to: self. ! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! vertical self vResizing: #spaceFill.! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! defaultColor "answer the default color/fill style for the receiver" ^ Color black! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'ar 8/15/2001 23:24'! initialize super initialize. self extent: 1@1; color: Color black; borderWidth: 0.! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09' prior: 34247428! initialize "initialize the state of the receiver" super initialize. "" self extent: 1 @ 1! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! forBottomEdge ^self new horizontal resizingEdge: #bottom! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! forTopEdge ^self new horizontal resizingEdge: #top! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! horizontal ^self new horizontal! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! vertical ^self new vertical! ! !BouncingAtomsMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:14'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.8! ! !BouncingAtomsMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:14' prior: 18541805! initialize "initialize the state of the receiver" super initialize. "" damageReported _ false. self extent: 400 @ 250. infectionHistory _ OrderedCollection new. transmitInfection _ false. self addAtoms: 30! ! !BouncingAtomsMorph methodsFor: 'initialization' stamp: 'ar 8/13/2003 11:41'! intoWorld: aWorld "Make sure report damage at least once" damageReported _ false. super intoWorld: aWorld.! ! !BouncingAtomsMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:15' prior: 18542093! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'startInfection' translated action: #startInfection. aCustomMenu add: 'set atom count' translated action: #setAtomCount. aCustomMenu add: 'show infection history' translated action: #showInfectionHistory:. ! ! !BouncingAtomsMorph methodsFor: 'other' stamp: 'aoy 2/15/2003 21:38' prior: 18544695! collisionPairs "Return a list of pairs of colliding atoms, which are assumed to be circles of known radius. This version uses the morph's positions--i.e. the top-left of their bounds rectangles--rather than their centers." | count sortedAtoms radius twoRadii radiiSquared collisions p1 continue j p2 distSquared m1 m2 | count := submorphs size. sortedAtoms := submorphs asSortedCollection: [:mt1 :mt2 | mt1 position x < mt2 position x]. radius := 8. twoRadii := 2 * radius. radiiSquared := radius squared * 2. collisions := OrderedCollection new. 1 to: count - 1 do: [:i | m1 := sortedAtoms at: i. p1 := m1 position. continue := (j := i + 1) <= count. [continue] whileTrue: [m2 := sortedAtoms at: j. p2 := m2 position. continue := p2 x - p1 x <= twoRadii ifTrue: [distSquared := (p1 x - p2 x) squared + (p1 y - p2 y) squared. distSquared < radiiSquared ifTrue: [collisions add: (Array with: m1 with: m2)]. (j := j + 1) <= count] ifFalse: [false]]]. ^collisions! ! !BouncingAtomsMorph methodsFor: 'other' stamp: 'dgd 2/22/2003 13:36' prior: 18547904! updateTemperature: currentTemperature "Record the current temperature, which is taken to be the number of atoms that have bounced in the last cycle. To avoid too much jitter in the reading, the last several readings are averaged." recentTemperatures isNil ifTrue: [recentTemperatures := OrderedCollection new. 20 timesRepeat: [recentTemperatures add: 0]]. recentTemperatures removeLast. recentTemperatures addFirst: currentTemperature. temperature := recentTemperatures sum asFloat / recentTemperatures size! ! !BouncingAtomsMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:21'! descriptionForPartsBin ^ self partName: 'BouncingAtoms' categories: #('Demo') documentation: 'The original, intensively-optimized bouncing-atoms simulation by John Maloney'! ! !BouncingAtomsMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:57'! initialize self registerInFlapsRegistry. ! ! !BouncingAtomsMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:58'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(BouncingAtomsMorph new 'Bouncing Atoms' 'Atoms, mate') forFlapNamed: 'Widgets']! ! !BouncingAtomsMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:32'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !BreakPoint commentStamp: 'md 11/18/2003 09:32' prior: 0! This exception is raised on executing a breakpoint. "BreakPoint signal" is called from "Object>>break".! !BreakpointManager commentStamp: 'emm 5/30/2002 14:20' prior: 0! This class manages methods that include breakpoints. It has several class methods to install and uninstall breakpoints. Evaluating "BreakpointManager clear" will remove all installed breakpoints in the system. Known issues: - currently, only break-on-entry type of breakpoints are supported - emphasis change not implemented for MVC browsers - uninstalling the breakpoint doesn't auto-update other browsers - uninstalling a breakpoint while debugging should restart-simulate the current method Ernest Micklei, 2002 Send comments to emicklei@philemonworks.com! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'emm 5/30/2002 09:37'! installInClass: aClass selector: aSymbol "Install a new method containing a breakpoint. The receiver will remember this for unstalling it later" | breakMethod | breakMethod _ self compilePrototype: aSymbol in: aClass. breakMethod isNil ifTrue: [^ nil]. self installed at: breakMethod put: aClass >> aSymbol. "old method" aClass methodDictionary at: aSymbol put: breakMethod.! ! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'emm 4/24/2002 23:24'! unInstall: breakMethod | who oldMethod | oldMethod _ self installed at: breakMethod ifAbsent:[^self]. who _ breakMethod who. (who first methodDictionary at: who last) == breakMethod ifTrue:[ who first methodDictionary at: who last put: oldMethod]. self installed removeKey: breakMethod! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:36'! breakpointMethodSourceFor: aSymbol in: aClass "Compose new source containing a break statement (currently it will be the first, later we want to insert it in any place)" | oldSource methodNode breakOnlyMethodNode sendBreakMessageNode | oldSource := aClass sourceCodeAt: aSymbol. methodNode := aClass compilerClass new compile: oldSource in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. breakOnlyMethodNode := aClass compilerClass new compile: 'temporaryMethodSelectorForBreakpoint self break. ^self' in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. sendBreakMessageNode := breakOnlyMethodNode block statements first. methodNode block statements addFirst: sendBreakMessageNode. ^methodNode printString ! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:33'! compilePrototype: aSymbol in: aClass "Compile and return a new method containing a break statement" | source node method | source := self breakpointMethodSourceFor: aSymbol in: aClass. node := aClass compilerClass new compile: source in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. node isNil ifTrue: [^nil]. "dunno what the arguments mean..." method := node generate: #(0 0 0 0). ^method! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 4/24/2002 23:24'! installed Installed isNil ifTrue:[Installed := IdentityDictionary new]. ^Installed! ! !BreakpointManager class methodsFor: 'intialization-release' stamp: 'emm 5/30/2002 09:08'! clear "BreakpointManager clear" self installed copy keysDo:[ :breakMethod | self unInstall: breakMethod]. ! ! !BreakpointManager class methodsFor: 'testing' stamp: 'emm 5/30/2002 09:22'! methodHasBreakpoint: aMethod ^self installed includesKey: aMethod! ! !BreakpointManager class methodsFor: 'examples' stamp: 'emm 5/30/2002 14:12'! testBreakpoint "In the menu of the methodList, click on -toggle break on entry- and evaluate the following:" "BreakpointManager testBreakpoint" Transcript cr; show: 'Breakpoint test'! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/6/2004 15:43'! testBrowseClass "self debug: #testBrowseClass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentBrowsers. 1 class browse. browsersAfter := self currentBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/11/2004 15:56'! testBrowseHierarchyClass "self debug: #testBrowseHierarchyClass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentHierarchyBrowsers. 1 class browseHierarchy. browsersAfter := self currentHierarchyBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/11/2004 15:52'! testBrowseHierarchyInstance "self debug: #testBrowseHierarchyInstance" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentHierarchyBrowsers. 1 browseHierarchy. browsersAfter := self currentHierarchyBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/11/2004 16:00'! testBrowseHierarchyMataclass "self debug: #testBrowseHierarchyMataclass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentHierarchyBrowsers. 1 class class browseHierarchy. browsersAfter := self currentHierarchyBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == Metaclass). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/6/2004 15:43'! testBrowseInstance "self debug: #testBrowseInstance" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentBrowsers. 1 browse. browsersAfter := self currentBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/6/2004 15:44'! testBrowseMetaclass "self debug: #testBrowseMetaclass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentBrowsers. 1 class class browse. browsersAfter := self currentBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == Metaclass). opened delete ! ! !BrowseTest methodsFor: 'private' stamp: 'mu 3/6/2004 15:41'! currentBrowsers ^ (ActiveWorld submorphs select: [:each | (each isKindOf: SystemWindow) and: [each model isKindOf: Browser]]) asSet! ! !BrowseTest methodsFor: 'private' stamp: 'mu 3/11/2004 15:52'! currentHierarchyBrowsers ^ (ActiveWorld submorphs select: [:each | (each isKindOf: SystemWindow) and: [each model isKindOf: HierarchyBrowser]]) asSet! ! !BrowseTest methodsFor: 'private' stamp: 'mu 3/6/2004 15:27'! ensureMorphic self isMorphic ifFalse: [self error: 'This test should be run in Morphic'].! ! !BrowseTest methodsFor: 'private' stamp: 'mu 3/6/2004 15:26'! isMorphic ^Smalltalk isMorphic! ! !BrowseTest methodsFor: 'running' stamp: 'mu 3/11/2004 15:57'! setUp | systemNavigation | systemNavigation := SystemNavigation default. originalBrowserClass := systemNavigation browserClass. originalHierarchyBrowserClass := systemNavigation hierarchyBrowserClass. systemNavigation browserClass: nil. systemNavigation hierarchyBrowserClass: nil. ! ! !BrowseTest methodsFor: 'running' stamp: 'mu 3/11/2004 15:57'! tearDown | systemNavigation | systemNavigation := SystemNavigation default. systemNavigation browserClass: originalBrowserClass. systemNavigation hierarchyBrowserClass: originalHierarchyBrowserClass.! ! !Browser methodsFor: 'accessing' stamp: 'sw 8/1/2002 14:20'! contents "Depending on the current selection, different information is retrieved. Answer a string description of that information. This information is the method of the currently selected class and message." | comment theClass latestCompiledMethod | latestCompiledMethod _ currentCompiledMethod. currentCompiledMethod _ nil. editSelection == #none ifTrue: [^ '']. editSelection == #editSystemCategories ifTrue: [^ systemOrganizer printString]. editSelection == #newClass ifTrue: [^ (theClass _ self selectedClass) ifNil: [Class template: self selectedSystemCategoryName] ifNotNil: [Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]]. editSelection == #editClass ifTrue: [^ (theClass _ self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass definitionST80: Preferences printAlternateSyntax not]]. editSelection == #editComment ifTrue: [(theClass _ self selectedClass) ifNil: [^ '']. comment _ theClass comment. currentCompiledMethod _ theClass organization commentRemoteStr. ^ comment size = 0 ifTrue: ['This class has not yet been commented.'] ifFalse: [comment]]. editSelection == #hierarchy ifTrue: [^ self selectedClassOrMetaClass printHierarchy]. editSelection == #editMessageCategories ifTrue: [^ self classOrMetaClassOrganizer printString]. editSelection == #newMessage ifTrue: [^ (theClass _ self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass sourceCodeTemplate]]. editSelection == #editMessage ifTrue: [self showingByteCodes ifTrue: [^ self selectedBytecodes]. currentCompiledMethod _ latestCompiledMethod. ^ self selectedMessage]. self error: 'Browser internal error: unknown edit selection.'! ! !Browser methodsFor: 'accessing' stamp: 'ls 10/28/2003 12:28' prior: 34260927! contents "Depending on the current selection, different information is retrieved. Answer a string description of that information. This information is the method of the currently selected class and message." | comment theClass latestCompiledMethod | latestCompiledMethod _ currentCompiledMethod. currentCompiledMethod _ nil. editSelection == #none ifTrue: [^ '']. editSelection == #editSystemCategories ifTrue: [^ systemOrganizer printString]. editSelection == #newClass ifTrue: [^ (theClass _ self selectedClass) ifNil: [Class template: self selectedSystemCategoryName] ifNotNil: [Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]]. editSelection == #editClass ifTrue: [^ self classDefinitionText ]. editSelection == #editComment ifTrue: [(theClass _ self selectedClass) ifNil: [^ '']. comment _ theClass comment. currentCompiledMethod _ theClass organization commentRemoteStr. ^ comment size = 0 ifTrue: ['This class has not yet been commented.'] ifFalse: [comment]]. editSelection == #hierarchy ifTrue: [^ self selectedClassOrMetaClass printHierarchy]. editSelection == #editMessageCategories ifTrue: [^ self classOrMetaClassOrganizer printString]. editSelection == #newMessage ifTrue: [^ (theClass _ self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass sourceCodeTemplate]]. editSelection == #editMessage ifTrue: [self showingByteCodes ifTrue: [^ self selectedBytecodes]. currentCompiledMethod _ latestCompiledMethod. ^ self selectedMessage]. self error: 'Browser internal error: unknown edit selection.'! ! !Browser methodsFor: 'accessing' stamp: 'sw 5/23/2001 12:37'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | self changed: #annotation. aString _ input asString. aText _ input asText. editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString]. editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController]. editSelection == #editComment ifTrue: [theClass _ self selectedClass. theClass ifNil: [self inform: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText stamp: Utilities changeStamp. ^ true]. editSelection == #hierarchy ifTrue: [^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. editSelection == #editMessage | (editSelection == #newMessage) ifTrue: [^ self okayToAccept ifFalse: [false] ifTrue: [self compileMessage: aText notifying: aController]]. editSelection == #none ifTrue: [self inform: 'This text cannot be accepted in this part of the browser.'. ^ false]. self error: 'unacceptable accept'! ! !Browser methodsFor: 'accessing' stamp: 'nk 3/29/2004 10:11' prior: 34264496! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | self changed: #annotation. aString _ input asString. aText _ input asText. editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString]. editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController]. editSelection == #editComment ifTrue: [theClass _ self selectedClass. theClass ifNil: [self inform: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText stamp: Utilities changeStamp. self changed: #classCommentText. ^ true]. editSelection == #hierarchy ifTrue: [^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. editSelection == #editMessage | (editSelection == #newMessage) ifTrue: [^ self okayToAccept ifFalse: [false] ifTrue: [self compileMessage: aText notifying: aController]]. editSelection == #none ifTrue: [self inform: 'This text cannot be accepted in this part of the browser.'. ^ false]. self error: 'unacceptable accept'! ! !Browser methodsFor: 'accessing' stamp: 'drs 1/6/2003 16:11' prior: 18557776! contentsSelection "Return the interval of text in the code pane to select when I set the pane's contents" messageCategoryListIndex > 0 & (messageListIndex = 0) ifTrue: [^ 1 to: 500] "entire empty method template" ifFalse: [^ 1 to: 0] "null selection"! ! !Browser methodsFor: 'accessing' stamp: 'nk 2/15/2004 13:27' prior: 18559030! editSelection: aSelection "Set the editSelection as requested." editSelection _ aSelection. self changed: #editSelection.! ! !Browser methodsFor: 'accessing' stamp: 'sw 9/26/2002 17:56'! suggestCategoryToSpawnedBrowser: aBrowser "aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up." (self isMemberOf: Browser) "yecch, but I didn't invent the browser hierarchy" ifTrue: [aBrowser messageCategoryListIndex: (self messageCategoryList indexOf: self categoryOfCurrentMethod ifAbsent: [2])] ifFalse: [aBrowser setOriginalCategoryIndexForCurrentMethod]! ! !Browser methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:00'! annotation "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." | aSelector aClass | (aClass _ self selectedClassOrMetaClass) == nil ifTrue: [^ '------']. self editSelection == #editComment ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. self editSelection == #editClass ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. (aSelector _ self selectedMessageName) ifNil: [^ '------']. ^ self annotationForSelector: aSelector ofClass: aClass! ! !Browser methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 09:23'! toggleBreakOnEntry "Install or uninstall a halt-on-entry breakpoint" | selectedMethod | self selectedClassOrMetaClass isNil ifTrue:[^self]. selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName. selectedMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: selectedMethod] ifFalse: [BreakpointManager installInClass: self selectedClassOrMetaClass selector: self selectedMessageName]. self changed: #messageList ! ! !Browser methodsFor: 'class comment pane' stamp: 'nk 2/15/2004 13:20'! buildMorphicCommentPane "Construct the pane that shows the class comment. Respect the Preference for standardCodeFont." | commentPane | commentPane := BrowserCommentTextMorph on: self text: #classCommentText accept: #classComment:notifying: readSelection: nil menu: #codePaneMenu:shifted:. commentPane font: Preferences standardCodeFont. ^ commentPane! ! !Browser methodsFor: 'class comment pane' stamp: 'nk 2/15/2004 13:19'! classComment: aText notifying: aPluggableTextMorph "The user has just entered aText. It may be all red (a side-effect of replacing the default comment), so remove the color if it is." | theClass cleanedText redRange | theClass := self selectedClassOrMetaClass. theClass ifNotNil: [cleanedText := aText asText. redRange := cleanedText rangeOf: TextColor red startingAt: 1. redRange size = cleanedText size ifTrue: [cleanedText removeAttribute: TextColor red from: 1 to: redRange last ]. theClass classComment: aText]. self changed: #classCommentText. ^ true! ! !Browser methodsFor: 'class functions' stamp: 'sd 5/23/2003 14:23' prior: 18560657! addAllMethodsToCurrentChangeSet "Add all the methods in the selected class or metaclass to the current change set. You ought to know what you're doing before you invoke this!!" | aClass | (aClass _ self selectedClassOrMetaClass) ifNotNil: [aClass selectors do: [:sel | ChangeSet current adoptSelector: sel forClass: aClass]. self changed: #annotation] ! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 14:32'! classCommentText "return the text to display for the comment of the currently selected class" | theClass | theClass _ self selectedClassOrMetaClass. theClass ifNil: [ ^'']. ^ theClass hasComment ifTrue: [ theClass comment ] ifFalse: [ Text string: 'THIS CLASS HAS NO COMMENT!!' translated attribute: TextColor red ]! ! !Browser methodsFor: 'class functions' stamp: 'ls 10/28/2003 12:34'! classDefinitionText "return the text to display for the definition of the currently selected class" | theClass | theClass _ self selectedClassOrMetaClass. theClass ifNil: [ ^'']. ^Text streamContents: [ :str | str nextPutAll: (theClass definitionST80: Preferences printAlternateSyntax not). str cr; cr. theClass hasComment ifTrue: [ str nextPutAll: '"Class comment:"'; cr. "ideally, this should avoid the asString, so that the text attributes are nice" str nextPutAll: theClass comment asString asSmalltalkComment ] ifFalse: [ str withAttribute: TextColor red do: [ str nextPutAll: '"THIS CLASS HAS NO COMMENT!!"' ] ] ]. ! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:11' prior: 34271843! classDefinitionText "return the text to display for the definition of the currently selected class" | theClass | theClass _ self selectedClassOrMetaClass. theClass ifNil: [ ^'']. ^theClass definitionST80: Preferences printAlternateSyntax not! ! !Browser methodsFor: 'class functions' stamp: 'sw 2/27/2001 12:06'! classListMenu: aMenu shifted: shifted "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" shifted ifTrue: [^ self shiftedClassListMenu: aMenu]. aMenu addList: #( - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse protocol (p)' browseFullProtocol) - ('printOut' printOutClass) ('fileOut' fileOutClass) - ('show hierarchy' hierarchy) ('show definition' editClass) ('show comment' editComment) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) ('class vars' browseClassVariables) ('class refs (N)' browseClassRefs) - ('rename class ...' renameClass) ('copy class' copyClass) ('remove class (x)' removeClass) - ('find method...' findMethod) - ('more...' offerShiftedClassListMenu)). ^ aMenu! ! !Browser methodsFor: 'class functions' stamp: 'sw 10/22/2002 16:10'! createInstVarAccessors "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class" | aClass newMessage setter | (aClass _ self selectedClassOrMetaClass) ifNotNil: [aClass instVarNames do: [:aName | (aClass canUnderstand: aName asSymbol) ifFalse: [newMessage _ aName, ' "Answer the value of ', aName, '" ^ ', aName. aClass compile: newMessage classified: 'accessing' notifying: nil]. (aClass canUnderstand: (setter _ aName, ':') asSymbol) ifFalse: [newMessage _ setter, ' anObject "Set the value of ', aName, '" ', aName, ' _ anObject'. aClass compile: newMessage classified: 'accessing' notifying: nil]]]! ! !Browser methodsFor: 'class functions' stamp: 'bf 10/19/2000 11:39'! defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass _ self selectedClassOrMetaClass. defTokens _ defString findTokens: Character separators. keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category']. envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $'). keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x]. newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass name asString ~= newClassName]) and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ false]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass _ oldClass superclass]. class _ oldClass subclassDefinerClass evaluate: defString notifying: aController logged: true. (class isKindOf: Behavior) ifTrue: [self changed: #classList. self classListIndex: (self classList indexOf: ((class isKindOf: Metaclass) ifTrue: [class soleInstance name] ifFalse: [class name])). self clearUserEditFlag; editClass. ^ true] ifFalse: [^ false]! ! !Browser methodsFor: 'class functions' stamp: 'ls 10/9/2003 11:56' prior: 34274808! defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass _ self selectedClassOrMetaClass. defTokens _ defString findTokens: Character separators. keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category']. envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $'). keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x]. newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass name asString ~= newClassName]) and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ false]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass _ oldClass superclass]. class _ oldClass subclassDefinerClass evaluate: defString notifying: aController logged: true. (class isKindOf: Behavior) ifTrue: [self changed: #systemCategoryList. self changed: #classList. self clearUserEditFlag. self setClass: class selector: nil. "self clearUserEditFlag; editClass." ^ true] ifFalse: [^ false]! ! !Browser methodsFor: 'class functions' stamp: 'sw 11/21/2003 21:45' prior: 34276598! defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass _ self selectedClassOrMetaClass. defTokens _ defString findTokens: Character separators. keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category']. envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $'). keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x]. newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ false]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass _ oldClass superclass]. class _ oldClass subclassDefinerClass evaluate: defString notifying: aController logged: true. (class isKindOf: Behavior) ifTrue: [self changed: #systemCategoryList. self changed: #classList. self clearUserEditFlag. self setClass: class selector: nil. "self clearUserEditFlag; editClass." ^ true] ifFalse: [^ false]! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/15/2004 13:23' prior: 18565762! editClass "Retrieve the description of the class definition." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. self editSelection: #editClass. self changed: #contents. self changed: #classCommentText. ! ! !Browser methodsFor: 'class functions' stamp: 'sw 11/22/2002 17:50'! editComment "Retrieve the description of the class comment." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. editSelection _ #editComment. metaClassIndicated _ false. self changed: #classSelectionChanged. self decorateButtons. self contentsChanged! ! !Browser methodsFor: 'class functions' stamp: 'asm 7/9/2003 17:28' prior: 34280423! editComment "Retrieve the description of the class comment." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. metaClassIndicated _ false. editSelection _ #editComment. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self decorateButtons. self contentsChanged ! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:08' prior: 34280827! editComment "Retrieve the description of the class comment." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. metaClassIndicated _ false. self editSelection: #editComment. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self decorateButtons. self contentsChanged ! ! !Browser methodsFor: 'class functions' stamp: 'nb 5/6/2003 16:49' prior: 18566399! explainSpecial: string "Answer a string explaining the code pane selection if it is displaying one of the special edit functions." | classes whole lits reply | (editSelection == #editClass or: [editSelection == #newClass]) ifTrue: ["Selector parts in class definition" string last == $: ifFalse: [^nil]. lits _ Array with: #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.'] ifFalse: [^nil]. classes _ self systemNavigation allClassesImplementing: whole. classes _ 'these classes ' , classes printString. ^reply , ' It is defined in ' , classes , '." Smalltalk browseAllImplementorsOf: #' , whole]. editSelection == #hierarchy ifTrue: ["Instance variables in subclasses" classes _ self selectedClassOrMetaClass allSubclasses. classes _ classes detect: [:each | (each instVarNames detect: [:name | name = string] ifNone: []) ~~ nil] ifNone: [^nil]. classes _ classes printString. ^'"is an instance variable in class ' , classes , '." ' , classes , ' browseAllAccessesTo: ''' , string , '''.']. editSelection == #editSystemCategories ifTrue: [^nil]. editSelection == #editMessageCategories ifTrue: [^nil]. ^nil! ! !Browser methodsFor: 'class functions' stamp: 'je 12/4/2002 18:10'! findMethod "Pop up a list of the current class's methods, and select the one chosen by the user" | aClass selectors reply cat messageCatIndex messageIndex | self classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. aClass _ self selectedClassOrMetaClass. selectors _ aClass selectors asSortedArray. selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self]. reply _ (SelectionMenu labelList: selectors selections: selectors) startUp. reply == nil ifTrue: [^ self]. cat _ aClass whichCategoryIncludesSelector: reply. messageCatIndex _ self messageCategoryList indexOf: cat. self messageCategoryListIndex: messageCatIndex. messageIndex _ (self messageList indexOf: reply). self messageListIndex: messageIndex! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09' prior: 18569305! hierarchy "Display the inheritance hierarchy of the receiver's selected class." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. self editSelection: #hierarchy. self changed: #editComment. self contentsChanged. ^ self! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:07' prior: 18569657! makeNewSubclass self selectedClassOrMetaClass ifNil: [^ self]. self okToChange ifFalse: [^ self]. self editSelection: #newClass. self contentsChanged! ! !Browser methodsFor: 'class functions' stamp: 'sw 11/22/2002 17:49'! plusButtonHit "Cycle among definition, comment, and hierachy" editSelection == #editComment ifTrue: [self hierarchy. ^ self]. editSelection == #hierarchy ifTrue: [editSelection := #editClass. classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self changed: #editComment. self contentsChanged. ^ self]. self editComment! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09' prior: 34284725! plusButtonHit "Cycle among definition, comment, and hierachy" editSelection == #editComment ifTrue: [self hierarchy. ^ self]. editSelection == #hierarchy ifTrue: [self editSelection: #editClass. classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self changed: #editComment. self contentsChanged. ^ self]. self editComment! ! !Browser methodsFor: 'class functions' stamp: 'sw 3/5/2001 18:04'! removeClass "If the user confirms the wish to delete the class, do so" super removeClass ifTrue: [self classListIndex: 0]! ! !Browser methodsFor: 'class functions' stamp: 'RAA 5/28/2001 13:38'! renameClass | oldName newName obs | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ self request: 'Please type new class name' initialAnswer: oldName. newName = '' ifTrue: [^ self]. " Cancel returns '' " newName _ newName asSymbol. newName = oldName ifTrue: [^ self]. (Smalltalk includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [ Smalltalk browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName ]. ! ! !Browser methodsFor: 'class functions' stamp: 'sd 4/16/2003 08:51' prior: 34285815! renameClass | oldName newName obs | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ self request: 'Please type new class name' initialAnswer: oldName. newName = '' ifTrue: [^ self]. " Cancel returns '' " newName _ newName asSymbol. newName = oldName ifTrue: [^ self]. (Smalltalk includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [ self systemNavigation browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName ]. ! ! !Browser methodsFor: 'class functions' stamp: 'sd 4/29/2003 11:49' prior: 34286716! renameClass | oldName newName obs | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ self request: 'Please type new class name' initialAnswer: oldName. newName = '' ifTrue: [^ self]. "Cancel returns ''" newName _ newName asSymbol. newName = oldName ifTrue: [^ self]. (Smalltalk includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs _ self systemNavigation allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [self systemNavigation browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName]! ! !Browser methodsFor: 'class functions' stamp: 'sw 10/16/2002 15:41'! shiftedClassListMenu: aMenu "Set up the menu to apply to the receiver's class list when the shift key is down" ^ aMenu addList: #( - ('unsent methods' browseUnusedMethods 'browse all methods defined by this class that have no senders') ('unreferenced inst vars' showUnreferencedInstVars 'show a list of all instance variables that are not referenced in methods') ('unreferenced class vars' showUnreferencedClassVars 'show a list of all class variables that are not referenced in methods') ('subclass template' makeNewSubclass 'put a template into the code pane for defining of a subclass of this class') - ('sample instance' makeSampleInstance 'give me a sample instance of this class, if possible') ('inspect instances' inspectInstances 'open an inspector on all the extant instances of this class') ('inspect subinstances' inspectSubInstances 'open an inspector on all the extant instances of this class and of all of its subclasses') - ('fetch documentation' fetchClassDocPane 'once, and maybe again someday, fetch up-to-date documentation for this class from the Squeak documentation repository') ('add all meths to current chgs' addAllMethodsToCurrentChangeSet 'place all the methods defined by this class into the current change set') ('create inst var accessors' createInstVarAccessors 'compile instance-variable access methods for any instance variables that do not yet have them') - ('more...' offerUnshiftedClassListMenu 'return to the standard class-list menu'))! ! !Browser methodsFor: 'class list' stamp: 'nk 2/13/2001 13:26'! classListIndex: anInteger "Set anInteger to be the index of the current class selection." | className | classListIndex _ anInteger. self setClassOrganizer. messageCategoryListIndex _ 1. messageListIndex _ 0. self classCommentIndicated ifTrue: [] ifFalse: [editSelection _ anInteger = 0 ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0) ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass]]. contents _ nil. self selectedClass isNil ifFalse: [className _ self selectedClass name. (RecentClasses includes: className) ifTrue: [RecentClasses remove: className]. RecentClasses addFirst: className. RecentClasses size > 16 ifTrue: [RecentClasses removeLast]]. self changed: #classSelectionChanged. self changed: #classListIndex. "update my selection" self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'class list' stamp: 'drs 1/5/2003 20:14' prior: 34290178! classListIndex: anInteger "Set anInteger to be the index of the current class selection." | className | classListIndex _ anInteger. self setClassOrganizer. messageCategoryListIndex _ 0. messageListIndex _ 0. self classCommentIndicated ifTrue: [] ifFalse: [editSelection _ anInteger = 0 ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0) ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass]]. contents _ nil. self selectedClass isNil ifFalse: [className _ self selectedClass name. (RecentClasses includes: className) ifTrue: [RecentClasses remove: className]. RecentClasses addFirst: className. RecentClasses size > 16 ifTrue: [RecentClasses removeLast]]. self changed: #classSelectionChanged. self changed: #classListIndex. "update my selection" self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'class list' stamp: 'nk 2/14/2004 15:07' prior: 34291197! classListIndex: anInteger "Set anInteger to be the index of the current class selection." | className | classListIndex _ anInteger. self setClassOrganizer. messageCategoryListIndex _ 0. messageListIndex _ 0. self classCommentIndicated ifTrue: [] ifFalse: [self editSelection: (anInteger = 0 ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0) ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass])]. contents _ nil. self selectedClass isNil ifFalse: [className _ self selectedClass name. (RecentClasses includes: className) ifTrue: [RecentClasses remove: className]. RecentClasses addFirst: className. RecentClasses size > 16 ifTrue: [RecentClasses removeLast]]. self changed: #classSelectionChanged. self changed: #classCommentText. self changed: #classListIndex. "update my selection" self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25' prior: 18573954! recent "Let the user select from a list of recently visited classes. 11/96 stp. 12/96 di: use class name, not classes themselves. : dont fall into debugger in empty case" | className class recentList | recentList _ RecentClasses select: [:n | Smalltalk includesKey: n]. recentList size == 0 ifTrue: [^ Beeper beep]. className := (SelectionMenu selections: recentList) startUp. className == nil ifTrue: [^ self]. class := Smalltalk at: className. self selectCategoryForClass: class. self classListIndex: (self classList indexOf: class name)! ! !Browser methodsFor: 'code pane' stamp: 'drs 1/29/2003 14:13' prior: 18575610! compileMessage: aText notifying: aController "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." | fallBackCategoryIndex fallBackMethodIndex originalSelectorName result | self selectedMessageCategoryName == nil ifTrue: [ self selectOriginalCategoryForCurrentMethod ]. self selectedMessageCategoryName asSymbol = ClassOrganizer allCategory ifTrue: [ "User tried to save a method while the ALL category was selected" fallBackCategoryIndex _ messageCategoryListIndex. fallBackMethodIndex _ messageListIndex. editSelection == #newMessage ifTrue: [ "Select the 'as yet unclassified' category" messageCategoryListIndex _ 0. (result _ self defineMessageFrom: aText notifying: aController) ifNil: ["Compilation failure: reselect the original category & method" messageCategoryListIndex _ fallBackCategoryIndex. messageListIndex _ fallBackMethodIndex] ifNotNil: [self setSelector: result]] ifFalse: [originalSelectorName _ self selectedMessageName. self setOriginalCategoryIndexForCurrentMethod. messageListIndex _ fallBackMethodIndex _ self messageList indexOf: originalSelectorName. (result _ self defineMessageFrom: aText notifying: aController) ifNotNil: [self setSelector: result] ifNil: [ "Compilation failure: reselect the original category & method" messageCategoryListIndex _ fallBackCategoryIndex. messageListIndex _ fallBackMethodIndex. ^ result notNil]]. self changed: #messageCategoryList. ^ result notNil] ifFalse: [ "User tried to save a method while the ALL category was NOT selected" ^ (self defineMessageFrom: aText notifying: aController) notNil]! ! !Browser methodsFor: 'code pane' stamp: 'asm 6/25/2003 22:48' prior: 34293916! compileMessage: aText notifying: aController "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." | fallBackCategoryIndex fallBackMethodIndex originalSelectorName result | self selectedMessageCategoryName ifNil: [ self selectOriginalCategoryForCurrentMethod ifFalse:["Select the '--all--' category" self messageCategoryListIndex: 1]]. self selectedMessageCategoryName asSymbol = ClassOrganizer allCategory ifTrue: [ "User tried to save a method while the ALL category was selected" fallBackCategoryIndex _ messageCategoryListIndex. fallBackMethodIndex _ messageListIndex. editSelection == #newMessage ifTrue: [ "Select the 'as yet unclassified' category" messageCategoryListIndex _ 0. (result _ self defineMessageFrom: aText notifying: aController) ifNil: ["Compilation failure: reselect the original category & method" messageCategoryListIndex _ fallBackCategoryIndex. messageListIndex _ fallBackMethodIndex] ifNotNil: [self setSelector: result]] ifFalse: [originalSelectorName _ self selectedMessageName. self setOriginalCategoryIndexForCurrentMethod. messageListIndex _ fallBackMethodIndex _ self messageList indexOf: originalSelectorName. (result _ self defineMessageFrom: aText notifying: aController) ifNotNil: [self setSelector: result] ifNil: [ "Compilation failure: reselect the original category & method" messageCategoryListIndex _ fallBackCategoryIndex. messageListIndex _ fallBackMethodIndex. ^ result notNil]]. self changed: #messageCategoryList. ^ result notNil] ifFalse: [ "User tried to save a method while the ALL category was NOT selected" ^ (self defineMessageFrom: aText notifying: aController) notNil]! ! !Browser methodsFor: 'code pane' stamp: 'sw 5/18/2001 20:55'! showBytecodes "Show or hide the bytecodes of the selected method -- an older protocol now mostly not relevant." self toggleShowingByteCodes! ! !Browser methodsFor: 'drag and drop' stamp: 'NS 4/7/2004 13:27' prior: 18578673! acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph "Here we are fetching informations from the dropped transferMorph and performing the correct action for this drop." | srcType success srcBrowser srcClass srcSelector srcCategory | success _ false. srcType _ transferMorph dragTransferType. srcBrowser _ transferMorph source model. srcClass _ transferMorph passenger key. srcSelector _ transferMorph passenger value. srcCategory _ srcBrowser selectedMessageCategoryName. srcCategory ifNil: [srcCategory _ srcClass organization categoryOfElement: srcSelector]. srcType == #messageList ifTrue: [success _ self acceptMethod: srcSelector messageCategory: srcCategory class: srcClass atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. srcType == #classList ifTrue: [success _ self changeCategoryForClass: transferMorph passenger srcSystemCategory: srcBrowser selectedSystemCategoryName atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. ^success! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 17:43' prior: 34298084! acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph "Here we are fetching informations from the dropped transferMorph and performing the correct action for this drop." | srcType success srcBrowser | success := false. srcType := transferMorph dragTransferType. srcBrowser := transferMorph source model. srcType == #messageList ifTrue: [ | srcClass srcSelector srcCategory | srcClass := transferMorph passenger key. srcSelector := transferMorph passenger value. srcCategory := srcBrowser selectedMessageCategoryName. srcCategory ifNil: [srcCategory := srcClass organization categoryOfElement: srcSelector]. success := self acceptMethod: srcSelector messageCategory: srcCategory class: srcClass atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. srcType == #classList ifTrue: [success := self changeCategoryForClass: transferMorph passenger srcSystemCategory: srcBrowser selectedSystemCategoryName atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. ^ success! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 2/14/2004 20:49' prior: 18583961! dragPassengerFor: item inMorph: dragSource | transferType | (dragSource isKindOf: PluggableListMorph) ifFalse: [^item]. transferType _ self dragTransferTypeForMorph: dragSource. transferType == #messageList ifTrue: [^self selectedClassOrMetaClass-> self selectedMessageName ]. transferType == #classList ifTrue: [^self selectedClass]. ^item contents! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 06:32' prior: 34300521! dragPassengerFor: item inMorph: dragSource | transferType smn | (dragSource isKindOf: PluggableListMorph) ifFalse: [^nil]. transferType _ self dragTransferTypeForMorph: dragSource. transferType == #classList ifTrue: [^self selectedClass]. transferType == #messageList ifFalse: [ ^nil ]. smn _ self selectedMessageName ifNil: [ ^nil ]. (MessageSet isPseudoSelector: smn) ifTrue: [ ^nil ]. ^ self selectedClassOrMetaClass -> smn. ! ! !Browser methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:21' prior: 18584576! dstCategoryDstListMorph: dstListMorph ^(dstListMorph getListSelector == #systemCategoryList) ifTrue: [dstListMorph potentialDropItem ] ifFalse: [self selectedSystemCategoryName]! ! !Browser methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:20' prior: 18584890! dstClassDstListMorph: dstListMorph | dropItem | ^(dstListMorph getListSelector == #classList) ifTrue: [(dropItem _ dstListMorph potentialDropItem) ifNotNil: [Smalltalk at: dropItem withBlanksCondensed asSymbol]] ifFalse: [dstListMorph model selectedClass]! ! !Browser methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:19' prior: 18585236! dstMessageCategoryDstListMorph: dstListMorph | dropItem | ^dstListMorph getListSelector == #messageCategoryList ifTrue: [dropItem _ dstListMorph potentialDropItem. dropItem ifNotNil: [dropItem asSymbol]] ifFalse: [self selectedMessageCategoryName]! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 06:16' prior: 34302118! dstMessageCategoryDstListMorph: dstListMorph | dropItem | ^dstListMorph getListSelector == #messageCategoryList ifTrue: [dropItem _ dstListMorph potentialDropItem. dropItem ifNotNil: [dropItem asSymbol]] ifFalse: [self selectedMessageCategoryName ifNil: [ Categorizer default ]]! ! !Browser methodsFor: 'initialize-release' stamp: 'ar 8/15/2001 23:28'! addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset | row switchHeight divider | row _ AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 1; layoutPolicy: ProportionalLayout new. switchHeight _ 25. row addMorph: aListPane fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@0 corner: 0@switchHeight negated) ). divider _ BorderedSubpaneDividerMorph forTopEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. row addMorph: divider fullFrame: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@switchHeight negated corner: 0@(1-switchHeight)) ). self addMorphicSwitchesTo: row at: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@(1-switchHeight) corner: 0@0) ). window addMorph: row fullFrame: ( LayoutFrame fractions: nominalFractions offsets: (0@verticalOffset corner: 0@0) ). row on: #mouseEnter send: #paneTransition: to: window. row on: #mouseLeave send: #paneTransition: to: window. ! ! !Browser methodsFor: 'initialize-release' stamp: 'sps 3/24/2004 11:50' prior: 34302832! addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset | row switchHeight divider | row _ AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 1; layoutPolicy: ProportionalLayout new. switchHeight _ 25. self addMorphicSwitchesTo: row at: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@(1-switchHeight) corner: 0@0) ). divider _ BorderedSubpaneDividerMorph forTopEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. row addMorph: divider fullFrame: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@switchHeight negated corner: 0@(1-switchHeight)) ). row addMorph: aListPane fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@0 corner: 0@(switchHeight negated)) ). window addMorph: row fullFrame: ( LayoutFrame fractions: nominalFractions offsets: (0@verticalOffset corner: 0@0) ). row on: #mouseEnter send: #paneTransition: to: window. row on: #mouseLeave send: #paneTransition: to: window. ! ! !Browser methodsFor: 'initialize-release' stamp: 'rww 8/18/2002 09:31'! browseSelectionInPlace "In place code - incomplete" " self systemCategoryListIndex: (self systemCategoryList indexOf: self selectedClass category). self classListIndex: (self classList indexOf: self selectedClass name)" self spawnHierarchy.! ! !Browser methodsFor: 'initialize-release' stamp: 'RAA 2/9/2001 16:36'! buildMorphicClassList | myClassList | (myClassList _ PluggableListMorph new) setProperty: #highlightSelector toValue: #highlightClassList:with:; on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted: keystroke: #classListKey:from:. myClassList borderWidth: 0. myClassList enableDragNDrop: Preferences browseWithDragNDrop. ^myClassList ! ! !Browser methodsFor: 'initialize-release' stamp: 'rww 8/18/2002 09:27' prior: 34305697! buildMorphicClassList | myClassList | (myClassList _ PluggableListMorph new) setProperty: #highlightSelector toValue: #highlightClassList:with:; on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted: keystroke: #classListKey:from:. myClassList borderWidth: 0. myClassList enableDragNDrop: Preferences browseWithDragNDrop. myClassList doubleClickSelector: #browseSelectionInPlace. ^myClassList ! ! !Browser methodsFor: 'initialize-release' stamp: 'RAA 2/9/2001 16:37'! buildMorphicMessageCatList | myMessageCatList | (myMessageCatList _ PluggableMessageCategoryListMorph new) setProperty: #highlightSelector toValue: #highlightMessageCategoryList:with:; on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu: keystroke: #arrowKey:from: getRawListSelector: #rawMessageCategoryList. myMessageCatList enableDragNDrop: Preferences browseWithDragNDrop. ^myMessageCatList ! ! !Browser methodsFor: 'initialize-release' stamp: 'sw 6/5/2001 20:01'! buildMorphicMessageList "Build a morphic message list, with #messageList as its list-getter" | aListMorph | (aListMorph _ PluggableListMorph new) setProperty: #highlightSelector toValue: #highlightMessageList:with:; setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForMethodString; on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph enableDragNDrop: Preferences browseWithDragNDrop. aListMorph menuTitleSelector: #messageListSelectorTitle. ^aListMorph ! ! !Browser methodsFor: 'initialize-release' stamp: 'dew 3/8/2002 00:05'! buildMorphicSwitches | instanceSwitch divider1 divider2 commentSwitch classSwitch row aColor | instanceSwitch _ PluggableButtonMorph on: self getState: #instanceMessagesIndicated action: #indicateInstanceMessages. instanceSwitch label: 'instance'; askBeforeChanging: true; borderWidth: 0. commentSwitch _ PluggableButtonMorph on: self getState: #classCommentIndicated action: #plusButtonHit. commentSwitch label: '?' asText allBold; askBeforeChanging: true; setBalloonText: 'class comment'; borderWidth: 0. classSwitch _ PluggableButtonMorph on: self getState: #classMessagesIndicated action: #indicateClassMessages. classSwitch label: 'class'; askBeforeChanging: true; borderWidth: 0. divider1 := BorderedSubpaneDividerMorph vertical. divider2 := BorderedSubpaneDividerMorph vertical. Preferences alternativeWindowLook ifTrue:[ divider1 extent: 4@4; borderWidth: 2; borderRaised; color: Color transparent. divider2 extent: 4@4; borderWidth: 2; borderRaised; color: Color transparent. ]. row _ AlignmentMorph newRow hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 0; addMorphBack: instanceSwitch; addMorphBack: divider1; addMorphBack: commentSwitch; addMorphBack: divider2; addMorphBack: classSwitch. aColor _ Color colorFrom: self defaultBackgroundColor. row color: aColor duller. "ensure matching button divider color. (see #paneColor)" Preferences alternativeWindowLook ifTrue:[aColor _ aColor muchLighter]. {instanceSwitch. commentSwitch. classSwitch} do: [:m | m color: aColor; onColor: aColor twiceDarker offColor: aColor; hResizing: #spaceFill; vResizing: #spaceFill. ]. ^ row ! ! !Browser methodsFor: 'initialize-release' stamp: 'RAA 2/9/2001 16:34'! buildMorphicSystemCatList | dragNDropFlag myCatList | dragNDropFlag _ Preferences browseWithDragNDrop. (myCatList _ PluggableListMorph new) setProperty: #highlightSelector toValue: #highlightSystemCategoryList:with:; on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:. myCatList enableDragNDrop: dragNDropFlag. ^myCatList ! ! !Browser methodsFor: 'initialize-release' stamp: 'nk 2/13/2001 13:25'! labelString ^self selectedClass ifNil: [ self defaultBrowserTitle ] ifNotNil: [ self defaultBrowserTitle, ': ', self selectedClass printString ]. ! ! !Browser methodsFor: 'initialize-release' stamp: 'sps 4/3/2004 19:38' prior: 18597523! openAsMorphClassEditing: editString "Create a pluggable version a Browser on just a single class." | window dragNDropFlag hSepFrac switchHeight mySingletonClassList | window _ (SystemWindow labelled: 'later') model: self. dragNDropFlag _ Preferences browseWithDragNDrop. hSepFrac _ 0.3. switchHeight _ 25. mySingletonClassList _ PluggableListMorph on: self list: #classListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #classListMenu:shifted: keystroke: #classListKey:from:. mySingletonClassList enableDragNDrop: dragNDropFlag. self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window addMorph: mySingletonClassList fullFrame: ( LayoutFrame fractions: (0@0 corner: 0.5@0) offsets: (0@0 corner: 0@switchHeight) ). self addMorphicSwitchesTo: window at: ( LayoutFrame fractions: (0.5@0 corner: 1.0@0) offsets: (0@0 corner: 0@switchHeight) ). window addMorph: self buildMorphicMessageCatList fullFrame: ( LayoutFrame fractions: (0@0 corner: 0.5@hSepFrac) offsets: (0@switchHeight corner: 0@0) ). window addMorph: self buildMorphicMessageList fullFrame: ( LayoutFrame fractions: (0.5@0 corner: 1.0@hSepFrac) offsets: (0@switchHeight corner: 0@0) ). window setUpdatablePanesFrom: #(messageCategoryList messageList). ^ window ! ! !Browser methodsFor: 'initialize-release' stamp: 'sps 4/3/2004 20:41' prior: 18598981! openAsMorphEditing: editString "Create a pluggable version of all the morphs for a Browser in Morphic" | window hSepFrac | hSepFrac _ 0.4. window _ (SystemWindow labelled: 'later') model: self. "The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars need the lowerpanes to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added. " Preferences scrollBarsOnRight ifFalse: [self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString]. window addMorph: self buildMorphicSystemCatList frame: (0@0 corner: 0.25@hSepFrac). self addClassAndSwitchesTo: window at: (0.25@0 corner: 0.5@hSepFrac) plus: 0. window addMorph: self buildMorphicMessageCatList frame: (0.5@0 extent: 0.25@hSepFrac). window addMorph: self buildMorphicMessageList frame: (0.75@0 extent: 0.25@hSepFrac). Preferences scrollBarsOnRight ifTrue: [self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString]. window setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). ^ window ! ! !Browser methodsFor: 'initialize-release' stamp: 'dew 1/7/2002 02:07'! openAsMorphSysCatEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." | window hSepFrac switchHeight mySingletonList nextOffsets | window _ (SystemWindow labelled: 'later') model: self. hSepFrac _ 0.30. switchHeight _ 25. mySingletonList _ PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:. mySingletonList enableDragNDrop: Preferences browseWithDragNDrop. mySingletonList hideScrollBarIndefinitely. window addMorph: mySingletonList fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@switchHeight) ). self addClassAndSwitchesTo: window at: (0@0 corner: 0.3333@hSepFrac) plus: switchHeight. nextOffsets _ 0@switchHeight corner: 0@0. window addMorph: self buildMorphicMessageCatList fullFrame: ( LayoutFrame fractions: (0.3333@0 corner: 0.6666@hSepFrac) offsets: nextOffsets ). window addMorph: self buildMorphicMessageList fullFrame: ( LayoutFrame fractions: (0.6666@0 corner: 1@hSepFrac) offsets: nextOffsets ). self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window setUpdatablePanesFrom: #( classList messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'nk 4/28/2004 10:17' prior: 34313412! openAsMorphSysCatEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." | window hSepFrac switchHeight mySingletonList nextOffsets | window _ (SystemWindow labelled: 'later') model: self. hSepFrac _ 0.30. switchHeight _ 25. mySingletonList _ PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:. mySingletonList enableDragNDrop: Preferences browseWithDragNDrop. mySingletonList hideScrollBarsIndefinitely. window addMorph: mySingletonList fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@switchHeight) ). self addClassAndSwitchesTo: window at: (0@0 corner: 0.3333@hSepFrac) plus: switchHeight. nextOffsets _ 0@switchHeight corner: 0@0. window addMorph: self buildMorphicMessageCatList fullFrame: ( LayoutFrame fractions: (0.3333@0 corner: 0.6666@hSepFrac) offsets: nextOffsets ). window addMorph: self buildMorphicMessageList fullFrame: ( LayoutFrame fractions: (0.6666@0 corner: 1@hSepFrac) offsets: nextOffsets ). self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window setUpdatablePanesFrom: #( classList messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'BG 10/21/2002 19:29'! openEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." | systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView underPane y optionalButtonsView annotationPane | self couldOpenInMorphic ifTrue: [^ self openAsMorphEditing: aString]. "Sensor leftShiftDown ifTrue: [^ self openAsMorphEditing: aString]. uncomment-out for testing morphic browser embedded in mvc project" topView _ StandardSystemView new model: self. topView borderWidth: 1. "label and minSize taken care of by caller" systemCategoryListView _ PluggableListView on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:. systemCategoryListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: systemCategoryListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted: keystroke: #classListKey:from:. classListView window: (0 @ 0 extent: 50 @ 62). topView addSubView: classListView toRightOf: systemCategoryListView. switchView _ self buildInstanceClassSwitchView. switchView borderWidth: 1. topView addSubView: switchView below: classListView. messageCategoryListView _ PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView controller terminateDuringSelect: true. messageCategoryListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: messageCategoryListView toRightOf: classListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView window: (0 @ 0 extent: 50 @ 70). messageListView menuTitleSelector: #messageListSelectorTitle. topView addSubView: messageListView toRightOf: messageCategoryListView. self wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: systemCategoryListView. underPane _ annotationPane. y _ 110 - self optionalAnnotationHeight] ifFalse: [ underPane _ systemCategoryListView. y _ 110]. self wantsOptionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'BG 10/21/2002 19:29'! openSystemCatEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers. The top list view is of the currently selected system class category--a single item list." | systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView y annotationPane underPane optionalButtonsView | Smalltalk isMorphic ifTrue: [^ self openAsMorphSysCatEditing: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" systemCategoryListView _ PluggableListView on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:. systemCategoryListView window: (0 @ 0 extent: 200 @ 12). topView addSubView: systemCategoryListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted: keystroke: #classListKey:from:. classListView window: (0 @ 0 extent: 67 @ 62). topView addSubView: classListView below: systemCategoryListView. messageCategoryListView _ PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView controller terminateDuringSelect: true. messageCategoryListView window: (0 @ 0 extent: 66 @ 70). topView addSubView: messageCategoryListView toRightOf: classListView. switchView _ self buildInstanceClassSwitchView. switchView window: switchView window viewport: (classListView viewport bottomLeft corner: messageCategoryListView viewport bottomLeft). switchView borderWidth: 1. topView addSubView: switchView below: classListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView menuTitleSelector: #messageListSelectorTitle. messageListView window: (0 @ 0 extent: 67 @ 70). topView addSubView: messageListView toRightOf: messageCategoryListView. self wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: switchView. y _ 110 - 12 - self optionalAnnotationHeight. underPane _ annotationPane] ifFalse: [y _ 110 - 12. underPane _ switchView]. self wantsOptionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(classList messageCategoryList messageList). ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'avi 2/21/2004 12:25' prior: 18620406! setClass: aBehavior selector: aSymbol "Set the state of a new, uninitialized Browser." | isMeta aClass messageCatIndex | aBehavior ifNil: [^ self]. (aBehavior isKindOf: Metaclass) ifTrue: [isMeta _ true. aClass _ aBehavior soleInstance] ifFalse: [isMeta _ false. aClass _ aBehavior]. self selectCategoryForClass: aClass. self classListIndex: ((SystemOrganization listAtCategoryNamed: self selectedSystemCategoryName ) indexOf: aClass name). self metaClassIndicated: isMeta. aSymbol ifNil: [^ self]. messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol. self messageCategoryListIndex: messageCatIndex + 1. "<- FIXED offset" messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)! ! !Browser methodsFor: 'initialize-release' stamp: 'rhi 5/12/2004 23:23' prior: 34324181! setClass: aBehavior selector: aSymbol "Set the state of a new, uninitialized Browser." | isMeta aClass messageCatIndex | aBehavior ifNil: [^ self]. (aBehavior isKindOf: Metaclass) ifTrue: [ isMeta _ true. aClass _ aBehavior soleInstance] ifFalse: [ isMeta _ false. aClass _ aBehavior]. self selectCategoryForClass: aClass. self classListIndex: ( (SystemOrganization listAtCategoryNamed: self selectedSystemCategoryName) indexOf: aClass name). self metaClassIndicated: isMeta. aSymbol ifNil: [^ self]. messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol. self messageCategoryListIndex: (messageCatIndex > 0 ifTrue: [messageCatIndex + 1] ifFalse: [0]). messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ( (aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol).! ! !Browser methodsFor: 'initialize-release' stamp: 'nk 2/14/2004 15:08' prior: 18622082! systemOrganizer: aSystemOrganizer "Initialize the receiver as a perspective on the system organizer, aSystemOrganizer. Typically there is only one--the system variable SystemOrganization." super initialize. contents _ nil. systemOrganizer _ aSystemOrganizer. systemCategoryListIndex _ 0. classListIndex _ 0. messageCategoryListIndex _ 0. messageListIndex _ 0. metaClassIndicated _ false. self setClassOrganizer. self editSelection: #none! ! !Browser methodsFor: 'initialize-release' stamp: 'rhi 5/12/2004 15:00' prior: 34326049! systemOrganizer: aSystemOrganizer "Initialize the receiver as a perspective on the system organizer, aSystemOrganizer. Typically there is only one--the system variable SystemOrganization." contents _ nil. systemOrganizer _ aSystemOrganizer. systemCategoryListIndex _ 0. classListIndex _ 0. messageCategoryListIndex _ 0. messageListIndex _ 0. metaClassIndicated _ false. self setClassOrganizer. self editSelection: #none.! ! !Browser methodsFor: 'message category functions' stamp: 'sd 5/23/2003 14:23' prior: 18624334! alphabetizeMessageCategories classListIndex = 0 ifTrue: [^ false]. self okToChange ifFalse: [^ false]. ChangeSet current reorganizeClass: self selectedClassOrMetaClass. self classOrMetaClassOrganizer sortCategories. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'NS 1/27/2004 12:53' prior: 34327131! alphabetizeMessageCategories classListIndex = 0 ifTrue: [^ false]. self okToChange ifFalse: [^ false]. self classOrMetaClassOrganizer sortCategories. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. SystemChangeNotifier uniqueInstance classReorganized: self selectedClassOrMetaClass. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:47' prior: 34327538! alphabetizeMessageCategories classListIndex = 0 ifTrue: [^ false]. self okToChange ifFalse: [^ false]. self classOrMetaClassOrganizer sortCategories. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'sd 1/5/2002 21:11'! buildMessageCategoryBrowserEditString: aString "Create and schedule a message category browser for the currently selected message category. The initial text view contains the characters in aString." "wod 6/24/1998: set newBrowser classListIndex so that it works whether the receiver is a standard or a Hierarchy Browser." | newBrowser | messageCategoryListIndex ~= 0 ifTrue: [newBrowser _ self class new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName). newBrowser metaClassIndicated: metaClassIndicated. newBrowser messageCategoryListIndex: messageCategoryListIndex. newBrowser messageListIndex: messageListIndex. self class openBrowserView: (newBrowser openMessageCatEditString: aString) label: 'Message Category Browser (' , newBrowser selectedClassOrMetaClassName , ')']! ! !Browser methodsFor: 'message category functions' stamp: 'nk 6/13/2004 07:21' prior: 34328286! buildMessageCategoryBrowserEditString: aString "Create and schedule a message category browser for the currently selected message category. The initial text view contains the characters in aString." "wod 6/24/1998: set newBrowser classListIndex so that it works whether the receiver is a standard or a Hierarchy Browser." | newBrowser | messageCategoryListIndex ~= 0 ifTrue: [newBrowser _ Browser new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName). newBrowser metaClassIndicated: metaClassIndicated. newBrowser messageCategoryListIndex: messageCategoryListIndex. newBrowser messageListIndex: messageListIndex. self class openBrowserView: (newBrowser openMessageCatEditString: aString) label: 'Message Category Browser (' , newBrowser selectedClassOrMetaClassName , ')']! ! !Browser methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:10'! canShowMultipleMessageCategories "Answer whether the receiver is capable of showing multiple message categories" ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'sw 2/22/2001 06:54'! categoryOfCurrentMethod "Determine the method category associated with the receiver at the current moment, or nil if none" | aCategory | ^ super categoryOfCurrentMethod ifNil: [(aCategory _ self messageCategoryListSelection) == ClassOrganizer allCategory ifTrue: [nil] ifFalse: [aCategory]]! ! !Browser methodsFor: 'message category functions' stamp: 'sd 5/23/2003 14:23' prior: 18626441! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." ChangeSet current reorganizeClass: self selectedClassOrMetaClass. self classOrMetaClassOrganizer changeFromString: aString. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'NS 1/27/2004 13:00' prior: 34330923! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." self classOrMetaClassOrganizer changeFromString: aString. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. SystemChangeNotifier uniqueInstance classReorganized: self selectedClassOrMetaClass. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:56' prior: 34331646! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." self classOrMetaClassOrganizer changeFromString: aString. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'nk 2/14/2004 15:06' prior: 18627148! editMessageCategories "Indicate to the receiver and its dependents that the message categories of the selected class have been changed." self okToChange ifFalse: [^ self]. classListIndex ~= 0 ifTrue: [self messageCategoryListIndex: 0. self editSelection: #editMessageCategories. self changed: #editMessageCategories. self contentsChanged]! ! !Browser methodsFor: 'message category functions' stamp: 'emm 5/30/2002 09:20' prior: 18597062! highlightMessageList: list with: morphList "Changed by emm to add emphasis in case of breakpoint" morphList do:[:each | | classOrNil methodOrNil | classOrNil := self selectedClassOrMetaClass. methodOrNil := classOrNil isNil ifTrue:[nil] ifFalse:[classOrNil methodDictionary at: each contents ifAbsent:[]]. (methodOrNil notNil and:[methodOrNil hasBreakpoint]) ifTrue:[each contents: ((each contents ,' [break]') asText allBold)]]! ! !Browser methodsFor: 'message category functions' stamp: 'dew 9/20/2001 00:21'! messageCategoryMenu: aMenu ^ aMenu labels: 'browse printOut fileOut reorganize alphabetize remove empty categories categorize all uncategorized new category... rename... remove' lines: #(3 8) selections: #(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories editMessageCategories alphabetizeMessageCategories removeEmptyCategories categorizeAllUncategorizedMethods addCategory renameCategory removeMessageCategory) ! ! !Browser methodsFor: 'message category functions' stamp: 'nk 4/23/2004 09:18' prior: 18628824! removeEmptyCategories self okToChange ifFalse: [^ self]. self selectedClassOrMetaClass organization removeEmptyCategories. self changed: #messageCategoryList ! ! !Browser methodsFor: 'message category functions' stamp: 'sd 5/23/2003 14:23' prior: 18629895! renameCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self]. oldName _ self selectedMessageCategoryName. newName _ self request: 'Please type new category name' initialAnswer: oldName. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. newName = oldName ifTrue: [^ self]. ChangeSet current reorganizeClass: self selectedClassOrMetaClass. self classOrMetaClassOrganizer renameCategory: oldName toBe: newName. self classListIndex: classListIndex. self messageCategoryListIndex: oldIndex. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message category functions' stamp: 'NS 1/27/2004 13:01' prior: 34334849! renameCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self]. oldName _ self selectedMessageCategoryName. newName _ self request: 'Please type new category name' initialAnswer: oldName. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. newName = oldName ifTrue: [^ self]. self classOrMetaClassOrganizer renameCategory: oldName toBe: newName. self classListIndex: classListIndex. self messageCategoryListIndex: oldIndex. self changed: #messageCategoryList. SystemChangeNotifier uniqueInstance classReorganized: self selectedClassOrMetaClass. ! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 23:01' prior: 34335746! renameCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self]. oldName _ self selectedMessageCategoryName. newName _ self request: 'Please type new category name' initialAnswer: oldName. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. newName = oldName ifTrue: [^ self]. self classOrMetaClassOrganizer renameCategory: oldName toBe: newName. self classListIndex: classListIndex. self messageCategoryListIndex: oldIndex. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message category functions' stamp: 'sw 10/8/2001 15:08'! showHomeCategory "Show the home category of the selected method. This is only really useful if one is in a tool that supports the showing of categories. Thus, it's good in browsers and hierarchy browsers but not in message-list browsers" | aSelector | self okToChange ifTrue: [(aSelector _ self selectedMessageName) ifNotNil: [self selectOriginalCategoryForCurrentMethod. self selectedMessageName: aSelector]]! ! !Browser methodsFor: 'message category list' stamp: 'nk 11/30/2002 08:20'! categorizeAllUncategorizedMethods "Categorize methods by looking in parent classes for a method category." | organizer organizers | organizer _ self classOrMetaClassOrganizer. organizers _ self selectedClassOrMetaClass withAllSuperclasses collect: [:ea | ea organization]. (organizer listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found | found _ (organizers collect: [ :org | org categoryOfElement: sel]) detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]] ifNone: []. found ifNotNil: [organizer classify: sel under: found]]. self changed: #messageCategoryList! ! !Browser methodsFor: 'message category list' stamp: 'drs 1/5/2003 19:12' prior: 18631428! messageCategoryListIndex: anInteger "Set the selected message category to be the one indexed by anInteger." messageCategoryListIndex _ anInteger. messageListIndex _ 0. editSelection _ anInteger <= 0 ifTrue: [#editClass] ifFalse: [#newMessage]. contents _ nil. self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self contentsChanged ! ! !Browser methodsFor: 'message category list' stamp: 'BG 2/4/2004 23:26' prior: 34338675! messageCategoryListIndex: anInteger "Set the selected message category to be the one indexed by anInteger." messageCategoryListIndex _ anInteger. messageListIndex _ 0. self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. editSelection = #newMessage ifTrue: [^self]. editSelection _ anInteger <= 0 ifTrue: [#editClass] ifFalse: [#newMessage]. contents _ nil. self contentsChanged ! ! !Browser methodsFor: 'message category list' stamp: 'nk 2/14/2004 15:08' prior: 34339209! messageCategoryListIndex: anInteger "Set the selected message category to be the one indexed by anInteger." messageCategoryListIndex _ anInteger. messageListIndex _ 0. self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. editSelection = #newMessage ifTrue: [^self]. self editSelection: (anInteger <= 0 ifTrue: [#editClass] ifFalse: [#newMessage]). contents _ nil. self contentsChanged ! ! !Browser methodsFor: 'message category list' stamp: 'rhi 5/12/2004 19:36' prior: 34339794! messageCategoryListIndex: anInteger "Set the selected message category to be the one indexed by anInteger." messageCategoryListIndex _ anInteger. messageListIndex _ 0. self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self editSelection: (anInteger > 0 ifTrue: [#newMessage] ifFalse: [self classListIndex > 0 ifTrue: [#editClass] ifFalse: [#newClass]]). contents _ nil. self contentsChanged.! ! !Browser methodsFor: 'message category list' stamp: 'nk 6/13/2004 06:20' prior: 18632560! selectMessageCategoryNamed: aSymbol "Given aSymbol, select the category with that name. Do nothing if aSymbol doesn't exist." self messageCategoryListIndex: (self messageCategoryList indexOf: aSymbol ifAbsent: [ 1])! ! !Browser methodsFor: 'message category list' stamp: 'asm 7/9/2003 13:52' prior: 18632913! selectOriginalCategoryForCurrentMethod "private - Select the message category for the current method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected. Returns: true on success, false on failure." | aSymbol selectorName | aSymbol _ self categoryOfCurrentMethod. selectorName _ self selectedMessageName. (aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory]) ifTrue: [messageCategoryListIndex _ (self messageCategoryList indexOf: aSymbol). messageListIndex _ (self messageList indexOf: selectorName). ^ true]. ^ false! ! !Browser methodsFor: 'message category list' stamp: 'BG 12/13/2003 14:23' prior: 34341296! selectOriginalCategoryForCurrentMethod "private - Select the message category for the current method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected. Returns: true on success, false on failure." | aSymbol selectorName | aSymbol _ self categoryOfCurrentMethod. selectorName _ self selectedMessageName. (aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory]) ifTrue: [messageCategoryListIndex _ (self messageCategoryList indexOf: aSymbol). messageListIndex _ (self messageList indexOf: selectorName). self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self changed: #messageListIndex. self contentsChanged. ^ true]. ^ false! ! !Browser methodsFor: 'message category list' stamp: 'KLC 2/20/2004 08:08' prior: 34342017! selectOriginalCategoryForCurrentMethod "private - Select the message category for the current method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected. Returns: true on success, false on failure." | aSymbol selectorName | aSymbol _ self categoryOfCurrentMethod. selectorName _ self selectedMessageName. (aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory]) ifTrue: [messageCategoryListIndex _ (self messageCategoryList indexOf: aSymbol). messageListIndex _ (self messageList indexOf: selectorName). self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self changed: #messageListIndex. ^ true]. ^ false! ! !Browser methodsFor: 'message functions' stamp: 'sd 1/5/2002 21:11'! buildMessageBrowserEditString: aString "Create and schedule a message browser for the receiver in which the argument, aString, contains characters to be edited in the text view." messageListIndex = 0 ifTrue: [^ self]. ^ self class openMessageBrowserForClass: self selectedClassOrMetaClass selector: self selectedMessageName editString: aString! ! !Browser methodsFor: 'message functions' stamp: 'sw 8/5/2002 16:50'! messageListMenu: aMenu shifted: shifted "Answer the message-list menu" shifted ifTrue: [^ self shiftedMessageListMenu: aMenu]. aMenu addList:#( ('what to show...' offerWhatToShowMenu) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut (o)' fileOutMessage) ('printOut' printOutMessage) ('copy selector (c)' copySelector) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class variables' browseClassVariables) ('class refs (N)' browseClassRefs) - ('remove method (x)' removeMessage) - ('more...' shiftedYellowButtonActivity)). ^ aMenu! ! !Browser methodsFor: 'message functions' stamp: 'emm 5/30/2002 10:25' prior: 34344257! messageListMenu: aMenu shifted: shifted "Answer the message-list menu" "Changed by emm to include menu-item for breakpoints" shifted ifTrue: [^ self shiftedMessageListMenu: aMenu]. aMenu addList:#( ('what to show...' offerWhatToShowMenu) ('toggle break on entry' toggleBreakOnEntry) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('tile scriptor' openSyntaxView) ('versions (v)' browseVersions) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class variables' browseClassVariables) ('class refs (N)' browseClassRefs) - ('remove method (x)' removeMessage) - ('more...' shiftedYellowButtonActivity)). ^ aMenu ! ! !Browser methodsFor: 'message functions' prior: 18640452! removeMessage "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. If the Preference 'confirmMethodRemoves' is set to false, the confirmer is bypassed." | messageName confirmation | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName _ self selectedMessageName. confirmation _ SystemNavigation new confirmRemovalOf: messageName on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: self selectedMessageName. self messageListIndex: 0. self changed: #messageList. self setClassOrganizer. "In case organization not cached" confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: messageName]! ! !Browser methodsFor: 'message functions' stamp: 'sd 4/15/2003 16:12' prior: 34346626! removeMessage "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. If the Preference 'confirmMethodRemoves' is set to false, the confirmer is bypassed." | messageName confirmation | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName _ self selectedMessageName. confirmation _ self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: self selectedMessageName. self messageListIndex: 0. self changed: #messageList. self setClassOrganizer. "In case organization not cached" confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: messageName]! ! !Browser methodsFor: 'message functions' stamp: 'nk 6/26/2003 21:41' prior: 34347538! removeMessage "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. If the Preference 'confirmMethodRemoves' is set to false, the confirmer is bypassed." | messageName confirmation | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName _ self selectedMessageName. confirmation _ self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: self selectedMessageName. self messageListIndex: 0. self changed: #messageList. self setClassOrganizer. "In case organization not cached" confirmation == 2 ifTrue: [self systemNavigation browseAllCallsOn: messageName]! ! !Browser methodsFor: 'message functions' stamp: 'sd 5/11/2003 21:01' prior: 34348452! removeMessage "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. If the Preference 'confirmMethodRemoves' is set to false, the confirmer is bypassed." | messageName confirmation | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName _ self selectedMessageName. confirmation _ self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: self selectedMessageName. self messageListIndex: 0. self changed: #messageList. self setClassOrganizer. "In case organization not cached" confirmation == 2 ifTrue: [self systemNavigation browseAllCallsOn: messageName]! ! !Browser methodsFor: 'message functions' stamp: 'sw 1/16/2002 21:54'! shiftedMessageListMenu: aMenu "Fill aMenu with the items appropriate when the shift key is held down" Smalltalk isMorphic ifTrue: [aMenu addStayUpItem]. aMenu addList: #( ('method pane' makeIsolatedCodePane) ('tile scriptor' openSyntaxView) ('toggle diffing (D)' toggleDiffing) ('implementors of sent messages' browseAllMessages) - ('local senders of...' browseLocalSendersOfMessages) ('local implementors of...' browseLocalImplementors) - ('spawn sub-protocol' spawnProtocol) ('spawn full protocol' spawnFullProtocol) - ('sample instance' makeSampleInstance) ('inspect instances' inspectInstances) ('inspect subinstances' inspectSubInstances)). self addExtraShiftedItemsTo: aMenu. aMenu addList: #( - ('change category...' changeCategory)). self canShowMultipleMessageCategories ifTrue: [aMenu addList: #(('show category (C)' showHomeCategory))]. aMenu addList: #( - ('change sets with this method' findMethodInChangeSets) ('revert to previous version' revertToPreviousVersion) ('remove from current change set' removeFromCurrentChanges) ('revert & remove from changes' revertAndForget) ('add to current change set' adoptMessageInCurrentChangeset) ('copy up or copy down...' copyUpOrCopyDown) - ('fetch documentation' fetchDocPane) ('more...' unshiftedYellowButtonActivity)). ^ aMenu ! ! !Browser methodsFor: 'message list' stamp: 'drs 1/1/2003 23:33' prior: 18642654! messageList "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." | sel | (sel _ self messageCategoryListSelection) ifNil: [ ^ self classOrMetaClassOrganizer ifNil: [Array new] ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors] "^ Array new" ]. ^ sel = ClassOrganizer allCategory ifTrue: [self classOrMetaClassOrganizer ifNil: [Array new] ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors]] ifFalse: [(self classOrMetaClassOrganizer listAtCategoryNumber: messageCategoryListIndex - 1) ifNil: [messageCategoryListIndex _ 0. Array new]]! ! !Browser methodsFor: 'message list' stamp: 'nk 2/14/2004 15:07' prior: 18643617! messageListIndex: anInteger "Set the selected message selector to be the one indexed by anInteger." messageListIndex _ anInteger. self editSelection: (anInteger = 0 ifTrue: [#newMessage] ifFalse: [#editMessage]). contents _ nil. self changed: #messageListIndex. "update my selection" self contentsChanged. self decorateButtons! ! !Browser methodsFor: 'message list' stamp: 'rhi 5/12/2004 19:35' prior: 34352748! messageListIndex: anInteger "Set the selected message selector to be the one indexed by anInteger." messageListIndex _ anInteger. self editSelection: (anInteger > 0 ifTrue: [#editMessage] ifFalse: [self messageCategoryListIndex > 0 ifTrue: [#newMessage] ifFalse: [self classListIndex > 0 ifTrue: [#editClass] ifFalse: [#newClass]]]). contents _ nil. self changed: #messageListIndex. "update my selection" self contentsChanged. self decorateButtons.! ! !Browser methodsFor: 'message list' stamp: 'sw 6/4/2001 17:31'! selectedMessage "Answer a copy of the source code for the selected message." | class selector method | contents == nil ifFalse: [^ contents copy]. self showingDecompile ifTrue: [^ self decompiledSourceIntoContents]. class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. method _ class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod _ method. (Sensor controlKeyPressed or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) == nil]]) ifTrue: ["Emergency or no source file -- decompile without temp names" contents _ (class decompilerClass new decompile: selector in: class method: method) decompileString. contents _ contents asText makeSelectorBoldIn: class. ^ contents copy]. Sensor leftShiftDown ifTrue: ["Special request to decompile, old and dubious interface" ^ self decompiledSourceIntoContents]. self showingDocumentation ifFalse: [contents _ self sourceStringPrettifiedAndDiffed] ifTrue: [contents _ self commentContents]. ^ contents _ contents copy asText makeSelectorBoldIn: class! ! !Browser methodsFor: 'message list' stamp: 'nk 6/19/2004 16:44' prior: 34353719! selectedMessage "Answer a copy of the source code for the selected message." | class selector method | contents == nil ifFalse: [^ contents copy]. self showingDecompile ifTrue: [^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ]. class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. method _ class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod _ method. ^ contents _ (self showingDocumentation ifFalse: [ self sourceStringPrettifiedAndDiffed ] ifTrue: [ self commentContents ]) copy asText makeSelectorBoldIn: class! ! !Browser methodsFor: 'message list' stamp: 'sw 8/26/2002 09:55'! selectedMessageName "Answer the message selector of the currently selected message, if any. Answer nil otherwise." | aList | editSelection == #editComment ifTrue: [^ #Comment]. editSelection == #editClass ifTrue: [^ #Definition]. messageListIndex = 0 ifTrue: [^ nil]. ^ (aList _ self messageList) size >= messageListIndex ifTrue: [aList at: messageListIndex] ifFalse: [nil]! ! !Browser methodsFor: 'message list' stamp: 'sw 10/8/2001 13:37'! selectedMessageName: aSelector "Make the given selector be the selected message name" | anIndex | anIndex _ self messageList indexOf: aSelector. anIndex > 0 ifTrue: [self messageListIndex: anIndex]! ! !Browser methodsFor: 'metaclass' stamp: 'drs 1/6/2003 21:25' prior: 18649361! metaClassIndicated: trueOrFalse "Indicate whether browsing instance or class messages." metaClassIndicated _ trueOrFalse. self setClassOrganizer. systemCategoryListIndex > 0 ifTrue: [editSelection _ classListIndex = 0 ifTrue: [metaClassIndicated ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass]]. messageCategoryListIndex _ 0. messageListIndex _ 0. contents _ nil. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self changed: #contents. self decorateButtons ! ! !Browser methodsFor: 'metaclass' stamp: 'asm 6/26/2003 00:24' prior: 34356408! metaClassIndicated: trueOrFalse "Indicate whether browsing instance or class messages." metaClassIndicated _ trueOrFalse. self setClassOrganizer. systemCategoryListIndex > 0 ifTrue: [editSelection _ classListIndex = 0 ifTrue: [metaClassIndicated ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass]]. messageCategoryListIndex _ 0. messageListIndex _ 0. contents _ nil. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self changed: #contents. self changed: #annotation. self decorateButtons ! ! !Browser methodsFor: 'metaclass' stamp: 'nk 2/14/2004 15:08' prior: 34357046! metaClassIndicated: trueOrFalse "Indicate whether browsing instance or class messages." metaClassIndicated _ trueOrFalse. self setClassOrganizer. systemCategoryListIndex > 0 ifTrue: [self editSelection: (classListIndex = 0 ifTrue: [metaClassIndicated ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass])]. messageCategoryListIndex _ 0. messageListIndex _ 0. contents _ nil. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self changed: #contents. self changed: #annotation. self decorateButtons ! ! !Browser methodsFor: 'system category functions' stamp: 'je 4/30/2001 17:59'! addSystemCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex newName | self okToChange ifFalse: [^ self]. oldIndex _ systemCategoryListIndex. newName _ self request: 'Please type new category name' initialAnswer: 'Category-Name'. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. systemOrganizer addCategory: newName before: (systemCategoryListIndex = 0 ifTrue: [nil] ifFalse: [self selectedSystemCategoryName]). self systemCategoryListIndex: (oldIndex = 0 ifTrue: [self systemCategoryList size] ifFalse: [oldIndex]). self changed: #systemCategoryList.! ! !Browser methodsFor: 'system category functions' stamp: 'brp 8/4/2003 21:38'! alphabetizeSystemCategories self okToChange ifFalse: [^ false]. systemOrganizer sortCategories. self systemCategoryListIndex: 0. self changed: #systemCategoryList. ! ! !Browser methodsFor: 'system category functions' stamp: 'sd 1/5/2002 21:11'! browseAllClasses "Create and schedule a new browser on all classes alphabetically." | newBrowser | newBrowser _ HierarchyBrowser new initAlphabeticListing. self class openBrowserView: (newBrowser openSystemCatEditString: nil) label: 'All Classes Alphabetically'! ! !Browser methodsFor: 'system category functions' stamp: 'sd 1/5/2002 21:12'! buildSystemCategoryBrowserEditString: aString "Create and schedule a new system category browser with initial textual contents set to aString." | newBrowser | systemCategoryListIndex > 0 ifTrue: [newBrowser _ self class new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName. self class openBrowserView: (newBrowser openSystemCatEditString: aString) label: 'Classes in category ', newBrowser selectedSystemCategoryName]! ! !Browser methodsFor: 'system category functions' stamp: 'nk 2/14/2004 15:09' prior: 18653085! editSystemCategories "Retrieve the description of the class categories of the system organizer." self okToChange ifFalse: [^ self]. self systemCategoryListIndex: 0. self editSelection: #editSystemCategories. self changed: #editSystemCategories. self contentsChanged! ! !Browser methodsFor: 'system category functions' stamp: 'brp 8/4/2003 21:32' prior: 18657609! systemCategoryMenu: aMenu ^ aMenu labels: 'find class... (f) recent classes... (r) browse all browse printOut fileOut reorganize alphabetize update add item... rename... remove' lines: #(2 4 6 8) selections: #(findClass recent browseAllClasses buildSystemCategoryBrowser printOutSystemCategory fileOutSystemCategory editSystemCategories alphabetizeSystemCategories updateSystemCategories addSystemCategory renameSystemCategory removeSystemCategory )! ! !Browser methodsFor: 'system category list' stamp: 'rhi 12/3/2001 22:32'! systemCategoryListIndex: anInteger "Set the selected system category index to be anInteger. Update all other selections to be deselected." systemCategoryListIndex _ anInteger. classListIndex _ 0. messageCategoryListIndex _ 0. messageListIndex _ 0. editSelection _ anInteger = 0 ifTrue: [#none] ifFalse: [#newClass]. metaClassIndicated _ false. self setClassOrganizer. contents _ nil. self changed: #systemCategorySelectionChanged. self changed: #systemCategoryListIndex. "update my selection" self changed: #classList. self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'system category list' stamp: 'nk 2/14/2004 15:06' prior: 34361309! systemCategoryListIndex: anInteger "Set the selected system category index to be anInteger. Update all other selections to be deselected." systemCategoryListIndex _ anInteger. classListIndex _ 0. messageCategoryListIndex _ 0. messageListIndex _ 0. self editSelection: ( anInteger = 0 ifTrue: [#none] ifFalse: [#newClass]). metaClassIndicated _ false. self setClassOrganizer. contents _ nil. self changed: #systemCategorySelectionChanged. self changed: #systemCategoryListIndex. "update my selection" self changed: #classList. self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'construction' stamp: 'nk 2/15/2004 13:49'! addLowerPanesTo: window at: nominalFractions with: editString | commentPane | super addLowerPanesTo: window at: nominalFractions with: editString. commentPane _ self buildMorphicCommentPane. window addMorph: commentPane fullFrame: (LayoutFrame fractions: (0@0.75 corner: 1@1)). self changed: #editSelection.! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 1/5/2002 21:07'! fullOnClass: aClass "Open a new full browser set to class." | brow | brow _ self new. brow setClass: aClass selector: nil. Browser openBrowserView: (brow openEditString: nil) label: 'System Browser'! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11' prior: 34363166! fullOnClass: aClass "Open a new full browser set to class." | brow | brow _ self new. brow setClass: aClass selector: nil. ^ Browser openBrowserView: (brow openEditString: nil) label: 'System Browser'! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 2/2/2004 13:50' prior: 34363471! fullOnClass: aClass "Open a new full browser set to class." | brow | brow _ self new. brow setClass: aClass selector: nil. ^ self openBrowserView: (brow openEditString: nil) label: 'System Browser'! ! !Browser class methodsFor: 'instance creation' stamp: 'nk 2/13/2001 13:47'! fullOnClass: aClass selector: aSelector "Open a new full browser set to class." | brow classToUse | classToUse _ Preferences browseToolClass. brow _ classToUse new. brow setClass: aClass selector: aSelector. classToUse openBrowserView: (brow openEditString: nil) label: brow labelString! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11' prior: 34364067! fullOnClass: aClass selector: aSelector "Open a new full browser set to class." | brow classToUse | classToUse _ Preferences browseToolClass. brow _ classToUse new. brow setClass: aClass selector: aSelector. ^ classToUse openBrowserView: (brow openEditString: nil) label: brow labelString! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 1/5/2002 21:08'! newOnCategory: aCategory "Browse the system category of the given name. 7/13/96 sw" "Browser newOnCategory: 'Interface-Browser'" | newBrowser catList | newBrowser _ self new. catList _ newBrowser systemCategoryList. newBrowser systemCategoryListIndex: (catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']). self openBrowserView: (newBrowser openSystemCatEditString: nil) label: 'Classes in category ', aCategory ! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:12' prior: 34364841! newOnCategory: aCategory "Browse the system category of the given name. 7/13/96 sw" "Browser newOnCategory: 'Interface-Browser'" | newBrowser catList | newBrowser _ self new. catList _ newBrowser systemCategoryList. newBrowser systemCategoryListIndex: (catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']). ^ self openBrowserView: (newBrowser openSystemCatEditString: nil) label: 'Classes in category ', aCategory ! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 1/5/2002 21:09'! newOnClass: aClass label: aLabel "Open a new class browser on this class." | newBrowser | newBrowser _ self new. newBrowser setClass: aClass selector: nil. self openBrowserView: (newBrowser openOnClassWithEditString: nil) label: aLabel ! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:12' prior: 34365941! newOnClass: aClass label: aLabel "Open a new class browser on this class." | newBrowser | newBrowser _ self new. newBrowser setClass: aClass selector: nil. ^ self openBrowserView: (newBrowser openOnClassWithEditString: nil) label: aLabel ! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 1/5/2002 21:09'! newOnClass: aClass selector: aSymbol "Open a new class browser on this class." | newBrowser | newBrowser _ self new. newBrowser setClass: aClass selector: aSymbol. self openBrowserView: (newBrowser openOnClassWithEditString: nil) label: 'Class Browser: ', aClass name ! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:12' prior: 34366614! newOnClass: aClass selector: aSymbol "Open a new class browser on this class." | newBrowser | newBrowser _ self new. newBrowser setClass: aClass selector: aSymbol. ^ self openBrowserView: (newBrowser openOnClassWithEditString: nil) label: 'Class Browser: ', aClass name ! ! !Browser class methodsFor: 'instance creation' stamp: 'SD 9/15/2001 15:18'! openBrowser "Create and schedule a BrowserView with default browser label. The view consists of five subviews, starting with the list view of system categories of SystemOrganization. The initial text view part is empty." | br | br := self new. self openBrowserView: (br openEditString: nil) label: br defaultBrowserTitle ! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11' prior: 34367352! openBrowser "Create and schedule a BrowserView with default browser label. The view consists of five subviews, starting with the list view of system categories of SystemOrganization. The initial text view part is empty." | br | br := self new. ^ self openBrowserView: (br openEditString: nil) label: br defaultBrowserTitle. ! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11' prior: 18663700! openBrowserView: aBrowserView label: aString "Schedule aBrowserView, labelling the view aString." aBrowserView isMorph ifTrue: [(aBrowserView setLabel: aString) openInWorld] ifFalse: [aBrowserView label: aString. aBrowserView minimumSize: 300 @ 200. aBrowserView subViews do: [:each | each controller]. aBrowserView controller open]. ^ aBrowserView model! ! !Browser class methodsFor: 'instance creation' stamp: 'sps 3/9/2004 15:54' prior: 34368218! openBrowserView: aBrowserView label: aString "Schedule aBrowserView, labelling the view aString." aBrowserView isMorph ifTrue: [(aBrowserView setLabel: aString) openInWorld] ifFalse: [aBrowserView label: aString. aBrowserView minimumSize: 300 @ 200. aBrowserView subViews do: [:each | each controller]. aBrowserView controller open]. ^ aBrowserView model ! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 1/5/2002 21:10'! openMessageBrowserForClass: aBehavior selector: aSymbol editString: aString "Create and schedule a message browser for the class, aBehavior, in which the argument, aString, contains characters to be edited in the text view. These characters are the source code for the message selector aSymbol." | newBrowser | (newBrowser _ self new) setClass: aBehavior selector: aSymbol. ^ self openBrowserView: (newBrowser openMessageEditString: aString) label: newBrowser selectedClassOrMetaClassName , ' ' , newBrowser selectedMessageName ! ! !Browser class methodsFor: 'instance creation' stamp: 'sw 6/11/2001 17:38'! prototypicalToolWindow "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" | aWindow | aWindow _ self new openAsMorphEditing: nil. aWindow setLabel: 'System Browser'; applyModelExtent. ^ aWindow! ! !Browser class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:27' prior: 18664736! initialize "Browser initialize" RecentClasses := OrderedCollection new. self registerInFlapsRegistry. ! ! !Browser class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:32'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(#Browser #prototypicalToolWindow 'Browser' 'A Browser is a tool that allows you to view all the code of all the classes in the system' ) forFlapNamed: 'Tools']! ! !Browser class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:32'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !Browser class methodsFor: 'window color' stamp: 'sw 2/26/2002 13:46'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Browser' brightColor: #lightGreen pastelColor: #paleGreen helpMessage: 'The standard "system browser" tool that allows you to browse through all the code in the system'! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 13:41'! hideOrShowPane (self model editSelection == #editClass) ifTrue: [ self showPane ] ifFalse: [ self hidePane ]! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 14:08'! hidePane | win | self lowerPane ifNotNilDo: [ :lp | lp layoutFrame bottomFraction: self layoutFrame bottomFraction ]. win _ self window ifNil: [ ^self ]. self delete. win updatePanesFromSubmorphs.! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 14:09'! showPane owner ifNil: [ | win | win _ self window ifNil: [ ^self ]. win addMorph: self fullFrame: self layoutFrame. win updatePanesFromSubmorphs ]. self lowerPane ifNotNilDo: [ :lp | lp layoutFrame bottomFraction: self layoutFrame topFraction ]! ! !BrowserCommentTextMorph methodsFor: 'updating' stamp: 'nk 2/15/2004 14:11'! noteNewOwner: win super noteNewOwner: win. self setProperty: #browserWindow toValue: win. win ifNil: [ ^self ]. win setProperty: #browserClassCommentPane toValue: self. self setProperty: #browserLowerPane toValue: (win submorphThat: [ :m | m isAlignmentMorph and: [ m layoutFrame bottomFraction = 1 ]] ifNone: []). ! ! !BrowserCommentTextMorph methodsFor: 'updating' stamp: 'nk 2/15/2004 13:42'! update: anAspect super update: anAspect. anAspect == #editSelection ifFalse: [ ^self ]. self hideOrShowPane! ! !BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:12'! lowerPane "Answer the AlignmentMorph that I live beneath" ^self valueOfProperty: #browserLowerPane! ! !BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:07'! window ^self owner ifNil: [ self valueOfProperty: #browserWindow ].! ! !BrowserCommentTextMorph commentStamp: '' prior: 0! I am a PluggableTextMorph that knows enough to make myself invisible when necessary.! !ButtonPhaseType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:23'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #ButtonPhase. symbols _ #(buttonDown whilePressed buttonUp)! ! !ButtonPhaseType methodsFor: 'color' stamp: 'sw 9/27/2001 17:20'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(0.806 1.0 0.806) ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 09:43'! actWhen ^ actWhen! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 09:43'! actWhen: condition (#(buttonDown mouseDown) includes: condition) ifTrue: [ actWhen _ #mouseDown ]. (#(buttonUp mouseUp) includes: condition) ifTrue: [ actWhen _ #mouseUp ]. (#(whilePressed mouseStillDown) includes: condition) ifTrue: [ actWhen _ #mouseStillDown ]. self setEventHandlers: true.! ! !ButtonProperties methodsFor: 'accessing'! actionSelector ^ actionSelector ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 08:46'! actionSelector: aSymbolOrString aSymbolOrString isEmptyOrNil ifTrue: [^actionSelector _ nil]. aSymbolOrString = 'nil' ifTrue: [^actionSelector _ nil]. actionSelector _ aSymbolOrString asSymbol. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:35'! addTextToButton: aStringOrText | tm existing | existing _ self currentTextMorphsInButton. existing do: [ :x | x delete]. aStringOrText ifNil: [^self]. tm _ TextMorph new contents: aStringOrText. tm fullBounds; lock; align: tm center with: visibleMorph center; setProperty: #textAddedByButtonProperties toValue: true; setToAdhereToEdge: #center. "maybe the user would like personal control here" "visibleMorph extent: (tm extent * 1.5) rounded." visibleMorph addMorphFront: tm. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 07:35'! adjustPositionsAfterSizeChange "re-center label, etc??"! ! !ButtonProperties methodsFor: 'accessing'! arguments ^ arguments ! ! !ButtonProperties methodsFor: 'accessing'! arguments: aCollection arguments _ aCollection asArray copy. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 11:40'! bringUpToDate self establishEtoyLabelWording ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:18'! currentLook ^currentLook ifNil: [currentLook _ #normal]! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:18'! currentTextInButton | existing | existing _ self currentTextMorphsInButton. existing isEmpty ifTrue: [^nil]. ^existing first ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:17'! currentTextMorphsInButton ^visibleMorph submorphsSatisfying: [ :x | x hasProperty: #textAddedByButtonProperties ] ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 11:47'! establishEtoyLabelWording "Set the label wording, unless it has already been manually edited" | itsName | self isTileScriptingElement ifFalse: [^self]. itsName _ target externalName. self addTextToButton: itsName, ' ', arguments first. visibleMorph setBalloonText: 'click to run the script "', arguments first, '" in player named "', itsName, '"'! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 19:01'! figureOutScriptSelector self halt! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 11:47'! isTileScriptingElement actionSelector == #runScript: ifFalse: [^false]. arguments isEmptyOrNil ifTrue: [^false]. ^target isKindOf: Player ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:19'! lockAnyText self currentTextMorphsInButton do: [ :x | x lock: true].! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:15'! mouseDownHaloColor ^mouseDownHaloColor! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:15'! mouseDownHaloColor: x mouseDownHaloColor _ x! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:31'! mouseDownHaloWidth ^mouseDownHaloWidth! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:31'! mouseDownHaloWidth: x mouseDownHaloWidth _ x! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:43'! mouseDownLook: aFormOrMorph self setLook: #mouseDown to: aFormOrMorph ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:43'! mouseEnterLook: aFormOrMorph self setLook: #mouseEnter to: aFormOrMorph ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:16'! mouseOverHaloColor ^mouseOverHaloColor! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:16'! mouseOverHaloColor: x mouseOverHaloColor _ x! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:30'! mouseOverHaloWidth ^mouseOverHaloWidth! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:31'! mouseOverHaloWidth: x mouseOverHaloWidth _ x! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:13'! privateSetLook: aSymbol to: aFormOrMorph | f | f _ (aFormOrMorph isKindOf: Form) ifTrue: [ aFormOrMorph ] ifFalse: [ aFormOrMorph imageForm ]. self stateCostumes at: aSymbol put: f! ! !ButtonProperties methodsFor: 'accessing' stamp: 'gm 2/22/2003 14:53' prior: 34378246! privateSetLook: aSymbol to: aFormOrMorph | f | f := (aFormOrMorph isForm) ifTrue: [aFormOrMorph] ifFalse: [aFormOrMorph imageForm]. self stateCostumes at: aSymbol put: f! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/10/2001 13:57'! setEventHandlers: enabled enabled ifTrue: [ visibleMorph on: #mouseDown send: #mouseDown: to: self. visibleMorph on: #mouseStillDown send: #mouseStillDown: to: self. visibleMorph on: #mouseUp send: #mouseUp: to: self. visibleMorph on: #mouseEnter send: #mouseEnter: to: self. visibleMorph on: #mouseLeave send: #mouseLeave: to: self. ] ifFalse: [ #(mouseDown mouseStillDown mouseUp mouseEnter mouseLeave) do: [ :sel | visibleMorph on: sel send: nil to: nil ]. ]. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:14'! setLook: aSymbol to: aFormOrMorph (self stateCostumes includesKey: #normal) ifFalse: [ self privateSetLook: #normal to: visibleMorph. ]. self privateSetLook: aSymbol to: aFormOrMorph. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:30'! stateCostumes ^stateCostumes ifNil: [stateCostumes _ Dictionary new]! ! !ButtonProperties methodsFor: 'accessing'! target ^ target ! ! !ButtonProperties methodsFor: 'accessing'! target: anObject target _ anObject ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:19'! unlockAnyText self currentTextMorphsInButton do: [ :x | x lock: false].! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 15:43'! visibleMorph: x visibleMorph ifNotNil: [self setEventHandlers: false]. visibleMorph _ x. visibleMorph ifNotNil: [self setEventHandlers: true]. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 09:09'! wantsRolloverIndicator ^wantsRolloverIndicator ifNil: [false]! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/10/2001 13:59'! wantsRolloverIndicator: aBoolean wantsRolloverIndicator _ aBoolean. wantsRolloverIndicator ifTrue: [ self setEventHandlers: true. ].! ! !ButtonProperties methodsFor: 'copying' stamp: 'jm 7/28/97 11:52'! updateReferencesUsing: aDictionary "If the arguments array points at a morph we are copying, then point at the new copy. And also copies the array, which is important!!" super updateReferencesUsing: aDictionary. arguments _ arguments collect: [:old | aDictionary at: old ifAbsent: [old]]. ! ! !ButtonProperties methodsFor: 'copying' stamp: 'tk 1/6/1999 17:55'! veryDeepFixupWith: deepCopier "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. target _ deepCopier references at: target ifAbsent: [target]. arguments _ arguments collect: [:each | deepCopier references at: each ifAbsent: [each]]. ! ! !ButtonProperties methodsFor: 'copying' stamp: 'RAA 3/16/2001 08:21'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. "target _ target. Weakly copied" "actionSelector _ actionSelector. a Symbol" "arguments _ arguments. All weakly copied" actWhen _ actWhen veryDeepCopyWith: deepCopier. "oldColor _ oldColor veryDeepCopyWith: deepCopier." visibleMorph _ visibleMorph. "I guess this will have been copied already if needed" delayBetweenFirings _ delayBetweenFirings. mouseDownHaloColor _ mouseDownHaloColor. stateCostumes _ stateCostumes veryDeepCopyWith: deepCopier. currentLook _ currentLook.! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/16/2001 08:28'! addMouseOverHalo self wantsRolloverIndicator ifTrue: [ visibleMorph addMouseActionIndicatorsWidth: mouseOverHaloWidth color: mouseOverHaloColor. ]. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/8/2001 09:29'! delayBetweenFirings ^delayBetweenFirings! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/8/2001 09:55'! delayBetweenFirings: millisecondsOrNil delayBetweenFirings _ millisecondsOrNil! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/15/2001 09:21'! displayCostume: aSymbol self currentLook == aSymbol ifTrue: [^true]. self stateCostumes at: aSymbol ifPresent: [ :aForm | currentLook _ aSymbol. visibleMorph wearCostume: aForm. ^true ]. ^false ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 08:58'! doButtonAction self doButtonAction: nil! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 17:08'! doButtonAction: evt | arity | target ifNil: [^self]. actionSelector ifNil: [^self]. arguments ifNil: [arguments _ #()]. Cursor normal showWhile: [ arity _ actionSelector numArgs. arity = arguments size ifTrue: [ target perform: actionSelector withArguments: arguments ]. arity = (arguments size + 1) ifTrue: [ target perform: actionSelector withArguments: {evt},arguments ]. arity = (arguments size + 2) ifTrue: [ target perform: actionSelector withArguments: {evt. visibleMorph},arguments ]. ]! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/14/2001 19:01'! editButtonsScript: evt "The user has touched my Scriptor halo-handle. Bring up a Scriptor on the script of the button." | cardsPasteUp cardsPlayer anEditor scriptSelector | cardsPasteUp _ self pasteUpMorph. (cardsPlayer _ cardsPasteUp assuredPlayer) assureUniClass. scriptSelector _ self figureOutScriptSelector. scriptSelector ifNil: [ scriptSelector _ cardsPasteUp scriptSelectorToTriggerFor: self. anEditor _ cardsPlayer newTextualScriptorFor: scriptSelector. evt hand attachMorph: anEditor. ^self ]. (cardsPlayer class selectors includes: scriptSelector) ifTrue: [ anEditor _ cardsPlayer scriptEditorFor: scriptSelector. evt hand attachMorph: anEditor. ^self ]. "Method somehow got removed; I guess we start aftresh" scriptSelector _ nil. ^ self editButtonsScript! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/14/2001 18:40'! mouseDown: evt self displayCostume: #mouseDown. mouseDownTime _ Time millisecondClockValue. nextTimeToFire _ nil. delayBetweenFirings ifNotNil: [ nextTimeToFire _ mouseDownTime + delayBetweenFirings. ]. self wantsRolloverIndicator ifTrue: [ visibleMorph addMouseActionIndicatorsWidth: mouseDownHaloWidth color: mouseDownHaloColor. ]. actWhen == #mouseDown ifFalse: [^self]. (visibleMorph containsPoint: evt cursorPoint) ifFalse: [^self]. self doButtonAction: evt. "===== aMorph . now _ Time millisecondClockValue. oldColor _ color. actWhen == #buttonDown ifTrue: [self doButtonAction] ifFalse: [ self updateVisualState: evt; refreshWorld]. dt _ Time millisecondClockValue - now max: 0. dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]. self mouseStillDown: evt. ====="! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/16/2001 08:29'! mouseEnter: evt self displayCostume: #mouseEnter. self addMouseOverHalo. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/14/2001 18:39'! mouseLeave: evt self displayCostume: #normal. visibleMorph deleteAnyMouseActionIndicators. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/8/2001 07:57'! mouseMove: evt actWhen == #mouseDown ifTrue: [^ self]. self updateVisualState: evt.! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 08:57'! mouseStillDown: evt (visibleMorph containsPoint: evt cursorPoint) ifFalse: [^self]. nextTimeToFire ifNil: [^self]. nextTimeToFire <= Time millisecondClockValue ifTrue: [ self doButtonAction: evt. nextTimeToFire _ Time millisecondClockValue + self delayBetweenFirings. ^self ]. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/16/2001 08:29'! mouseUp: evt (self displayCostume: #mouseEnter) ifFalse: [self displayCostume: #normal]. self addMouseOverHalo. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 12:27'! replaceVisibleMorph: aNewMorph | old oldOwner oldText | old _ visibleMorph. oldText _ self currentTextInButton. self visibleMorph: nil. old buttonProperties: nil. aNewMorph buttonProperties: self. self visibleMorph: aNewMorph. self addTextToButton: oldText. oldOwner _ old owner ifNil: [^self]. oldOwner replaceSubmorph: old by: aNewMorph.! ! !ButtonProperties methodsFor: 'initialization' stamp: 'ar 3/17/2001 20:12'! adaptToWorld: aWorld super adaptToWorld: aWorld. target _ target adaptedToWorld: aWorld.! ! !ButtonProperties methodsFor: 'initialization' stamp: 'RAA 3/9/2001 09:47'! initialize wantsRolloverIndicator _ false. delayBetweenFirings _ nil. mouseOverHaloWidth _ 10. mouseOverHaloColor _ Color blue alpha: 0.3. mouseDownHaloWidth _ 15. mouseDownHaloColor _ Color blue alpha: 0.7. arguments _ #().! ! !ButtonProperties methodsFor: 'menu' stamp: 'RAA 3/8/2001 07:56'! setActWhen actWhen _ (SelectionMenu selections: #(mouseDown mouseUp mouseStillDown)) startUpWithCaption: 'Choose one of the following conditions' ! ! !ButtonProperties methodsFor: 'menu'! setActionSelector | newSel | newSel _ FillInTheBlank request: 'Please type the selector to be sent to the target when this button is pressed' initialAnswer: actionSelector. newSel isEmpty ifFalse: [self actionSelector: newSel]. ! ! !ButtonProperties methodsFor: 'menu'! setArguments | s newArgs newArgsArray | s _ WriteStream on: ''. arguments do: [:arg | arg printOn: s. s nextPutAll: '. ']. newArgs _ FillInTheBlank request: 'Please type the arguments to be sent to the target when this button is pressed separated by periods' initialAnswer: s contents. newArgs isEmpty ifFalse: [ newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false. self arguments: newArgsArray]. ! ! !ButtonProperties methodsFor: 'menu'! setLabel | newLabel | newLabel _ FillInTheBlank request: 'Please a new label for this button' initialAnswer: self label. newLabel isEmpty ifFalse: [self label: newLabel]. ! ! !ButtonProperties methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'! setPageSound: event ^ target menuPageSoundFor: self event: event! ! !ButtonProperties methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'! setPageVisual: event ^ target menuPageVisualFor: self event: event! ! !ButtonProperties methodsFor: 'menu'! setTarget: evt | rootMorphs | rootMorphs _ self world rootMorphsAt: evt hand targetOffset. rootMorphs size > 1 ifTrue: [target _ rootMorphs at: 2] ifFalse: [target _ nil. ^ self]. ! ! !ButtonProperties methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:52' prior: 34388944! setTarget: evt | rootMorphs | rootMorphs := self world rootMorphsAt: evt hand targetOffset. target := rootMorphs size > 1 ifTrue: [rootMorphs second] ifFalse: [nil]! ! !ButtonProperties methodsFor: 'visual properties' stamp: 'RAA 3/8/2001 14:24'! updateVisualState: evt " oldColor ifNil: [^self]. self color: ((self containsPoint: evt cursorPoint) ifTrue: [oldColor mixed: 1/2 with: Color white] ifFalse: [oldColor])"! ! !ButtonProperties commentStamp: '' prior: 0! ButtonProperties test1 ButtonProperties test2 ButtonProperties test3 ! !ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:29'! ellipticalButtonWithText: aStringOrText | m prop | m _ EllipseMorph new. prop _ m ensuredButtonProperties. prop target: #(1 2 3); actionSelector: #inspect; actWhen: #mouseUp; addTextToButton: aStringOrText; wantsRolloverIndicator: true. ^m! ! !ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 08:31'! test1 | m prop | m _ EllipseMorph new. prop _ m ensuredButtonProperties. prop target: #(1 2 3); actionSelector: #inspect; actWhen: #mouseUp. m openInWorld.! ! !ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 08:41'! test2 (self ellipticalButtonWithText: 'Hello world') openInWorld.! ! !ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 12:21'! test3 | m | (m _ self ellipticalButtonWithText: 'Hello world') openInWorld. m ensuredButtonProperties target: 1; actionSelector: #beep; delayBetweenFirings: 1000.! ! !ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 34390649! test3 | m | (m _ self ellipticalButtonWithText: 'Hello world') openInWorld. m ensuredButtonProperties target: Beeper; actionSelector: #beep; delayBetweenFirings: 1000.! ! !ButtonProperties class methodsFor: 'printing' stamp: 'sw 2/16/98 01:31'! defaultNameStemForInstances ^ 'button'! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:25'! acceptDroppingMorph: aMorph event: evt in: aSubmorph | why | self clearDropHighlightingEvt: evt morph: aSubmorph. why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs. why == #changeTargetMorph ifTrue: [ self targetProperties replaceVisibleMorph: aMorph. myTarget _ aMorph. self rebuild. ^true ]. why == #changeTargetTarget ifTrue: [ (aMorph setAsActionInButtonProperties: self targetProperties) ifFalse: [ ^false ]. ^true ]. why == #changeTargetMouseDownLook ifTrue: [ self targetProperties mouseDownLook: aMorph. ^false ]. why == #changeTargetMouseEnterLook ifTrue: [ self targetProperties mouseEnterLook: aMorph. ^false ]. ^false ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:45'! addTextToTarget self targetProperties currentTextInButton ifNil: [ self targetProperties addTextToButton: '???'. ]. self targetProperties currentTextInButton openATextPropertySheet. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:08'! adjustTargetMouseDownHaloSize: aFractionalPoint self targetProperties mouseDownHaloWidth: ((aFractionalPoint x * 10) rounded max: 0). ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:08'! adjustTargetMouseOverHaloSize: aFractionalPoint self targetProperties mouseOverHaloWidth: ((aFractionalPoint x * 10) rounded max: 0). ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:14'! adjustTargetRepeatingInterval: aFractionalPoint | n | n _ 2 raisedTo: ((aFractionalPoint x * 12) rounded max: 1). self targetProperties delayBetweenFirings: n. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:26'! allowDropsInto: aMorph withIntent: aSymbol aMorph on: #mouseEnterDragging send: #mouseEnterDraggingEvt:morph: to: self; on: #mouseLeaveDragging send: #mouseLeaveDraggingEvt:morph: to: self; on: #mouseLeave send: #clearDropHighlightingEvt:morph: to: self; setProperty: #handlerForDrops toValue: self; setProperty: #intentOfDroppedMorphs toValue: aSymbol; borderWidth: 1; borderColor: Color gray ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 13:03'! attachMorphOfClass: aClass to: aHand aHand attachMorph: aClass new! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:24'! clearDropHighlightingEvt: evt morph: aMorph aMorph color: Color transparent. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:25'! doEnables | itsName | self allMorphsDo: [ :each | itsName _ each knownName. itsName == #pickerForMouseDownColor ifTrue: [ self enable: each when: self targetWantsRollover ]. itsName == #pickerForMouseOverColor ifTrue: [ self enable: each when: self targetWantsRollover ]. itsName == #paneForRepeatingInterval ifTrue: [ self enable: each when: self targetRepeatingWhileDown ]. ]. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/10/2001 13:36'! doRemoveProperties myTarget buttonProperties: nil. self delete.! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 13:02'! mouseDownEvent: evt for: aSubmorph | why aMenu | why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs. why == #changeTargetMorph ifTrue: [ aMenu _ MenuMorph new defaultTarget: self. { {'Rectangle'. RectangleMorph}. {'Ellipse'. EllipseMorph} } do: [ :pair | aMenu add: pair first target: self selector: #attachMorphOfClass:to: argumentList: {pair second. evt hand}. ]. aMenu popUpEvent: evt in: self world. ^self ]. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:00' prior: 34394563! mouseDownEvent: evt for: aSubmorph | why aMenu | why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs. why == #changeTargetMorph ifTrue: [ aMenu _ MenuMorph new defaultTarget: self. { {'Rectangle'. RectangleMorph}. {'Ellipse'. EllipseMorph} } do: [ :pair | aMenu add: pair first translated target: self selector: #attachMorphOfClass:to: argumentList: {pair second. evt hand}. ]. aMenu popUpEvent: evt in: self world. ^self ]. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:33'! mouseEnterDraggingEvt: evt morph: aMorph aMorph color: (Color red alpha: 0.5)! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:24'! mouseLeaveDraggingEvt: evt morph: aMorph self clearDropHighlightingEvt: evt morph: aMorph. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:48'! paneForActsOnMouseDownToggle ^self inARow: { self directToggleButtonFor: self getter: #targetActsOnMouseDown setter: #toggleTargetActsOnMouseDown help: 'If the button is to act when the mouse goes down'. self lockedString: ' Mouse-down action'. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34396065! paneForActsOnMouseDownToggle ^self inARow: { self directToggleButtonFor: self getter: #targetActsOnMouseDown setter: #toggleTargetActsOnMouseDown help: 'If the button is to act when the mouse goes down' translated. self lockedString: ' Mouse-down action' translated. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:49'! paneForActsOnMouseUpToggle ^self inARow: { self directToggleButtonFor: self getter: #targetActsOnMouseUp setter: #toggleTargetActsOnMouseUp help: 'If the button is to act when the mouse goes up'. self lockedString: ' Mouse-up action'. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34396820! paneForActsOnMouseUpToggle ^self inARow: { self directToggleButtonFor: self getter: #targetActsOnMouseUp setter: #toggleTargetActsOnMouseUp help: 'If the button is to act when the mouse goes up' translated. self lockedString: ' Mouse-up action' translated. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 09:56'! paneForButtonSelectorReport ^self inARow: { self lockedString: 'Action: '. UpdatingStringMorph new useStringFormat; getSelector: #actionSelector; target: self targetProperties; growable: true; minimumWidth: 24; lock. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34397555! paneForButtonSelectorReport ^self inARow: { self lockedString: 'Action: ' translated. UpdatingStringMorph new useStringFormat; getSelector: #actionSelector; target: self targetProperties; growable: true; minimumWidth: 24; lock. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 09:01'! paneForButtonTargetReport | r | r _ self inARow: { self lockedString: 'Target: '. UpdatingStringMorph new useStringFormat; getSelector: #target; target: self targetProperties; growable: true; minimumWidth: 24; lock. }. r hResizing: #shrinkWrap. self allowDropsInto: r withIntent: #changeTargetTarget. r setBalloonText: 'Drop another morph here to change the target and action of this button. (Only some morphs will work)'. ^self inARow: {r} ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34398256! paneForButtonTargetReport | r | r _ self inARow: { self lockedString: 'Target: ' translated. UpdatingStringMorph new useStringFormat; getSelector: #target; target: self targetProperties; growable: true; minimumWidth: 24; lock. }. r hResizing: #shrinkWrap. self allowDropsInto: r withIntent: #changeTargetTarget. r setBalloonText: 'Drop another morph here to change the target and action of this button. (Only some morphs will work)' translated. ^self inARow: {r} ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 09:22'! paneForChangeMouseDownLook | r | r _ self inARow: { self lockedString: ' Mouse-down look '. }. self allowDropsInto: r withIntent: #changeTargetMouseDownLook. r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse is clicked in it.'. ^r ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34399428! paneForChangeMouseDownLook | r | r _ self inARow: { self lockedString: ' Mouse-down look ' translated. }. self allowDropsInto: r withIntent: #changeTargetMouseDownLook. r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse is clicked in it.' translated. ^r ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 09:03'! paneForChangeMouseEnterLook | r | r _ self inARow: { self lockedString: ' Mouse-enter look '. }. self allowDropsInto: r withIntent: #changeTargetMouseEnterLook. r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse enters it.'. ^r ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34400240! paneForChangeMouseEnterLook | r | r _ self inARow: { self lockedString: ' Mouse-enter look ' translated. }. self allowDropsInto: r withIntent: #changeTargetMouseEnterLook. r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse enters it.' translated. ^r ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 09:00'! paneForChangeVisibleMorph | r | r _ self inARow: { self lockedString: ' Change morph '. }. r on: #mouseDown send: #mouseDownEvent:for: to: self. self allowDropsInto: r withIntent: #changeTargetMorph. r setBalloonText: 'Drop another morph here to change the visual appearance of this button. Or click here to get a menu of possible replacement morphs.'. ^r ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34401044! paneForChangeVisibleMorph | r | r _ self inARow: { self lockedString: ' Change morph ' translated. }. r on: #mouseDown send: #mouseDownEvent:for: to: self. self allowDropsInto: r withIntent: #changeTargetMorph. r setBalloonText: 'Drop another morph here to change the visual appearance of this button. Or click here to get a menu of possible replacement morphs.' translated. ^r ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:33'! paneForMouseDownColorPicker ^self inAColumn: { (self inAColumn: { self colorPickerFor: self targetProperties getter: #mouseDownHaloColor setter: #mouseDownHaloColor:. self lockedString: 'mouse-down halo color'. self paneForMouseDownHaloWidth. } named: #pickerForMouseDownColor) layoutInset: 0. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34401997! paneForMouseDownColorPicker ^self inAColumn: { (self inAColumn: { self colorPickerFor: self targetProperties getter: #mouseDownHaloColor setter: #mouseDownHaloColor:. self lockedString: 'mouse-down halo color' translated. self paneForMouseDownHaloWidth. } named: #pickerForMouseDownColor) layoutInset: 0. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:07'! paneForMouseDownHaloWidth ^(self inARow: { self buildFakeSlider: #valueForMouseDownHaloWidth selector: #adjustTargetMouseDownHaloSize: help: 'Drag in here to change the halo width' }) hResizing: #shrinkWrap ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01' prior: 34402869! paneForMouseDownHaloWidth ^(self inARow: { self buildFakeSlider: #valueForMouseDownHaloWidth selector: #adjustTargetMouseDownHaloSize: help: 'Drag in here to change the halo width' translated }) hResizing: #shrinkWrap ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:34'! paneForMouseOverColorPicker ^self inAColumn: { (self inAColumn: { self colorPickerFor: self targetProperties getter: #mouseOverHaloColor setter: #mouseOverHaloColor:. self lockedString: 'mouse-over halo color'. self paneForMouseOverHaloWidth. } named: #pickerForMouseOverColor) layoutInset: 0. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34403523! paneForMouseOverColorPicker ^self inAColumn: { (self inAColumn: { self colorPickerFor: self targetProperties getter: #mouseOverHaloColor setter: #mouseOverHaloColor:. self lockedString: 'mouse-over halo color' translated. self paneForMouseOverHaloWidth. } named: #pickerForMouseOverColor) layoutInset: 0. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:09'! paneForMouseOverHaloWidth ^(self inARow: { self buildFakeSlider: #valueForMouseOverHaloWidth selector: #adjustTargetMouseOverHaloSize: help: 'Drag in here to change the halo width' }) hResizing: #shrinkWrap ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34404395! paneForMouseOverHaloWidth ^(self inARow: { self buildFakeSlider: #valueForMouseOverHaloWidth selector: #adjustTargetMouseOverHaloSize: help: 'Drag in here to change the halo width' translated }) hResizing: #shrinkWrap ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:16'! paneForRepeatingInterval ^(self inAColumn: { self buildFakeSlider: #valueForRepeatingInterval selector: #adjustTargetRepeatingInterval: help: 'Drag in here to change how often the button repeats while the mouse is down' } named: #paneForRepeatingInterval ) hResizing: #shrinkWrap ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34405047! paneForRepeatingInterval ^(self inAColumn: { self buildFakeSlider: #valueForRepeatingInterval selector: #adjustTargetRepeatingInterval: help: 'Drag in here to change how often the button repeats while the mouse is down' translated } named: #paneForRepeatingInterval ) hResizing: #shrinkWrap ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:19'! paneForWantsFiringWhileDownToggle ^self inARow: { self directToggleButtonFor: self getter: #targetRepeatingWhileDown setter: #toggleTargetRepeatingWhileDown help: 'Turn repeating while mouse is held down on or off'. self lockedString: ' Mouse-down repeating '. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34405869! paneForWantsFiringWhileDownToggle ^self inARow: { self directToggleButtonFor: self getter: #targetRepeatingWhileDown setter: #toggleTargetRepeatingWhileDown help: 'Turn repeating while mouse is held down on or off' translated. self lockedString: ' Mouse-down repeating ' translated. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:26'! paneForWantsRolloverToggle ^self inARow: { self directToggleButtonFor: self getter: #targetWantsRollover setter: #toggleTargetWantsRollover help: 'Turn mouse-over highlighting on or off'. self lockedString: ' Mouse-over highlighting'. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02' prior: 34406656! paneForWantsRolloverToggle ^self inARow: { self directToggleButtonFor: self getter: #targetWantsRollover setter: #toggleTargetWantsRollover help: 'Turn mouse-over highlighting on or off' translated. self lockedString: ' Mouse-over highlighting' translated. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 12:51'! rebuild | buttonColor | myTarget ensuredButtonProperties. "self targetProperties unlockAnyText." "makes styling the text easier" self removeAllMorphs. self addAColumn: { self lockedString: 'Button Properties for ',myTarget name. }. self addAColumn: { self paneForButtonTargetReport. }. self addAColumn: { self paneForButtonSelectorReport. }. self addAColumn: { (self inARow: { self paneForActsOnMouseDownToggle. self paneForActsOnMouseUpToggle. }) hResizing: #shrinkWrap. }. self addAColumn: { self inARow: { (self paneForWantsFiringWhileDownToggle) hResizing: #shrinkWrap. self paneForRepeatingInterval. }. }. self addAColumn: { (self inAColumn: { self paneForWantsRolloverToggle. }) hResizing: #shrinkWrap. }. self addARow: { self paneForMouseOverColorPicker. self paneForMouseDownColorPicker. }. self addARow: { self paneForChangeMouseEnterLook. self paneForChangeMouseDownLook. }. buttonColor _ color lighter. self addARow: { self inAColumn: { self addARow: { self buttonNamed: 'Add label' action: #addTextToTarget color: buttonColor help: 'add some text to the button'. self buttonNamed: 'Remove label' action: #removeTextFromTarget color: buttonColor help: 'remove text from the button'. }. self addARow: { self buttonNamed: 'Accept' action: #doAccept color: buttonColor help: 'keep changes made and close panel'. self buttonNamed: 'Cancel' action: #doCancel color: buttonColor help: 'cancel changes made and close panel'. self transparentSpacerOfSize: 10@3. self buttonNamed: 'Main' action: #doMainProperties color: color lighter help: 'open a main properties panel for the morph'. self buttonNamed: 'Remove' action: #doRemoveProperties color: color lighter help: 'remove the button properties of this morph'. }. }. self inAColumn: { self paneForChangeVisibleMorph }. }. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:03' prior: 34407392! rebuild | buttonColor | myTarget ensuredButtonProperties. "self targetProperties unlockAnyText." "makes styling the text easier" self removeAllMorphs. self addAColumn: { self lockedString: ('Button Properties for {1}' translated format: {myTarget name}). }. self addAColumn: { self paneForButtonTargetReport. }. self addAColumn: { self paneForButtonSelectorReport. }. self addAColumn: { (self inARow: { self paneForActsOnMouseDownToggle. self paneForActsOnMouseUpToggle. }) hResizing: #shrinkWrap. }. self addAColumn: { self inARow: { (self paneForWantsFiringWhileDownToggle) hResizing: #shrinkWrap. self paneForRepeatingInterval. }. }. self addAColumn: { (self inAColumn: { self paneForWantsRolloverToggle. }) hResizing: #shrinkWrap. }. self addARow: { self paneForMouseOverColorPicker. self paneForMouseDownColorPicker. }. self addARow: { self paneForChangeMouseEnterLook. self paneForChangeMouseDownLook. }. buttonColor _ color lighter. self addARow: { self inAColumn: { self addARow: { self buttonNamed: 'Add label' translated action: #addTextToTarget color: buttonColor help: 'add some text to the button' translated. self buttonNamed: 'Remove label' translated action: #removeTextFromTarget color: buttonColor help: 'remove text from the button' translated. }. self addARow: { self buttonNamed: 'Accept' translated action: #doAccept color: buttonColor help: 'keep changes made and close panel' translated. self buttonNamed: 'Cancel' translated action: #doCancel color: buttonColor help: 'cancel changes made and close panel' translated. self transparentSpacerOfSize: 10@3. self buttonNamed: 'Main' translated action: #doMainProperties color: color lighter help: 'open a main properties panel for the morph' translated. self buttonNamed: 'Remove' translated action: #doRemoveProperties color: color lighter help: 'remove the button properties of this morph' translated. }. }. self inAColumn: { self paneForChangeVisibleMorph }. }. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:36'! removeTextFromTarget self targetProperties addTextToButton: nil. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:49'! targetActsOnMouseDown ^self targetProperties actWhen == #mouseDown! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:49'! targetActsOnMouseUp ^self targetProperties actWhen == #mouseUp! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:05'! targetProperties ^myTarget ensuredButtonProperties! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:01'! targetRepeatingWhileDown ^self targetProperties delayBetweenFirings notNil! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:28'! targetWantsRollover ^self targetProperties wantsRolloverIndicator! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:51'! toggleTargetActsOnMouseDown | prop | prop _ self targetProperties. prop actWhen: (prop actWhen == #mouseDown ifTrue: [nil] ifFalse: [#mouseDown])! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:50'! toggleTargetActsOnMouseUp | prop | prop _ self targetProperties. prop actWhen: (prop actWhen == #mouseUp ifTrue: [nil] ifFalse: [#mouseUp])! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:02'! toggleTargetRepeatingWhileDown | prop | prop _ self targetProperties. prop delayBetweenFirings: (prop delayBetweenFirings ifNil: [1024] ifNotNil: [nil]) ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:28'! toggleTargetWantsRollover self targetProperties wantsRolloverIndicator: self targetProperties wantsRolloverIndicator not! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:08'! valueForMouseDownHaloWidth ^'mouse-down halo width: ',self targetProperties mouseDownHaloWidth printString ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:09'! valueForMouseOverHaloWidth ^'mouse-over halo width: ',self targetProperties mouseOverHaloWidth printString ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:41'! valueForRepeatingInterval | n s | n _ self targetProperties delayBetweenFirings. s _ n ifNil: [ '*none*' ] ifNotNil: [ n < 1000 ifTrue: [n printString,' ms'] ifFalse: [(n // 1000) printString,' secs'] ]. ^'interval: ',s ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:04' prior: 34413967! valueForRepeatingInterval | n s | n _ self targetProperties delayBetweenFirings. s _ n ifNil: [ '*none*' ] ifNotNil: [ n < 1000 ifTrue: [n printString,' ms'] ifFalse: [(n // 1000) printString,' secs'] ]. ^'interval: ' translated, s ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:31'! wantsDroppedMorph: aMorph event: evt in: aSubmorph | why | why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs. ^why notNil " toValue: #changeTargetMorph. ^true"! ! !ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:17'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ self defaultColor darker! ! !ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:17'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.935 g: 0.839 b: 0.452! ! !ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'RAA 3/15/2001 11:53'! initialize super initialize. myTarget ifNil: [myTarget _ RectangleMorph new openInWorld]. self color: (Color r: 0.935 g: 0.839 b: 0.452). self borderColor: self color darker. thingsToRevert at: #buttonProperties: put: myTarget buttonProperties. self rebuild. ! ! !ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:17' prior: 34415293! initialize "initialize the state of the receiver" super initialize. "" myTarget ifNil: [myTarget _ RectangleMorph new openInWorld]. thingsToRevert at: #buttonProperties: put: myTarget buttonProperties. self rebuild! ! !ButtonPropertiesMorph commentStamp: '' prior: 0! ButtonPropertiesMorph basicNew targetMorph: self; initialize; openNearTarget! !ByteArray methodsFor: 'accessing' stamp: 'yo 10/23/2002 23:35'! asMultiString ^ MultiString fromByteArray: self. ! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'! byteSize ^self size! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 8/2/2003 19:29' prior: 18670736! longAt: index put: value bigEndian: aBool "Return a 32bit integer quantity starting from the given byte index" | b0 b1 b2 b3 | b0 _ value bitShift: -24. b0 _ (b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80). b0 < 0 ifTrue:[b0 := 256 + b0]. b1 _ (value bitShift: -16) bitAnd: 255. b2 _ (value bitShift: -8) bitAnd: 255. b3 _ value bitAnd: 255. aBool ifTrue:[ self at: index put: b0. self at: index+1 put: b1. self at: index+2 put: b2. self at: index+3 put: b3. ] ifFalse:[ self at: index put: b3. self at: index+1 put: b2. self at: index+2 put: b1. self at: index+3 put: b0. ]. ^value! ! !ByteArray methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52' prior: 18675394! hash "#hash is implemented, because #= is implemented" ^self class hashBytes: self startingWith: self species hash! ! !ByteArray class methodsFor: 'byte based hash' stamp: 'SqR 8/21/2002 16:21'! hashBytes: aByteArray startingWith: speciesHash "Answer the hash of a byte-indexed collection, using speciesHash as the initial value. See SmallInteger>>hashMultiply. The primitive should be renamed at a suitable point in the future" | byteArraySize hash low | self var: #aHash declareC: 'int speciesHash'. self var: #aByteArray declareC: 'unsigned char *aByteArray'. byteArraySize _ aByteArray size. hash _ speciesHash bitAnd: 16rFFFFFFF. 1 to: byteArraySize do: [:pos | hash _ hash + (aByteArray basicAt: pos). "Begin hashMultiply" low _ hash bitAnd: 16383. hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. ]. ^ hash! ! !ByteArrayBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/2/2003 19:28'! testByteArrayLongAt | ba value | ba := ByteArray new: 4. value := -1. self shouldnt:[ba longAt: 1 put: value bigEndian: true] raise: Error. self assert: (ba longAt: 1 bigEndian: true) = value. self shouldnt:[ba longAt: 1 put: value bigEndian: false] raise: Error. self assert: (ba longAt: 1 bigEndian: false) = value. ! ! !ByteEncoder methodsFor: 'writing' stamp: 'nk 12/31/2003 16:01'! nextPut: encodedObject "pass through for stream compatibility" ^target nextPut: encodedObject. ! ! !ByteEncoder methodsFor: 'writing' stamp: 'nk 12/31/2003 16:00'! nextPutAll: encodedObject "pass through for stream compatibility" ^target nextPutAll: encodedObject. ! ! !BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 5/22/2003 17:11'! initialize literals _ LiteralList new. "The following dicts are keyed by sequence id given by client in label: (and gotos)." seqOrder _ IdentityDictionary new. "seqId -> seq order num" seqBytes _ IdentityDictionary new. "seqId -> seq bytecodes" jumps _ IdentityDictionary new. "seqId -> last jump instr" instrMaps _ IdentityDictionary new. "seqId -> (clientInstr -> bytecode pos)" stacks _ IdentityDictionary new. "seqId -> stackCount" maxTemp _ 0. primNum _ 0. numArgs _ 0. currentSeqNum _ 0. orderSeq _ OrderedCollection new. "reverse map of seqOrder" "starting label in case one is not provided by client" self label: self newDummySeqId. ! ! !BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 5/22/2003 17:11' prior: 34418839! initialize literals _ LiteralList new. "The following dicts are keyed by sequence id given by client in label: (and gotos)." seqOrder _ IdentityDictionary new. "seqId -> seq order num" seqBytes _ IdentityDictionary new. "seqId -> seq bytecodes" jumps _ IdentityDictionary new. "seqId -> last jump instr" instrMaps _ IdentityDictionary new. "seqId -> (clientInstr -> bytecode pos)" stacks _ IdentityDictionary new. "seqId -> stackCount" maxTemp _ 0. primNum _ 0. numArgs _ 0. currentSeqNum _ 0. orderSeq _ OrderedCollection new. "reverse map of seqOrder" "starting label in case one is not provided by client" self label: self newDummySeqId. ! ! !BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 3/13/2003 18:21'! numArgs: n numArgs _ n! ! !BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 3/13/2003 18:21' prior: 34420339! numArgs: n numArgs _ n! ! !BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 3/13/2003 18:21'! primitiveNode: aPrimitiveNode literals isEmpty ifFalse: [self error: 'init prim before adding instructions']. aPrimitiveNode spec ifNotNil: [literals add: aPrimitiveNode spec]. primNum _ aPrimitiveNode num. ! ! !BytecodeGenerator methodsFor: 'initialize' stamp: 'ajh 3/13/2003 18:21' prior: 34420561! primitiveNode: aPrimitiveNode literals isEmpty ifFalse: [self error: 'init prim before adding instructions']. aPrimitiveNode spec ifNotNil: [literals add: aPrimitiveNode spec]. primNum _ aPrimitiveNode num. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 12:22'! goto: seqId stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [nil])). self saveLastJump: (Message selector: #from:goto: arguments: {currentSeqId. seqId}). self from: currentSeqId goto: seqId. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 12:22' prior: 34421159! goto: seqId stacks at: seqId put: (stack linkTo: (stacks at: seqId ifAbsentPut: [nil])). self saveLastJump: (Message selector: #from:goto: arguments: {currentSeqId. seqId}). self from: currentSeqId goto: seqId. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 13:26'! if: bool goto: seqId | otherwiseSeqId | otherwiseSeqId _ self newDummySeqId. self if: bool goto: seqId otherwise: otherwiseSeqId. self label: otherwiseSeqId. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 13:26' prior: 34421777! if: bool goto: seqId | otherwiseSeqId | otherwiseSeqId _ self newDummySeqId. self if: bool goto: seqId otherwise: otherwiseSeqId. self label: otherwiseSeqId. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 12:26'! if: bool goto: seqId1 otherwise: seqId2 stack pop. stacks at: seqId1 put: (stack linkTo: (stacks at: seqId1 ifAbsentPut: [nil])). stacks at: seqId2 put: (stack linkTo: (stacks at: seqId2 ifAbsentPut: [nil])). self saveLastJump: (Message selector: #from:if:goto:otherwise: arguments: {currentSeqId. bool. seqId1. seqId2}). self from: currentSeqId if: bool goto: seqId1 otherwise: seqId2. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 12:26' prior: 34422281! if: bool goto: seqId1 otherwise: seqId2 stack pop. stacks at: seqId1 put: (stack linkTo: (stacks at: seqId1 ifAbsentPut: [nil])). stacks at: seqId2 put: (stack linkTo: (stacks at: seqId2 ifAbsentPut: [nil])). self saveLastJump: (Message selector: #from:if:goto:otherwise: arguments: {currentSeqId. bool. seqId1. seqId2}). self from: currentSeqId if: bool goto: seqId1 otherwise: seqId2. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:16'! label: seqId (currentSeqId notNil and: [(jumps at: currentSeqId) isNil]) ifTrue: [ "make previous implicit goto explicit" self goto: seqId. ]. lastSpecialReturn _ nil. currentSeqId _ seqId. currentSeqNum _ currentSeqNum + 1. seqOrder at: seqId put: currentSeqNum. orderSeq at: currentSeqNum ifAbsentPut: [seqId]. bytes _ seqBytes at: seqId ifAbsentPut: [OrderedCollection new]. jumps at: seqId ifAbsentPut: [nil]. instrMap _ instrMaps at: seqId ifAbsentPut: [OrderedCollection new]. stack _ stacks at: seqId ifAbsentPut: [StackCount new]. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:16' prior: 34423255! label: seqId (currentSeqId notNil and: [(jumps at: currentSeqId) isNil]) ifTrue: [ "make previous implicit goto explicit" self goto: seqId. ]. lastSpecialReturn _ nil. currentSeqId _ seqId. currentSeqNum _ currentSeqNum + 1. seqOrder at: seqId put: currentSeqNum. orderSeq at: currentSeqNum ifAbsentPut: [seqId]. bytes _ seqBytes at: seqId ifAbsentPut: [OrderedCollection new]. jumps at: seqId ifAbsentPut: [nil]. instrMap _ instrMaps at: seqId ifAbsentPut: [OrderedCollection new]. stack _ stacks at: seqId ifAbsentPut: [StackCount new]. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:48'! popTop stack pop. self nextPut: (Bytecodes at: #popStackBytecode). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:48' prior: 34424545! popTop stack pop. self nextPut: (Bytecodes at: #popStackBytecode). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:48'! pushDup stack push. self nextPut: (Bytecodes at: #duplicateTopBytecode). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:48' prior: 34424865! pushDup stack push. self nextPut: (Bytecodes at: #duplicateTopBytecode). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:49'! pushInstVar: instVarIndex | interval | stack push. interval _ Bytecodes at: #pushReceiverVariableBytecode. instVarIndex <= interval size ifTrue: [ ^ self nextPut: (interval at: instVarIndex). ]. instVarIndex <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedPushBytecode). ^ self nextPut: (0 "instVar" << 6) + instVarIndex - 1. ]. instVarIndex <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 2 "pushInstVar" << 5. self nextPut: instVarIndex - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:49' prior: 34425197! pushInstVar: instVarIndex | interval | stack push. interval _ Bytecodes at: #pushReceiverVariableBytecode. instVarIndex <= interval size ifTrue: [ ^ self nextPut: (interval at: instVarIndex). ]. instVarIndex <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedPushBytecode). ^ self nextPut: (0 "instVar" << 6) + instVarIndex - 1. ]. instVarIndex <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 2 "pushInstVar" << 5. self nextPut: instVarIndex - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:50'! pushLiteral: object | index interval | stack push. (index _ SpecialConstants identityIndexOf: object) > 0 ifTrue: [ ^ self nextPut: (Bytecodes at: #pushConstantTrueBytecode) + index - 1]. index _ self addLiteral: object. interval _ Bytecodes at: #pushLiteralConstantBytecode. (index <= interval size) ifTrue: [ ^ self nextPut: (interval at: index) ]. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedPushBytecode). ^ self nextPut: 2 "lit constant" << 6 + index - 1 ]. index > 256 ifTrue: [self error: 'too many literals (>256)']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 3 "lit constant" << 5. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:50' prior: 34426523! pushLiteral: object | index interval | stack push. (index _ SpecialConstants identityIndexOf: object) > 0 ifTrue: [ ^ self nextPut: (Bytecodes at: #pushConstantTrueBytecode) + index - 1]. index _ self addLiteral: object. interval _ Bytecodes at: #pushLiteralConstantBytecode. (index <= interval size) ifTrue: [ ^ self nextPut: (interval at: index) ]. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedPushBytecode). ^ self nextPut: 2 "lit constant" << 6 + index - 1 ]. index > 256 ifTrue: [self error: 'too many literals (>256)']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 3 "lit constant" << 5. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:50'! pushReceiver stack push. self nextPut: (Bytecodes at: #pushReceiverBytecode)! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:50' prior: 34428085! pushReceiver stack push. self nextPut: (Bytecodes at: #pushReceiverBytecode)! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:51'! pushTemp: index | interval | stack push. maxTemp _ index max: maxTemp. interval _ Bytecodes at: #pushTemporaryVariableBytecode. index <= interval size ifTrue: [ ^ self nextPut: (interval at: index). ]. index <= 64 ifFalse: [self error: 'too many temp vars (>64)']. self nextPut: (Bytecodes at: #extendedPushBytecode). self nextPut: (1 "temp" << 6) + index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:51' prior: 34428423! pushTemp: index | interval | stack push. maxTemp _ index max: maxTemp. interval _ Bytecodes at: #pushTemporaryVariableBytecode. index <= interval size ifTrue: [ ^ self nextPut: (interval at: index). ]. index <= 64 ifFalse: [self error: 'too many temp vars (>64)']. self nextPut: (Bytecodes at: #extendedPushBytecode). self nextPut: (1 "temp" << 6) + index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:51'! pushThisContext stack push. self nextPut: (Bytecodes at: #pushActiveContextBytecode). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 17:51' prior: 34429349! pushThisContext stack push. self nextPut: (Bytecodes at: #pushActiveContextBytecode). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:01'! remoteReturn self saveLastJump: #return. self send: #remoteReturnTo:. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:01' prior: 34429707! remoteReturn self saveLastJump: #return. self send: #remoteReturnTo:. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02'! returnConstant: obj self saveLastJump: #return. bytes size = 0 ifTrue: [ lastSpecialReturn _ Message selector: #returnConstant: argument: obj]. obj caseOf: { [true] -> [self nextPut: (Bytecodes at: #returnTrue)]. [false] -> [self nextPut: (Bytecodes at: #returnFalse)]. [nil] -> [self nextPut: (Bytecodes at: #returnNil)] } otherwise: [ self pushLiteral: obj. self returnTop. ] ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02' prior: 34430033! returnConstant: obj self saveLastJump: #return. bytes size = 0 ifTrue: [ lastSpecialReturn _ Message selector: #returnConstant: argument: obj]. obj caseOf: { [true] -> [self nextPut: (Bytecodes at: #returnTrue)]. [false] -> [self nextPut: (Bytecodes at: #returnFalse)]. [nil] -> [self nextPut: (Bytecodes at: #returnNil)] } otherwise: [ self pushLiteral: obj. self returnTop. ] ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02'! returnInstVar: index self saveLastJump: #return. bytes size = 0 ifTrue: [ lastSpecialReturn _ Message selector: #returnInstVar: argument: index]. self pushInstVar: index. self returnTop. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02' prior: 34431007! returnInstVar: index self saveLastJump: #return. bytes size = 0 ifTrue: [ lastSpecialReturn _ Message selector: #returnInstVar: argument: index]. self pushInstVar: index. self returnTop. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02'! returnReceiver self saveLastJump: #return. bytes size = 0 ifTrue: [ lastSpecialReturn _ Message selector: #returnReceiver]. self nextPut: (Bytecodes at: #returnReceiver). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02' prior: 34431577! returnReceiver self saveLastJump: #return. bytes size = 0 ifTrue: [ lastSpecialReturn _ Message selector: #returnReceiver]. self nextPut: (Bytecodes at: #returnReceiver). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02'! returnTop self saveLastJump: #return. self nextPut: (Bytecodes at: #returnTopFromMethod). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 5/22/2003 14:02' prior: 34432113! returnTop self saveLastJump: #return. self nextPut: (Bytecodes at: #returnTopFromMethod). ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/16/2003 14:43'! send: selector | index nArgs | nArgs _ selector numArgs. stack pop: nArgs. SpecialSelectors at: selector ifPresent: [:i | ^ self nextPut: (Bytecodes at: #bytecodePrimAdd) + i]. index _ self addLiteral: selector. (index <= 16 and: [nArgs <= 2]) ifTrue: [ "short send" ^ self nextPut: (Bytecodes at: #sendLiteralSelectorBytecode) first + (nArgs * 16) + index - 1 ]. (index <= 32 and: [nArgs <= 7]) ifTrue: [ "extended (2-byte) send" self nextPut: (Bytecodes at: #singleExtendedSendBytecode). ^ self nextPut: nArgs * 32 + index - 1 ]. (index <= 64 and: [nArgs <= 3]) ifTrue: [ "new extended (2-byte)" self nextPut: (Bytecodes at: #secondExtendedSendBytecode). ^ self nextPut: nArgs * 64 + index - 1 ]. "long (3-byte) send" self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: nArgs. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/16/2003 14:43' prior: 34432479! send: selector | index nArgs | nArgs _ selector numArgs. stack pop: nArgs. SpecialSelectors at: selector ifPresent: [:i | ^ self nextPut: (Bytecodes at: #bytecodePrimAdd) + i]. index _ self addLiteral: selector. (index <= 16 and: [nArgs <= 2]) ifTrue: [ "short send" ^ self nextPut: (Bytecodes at: #sendLiteralSelectorBytecode) first + (nArgs * 16) + index - 1 ]. (index <= 32 and: [nArgs <= 7]) ifTrue: [ "extended (2-byte) send" self nextPut: (Bytecodes at: #singleExtendedSendBytecode). ^ self nextPut: nArgs * 32 + index - 1 ]. (index <= 64 and: [nArgs <= 3]) ifTrue: [ "new extended (2-byte)" self nextPut: (Bytecodes at: #secondExtendedSendBytecode). ^ self nextPut: nArgs * 64 + index - 1 ]. "long (3-byte) send" self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: nArgs. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/16/2003 14:43'! send: selector toSuperOf: behavior | index nArgs | nArgs _ selector numArgs. stack pop: nArgs. self addLastLiteral: behavior holder. index _ self addLiteral: selector. (index <= 32 and: [nArgs <= 7]) ifTrue: [ "extended (2-byte) send" self nextPut: (Bytecodes at: #singleExtendedSuperBytecode). ^ self nextPut: nArgs * 32 + index - 1 ]. "long (3-byte) send" self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 1 << 5 "super" + nArgs. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/16/2003 14:43' prior: 34434391! send: selector toSuperOf: behavior | index nArgs | nArgs _ selector numArgs. stack pop: nArgs. self addLastLiteral: behavior holder. index _ self addLiteral: selector. (index <= 32 and: [nArgs <= 7]) ifTrue: [ "extended (2-byte) send" self nextPut: (Bytecodes at: #singleExtendedSuperBytecode). ^ self nextPut: nArgs * 32 + index - 1 ]. "long (3-byte) send" self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 1 << 5 "super" + nArgs. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 20:36'! storeInstVar: index index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreBytecode). ^ self nextPut: (0 "instVar" << 6) + index - 1. ]. index <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 5 "storeInstVar" << 5. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/9/2003 20:36' prior: 34435578! storeInstVar: index index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreBytecode). ^ self nextPut: (0 "instVar" << 6) + index - 1. ]. index <= 256 ifFalse: [self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 5 "storeInstVar" << 5. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:00'! storePopInstVar: index | interval | stack pop. interval _ Bytecodes at: #storeAndPopReceiverVariableBytecode. index <= interval size ifTrue: [ ^ self nextPut: (interval at: index) ]. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode). ^ self nextPut: (0 "instVar" << 6) + index - 1. ]. index <= 256 ifFalse: [ self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 6 "storePopInstVar" << 5. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:00' prior: 34436485! storePopInstVar: index | interval | stack pop. interval _ Bytecodes at: #storeAndPopReceiverVariableBytecode. index <= interval size ifTrue: [ ^ self nextPut: (interval at: index) ]. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode). ^ self nextPut: (0 "instVar" << 6) + index - 1. ]. index <= 256 ifFalse: [ self error: 'can''t reference more than 256 inst vars']. self nextPut: (Bytecodes at: #doubleExtendedDoAnythingBytecode). self nextPut: 6 "storePopInstVar" << 5. self nextPut: index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:01'! storePopTemp: index | interval | stack pop. maxTemp _ index max: maxTemp. interval _ Bytecodes at: #storeAndPopTemporaryVariableBytecode. index <= interval size ifTrue: [ ^ self nextPut: (interval at: index) ]. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode). ^ self nextPut: (1 "temp" << 6) + index - 1. ]. self error: 'too many temps (>64)'! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:01' prior: 34437759! storePopTemp: index | interval | stack pop. maxTemp _ index max: maxTemp. interval _ Bytecodes at: #storeAndPopTemporaryVariableBytecode. index <= interval size ifTrue: [ ^ self nextPut: (interval at: index) ]. index <= 64 ifTrue: [ self nextPut: (Bytecodes at: #extendedStoreAndPopBytecode). ^ self nextPut: (1 "temp" << 6) + index - 1. ]. self error: 'too many temps (>64)'! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:01'! storeTemp: index maxTemp _ index max: maxTemp. index <= 64 ifFalse: [self error: 'too many temps (>64)']. self nextPut: (Bytecodes at: #extendedStoreBytecode). self nextPut: (1 "temp" << 6) + index - 1. ! ! !BytecodeGenerator methodsFor: 'instructions' stamp: 'ajh 3/13/2003 18:01' prior: 34438721! storeTemp: index maxTemp _ index max: maxTemp. index <= 64 ifFalse: [self error: 'too many temps (>64)']. self nextPut: (Bytecodes at: #extendedStoreBytecode). self nextPut: (1 "temp" << 6) + index - 1. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/6/2003 22:48'! addLastLiteral: object lastLiteral ifNil: [^ lastLiteral _ object]. (lastLiteral literalEqual: object) ifFalse: [self error: 'there can only be one last literal'].! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/6/2003 22:48' prior: 34439311! addLastLiteral: object lastLiteral ifNil: [^ lastLiteral _ object]. (lastLiteral literalEqual: object) ifFalse: [self error: 'there can only be one last literal'].! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/8/2003 20:56'! addLiteral: object literals add: object. ^ literals indexOf: object! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/8/2003 20:56' prior: 34439813! addLiteral: object literals add: object. ^ literals indexOf: object! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:00'! from: fromSeqId goto: toSeqId | distance from to | from _ seqOrder at: fromSeqId. to _ seqOrder at: toSeqId ifAbsent: [^ self]. from + 1 = to ifTrue: [^ self]. "fall through, no jump needed" from < to ifTrue: [ "jump forward" distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]. self jumpForward: distance. ] ifFalse: [ "jump backward" distance _ ((to to: from - 1) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]) + bytes size. self jumpBackward: distance. ]. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:00' prior: 34440120! from: fromSeqId goto: toSeqId | distance from to | from _ seqOrder at: fromSeqId. to _ seqOrder at: toSeqId ifAbsent: [^ self]. from + 1 = to ifTrue: [^ self]. "fall through, no jump needed" from < to ifTrue: [ "jump forward" distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]. self jumpForward: distance. ] ifFalse: [ "jump backward" distance _ ((to to: from - 1) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]) + bytes size. self jumpBackward: distance. ]. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:22'! from: fromSeqId if: bool goto: toSeqId otherwise: otherwiseSeqId | distance from to otherwise | from _ seqOrder at: fromSeqId. to _ seqOrder at: toSeqId ifAbsent: [^ self jump: 0 if: bool]. "not done yet" otherwise _ seqOrder at: otherwiseSeqId ifAbsent: [^ self jump: 0 if: bool]. "not done yet" from < to ifFalse: [self errorConditionalJumpBackwards]. from + 1 = otherwise ifFalse: [self errorFallThroughSequenceNotNext]. distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]. self jump: distance if: bool. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:22' prior: 34441428! from: fromSeqId if: bool goto: toSeqId otherwise: otherwiseSeqId | distance from to otherwise | from _ seqOrder at: fromSeqId. to _ seqOrder at: toSeqId ifAbsent: [^ self jump: 0 if: bool]. "not done yet" otherwise _ seqOrder at: otherwiseSeqId ifAbsent: [^ self jump: 0 if: bool]. "not done yet" from < to ifFalse: [self errorConditionalJumpBackwards]. from + 1 = otherwise ifFalse: [self errorFallThroughSequenceNotNext]. distance _ (from + 1 to: to - 1) inject: 0 into: [:size :i | size + (seqBytes at: (orderSeq at: i)) size]. self jump: distance if: bool. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:48'! jump: distance if: condition | hi | distance = 0 ifTrue: [ "jumps to fall through, no-op" ^ self nextPut: (Bytecodes at: #popStackBytecode)]. condition ifTrue: [ hi _ distance // 256. hi < 8 ifFalse: [self error: 'true jump too big']. self nextPut: (Bytecodes at: #longJumpIfTrue) first + hi. self nextPut: distance \\ 256. ] ifFalse: [ distance <= 8 ifTrue: [ self nextPut: (Bytecodes at: #shortConditionalJump) first + distance - 1. ] ifFalse: [ hi _ distance // 256. hi < 8 ifFalse: [self error: 'false jump too big']. self nextPut: (Bytecodes at: #longJumpIfFalse) first + hi. self nextPut: distance \\ 256. ]. ] ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:48' prior: 34442748! jump: distance if: condition | hi | distance = 0 ifTrue: [ "jumps to fall through, no-op" ^ self nextPut: (Bytecodes at: #popStackBytecode)]. condition ifTrue: [ hi _ distance // 256. hi < 8 ifFalse: [self error: 'true jump too big']. self nextPut: (Bytecodes at: #longJumpIfTrue) first + hi. self nextPut: distance \\ 256. ] ifFalse: [ distance <= 8 ifTrue: [ self nextPut: (Bytecodes at: #shortConditionalJump) first + distance - 1. ] ifFalse: [ hi _ distance // 256. hi < 8 ifFalse: [self error: 'false jump too big']. self nextPut: (Bytecodes at: #longJumpIfFalse) first + hi. self nextPut: distance \\ 256. ]. ] ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:46'! jumpBackward: distance | dist | distance = 0 ifTrue: [^ self]. "no-op" dist _ 1024 - distance - 2. dist < 0 ifTrue: [self error: 'back jump to big']. self nextPut: (Bytecodes at: #longUnconditionalJump) first + (dist // 256). self nextPut: dist \\ 256. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:46' prior: 34444230! jumpBackward: distance | dist | distance = 0 ifTrue: [^ self]. "no-op" dist _ 1024 - distance - 2. dist < 0 ifTrue: [self error: 'back jump to big']. self nextPut: (Bytecodes at: #longUnconditionalJump) first + (dist // 256). self nextPut: dist \\ 256. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:46'! jumpForward: distance distance = 0 ifTrue: [^ self]. "no-op" distance <= 8 ifTrue: [ self nextPut: (Bytecodes at: #shortUnconditionalJump) first + distance - 1. ] ifFalse: [ distance > 1023 ifTrue: [self error: 'forward jump too big']. self nextPut: (Bytecodes at: #longUnconditionalJump) first + (distance // 256) + 4. self nextPut: distance \\ 256. ]. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/24/2003 17:46' prior: 34444920! jumpForward: distance distance = 0 ifTrue: [^ self]. "no-op" distance <= 8 ifTrue: [ self nextPut: (Bytecodes at: #shortUnconditionalJump) first + distance - 1. ] ifFalse: [ distance > 1023 ifTrue: [self error: 'forward jump too big']. self nextPut: (Bytecodes at: #longUnconditionalJump) first + (distance // 256) + 4. self nextPut: distance \\ 256. ]. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:28'! newDummySeqId ^ Object new! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 13:28' prior: 34445824! newDummySeqId ^ Object new! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/13/2003 13:00'! nextPut: byte bytes add: byte! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 3/13/2003 13:00' prior: 34446048! nextPut: byte bytes add: byte! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 12:23'! saveLastJump: message jumps at: currentSeqId put: {bytes size. message}. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 5/22/2003 12:23' prior: 34446278! saveLastJump: message jumps at: currentSeqId put: {bytes size. message}. ! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 6/22/2003 14:41'! updateJump: seqId "Recalculate final jump bytecodes. Return true if jump bytecodes SIZE has changed, otherwise return false" | pair s1 | pair _ jumps at: seqId. pair last == #return ifTrue: [^ false]. "no jump, a return" bytes _ seqBytes at: seqId. s1 _ bytes size. bytes removeLast: (bytes size - pair first). pair last sendTo: self. ^ s1 ~= bytes size! ! !BytecodeGenerator methodsFor: 'private' stamp: 'ajh 6/22/2003 14:41' prior: 34446596! updateJump: seqId "Recalculate final jump bytecodes. Return true if jump bytecodes SIZE has changed, otherwise return false" | pair s1 | pair _ jumps at: seqId. pair last == #return ifTrue: [^ false]. "no jump, a return" bytes _ seqBytes at: seqId. s1 _ bytes size. bytes removeLast: (bytes size - pair first). pair last sendTo: self. ^ s1 ~= bytes size! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 5/22/2003 13:06'! bytecodes | stream | [ orderSeq inject: false into: [:changed :seqId | (self updateJump: seqId) | changed] ] whileTrue. stream _ (ByteArray new: 100) writeStream. orderSeq do: [:seqId | (instrMaps at: seqId) do: [:assoc | assoc key "instr" bytecodeIndex: stream position + assoc value. ]. stream nextPutAll: (seqBytes at: seqId). ]. ^ stream contents! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 5/22/2003 13:06' prior: 34447494! bytecodes | stream | [ orderSeq inject: false into: [:changed :seqId | (self updateJump: seqId) | changed] ] whileTrue. stream _ (ByteArray new: 100) writeStream. orderSeq do: [:seqId | (instrMaps at: seqId) do: [:assoc | assoc key "instr" bytecodeIndex: stream position + assoc value. ]. stream nextPutAll: (seqBytes at: seqId). ]. ^ stream contents! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 5/23/2003 10:48'! compiledMethod ^ self compiledMethodWith: #(0)! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 5/23/2003 10:48' prior: 34448406! compiledMethod ^ self compiledMethodWith: #(0)! ! !BytecodeGenerator methodsFor: 'results' stamp: 'md 11/14/2003 19:43'! compiledMethodWith: trailer ^ (CompiledMethod primitive: (self primNum > 0 ifTrue: [self primNum] ifFalse: [self quickMethodPrim]) numArgs: self numArgs numTemps: (self numTemps max: self numArgs) stackSize: self stackSize literals: self literals bytecodes: self bytecodes trailer: trailer)! ! !BytecodeGenerator methodsFor: 'results' stamp: 'md 11/14/2003 19:43' prior: 34448670! compiledMethodWith: trailer ^ (CompiledMethod primitive: (self primNum > 0 ifTrue: [self primNum] ifFalse: [self quickMethodPrim]) numArgs: self numArgs numTemps: (self numTemps max: self numArgs) stackSize: self stackSize literals: self literals bytecodes: self bytecodes trailer: trailer)! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/16/2003 13:57'! literals ^ lastLiteral ifNil: [literals] ifNotNil: [literals asArray copyWith: lastLiteral]! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/16/2003 13:57' prior: 34449462! literals ^ lastLiteral ifNil: [literals] ifNotNil: [literals asArray copyWith: lastLiteral]! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:27'! numArgs ^ numArgs! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:27' prior: 34449824! numArgs ^ numArgs! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:03'! numTemps ^ maxTemp! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:03' prior: 34450030! numTemps ^ maxTemp! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:27'! primNum ^ primNum! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:27' prior: 34450238! primNum ^ primNum! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:28'! quickMethodPrim | i | self numArgs = 0 ifFalse: [^ 0]. lastSpecialReturn ifNil: [^ 0]. seqBytes size = 1 ifFalse: [^ 0]. ^ lastSpecialReturn selector caseOf: { [#returnReceiver] -> [256]. [#returnConstant:] -> [ (i _ SpecialConstants indexOf: lastSpecialReturn argument) > 0 ifTrue: [256 + i] ifFalse: [0]]. [#returnInstVar:] -> [263 + lastSpecialReturn argument] }! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:28' prior: 34450444! quickMethodPrim | i | self numArgs = 0 ifFalse: [^ 0]. lastSpecialReturn ifNil: [^ 0]. seqBytes size = 1 ifFalse: [^ 0]. ^ lastSpecialReturn selector caseOf: { [#returnReceiver] -> [256]. [#returnConstant:] -> [ (i _ SpecialConstants indexOf: lastSpecialReturn argument) > 0 ifTrue: [256 + i] ifFalse: [0]]. [#returnInstVar:] -> [263 + lastSpecialReturn argument] }! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:03'! stackSize ^ (stacks collect: [:s | s length]) max! ! !BytecodeGenerator methodsFor: 'results' stamp: 'ajh 3/13/2003 18:03' prior: 34451386! stackSize ^ (stacks collect: [:s | s length]) max! ! !BytecodeGenerator methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:00'! mapBytesTo: instr "Associate next byte with instr" instrMap add: instr -> (bytes size + 1)! ! !BytecodeGenerator methodsFor: 'mapping' stamp: 'ajh 3/13/2003 13:00' prior: 34451656! mapBytesTo: instr "Associate next byte with instr" instrMap add: instr -> (bytes size + 1)! ! !BytecodeGenerator commentStamp: 'ajh 5/23/2003 10:59' prior: 0! I generate bytecodes in response to 'instructions' messages being sent to me. I rewrite jumps at the end so their jump offsets are correct (see #bytecodes). For example, to create a compiled method that compares first instVar to first arg and returns 'yes' or 'no' (same example as in IRBuilder), do: BytecodeGenerator new numArgs: 1; pushInstVar: 1; pushTemp: 1; send: #>; if: false goto: #else; pushLiteral: 'yes'; returnTop; label: #else; pushLiteral: 'no'; returnTop; compiledMethod You can send #ir to the compiledMethod to decompile to its IRMethod, and you can send #methodNode to either to decompile to its parse tree. ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:44'! bytecodeTableFrom: specArray "SpecArray is an array of either (index selector) or (index1 index2 selector)." | contiguous | Bytecodes _ IdentityDictionary new: 256. BytecodeTable _ Array new: 256. contiguous _ 0. specArray do: [ :spec | (spec at: 1) = contiguous ifFalse: [self error: 'Non-contiguous table entry']. spec size = 2 ifTrue: [ Bytecodes at: (spec at: 2) put: (spec at: 1). BytecodeTable at: (spec at: 1) + 1 put: (spec at: 2). contiguous _ contiguous + 1. ] ifFalse: [ spec size = 3 ifFalse: [self error: 'bad spec size']. Bytecodes at: (spec at: 3) put: ((spec at: 1) to: (spec at: 2)). (spec at: 1) to: (spec at: 2) do: [ :i | BytecodeTable at: i + 1 put: (spec at: 3). ]. contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1. ]. ]. ^ BytecodeTable! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:44' prior: 34452739! bytecodeTableFrom: specArray "SpecArray is an array of either (index selector) or (index1 index2 selector)." | contiguous | Bytecodes _ IdentityDictionary new: 256. BytecodeTable _ Array new: 256. contiguous _ 0. specArray do: [ :spec | (spec at: 1) = contiguous ifFalse: [self error: 'Non-contiguous table entry']. spec size = 2 ifTrue: [ Bytecodes at: (spec at: 2) put: (spec at: 1). BytecodeTable at: (spec at: 1) + 1 put: (spec at: 2). contiguous _ contiguous + 1. ] ifFalse: [ spec size = 3 ifFalse: [self error: 'bad spec size']. Bytecodes at: (spec at: 3) put: ((spec at: 1) to: (spec at: 2)). (spec at: 1) to: (spec at: 2) do: [ :i | BytecodeTable at: i + 1 put: (spec at: 3). ]. contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1. ]. ]. ^ BytecodeTable! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40'! initialize self initializeBytecodeTable. self initializeSpecialSelectors. self initializeSpecialConstants. ! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40' prior: 34454557! initialize self initializeBytecodeTable. self initializeSpecialSelectors. self initializeSpecialConstants. ! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:42'! initializeBytecodeTable "BytecodeWriteStream initialize" "Defines all the bytecode instructions for the Compiler and the Interpreter. The following bytecode tuple format is: #(bytecode bytecodeSelector) bytecodeSelector is the method in the Interpreter that gets executed for the given bytecode. Common Send selector position within the specialSelectorsArray is hard code in the Interpreter, see senders of Interpreter specialSelector:." ^ self bytecodeTableFrom: #( ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushTemporaryVariableBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 95 pushLiteralVariableBytecode) ( 96 103 storeAndPopReceiverVariableBytecode) (104 111 storeAndPopTemporaryVariableBytecode) (112 pushReceiverBytecode) (113 pushConstantTrueBytecode) (114 pushConstantFalseBytecode) (115 pushConstantNilBytecode) (116 pushConstantMinusOneBytecode) (117 pushConstantZeroBytecode) (118 pushConstantOneBytecode) (119 pushConstantTwoBytecode) (120 returnReceiver) (121 returnTrue) (122 returnFalse) (123 returnNil) (124 returnTopFromMethod) (125 returnTopFromBlock) (126 unknownBytecode) (127 unknownBytecode) (128 extendedPushBytecode) (129 extendedStoreBytecode) (130 extendedStoreAndPopBytecode) (131 singleExtendedSendBytecode) (132 doubleExtendedDoAnythingBytecode) (133 singleExtendedSuperBytecode) (134 secondExtendedSendBytecode) (135 popStackBytecode) (136 duplicateTopBytecode) (137 pushActiveContextBytecode) (138 143 experimentalBytecode) (144 151 shortUnconditionalJump) (152 159 shortConditionalJump) (160 167 longUnconditionalJump) (168 171 longJumpIfTrue) (172 175 longJumpIfFalse) "176-191 were sendArithmeticSelectorBytecode" (176 bytecodePrimAdd) (177 bytecodePrimSubtract) (178 bytecodePrimLessThan) (179 bytecodePrimGreaterThan) (180 bytecodePrimLessOrEqual) (181 bytecodePrimGreaterOrEqual) (182 bytecodePrimEqual) (183 bytecodePrimNotEqual) (184 bytecodePrimMultiply) (185 bytecodePrimDivide) (186 bytecodePrimMod) (187 bytecodePrimMakePoint) (188 bytecodePrimBitShift) (189 bytecodePrimDiv) (190 bytecodePrimBitAnd) (191 bytecodePrimBitOr) "192-207 were sendCommonSelectorBytecode" (192 bytecodePrimAt) (193 bytecodePrimAtPut) (194 bytecodePrimSize) (195 bytecodePrimNext) (196 bytecodePrimNextPut) (197 bytecodePrimAtEnd) (198 bytecodePrimEquivalent) (199 bytecodePrimClass) (200 bytecodePrimBlockCopy) (201 bytecodePrimValue) (202 bytecodePrimValueWithArg) (203 bytecodePrimDo) (204 bytecodePrimNew) (205 bytecodePrimNewWithArg) (206 bytecodePrimPointX) (207 bytecodePrimPointY) (208 255 sendLiteralSelectorBytecode) ) ! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:42' prior: 34454963! initializeBytecodeTable "BytecodeWriteStream initialize" "Defines all the bytecode instructions for the Compiler and the Interpreter. The following bytecode tuple format is: #(bytecode bytecodeSelector) bytecodeSelector is the method in the Interpreter that gets executed for the given bytecode. Common Send selector position within the specialSelectorsArray is hard code in the Interpreter, see senders of Interpreter specialSelector:." ^ self bytecodeTableFrom: #( ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushTemporaryVariableBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 95 pushLiteralVariableBytecode) ( 96 103 storeAndPopReceiverVariableBytecode) (104 111 storeAndPopTemporaryVariableBytecode) (112 pushReceiverBytecode) (113 pushConstantTrueBytecode) (114 pushConstantFalseBytecode) (115 pushConstantNilBytecode) (116 pushConstantMinusOneBytecode) (117 pushConstantZeroBytecode) (118 pushConstantOneBytecode) (119 pushConstantTwoBytecode) (120 returnReceiver) (121 returnTrue) (122 returnFalse) (123 returnNil) (124 returnTopFromMethod) (125 returnTopFromBlock) (126 unknownBytecode) (127 unknownBytecode) (128 extendedPushBytecode) (129 extendedStoreBytecode) (130 extendedStoreAndPopBytecode) (131 singleExtendedSendBytecode) (132 doubleExtendedDoAnythingBytecode) (133 singleExtendedSuperBytecode) (134 secondExtendedSendBytecode) (135 popStackBytecode) (136 duplicateTopBytecode) (137 pushActiveContextBytecode) (138 143 experimentalBytecode) (144 151 shortUnconditionalJump) (152 159 shortConditionalJump) (160 167 longUnconditionalJump) (168 171 longJumpIfTrue) (172 175 longJumpIfFalse) "176-191 were sendArithmeticSelectorBytecode" (176 bytecodePrimAdd) (177 bytecodePrimSubtract) (178 bytecodePrimLessThan) (179 bytecodePrimGreaterThan) (180 bytecodePrimLessOrEqual) (181 bytecodePrimGreaterOrEqual) (182 bytecodePrimEqual) (183 bytecodePrimNotEqual) (184 bytecodePrimMultiply) (185 bytecodePrimDivide) (186 bytecodePrimMod) (187 bytecodePrimMakePoint) (188 bytecodePrimBitShift) (189 bytecodePrimDiv) (190 bytecodePrimBitAnd) (191 bytecodePrimBitOr) "192-207 were sendCommonSelectorBytecode" (192 bytecodePrimAt) (193 bytecodePrimAtPut) (194 bytecodePrimSize) (195 bytecodePrimNext) (196 bytecodePrimNextPut) (197 bytecodePrimAtEnd) (198 bytecodePrimEquivalent) (199 bytecodePrimClass) (200 bytecodePrimBlockCopy) (201 bytecodePrimValue) (202 bytecodePrimValueWithArg) (203 bytecodePrimDo) (204 bytecodePrimNew) (205 bytecodePrimNewWithArg) (206 bytecodePrimPointX) (207 bytecodePrimPointY) (208 255 sendLiteralSelectorBytecode) ) ! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:45'! initializeSpecialConstants SpecialConstants _ {true. false. nil. -1. 0. 1. 2}! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:45' prior: 34460597! initializeSpecialConstants SpecialConstants _ {true. false. nil. -1. 0. 1. 2}! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40'! initializeSpecialSelectors "Create a map from specialSelector -> bytecode offset from sendAdd (the first one)" | array | SpecialSelectors _ IdentityDictionary new. array _ self specialSelectorsArray. "Smalltalk specialObjectsArray at: 24" 1 to: array size by: 2 "skip numArgs" do: [:i | SpecialSelectors at: (array at: i) put: i - 1 / 2]. ! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:40' prior: 34460939! initializeSpecialSelectors "Create a map from specialSelector -> bytecode offset from sendAdd (the first one)" | array | SpecialSelectors _ IdentityDictionary new. array _ self specialSelectorsArray. "Smalltalk specialObjectsArray at: 24" 1 to: array size by: 2 "skip numArgs" do: [:i | SpecialSelectors at: (array at: i) put: i - 1 / 2]. ! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/15/2003 15:43'! specialConstants ^ SpecialConstants! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/15/2003 15:43' prior: 34461820! specialConstants ^ SpecialConstants! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:45'! specialSelectorsArray ^ #(#+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1 #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1 #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0 #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0)! ! !BytecodeGenerator class methodsFor: 'initialize' stamp: 'ajh 3/6/2003 22:45' prior: 34462079! specialSelectorsArray ^ #(#+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1 #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1 #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0 #blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0)! ! !CNGBTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 14:42'! leadingChar ^ GB2312 leadingChar ! ! !CNGBTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 10/4/2003 15:38'! unicodeClass ^ UnicodeTraditionalChinese. ! ! !CNGBTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 14:42'! encodingNames ^ #('gb2312' ) copy ! ! !CNGBTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 14:42'! example1 "CNGBTextConverter example1" | fileStream | fileStream _ FileStream newFileNamed: 'test.gb'. fileStream converter: CNGBTextConverter new. fileStream nextPut: (MultiCharacter value: 33559461). fileStream nextPut: (MultiCharacter value: 33556777). fileStream close ! ! !CNGBTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/23/2002 14:43'! example2 "CNGBTextConverter example2" | writeStream fileStream | writeStream _ WriteStream on: String new. fileStream _ FileStream fileNamed: 'test.gb'. fileStream converter: CNGBTextConverter new. [fileStream atEnd] whileFalse: [writeStream nextPut: fileStream next]. fileStream close. ^ writeStream contents ! ! !CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:13'! debugProcess: aProcess | uiPriority oldPriority | uiPriority _ Processor activeProcess priority. aProcess priority >= uiPriority ifTrue: [ oldPriority _ ProcessBrowser setProcess: aProcess toPriority: uiPriority - 1 ]. ProcessBrowser debugProcess: aProcess.! ! !CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:27'! debugProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. self debugProcess: aProcess.! ! !CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:21'! resumeProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. ProcessBrowser resumeProcess: aProcess.! ! !CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:24'! terminateProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. ProcessBrowser terminateProcess: aProcess.! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 20:47'! catchThePig: aProcess | rules | "nickname, allow-stop, allow-debug" rules _ ProcessBrowser nameAndRulesFor: aProcess. (ProcessBrowser isUIProcess: aProcess) ifTrue: [ "aProcess debugWithTitle: 'Interrupted from the CPUWatcher'." ] ifFalse: [ rules second ifFalse: [ ^self ]. ProcessBrowser suspendProcess: aProcess. self openWindowForSuspendedProcess: aProcess ] ! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 16:05'! findThePig "tally has been updated. Look at it to see if there is a bad process. This runs at a very high priority, so make it fast" | countAndProcess | countAndProcess _ tally sortedCounts first. (countAndProcess key / tally size > self threshold) ifTrue: [ | proc | proc _ countAndProcess value. proc == Processor backgroundProcess ifTrue: [ ^self ]. "idle process? OK" self catchThePig: proc ]. ! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 18:34'! openMVCWindowForSuspendedProcess: aProcess ProcessBrowser new openAsMVC.! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 17:23'! openMorphicWindowForSuspendedProcess: aProcess | menu rules | menu _ MenuMorph new. "nickname allow-stop allow-debug" rules _ ProcessBrowser nameAndRulesFor: aProcess. menu add: 'Dismiss this menu' target: menu selector: #delete; addLine. menu add: 'Open Process Browser' target: ProcessBrowser selector: #open. menu add: 'Resume' target: self selector: #resumeProcess:fromMenu: argumentList: { aProcess . menu }. menu add: 'Terminate' target: self selector: #terminateProcess:fromMenu: argumentList: { aProcess . menu }. rules third ifTrue: [ menu add: 'Debug at a lower priority' target: self selector: #debugProcess:fromMenu: argumentList: { aProcess . menu }. ]. menu addTitle: aProcess identityHash asString, ' ', rules first, ' is taking too much time and has been suspended. What do you want to do with it?'. menu stayUp: true. menu popUpInWorld ! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 18:35'! openWindowForSuspendedProcess: aProcess Smalltalk isMorphic ifTrue: [ WorldState addDeferredUIMessage: [ self openMorphicWindowForSuspendedProcess: aProcess ] ] ifFalse: [ [ self openMVCWindowForSuspendedProcess: aProcess ] forkAt: Processor userSchedulingPriority ] ! ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'nk 3/14/2001 08:39'! monitorProcessPeriod: secs sampleRate: msecs self stopMonitoring. watcher _ [ [ | promise | promise _ Processor tallyCPUUsageFor: secs every: msecs. tally _ promise value. promise _ nil. self findThePig. ] repeat ] forkAt: Processor highestPriority. Processor yield ! ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'nk 3/14/2001 08:07'! startMonitoring self monitorProcessPeriod: 20 sampleRate: 100! ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'nk 3/8/2001 16:24'! stopMonitoring watcher ifNotNil: [ ProcessBrowser terminateProcess: watcher. watcher _ nil. ]! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 07:56'! isMonitoring ^watcher notNil! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:36'! tally ^tally copy! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:49'! threshold "What fraction of the time can a process be the active process before we stop it?" ^threshold! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:38'! threshold: thresh "What fraction of the time can a process be the active process before we stop it?" threshold _ (thresh max: 0.02) min: 1.0! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 08:26'! watcherProcess ^watcher! ! !CPUWatcher commentStamp: '' prior: 0! CPUWatcher implements a simple runaway process monitoring tool that will suspend a process that is taking up too much of Squeak's time and allow user interaction. By default it watches for a Process that is taking more than 80% of the time; this threshold can be changed. CPUWatcher can also be used to show cpu percentages for each process from within the ProcessBrowser. CPUWatcher startMonitoring. "process period 20 seconds, sample rate 100 msec" CPUWatcher current monitorProcessPeriod: 10 sampleRate: 20. CPUWatcher current threshold: 0.5. "change from 80% to 50%" CPUWatcher stopMonitoring. ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/8/2001 18:45'! current ^CurrentCPUWatcher ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:28'! currentWatcherProcess ^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ] ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/8/2001 21:43'! dumpTallyOnTranscript self current ifNotNil: [ ProcessBrowser dumpTallyOnTranscript: self current tally ]! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:15'! initialize "CPUWatcher initialize" Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:06'! isMonitoring ^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ] ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 10/31/2001 10:50'! monitorPreferenceChanged Preferences cpuWatcherEnabled ifTrue: [ self startMonitoring ] ifFalse: [ self stopMonitoring ]! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'! shutDown self stopMonitoring.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:17'! startMonitoring "CPUWatcher startMonitoring" ^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:16'! startMonitoringPeriod: pd rate: rt threshold: th "CPUWatcher startMonitoring" CurrentCPUWatcher ifNotNil: [ ^CurrentCPUWatcher startMonitoring. ]. CurrentCPUWatcher _ (self new) monitorProcessPeriod: pd sampleRate: rt; threshold: th; yourself. ^CurrentCPUWatcher ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'! startUp self monitorPreferenceChanged.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:05'! stopMonitoring "CPUWatcher stopMonitoring" CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ]. CurrentCPUWatcher _ nil. ! ! !CRCError methodsFor: 'as yet unclassified' stamp: 'nk 3/7/2004 15:56'! isResumable ^true! ! !CachingCodeLoader methodsFor: 'private' stamp: 'avi 4/30/2004 01:40' prior: 18764503! httpRequestClass ^CachedHTTPDownloadRequest ! ! !CachingMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 23:03' prior: 18766208! updateCacheCanvas: aCanvas "Update the cached image of the morphs being held by this hand." | myBnds rectList | myBnds := self fullBounds. (cacheCanvas isNil or: [cacheCanvas extent ~= myBnds extent]) ifTrue: [cacheCanvas := (aCanvas allocateForm: myBnds extent) getCanvas. cacheCanvas translateBy: myBnds origin negated during: [:tempCanvas | super fullDrawOn: tempCanvas]. ^self]. "incrementally update the cache canvas" rectList := damageRecorder invalidRectsFullBounds: (0 @ 0 extent: myBnds extent). damageRecorder reset. rectList do: [:r | cacheCanvas translateTo: myBnds origin negated clippingTo: r during: [:c | c fillColor: Color transparent. "clear to transparent" super fullDrawOn: c]]! ! !CachingMorph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:14'! fullDrawOn: aCanvas (aCanvas isVisible: self fullBounds) ifFalse:[^self]. self updateCacheCanvas: aCanvas. aCanvas cache: self fullBounds using: cacheCanvas form during:[:cachingCanvas| super fullDrawOn: cachingCanvas]. ! ! !CachingMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color veryLightGray! ! !CachingMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:48' prior: 18765573! initialize "initialize the state of the receiver" super initialize. "" damageRecorder _ DamageRecorder new! ! !Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:22'! asAlphaBlendingCanvas: alpha ^(AlphaBlendingCanvas on: self) alpha: alpha! ! !Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:14'! asShadowDrawingCanvas: aColor ^(ShadowDrawingCanvas on: self) shadowColor: aColor! ! !Canvas methodsFor: 'drawing' stamp: 'aoy 2/15/2003 21:41' prior: 18771328! line: pt1 to: pt2 width: width color: color1 dashLength: s1 secondColor: color2 secondDashLength: s2 startingOffset: startingOffset "Draw a line using the given width, colors and dash lengths. Originally written by Stephan Rudlof; tweaked by Dan Ingalls to use startingOffset for sliding offset as in 'ants' animations. Returns the sum of the starting offset and the length of this line." | dist deltaBig colors nextPhase segmentOffset phase segmentLength startPoint distDone endPoint segLens | dist := pt1 dist: pt2. dist = 0 ifTrue: [^startingOffset]. s1 = 0 & (s2 = 0) ifTrue: [^startingOffset]. deltaBig := pt2 - pt1. colors := { color1. color2}. segLens := { s1 asFloat. s2 asFloat}. nextPhase := { 2. 1}. "Figure out what phase we are in and how far, given startingOffset." segmentOffset := startingOffset \\ (s1 + s2). segmentLength := segmentOffset < s1 ifTrue: [phase := 1. s1 - segmentOffset] ifFalse: [phase := 2. s1 + s2 - segmentOffset]. startPoint := pt1. distDone := 0.0. [distDone < dist] whileTrue: [segmentLength := segmentLength min: dist - distDone. endPoint := startPoint + (deltaBig * segmentLength / dist). self line: startPoint truncated to: endPoint truncated width: width color: (colors at: phase). distDone := distDone + segmentLength. phase := nextPhase at: phase. startPoint := endPoint. segmentLength := segLens at: phase]. ^startingOffset + dist! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 15:23'! drawMorph: aMorph self draw: aMorph! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 15:23'! fullDrawMorph: aMorph self fullDraw: aMorph! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! roundCornersOf: aMorph during: aBlock ^self roundCornersOf: aMorph in: aMorph bounds during: aBlock! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! roundCornersOf: aMorph in: bounds during: aBlock ^aBlock value! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/10/2004 17:19' prior: 18784976! translucentImage: aForm at: aPoint sourceRect: sourceRect "Draw a translucent image using the best available way of representing translucency. Note: This will be fixed in the future." self shadowColor ifNotNil:[ ^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor]. (self depth < 32 or:[aForm isTranslucent not]) ifTrue:[^self paintImage: aForm at: aPoint sourceRect: sourceRect]. self image: aForm at: aPoint sourceRect: sourceRect rule: Form blend! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:44'! warpImage: aForm transform: aTransform "Warp the given form using aTransform" ^self warpImage: aForm transform: aTransform at: 0@0! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:54'! warpImage: aForm transform: aTransform at: extraOffset "Warp the given form using aTransform. TODO: Use transform to figure out appropriate cell size" ^self warpImage: aForm transform: aTransform at: extraOffset sourceRect: aForm boundingBox cellSize: 1! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 12/29/2001 00:20'! warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize "Warp the given using the appropriate transform and offset." ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 8/25/2001 17:27'! fillRectangle: aRectangle fillStyle: aFillStyle borderStyle: aBorderStyle "Fill the given rectangle." self fillRectangle: (aRectangle insetBy: aBorderStyle width) fillStyle: aFillStyle. aBorderStyle frameRectangle: aRectangle on: self! ! !Canvas methodsFor: 'drawing-support' stamp: 'gm 2/22/2003 14:53' prior: 18776484! cache: aRectangle using: aCache during: aBlock "Cache the execution of aBlock by the given cache. Note: At some point we may want to actually *create* the cache here; for now we're only using it." (aCache notNil and: [(aCache isForm) and: [aCache extent = aRectangle extent]]) ifTrue: [^self paintImage: aCache at: aRectangle origin]. aBlock value: self! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:35'! drawString: s at: pt ^ self drawString: s from: 1 to: s size at: pt font: nil color: Color black! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:25'! drawString: s at: pt font: aFont color: aColor ^ self drawString: s from: 1 to: s size at: pt font: aFont color: aColor! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:36'! drawString: s from: firstIndex to: lastIndex at: pt font: font color: aColor self drawString: s from: firstIndex to: lastIndex in: (pt extent: 10000@10000) font: font color: aColor! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:37'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:39'! drawString: s in: boundsRect ^self drawString: s from: 1 to: s size in: boundsRect font: nil color: Color black! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:13'! drawString: s in: boundsRect font: fontOrNil color: c ^self drawString: s from: 1 to: s size in: boundsRect font: fontOrNil color: c! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:40'! text: s at: pt font: fontOrNil color: c "OBSOLETE" ^ self drawString: s at: pt font: fontOrNil color: c! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:40'! text: s bounds: boundsRect font: fontOrNil color: c "OBSOLETE" ^self drawString: s in: boundsRect font: fontOrNil color: c! ! !Canvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:09'! isPostscriptCanvas ^false! ! !Canvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:21'! image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha "Privately used for blending forms w/ constant alpha. Fall back to simpler case by defaul." ^self image: aForm at: aPoint sourceRect: sourceRect rule: rule! ! !CanvasCharacterScanner methodsFor: 'scanning' stamp: 'ar 12/31/2001 02:35'! displayLine: textLine offset: offset leftInRun: leftInRun | nowLeftInRun done startLoc startIndex stopCondition | "largely copied from DisplayScanner's routine" line _ textLine. foregroundColor ifNil: [ foregroundColor _ Color black ]. leftMargin _ (line leftMarginForAlignment: alignment) + offset x. rightMargin _ line rightMargin + offset x. lineY _ line top + offset y. lastIndex _ textLine first. leftInRun <= 0 ifTrue: [self setStopConditions. "also sets the font" nowLeftInRun _ text runLengthFor: lastIndex] ifFalse: [nowLeftInRun _ leftInRun]. runX _ destX _ leftMargin. runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. spaceCount _ 0. done _ false. [done] whileFalse: [ "remember where this portion of the line starts" startLoc _ destX@destY. startIndex _ lastIndex. "find the end of this portion of the line" stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern "displaying: false". "display that portion of the line" canvas drawString: text string from: startIndex to: lastIndex at: startLoc font: font color: foregroundColor. "handle the stop condition" done _ self perform: stopCondition ]. ^runStopIndex - lastIndex! ! !CanvasCharacterScanner methodsFor: 'scanning' stamp: 'aoy 2/15/2003 21:24' prior: 34479556! displayLine: textLine offset: offset leftInRun: leftInRun "largely copied from DisplayScanner's routine" | nowLeftInRun done startLoc startIndex stopCondition | line := textLine. foregroundColor ifNil: [foregroundColor := Color black]. leftMargin := (line leftMarginForAlignment: alignment) + offset x. rightMargin := line rightMargin + offset x. lineY := line top + offset y. lastIndex := textLine first. nowLeftInRun := leftInRun <= 0 ifTrue: [self setStopConditions. "also sets the font" text runLengthFor: lastIndex] ifFalse: [leftInRun]. runX := destX := leftMargin. runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last. spaceCount := 0. done := false. [done] whileFalse: ["remember where this portion of the line starts" startLoc := destX @ destY. startIndex := lastIndex. "find the end of this portion of the line" stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "displaying: false" "display that portion of the line" canvas drawString: text string from: startIndex to: lastIndex at: startLoc font: font color: foregroundColor. "handle the stop condition" done := self perform: stopCondition]. ^runStopIndex - lastIndex! ! !CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:27'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. stopConditions at: Space asciiValue + 1 put: (alignment = Justified ifTrue: [#paddedSpace])! ! !CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 10/4/2002 20:44' prior: 34482424! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (textStyle alignment = Justified ifTrue: [#paddedSpace]). ! ! !CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'! tab destX _ (alignment == Justified and: [self leadingTab not]) ifTrue: "imbedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]. lastIndex _ lastIndex + 1. ^ false! ! !CanvasCharacterScanner methodsFor: 'private' stamp: 'mu 8/9/2003 22:40'! defaultTextColor defaultTextColor ifNil:[defaultTextColor _ Color black]. ^defaultTextColor! ! !CanvasCharacterScanner methodsFor: 'private' stamp: 'yo 6/23/2003 18:09'! defaultTextColor: color "This defaultTextColor inst var is equivalent to paragraphColor of DisplayScanner." defaultTextColor _ color. ! ! !CanvasCharacterScanner methodsFor: 'private' stamp: 'RAA 3/3/2001 19:42'! setFont foregroundColor ifNil: [foregroundColor _ Color black]. super setFont. destY _ lineY + line baseline - font ascent! ! !CanvasCharacterScanner methodsFor: 'private' stamp: 'yo 6/8/2003 21:29' prior: 34483807! setFont foregroundColor _ defaultTextColor. super setFont. destY _ lineY + line baseline - font ascent! ! !CanvasCharacterScanner methodsFor: 'private' stamp: 'mu 8/9/2003 22:40' prior: 34484027! setFont foregroundColor _ self defaultTextColor. super setFont. destY _ lineY + line baseline - font ascent! ! !CanvasCharacterScanner methodsFor: 'object fileIn' stamp: 'nk 6/17/2003 15:30'! convertToCurrentVersion: varDict refStream: smartRefStrm "From Squeak3.5 [latest update: #5180] on 17 June 2003" varDict at: 'defaultTextColor' put: Color black. ^ super convertToCurrentVersion: varDict refStream: smartRefStrm! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'yo 10/23/2002 23:36'! addFontSetToCache: command | index font | index := self class decodeInteger: command second. font := self class decodeFontSet: command third. index > fonts size ifTrue: [ | newFonts | newFonts := Array new: index. newFonts replaceFrom: 1 to: fonts size with: fonts. fonts := newFonts ]. fonts at: index put: font ! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'yo 3/21/2003 23:02'! addTTCFontToCache: command | index font | index := self class decodeInteger: command second. font := self class decodeTTCFont: command third. index > fonts size ifTrue: [ | newFonts | newFonts := Array new: index. newFonts replaceFrom: 1 to: fonts size with: fonts. fonts := newFonts ]. fonts at: index put: font. ! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:42' prior: 18795663! drawBalloonOval: command | aRectangle aFillStyle borderWidth borderColor | aRectangle := self class decodeRectangle: command second. aFillStyle := self class decodeFillStyle: command third. borderWidth := self class decodeInteger: command fourth. borderColor := self class decodeColor: (command fifth). self drawCommand: [:c | c asBalloonCanvas fillOval: aRectangle fillStyle: aFillStyle borderWidth: borderWidth borderColor: borderColor]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:42' prior: 18796202! drawBalloonRect: command | aRectangle aFillStyle | aRectangle := self class decodeRectangle: (command second). aFillStyle := self class decodeFillStyle: command third. self drawCommand: [:c | c asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:43' prior: 18796839! drawImage: command | image point sourceRect rule cacheID cacheNew previousImage | image := self class decodeImage: command second. point := self class decodePoint: command third. sourceRect := self class decodeRectangle: command fourth. rule := self class decodeInteger: command fifth. command size >= 7 ifTrue: [false ifTrue: [self showSpaceUsed]. "debugging" cacheID := self class decodeInteger: (command sixth). cacheNew := (self class decodeInteger: command seventh) = 1. cacheID > 0 ifTrue: [CachedForms ifNil: [CachedForms := Array new: 100]. cacheNew ifTrue: [CachedForms at: cacheID put: image] ifFalse: [previousImage := CachedForms at: cacheID. image ifNil: [image := previousImage] ifNotNil: [(previousImage notNil and: [image depth > 8]) ifTrue: [image := previousImage addDeltasFrom: image]. CachedForms at: cacheID put: image]]]]. self drawCommand: [:c | c image: image at: point sourceRect: sourceRect rule: rule]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'nk 6/25/2003 12:24' prior: 34486468! drawImage: command | image point sourceRect rule cacheID cacheNew previousImage | image := self class decodeImage: command second. point := self class decodePoint: command third. sourceRect := self class decodeRectangle: command fourth. rule := self class decodeInteger: command fifth. command size >= 7 ifTrue: [false ifTrue: [self showSpaceUsed]. "debugging" cacheID := self class decodeInteger: (command sixth). cacheNew := (self class decodeInteger: command seventh) = 1. cacheID > 0 ifTrue: [ cacheNew ifTrue: [CachedForms at: cacheID put: image] ifFalse: [previousImage := CachedForms at: cacheID. image ifNil: [image := previousImage] ifNotNil: [(previousImage notNil and: [image depth > 8]) ifTrue: [image := previousImage addDeltasFrom: image]. CachedForms at: cacheID put: image]]]]. self drawCommand: [:c | c image: image at: point sourceRect: sourceRect rule: rule]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:43' prior: 18797943! drawInfiniteFill: command | aRectangle aFillStyle | aRectangle := self class decodeRectangle: (command second). aFillStyle := InfiniteForm with: (self class decodeImage: command third). self drawCommand: [:c | c asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 13:18' prior: 18798312! drawLine: command | verb pt1Enc pt2Enc widthEnc colorEnc pt1 pt2 width color | verb _ command first. pt1Enc _ command second. pt2Enc _ command third. widthEnc _ command fourth. colorEnc _ command fifth. "" pt1 _ self class decodePoint: pt1Enc. pt2 _ self class decodePoint: pt2Enc. width _ self class decodeInteger: widthEnc. color _ self class decodeColor: colorEnc. "" self drawCommand: [:c | c line: pt1 to: pt2 width: width color: color]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'yo 10/23/2002 23:37'! drawMultiText: command | boundsEnc colorEnc text bounds color fontIndexEnc fontIndex | text := MultiString fromByteArray: (command at: 2) asByteArray. "text asByteArray printString displayAt: 800@0." "self halt." boundsEnc := command at: 3. fontIndexEnc := command at: 4. colorEnc := command at: 5. bounds _ self class decodeRectangle: boundsEnc. fontIndex := self class decodeInteger: fontIndexEnc. color _ self class decodeColor: colorEnc. self drawCommand: [ :c | c drawString: text in: bounds font: (fonts at: fontIndex) color: color ] ! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 13:19' prior: 18798839! drawOval: command | verb rectEnc colorEnc borderWidthEnc borderColorEnc rect color borderWidth borderColor | verb _ command first. rectEnc _ command second. colorEnc _ command third. borderWidthEnc _ command fourth. borderColorEnc _ command fifth. "" rect _ self class decodeRectangle: rectEnc. color _ self class decodeColor: colorEnc. borderWidth _ self class decodeInteger: borderWidthEnc. borderColor _ self class decodeColor: borderColorEnc. "" self drawCommand: [:c | c fillOval: rect color: color borderWidth: borderWidth borderColor: borderColor]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:43' prior: 18799479! drawPoly: command | verticesEnc fillColorEnc borderWidthEnc borderColorEnc vertices fillColor borderWidth borderColor | fillColorEnc := command second. borderWidthEnc := command third. borderColorEnc := command fourth. verticesEnc := command copyFrom: 5 to: command size. fillColor := self class decodeColor: fillColorEnc. borderWidth := self class decodeInteger: borderWidthEnc. borderColor := self class decodeColor: borderColorEnc. vertices := verticesEnc collect: [:enc | self class decodePoint: enc]. self drawCommand: [:c | c drawPolygon: vertices color: fillColor borderWidth: borderWidth borderColor: borderColor]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 13:19' prior: 18800195! drawRect: command | verb rectEnc fillColorEnc borderWidthEnc borderColorEnc rect fillColor borderWidth borderColor | verb _ command first. rectEnc _ command second. fillColorEnc _ command third. borderWidthEnc _ command fourth. borderColorEnc _ command fifth. "" rect _ self class decodeRectangle: rectEnc. fillColor _ self class decodeColor: fillColorEnc. borderWidth _ self class decodeInteger: borderWidthEnc. borderColor _ self class decodeColor: borderColorEnc. "" self drawCommand: [:c | c frameAndFillRectangle: rect fillColor: fillColor borderWidth: borderWidth borderColor: borderColor]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44' prior: 18800879! drawStencil: command | stencilFormEnc locationEnc sourceRectEnc colorEnc stencilForm location sourceRect color | stencilFormEnc := command second. locationEnc := command third. sourceRectEnc := command fourth. colorEnc := command fifth. stencilForm := self class decodeImage: stencilFormEnc. location := self class decodePoint: locationEnc. sourceRect := self class decodeRectangle: sourceRectEnc. color := self class decodeColor: colorEnc. self drawCommand: [:executor | executor stencil: stencilForm at: location sourceRect: sourceRect color: color]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'ar 12/31/2001 02:33'! drawText: command | boundsEnc colorEnc text bounds color fontIndexEnc fontIndex | text := command at: 2. boundsEnc := command at: 3. fontIndexEnc := command at: 4. colorEnc := command at: 5. bounds _ self class decodeRectangle: boundsEnc. fontIndex := self class decodeInteger: fontIndexEnc. color _ self class decodeColor: colorEnc. self drawCommand: [ :c | c drawString: text in: bounds font: (fonts at: fontIndex) color: color ]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44' prior: 34493079! drawText: command | boundsEnc colorEnc text bounds color fontIndexEnc fontIndex | text := command second. boundsEnc := command third. fontIndexEnc := command fourth. colorEnc := command fifth. bounds := self class decodeRectangle: boundsEnc. fontIndex := self class decodeInteger: fontIndexEnc. color := self class decodeColor: colorEnc. self drawCommand: [:c | c drawString: text in: bounds font: (fonts at: fontIndex) color: color]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44' prior: 18802033! extentDepth: command | depth extent | extent := self class decodePoint: (command second). depth := self class decodeInteger: (command third). drawingCanvas := FormCanvas extent: extent depth: depth! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 3/3/2001 18:27'! processCommand: command onForceDo: forceBlock | verb verbCode | command isEmpty ifTrue: [ ^self ]. verb _ command first. verbCode := verb at: 1. verbCode = CanvasEncoder codeClip ifTrue: [ ^self setClip: command ]. verbCode = CanvasEncoder codeTransform ifTrue: [ ^self setTransform: command ]. verbCode = CanvasEncoder codeText ifTrue: [ ^self drawText: command ]. verbCode = CanvasEncoder codeLine ifTrue: [ ^self drawLine: command ]. verbCode = CanvasEncoder codeRect ifTrue: [ ^self drawRect: command ]. verbCode = CanvasEncoder codeBalloonRect ifTrue: [ ^self drawBalloonRect: command ]. verbCode = CanvasEncoder codeBalloonOval ifTrue: [ ^self drawBalloonOval: command ]. verbCode = CanvasEncoder codeInfiniteFill ifTrue: [ ^self drawInfiniteFill: command ]. verbCode = CanvasEncoder codeOval ifTrue: [ ^self drawOval: command ]. verbCode = CanvasEncoder codeImage ifTrue: [ ^self drawImage: command ]. verbCode = CanvasEncoder codeReleaseCache ifTrue: [ ^self releaseImage: command ]. verbCode = CanvasEncoder codePoly ifTrue: [ ^self drawPoly: command ]. verbCode = CanvasEncoder codeStencil ifTrue: [ ^self drawStencil: command ]. verbCode = CanvasEncoder codeForce ifTrue: [ ^self forceToScreen: command withBlock: forceBlock ]. verbCode = CanvasEncoder codeFont ifTrue: [ ^self addFontToCache: command ]. verbCode = CanvasEncoder codeExtentDepth ifTrue: [ ^self extentDepth: command ]. verbCode = CanvasEncoder codeShadowColor ifTrue: [ ^self shadowColor: command ]. self error: 'unknown command: ', command first.! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 13:20' prior: 34494446! processCommand: command onForceDo: forceBlock | verb verbCode | command isEmpty ifTrue: [^ self]. verb _ command first. verbCode _ verb first. "" verbCode = CanvasEncoder codeClip ifTrue: [^ self setClip: command]. verbCode = CanvasEncoder codeTransform ifTrue: [^ self setTransform: command]. verbCode = CanvasEncoder codeText ifTrue: [^ self drawText: command]. verbCode = CanvasEncoder codeLine ifTrue: [^ self drawLine: command]. verbCode = CanvasEncoder codeRect ifTrue: [^ self drawRect: command]. verbCode = CanvasEncoder codeBalloonRect ifTrue: [^ self drawBalloonRect: command]. verbCode = CanvasEncoder codeBalloonOval ifTrue: [^ self drawBalloonOval: command]. verbCode = CanvasEncoder codeInfiniteFill ifTrue: [^ self drawInfiniteFill: command]. verbCode = CanvasEncoder codeOval ifTrue: [^ self drawOval: command]. verbCode = CanvasEncoder codeImage ifTrue: [^ self drawImage: command]. verbCode = CanvasEncoder codeReleaseCache ifTrue: [^ self releaseImage: command]. verbCode = CanvasEncoder codePoly ifTrue: [^ self drawPoly: command]. verbCode = CanvasEncoder codeStencil ifTrue: [^ self drawStencil: command]. verbCode = CanvasEncoder codeForce ifTrue: [^ self forceToScreen: command withBlock: forceBlock]. verbCode = CanvasEncoder codeFont ifTrue: [^ self addFontToCache: command]. verbCode = CanvasEncoder codeExtentDepth ifTrue: [^ self extentDepth: command]. verbCode = CanvasEncoder codeShadowColor ifTrue: [^ self shadowColor: command]. "" self error: 'unknown command: ' , command first! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'nk 6/25/2003 12:42' prior: 34496086! processCommand: command onForceDo: forceBlock "Decode the given string command and perform the required action. If the command is a forceToScreen command, also pass the forceBlock. The previous chained equality tests and conditionals have been replaced by a lookup table in my class variable DecodeTable, which is set in the class-side initialize method." | verb verbCode selector | command isEmpty ifTrue: [ ^self ]. verb _ command first. verbCode := verb first. selector _ DecodeTable at: (verbCode asciiValue + 1) ifAbsent: [ self error: 'unknown command: ', verb ]. "note: codeForce is the only odd one" ^(selector == #forceToScreen:) ifTrue: [ self forceToScreen: command withBlock: forceBlock ] ifFalse: [ self perform: selector withArguments: { command } ] ! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44' prior: 18804064! releaseImage: command | cacheID | CachedForms ifNil: [^self]. cacheID := self class decodeInteger: (command second). CachedForms at: cacheID put: nil! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44' prior: 18804290! setClip: command | clipRectEnc | clipRectEnc := command second. clipRect := self class decodeRectangle: clipRectEnc! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:45' prior: 18804477! setTransform: command | transformEnc | transformEnc := command second. transform := self class decodeTransform: transformEnc! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 3/3/2001 18:29'! shadowColor: command drawingCanvas shadowColor: ( command second = '0' ifTrue: [nil] ifFalse: [self class decodeColor: command second] ) ! ! !CanvasDecoder class methodsFor: 'decoding' stamp: 'yo 10/23/2002 23:39'! decodeFontSet: fontString ^ StrikeFontSet fontNamed: fontString ! ! !CanvasDecoder class methodsFor: 'decoding' stamp: 'yo 6/23/2003 20:12'! decodeTTCFont: fontString "Decode a string that consists of (e.g. 'ComicSansMS 12 0') into a proper instance." | first second | first _ fontString indexOf: $ startingAt: 1. second _ fontString indexOf: $ startingAt: first + 1. (first ~= 0 and: [second ~= 0]) ifTrue: [ ^ (TTCFont family: (fontString copyFrom: 1 to: (first - 1)) size: (fontString copyFrom: first + 1 to: second - 1) asNumber) emphasized: (fontString copyFrom: second + 1 to: fontString size) asNumber. ]. ^ TextStyle defaultFont. ! ! !CanvasDecoder class methodsFor: 'decode table modification' stamp: 'nk 6/25/2003 12:49'! decodeVerb: verb toSelector: selector "verb is a single character which will be ferformed by my instances using selector" DecodeTable at: verb asciiValue + 1 put: selector. ! ! !CanvasDecoder class methodsFor: 'class initialization' stamp: 'nk 6/25/2003 12:45'! initialize "CanvasDecoder initialize" "Set up my cache and decode table if necessary." CachedForms ifNil: [CachedForms := Array new: 100]. DecodeTable ifNotNil: [ ^self ]. DecodeTable _ Array new: 128. #((codeClip setClip:) (codeTransform setTransform:) (codeText drawText:) (codeLine drawLine:) (codeRect drawRect:) (codeBalloonRect drawBalloonRect:) (codeBalloonOval drawBalloonOval:) (codeInfiniteFill drawInfiniteFill:) (codeOval drawOval:) (codeImage drawImage:) (codeReleaseCache releaseImage:) (codePoly drawPoly:) (codeStencil drawStencil:) (codeForce forceToScreen:) (codeFont addFontToCache:) (codeTTCFont addTTCFontToCache:) (codeExtentDepth extentDepth:) (codeShadowColor shadowColor:)) do: [ :arr | DecodeTable at: ((CanvasEncoder perform: arr first) asciiValue + 1) put: arr second ]. ! ! !CanvasDecoder class methodsFor: 'class initialization' stamp: 'nk 6/25/2003 12:46'! reinitialize "CanvasDecoder reinitialize" "Set up my cache and decode table, removing old contents." CachedForms _ nil. DecodeTable _ nil. self initialize. ! ! !CanvasEncoder methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:36'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c | fontIndex | fontIndex := self establishFont: (fontOrNil ifNil: [ TextStyle defaultFont ]). self sendCommand: { String with: CanvasEncoder codeText. s asString copyFrom: firstIndex to: lastIndex. self class encodeRectangle: boundsRect. self class encodeInteger: fontIndex. self class encodeColor: c }! ! !CanvasEncoder methodsFor: 'drawing' stamp: 'yo 10/23/2002 23:40' prior: 34501712! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c | fontIndex str | fontIndex := self establishFont: (fontOrNil ifNil: [ TextStyle defaultFont ]). str _ s asString. str class = MultiString ifTrue: [ self sendCommand: { String with: CanvasEncoder codeMultiText. (str copyFrom: firstIndex to: lastIndex) asByteArray asString. self class encodeRectangle: boundsRect. self class encodeInteger: fontIndex. self class encodeColor: c } ] ifFalse: [ self sendCommand: { String with: CanvasEncoder codeText. s asString copyFrom: firstIndex to: lastIndex. self class encodeRectangle: boundsRect. self class encodeInteger: fontIndex. self class encodeColor: c } ]. ! ! !CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 3/3/2001 18:26'! shadowColor: aFillStyle self sendCommand: { String with: CanvasEncoder codeShadowColor. aFillStyle ifNil: ['0'] ifNotNil: [aFillStyle encodeForRemoteCanvas]. }! ! !CanvasEncoder methodsFor: 'drawing' stamp: 'dgd 2/22/2003 19:01' prior: 18818021! testCache: anObject | firstFree cachedObject newEntry | cachingEnabled ifFalse: [cachedObjects := nil. ^nil]. cachedObjects ifNil: [cachedObjects := (1 to: 100) collect: [:x | { WeakArray new: 1. nil. nil. nil}]]. self purgeCache. firstFree := nil. cachedObjects withIndexDo: [:each :index | cachedObject := each first first. firstFree ifNil: [cachedObject ifNil: [firstFree := index]]. cachedObject == anObject ifTrue: [each at: 2 put: (each second) + 1. ^{ index. false. each}]]. firstFree ifNil: [^nil]. newEntry := { WeakArray with: anObject. 1. Time millisecondClockValue. nil}. cachedObjects at: firstFree put: newEntry. ^{ firstFree. true. newEntry}! ! !CanvasEncoder methodsFor: 'fonts' stamp: 'nk 6/25/2003 12:58' prior: 18821234! sendFont: aFont atIndex: index "Transmits the given fint to the other side" | code | code _ CanvasEncoder codeFont. aFont isTTCFont ifTrue: [code _ CanvasEncoder codeTTCFont]. self sendCommand: { String with: code. self class encodeInteger: index. self class encodeFont: aFont }. ! ! !CanvasEncoder methodsFor: 'private' stamp: 'dgd 2/22/2003 14:41' prior: 18819742! sendCommand: stringArray | bucket | connection ifNil: [^self]. connection isConnected ifFalse: [^self]. connection nextPut: stringArray. SentTypesAndSizes ifNil: [^self]. bucket := SentTypesAndSizes at: stringArray first ifAbsentPut: [{ 0. 0. 0}]. bucket at: 1 put: bucket first + 1. bucket at: 2 put: (bucket second) + (stringArray inject: 4 into: [:sum :array | sum + (array size + 4)])! ! !CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 18826041! explainTestVars " CanvasEncoder explainTestVars " | answer total oneBillion data putter nReps | SimpleCounters ifNil: [^ Beeper beep]. total _ 0. oneBillion _ 1000 * 1000 * 1000. answer _ String streamContents: [ :strm | data _ SimpleCounters copy. putter _ [ :msg :index :nSec | nReps _ data at: index. total _ total + (nSec * nReps). strm nextPutAll: nReps asStringWithCommas,' * ',nSec printString,' ', (nSec * nReps / oneBillion roundTo: 0.01) printString,' secs for ',msg; cr ]. putter value: 'string socket' value: 1 value: 8000. putter value: 'rectangles' value: 2 value: 40000. putter value: 'points' value: 3 value: 18000. putter value: 'colors' value: 4 value: 8000. ]. StringHolder new contents: answer; openLabel: 'put integer times'. ! ! !CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'RAA 3/3/2001 18:25'! nameForCode: aStringOrChar | ch | ch _ (aStringOrChar isKindOf: String) ifTrue: [aStringOrChar first] ifFalse: [aStringOrChar]. ch == self codeBalloonOval ifTrue: [^'balloon oval']. ch == self codeBalloonRect ifTrue: [^'balloon rectangle']. ch == self codeClip ifTrue: [^'clip']. ch == self codeExtentDepth ifTrue: [^'codeExtentDepth']. ch == self codeFont ifTrue: [^'codeFont']. ch == self codeForce ifTrue: [^'codeForce']. ch == self codeImage ifTrue: [^'codeImage']. ch == self codeLine ifTrue: [^'codeLine']. ch == self codeOval ifTrue: [^'codeOval']. ch == self codePoly ifTrue: [^'codePoly']. ch == self codeRect ifTrue: [^'codeRect']. ch == self codeReleaseCache ifTrue: [^'codeReleaseCache']. ch == self codeStencil ifTrue: [^'codeStencil']. ch == self codeText ifTrue: [^'codeText']. ch == self codeTransform ifTrue: [^'codeTransform']. ch == self codeInfiniteFill ifTrue: [^'codeInfiniteFill']. ch == self codeShadowColor ifTrue: [^'shadowColor']. ^'????' ! ! !CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'yo 3/21/2003 23:01' prior: 34505941! nameForCode: aStringOrChar | ch | ch _ (aStringOrChar isKindOf: String) ifTrue: [aStringOrChar first] ifFalse: [aStringOrChar]. ch == self codeBalloonOval ifTrue: [^'balloon oval']. ch == self codeBalloonRect ifTrue: [^'balloon rectangle']. ch == self codeClip ifTrue: [^'clip']. ch == self codeExtentDepth ifTrue: [^'codeExtentDepth']. ch == self codeFont ifTrue: [^'codeFont']. ch == self codeTTCFont ifTrue: [^'codeTTCFont']. ch == self codeForce ifTrue: [^'codeForce']. ch == self codeImage ifTrue: [^'codeImage']. ch == self codeLine ifTrue: [^'codeLine']. ch == self codeOval ifTrue: [^'codeOval']. ch == self codePoly ifTrue: [^'codePoly']. ch == self codeRect ifTrue: [^'codeRect']. ch == self codeReleaseCache ifTrue: [^'codeReleaseCache']. ch == self codeStencil ifTrue: [^'codeStencil']. ch == self codeText ifTrue: [^'codeText']. ch == self codeTransform ifTrue: [^'codeTransform']. ch == self codeInfiniteFill ifTrue: [^'codeInfiniteFill']. ch == self codeShadowColor ifTrue: [^'shadowColor']. ^'????' ! ! !CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 18828220! showStats " CanvasEncoder showStats " | answer bucket | SentTypesAndSizes ifNil: [^Beeper beep]. answer _ WriteStream on: String new. SentTypesAndSizes keys asSortedCollection do: [ :each | bucket _ SentTypesAndSizes at: each. answer nextPutAll: each printString,' ', bucket first printString,' ', bucket second asStringWithCommas,' ', (self nameForCode: each); cr. ]. StringHolder new contents: answer contents; openLabel: 'send/receive stats'. ! ! !CanvasEncoder class methodsFor: 'codes' stamp: 'yo 10/23/2002 23:41'! codeFontSet ^ $S ! ! !CanvasEncoder class methodsFor: 'codes' stamp: 'yo 10/23/2002 23:42'! codeMultiText ^ $c ! ! !CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 3/3/2001 18:24'! codeShadowColor ^$s! ! !CanvasEncoder class methodsFor: 'codes' stamp: 'yo 3/21/2003 23:00'! codeTTCFont ^ $T. ! ! !CardPlayer methodsFor: 'as template' stamp: 'tk 5/29/2001 22:44'! matchIndex | tms | "Index of one we are looking at, in the cards that matched the last search with this template." tms _ self class classPool at: #TemplateMatches ifAbsent: [^ 0]. ^ (tms at: self ifAbsent: [#(0 0)]) second. ! ! !CardPlayer methodsFor: 'as template' stamp: 'tk 5/29/2001 22:47'! matchIndex: newPlace | tms pair | "One we are looking at, in cards that matched the last template search." tms _ self class classPool at: #TemplateMatches ifAbsent: [ self class addClassVarName: 'TemplateMatches'. self class classPool at: #TemplateMatches put: IdentityDictionary new]. pair _ tms at: self ifAbsent: [tms at: self put: (Array new: 2)]. pair at: 2 put: newPlace. newPlace = 0 ifTrue: [^ self]. pair first ifNil: [^ self]. (costume valueOfProperty: #myStack ifAbsent: [^ self]) goToCard: ((pair first "list") at: newPlace). self changed: #matchIndex. "update my selection" ! ! !CardPlayer methodsFor: 'as template' stamp: 'tk 5/31/2001 16:46'! matchNames | list str ll tms stk crds | "List of names of cards that matched the last template search." tms _ self class classPool at: #TemplateMatches ifAbsent: [^ #()]. list _ (tms at: self ifAbsent: [#(#() 0)]) first. stk _ costume valueOfProperty: #myStack ifAbsent: [nil]. crds _ stk ifNil: [#()] ifNotNil: [stk cards]. ^ list collect: [:cd | str _ ''. (ll _ cd allStringsAfter: nil) ifNotNil: [ str _ ll inject: '' into: [:strr :this | strr, this]]. (str copyFrom: 1 to: (30 min: str size)), '... (' , (crds indexOf: cd) printString, ')']. "Maybe include a card title?"! ! !CardPlayer methodsFor: 'as template' stamp: 'tk 5/29/2001 22:49'! results "Return my (cardlist index) pair from the last search" ^ (self class classPool at: #TemplateMatches ifAbsent: [^ Array new: 2]) at: self ! ! !CardPlayer methodsFor: 'card data' stamp: 'tk 5/28/2001 14:54'! allStringsAfter: aText | list ok instVarValue string | "return an OrderedCollection of strings of text in my instance vars. If aText is non-nil, begin with that object." list _ OrderedCollection new. ok _ aText == nil. self class variableDocks do: [:vdock | instVarValue _ self perform: vdock playerGetSelector. ok ifFalse: [ok _ instVarValue == aText]. "and do this one too" ok ifTrue: [string _ nil. instVarValue isString ifTrue: [string _ instVarValue]. instVarValue isText ifTrue: [string _ instVarValue string]. instVarValue isNumber ifTrue: [string _ instVarValue printString]. instVarValue isMorph ifTrue: [string _ instVarValue userString]. "not used" string ifNotNil: [string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]]. privateMorphs ifNotNil: [ privateMorphs do: [:mm | list addAll: (mm allStringsAfter: nil)]]. ^ list! ! !CardPlayer methodsFor: 'card data' stamp: 'dgd 2/22/2003 14:43' prior: 34510964! allStringsAfter: aText "return an OrderedCollection of strings of text in my instance vars. If aText is non-nil, begin with that object." | list ok instVarValue string | list := OrderedCollection new. ok := aText isNil. self class variableDocks do: [:vdock | instVarValue := self perform: vdock playerGetSelector. ok ifFalse: [ok := instVarValue == aText]. "and do this one too" ok ifTrue: [string := nil. instVarValue isString ifTrue: [string := instVarValue]. instVarValue isText ifTrue: [string := instVarValue string]. instVarValue isNumber ifTrue: [string := instVarValue printString]. instVarValue isMorph ifTrue: [string := instVarValue userString]. "not used" string ifNotNil: [string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]]. privateMorphs ifNotNil: [privateMorphs do: [:mm | list addAll: (mm allStringsAfter: nil)]]. ^list! ! !CardPlayer methodsFor: 'card data' stamp: 'tk 5/25/2001 17:42'! asKeys | keys kk vd gotData | "Take my fields, tokenize the text, and return as an array in the same order as variableDocks. Simple background fields on the top level. If no data, return nil." keys _ self class variableDocks copy. gotData _ false. 1 to: keys size do: [:ind | kk _ nil. vd _ self class variableDocks at: ind. vd type == #text ifTrue: [ kk _ (self perform: vd playerGetSelector) string findTokens: Character separators. kk isEmpty ifTrue: [kk _ nil] ifFalse: [gotData _ true]]. keys at: ind put: kk]. ^ gotData ifTrue: [keys] ifFalse: [nil]! ! !CardPlayer methodsFor: 'card data' stamp: 'tk 5/25/2001 17:02'! match: keys fields: docks | longString | "see if each key occurs in my corresponding text instance." keys withIndexDo: [:kk :ind | kk ifNotNil: [ longString _ (self perform: (docks at: ind) playerGetSelector) string. kk do: [:aKey | ((longString findString: aKey startingAt: 1 caseSensitive: false) > 0) ifFalse: [^ false]]]]. "all keys must match" ^ true! ! !CardPlayer methodsFor: 'card data' stamp: 'tk 5/7/2001 15:51'! url "For now, don't know we could be on a server" ^ nil! ! !CardPlayer methodsFor: 'misc' stamp: 'tk 9/28/2001 13:00'! tileReferringToSelf "answer a tile that refers to the receiver. For CardPlayer, want 'self', not the specific name of this card. Script needs to work for any card of the background." | aTile tile | Preferences universalTiles ifTrue: [tile _ SyntaxMorph new parseNode: (VariableNode new name: 'self' key: 'self' code: 112). tile layoutInset: 1; addMorph: (tile addString: 'self' special: false). "translate to wordy variant here..." tile color: (SyntaxMorph translateColor: #variable). tile extent: tile firstSubmorph extent + (2@2). ^ tile]. aTile _ TileMorph new setToReferTo: self. ^ aTile! ! !CardPlayer methodsFor: 'scripts-kernel' stamp: 'svp 10/15/2001 14:44'! renameScript: oldSelector newSelector: newSelector "Find all buttons that fire this script and tell them the new name" | stack | super renameScript: oldSelector newSelector: newSelector. costume allMorphsDo: [:mm | self retargetButton: mm oldSelector: oldSelector newSelector: newSelector]. stack _ costume valueOfProperty: #myStack. stack ifNotNil: [stack cards do: [:cc | cc privateMorphs do: [:pp | pp allMorphsDo: [:mm | self retargetButton: mm oldSelector: oldSelector newSelector: newSelector]]]]! ! !CardPlayer methodsFor: 'scripts-kernel' stamp: 'tk 9/29/2001 10:27'! retargetButton: mm oldSelector: oldSelector newSelector: newSelector "changing the name of a script -- tell any buttons that fire it" (mm respondsTo: #scriptSelector) ifTrue: [ mm scriptSelector == oldSelector ifTrue: [ mm scriptSelector: newSelector. mm setNameTo: newSelector]]. (mm respondsTo: #actionSelector) ifTrue: [ mm actionSelector == oldSelector ifTrue: [ mm target class == self class ifTrue: [ mm actionSelector: newSelector. mm setNameTo: newSelector]]]. ! ! !CardPlayer commentStamp: '' prior: 0! CardPlayer Instance variables of the Uniclass represent the data in the "fields" of each card in the stack. Each Instance variable is some kind of value holder. The code for the *buttons* on the background resides in the CardPlayer uniclass. privateMorphs -- OrderedCollection of objects specific to this card. Individual CardPlayer classes need to store the search results of any instances that are templates. As a hack, we use a class variable TemplateMatches in each individual class (CardPlayer21). It is initialized in #matchIndex:. TemplateMatches an IndentityDictionary of (aCardPlayer -> (list of matching cards, index in that list)) ! !CardPlayer class methodsFor: 'compiling' stamp: 'tk 9/28/2001 11:42'! wantsChangeSetLogging "Log changes for CardPlayer itself, but not for automatically-created subclasses like CardPlayer1, CardPlayer2, but *do* log it for uniclasses that have been manually renamed." ^ (self == CardPlayer or: [(self name beginsWith: 'CardPlayer') not]) or: [Preferences universalTiles]! ! !CardPlayer class methodsFor: 'slots' stamp: 'sw 2/18/2001 17:02'! compileAccessorsFor: varName "Compile instance-variable accessor methods for the given variable name" | nameString | nameString _ varName asString capitalized. self compileInobtrusively: ('get', nameString, ' ^ ', varName) classified: 'access'. self compileInobtrusively: ('set', nameString, ': val ', varName, ' _ val') classified: 'access'! ! !CardPlayer class methodsFor: 'slots' stamp: 'NS 1/28/2004 14:41' prior: 34517131! compileAccessorsFor: varName "Compile instance-variable accessor methods for the given variable name" | nameString | nameString _ varName asString capitalized. self compileSilently: ('get', nameString, ' ^ ', varName) classified: 'access'. self compileSilently: ('set', nameString, ': val ', varName, ' _ val') classified: 'access'! ! !CardPlayer class methodsFor: 'slots' stamp: 'NS 1/30/2004 13:11' prior: 18834410! removeAccessorsFor: varName "Remove the instance-variable accessor methods associated with varName" | nameString | nameString _ varName asString capitalized. self removeSelectorSilently: ('get', nameString) asSymbol. self removeSelectorSilently: ('set', nameString, ':') asSymbol! ! !CardPlayer class methodsFor: 'user-defined inst vars' stamp: 'sw 12/6/2001 20:36'! resortInstanceVariables: newList "Accept a new ordering for instance variables" variableDocks _ newList collect: [:aName | variableDocks detect: [:d | d variableName = aName]]. self setNewInstVarNames: newList asOrderedCollection. self newVariableDocks: variableDocks. ! ! !CardPlayer class methodsFor: 'user-defined inst vars' stamp: 'tk 8/26/2001 16:58'! setNewInstVarNames: listOfStrings "Make listOfStrings be the new list of instance variable names for the receiver" | disappearing firstAppearing instVarString instVarList | instVarList _ self instVarNames asOrderedCollection. disappearing _ instVarList copy. disappearing removeAllFoundIn: listOfStrings. disappearing do: [:oldName | self removeAccessorsFor: oldName]. firstAppearing _ listOfStrings copy. firstAppearing removeAllFoundIn: instVarList. instVarString _ String streamContents: [:aStream | listOfStrings do: [:aString | aStream nextPutAll: aString; nextPut: $ ]]. superclass subclass: self name instanceVariableNames: instVarString classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses. firstAppearing do: [:newName | self compileAccessorsFor: newName]. ! ! !CascadeNode methodsFor: 'tiles' stamp: 'RAA 2/22/2001 13:56'! asMorphicSyntaxIn: parent ^parent cascadeNode: self receiver: receiver messages: messages ! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! addCategory: newCategory ^ self addCategory: newCategory before: nil ! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! addCategory: catString before: nextCategory "Add a new category named heading. If default category exists and is empty, remove it. If nextCategory is nil, then add the new one at the end, otherwise, insert it before nextCategory." | index newCategory | newCategory _ catString asSymbol. (categoryArray indexOf: newCategory) > 0 ifTrue: [^self]. "heading already exists, so done" index _ categoryArray indexOf: nextCategory ifAbsent: [categoryArray size + 1]. categoryArray _ categoryArray copyReplaceFrom: index to: index-1 with: (Array with: newCategory). categoryStops _ categoryStops copyReplaceFrom: index to: index-1 with: (Array with: (index = 1 ifTrue: [0] ifFalse: [categoryStops at: index-1])). "remove empty default category" (newCategory ~= Default and: [(self listAtCategoryNamed: Default) isEmpty]) ifTrue: [self removeCategory: Default]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! allMethodSelectors "give a list of all method selectors." ^ elementArray copy sort! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:29'! categories "Answer an Array of categories (names)." categoryArray isNil ifTrue: [^ nil]. (categoryArray size = 1 and: [categoryArray first = Default & (elementArray size = 0)]) ifTrue: [^Array with: NullCategory]. ^categoryArray! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! categories: anArray "Reorder my categories to be in order of the argument, anArray. If the resulting organization does not include all elements, then give an error." | newCategories newStops newElements catName list runningTotal | newCategories _ Array new: anArray size. newStops _ Array new: anArray size. newElements _ Array new: 0. runningTotal _ 0. 1 to: anArray size do: [:i | catName _ (anArray at: i) asSymbol. list _ self listAtCategoryNamed: catName. newElements _ newElements, list. newCategories at: i put: catName. newStops at: i put: (runningTotal _ runningTotal + list size)]. elementArray do: [:element | "check to be sure all elements are included" (newElements includes: element) ifFalse: [^self error: 'New categories must match old ones']]. "Everything is good, now update my three arrays." categoryArray _ newCategories. categoryStops _ newStops. elementArray _ newElements! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! categoryOfElement: element "Answer the category associated with the argument, element." | index | index _ self numberOfCategoryOfElement: element. index = 0 ifTrue: [^nil] ifFalse: [^categoryArray at: index]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:36'! changeFromCategorySpecs: categorySpecs "Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment." | oldElements newElements newCategories newStops currentStop temp ii cc catSpec | oldElements _ elementArray asSet. newCategories _ Array new: categorySpecs size. newStops _ Array new: categorySpecs size. currentStop _ 0. newElements _ WriteStream on: (Array new: 16). 1 to: categorySpecs size do: [:i | catSpec _ categorySpecs at: i. newCategories at: i put: catSpec first asSymbol. catSpec allButFirst asSortedCollection do: [:elem | (oldElements remove: elem ifAbsent: [nil]) notNil ifTrue: [newElements nextPut: elem. currentStop _ currentStop+1]]. newStops at: i put: currentStop]. "Ignore extra elements but don't lose any existing elements!!" oldElements _ oldElements collect: [:elem | Array with: (self categoryOfElement: elem) with: elem]. newElements _ newElements contents. categoryArray _ newCategories. (cc _ categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element" temp _ categoryArray asOrderedCollection. temp removeAll: categoryArray asSet asOrderedCollection. temp do: [:dup | ii _ categoryArray indexOf: dup. [dup _ (dup,' #2') asSymbol. cc includes: dup] whileTrue. cc add: dup. categoryArray at: ii put: dup]]. categoryStops _ newStops. elementArray _ newElements. oldElements do: [:pair | self classify: pair last under: pair first].! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! changeFromString: aString "Parse the argument, aString, and make this be the receiver's structure." | categorySpecs | categorySpecs _ Scanner new scanTokens: aString. "If nothing was scanned and I had no elements before, then default me" (categorySpecs isEmpty and: [elementArray isEmpty]) ifTrue: [^ self setDefaultList: Array new]. ^ self changeFromCategorySpecs: categorySpecs! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! classify: element under: heading self classify: element under: heading suppressIfDefault: true! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:54'! classify: element under: heading suppressIfDefault: aBoolean "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" | catName catIndex elemIndex realHeading | ((heading = NullCategory) or: [heading == nil]) ifTrue: [realHeading _ Default] ifFalse: [realHeading _ heading asSymbol]. (catName _ self categoryOfElement: element) = realHeading ifTrue: [^ self]. "done if already under that category" catName ~~ nil ifTrue: [(aBoolean and: [realHeading = Default]) ifTrue: [^ self]. "return if non-Default category already assigned in memory" self removeElement: element]. "remove if in another category" (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. catIndex _ categoryArray indexOf: realHeading. elemIndex _ catIndex > 1 ifTrue: [categoryStops at: catIndex - 1] ifFalse: [0]. [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) and: [element >= (elementArray at: elemIndex)]] whileTrue. "elemIndex is now the index for inserting the element. Do the insertion before it." elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1 with: (Array with: element). "add one to stops for this and later categories" catIndex to: categoryArray size do: [:i | categoryStops at: i put: (categoryStops at: i) + 1]. (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! classifyAll: aCollection under: heading aCollection do: [:element | self classify: element under: heading]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:20'! elementCategoryDict | dict firstIndex lastIndex | elementArray isNil ifTrue: [^ nil]. dict _ Dictionary new: elementArray size. 1to: categoryStops size do: [:cat | firstIndex _ self firstIndexOfCategoryNumber: cat. lastIndex _ self lastIndexOfCategoryNumber: cat. firstIndex to: lastIndex do: [:el | dict at: (elementArray at: el) put: (categoryArray at: cat)]. ]. ^ dict.! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'! isEmptyCategoryNamed: categoryName | i | i _ categoryArray indexOf: categoryName ifAbsent: [^false]. ^self isEmptyCategoryNumber: i! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'! isEmptyCategoryNumber: anInteger | firstIndex lastIndex | (anInteger < 1 or: [anInteger > categoryStops size]) ifTrue: [^ true]. firstIndex _ self firstIndexOfCategoryNumber: anInteger. lastIndex _ self lastIndexOfCategoryNumber: anInteger. ^ firstIndex > lastIndex! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! listAtCategoryNamed: categoryName "Answer the array of elements associated with the name, categoryName." | i | i _ categoryArray indexOf: categoryName ifAbsent: [^Array new]. ^self listAtCategoryNumber: i! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 13:51'! listAtCategoryNumber: anInteger "Answer the array of elements stored at the position indexed by anInteger. Answer nil if anInteger is larger than the number of categories." | firstIndex lastIndex | (anInteger < 1 or: [anInteger > categoryStops size]) ifTrue: [^ nil]. firstIndex _ self firstIndexOfCategoryNumber: anInteger. lastIndex _ self lastIndexOfCategoryNumber: anInteger. ^elementArray copyFrom: firstIndex to: lastIndex! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! numberOfCategoryOfElement: element "Answer the index of the category with which the argument, element, is associated." | categoryIndex elementIndex | categoryIndex _ 1. elementIndex _ 0. [(elementIndex _ elementIndex + 1) <= elementArray size] whileTrue: ["point to correct category" [elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryIndex _ categoryIndex + 1]. "see if this is element" element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]]. ^0! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! removeCategory: cat "Remove the category named, cat. Create an error notificiation if the category has any elements in it." | index lastStop | index _ categoryArray indexOf: cat ifAbsent: [^self]. lastStop _ index = 1 ifTrue: [0] ifFalse: [categoryStops at: index - 1]. (categoryStops at: index) - lastStop > 0 ifTrue: [^self error: 'cannot remove non-empty category']. categoryArray _ categoryArray copyReplaceFrom: index to: index with: Array new. categoryStops _ categoryStops copyReplaceFrom: index to: index with: Array new. categoryArray size = 0 ifTrue: [categoryArray _ Array with: Default. categoryStops _ Array with: 0] ! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! removeElement: element "Remove the selector, element, from all categories." | categoryIndex elementIndex nextStop newElements | categoryIndex _ 1. elementIndex _ 0. nextStop _ 0. "nextStop keeps track of the stops in the new element array" newElements _ WriteStream on: (Array new: elementArray size). [(elementIndex _ elementIndex + 1) <= elementArray size] whileTrue: [[elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex _ categoryIndex + 1]. (elementArray at: elementIndex) = element ifFalse: [nextStop _ nextStop + 1. newElements nextPut: (elementArray at: elementIndex)]]. [categoryIndex <= categoryStops size] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex _ categoryIndex + 1]. elementArray _ newElements contents! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! removeEmptyCategories "Remove empty categories." | categoryIndex currentStop keptCategories keptStops | keptCategories _ WriteStream on: (Array new: 16). keptStops _ WriteStream on: (Array new: 16). currentStop _ categoryIndex _ 0. [(categoryIndex _ categoryIndex + 1) <= categoryArray size] whileTrue: [(categoryStops at: categoryIndex) > currentStop ifTrue: [keptCategories nextPut: (categoryArray at: categoryIndex). keptStops nextPut: (currentStop _ categoryStops at: categoryIndex)]]. categoryArray _ keptCategories contents. categoryStops _ keptStops contents. categoryArray size = 0 ifTrue: [categoryArray _ Array with: Default. categoryStops _ Array with: 0] "ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! renameCategory: oldCatString toBe: newCatString "Rename a category. No action if new name already exists, or if old name does not exist." | index oldCategory newCategory | oldCategory _ oldCatString asSymbol. newCategory _ newCatString asSymbol. (categoryArray indexOf: newCategory) > 0 ifTrue: [^ self]. "new name exists, so no action" (index _ categoryArray indexOf: oldCategory) = 0 ifTrue: [^ self]. "old name not found, so no action" categoryArray _ categoryArray copy. "need to change identity so smart list update will notice the change" categoryArray at: index put: newCategory! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! sortCategories | privateCategories publicCategories newCategories | privateCategories _ self categories select: [:one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1]. publicCategories _ self categories copyWithoutAll: privateCategories. newCategories _ publicCategories asSortedCollection asOrderedCollection addAll: privateCategories asSortedCollection; asArray. self categories: newCategories! ! !Categorizer methodsFor: 'printing' stamp: 'NS 4/5/2004 17:44'! printOn: aStream "Refer to the comment in Object|printOn:." | elementIndex | elementIndex _ 1. 1 to: categoryArray size do: [:i | aStream nextPut: $(. (categoryArray at: i) asString printOn: aStream. [elementIndex <= (categoryStops at: i)] whileTrue: [aStream space; nextPutAll: (elementArray at: elementIndex). elementIndex _ elementIndex + 1]. aStream nextPut: $); cr]! ! !Categorizer methodsFor: 'printing' stamp: 'NS 4/5/2004 17:44'! printOnStream: aStream "Refer to the comment in Object|printOn:." | elementIndex | elementIndex _ 1. 1 to: categoryArray size do: [:i | aStream print: '('; write:(categoryArray at:i). " is the asString redundant? " [elementIndex <= (categoryStops at: i)] whileTrue: [aStream print:' '; write:(elementArray at: elementIndex). elementIndex _ elementIndex + 1]. aStream print:')'. aStream cr]! ! !Categorizer methodsFor: 'fileIn/Out' stamp: 'NS 4/5/2004 17:44'! scanFrom: aStream "Reads in the organization from the next chunk on aStream. Categories or elements not found in the definition are not affected. New elements are ignored." self changeFromString: aStream nextChunk. aStream skipStyleChunk.! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:44'! elementArray ^ elementArray! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:51'! firstIndexOfCategoryNumber: anInteger anInteger < 1 ifTrue: [^ nil]. ^ (anInteger > 1 ifTrue: [(categoryStops at: anInteger - 1) + 1] ifFalse: [1]).! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:52'! lastIndexOfCategoryNumber: anInteger anInteger > categoryStops size ifTrue: [^ nil]. ^ categoryStops at: anInteger! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:50'! setDefaultList: aSortedCollection categoryArray _ Array with: Default. categoryStops _ Array with: aSortedCollection size. elementArray _ aSortedCollection asArray! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! allCategory "Return a symbol that represents the virtual all methods category." ^ '-- all --' asSymbol! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! default ^ Default! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/6/2004 11:48'! initialize " self initialize " Default _ 'as yet unclassified' asSymbol. NullCategory _ 'no messages' asSymbol.! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! nullCategory ^ NullCategory! ! !Categorizer class methodsFor: 'instance creation' stamp: 'NS 4/5/2004 17:44'! defaultList: aSortedCollection "Answer an instance of me with initial elements from the argument, aSortedCollection." ^self new setDefaultList: aSortedCollection! ! !Categorizer class methodsFor: 'documentation' stamp: 'NS 4/5/2004 17:44'! documentation "Instances consist of an Array of category names (categoryArray), each of which refers to an Array of elements (elementArray). This association is made through an Array of stop indices (categoryStops), each of which is the index in elementArray of the last element (if any) of the corresponding category. For example: categories _ Array with: 'firstCat' with: 'secondCat' with: 'thirdCat'. stops _ Array with: 1 with: 4 with: 4. elements _ Array with: #a with: #b with: #c with: #d. This means that category firstCat has only #a, secondCat has #b, #c, and #d, and thirdCat has no elements. This means that stops at: stops size must be the same as elements size." ! ! !Categorizer class methodsFor: 'housekeeping' stamp: 'NS 4/6/2004 11:48'! sortAllCategories self allSubInstances do: [:x | x sortCategories]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 11/11/2001 21:07'! adjustColorsAndBordersWithin "Adjust the colors and borders of submorphs to suit current fashion" self allMorphsDo: [:aMorph | (aMorph isKindOf: ViewerLine) ifTrue: [aMorph layoutInset: 1]. (aMorph isKindOf: TilePadMorph) ifTrue: [aMorph beTransparent]. (aMorph isKindOf: PhraseTileMorph) ifTrue: [aMorph beTransparent. aMorph borderWidth: 0]. (aMorph isKindOf: TileMorph orOf: TilePadMorph) ifTrue: [aMorph borderWidth: 1]]. self borderWidth: 1! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 8/22/2002 14:00'! beReplacedByCategory: chosenCategory "Be replaced by a category pane pointed at the chosen category" self outerViewer replaceSubmorph: self by: (self outerViewer categoryViewerFor: chosenCategory) ! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:55'! categoryNameWhoseTranslatedWordingIs: aWording "Answer the category name with the given wording" | result | result _ self currentVocabulary categoryWhoseTranslatedWordingIs: aWording. ^ result ifNotNil: [result categoryName] ifNil: [aWording]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/12/2001 20:34'! categoryWhoseTranslatedWordingIs: aWording "Answer the elementCategory with the given wording" ^ self currentVocabulary categoryWhoseTranslatedWordingIs: aWording! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 10/30/2001 13:45'! categoryWording: aCategoryWording "Make the category with the given wording be my current one." | actualPane | (actualPane _ namePane renderedMorph) firstSubmorph contents: aCategoryWording; color: Color black. actualPane extent: actualPane firstSubmorph extent. self removeAllButFirstSubmorph. "that being the header" self addAllMorphs: ((scriptedPlayer tilePhrasesForCategory: chosenCategorySymbol inViewer: self)). self enforceTileColorPolicy. self secreteCategorySymbol. self world ifNotNil: [self world startSteppingSubmorphsOf: self]. self adjustColorsAndBordersWithin. owner ifNotNil: [owner isStandardViewer ifTrue: [owner fitFlap]]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 11/16/2001 14:15'! chooseCategory "The mouse went down on my category-list control; pop up a list of category choices" | aList aMenu reply aLinePosition lineList | aList _ scriptedPlayer categoriesForViewer: self. aLinePosition _ aList indexOf: #miscellaneous ifAbsent: [nil]. aList _ aList collect: [:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol]. lineList _ aLinePosition ifNil: [#()] ifNotNil: [Array with: aLinePosition]. aList size == 0 ifTrue: [aList add: #'instance variables']. aMenu _ CustomMenu labels: aList lines: lineList selections: aList. reply _ aMenu startUpWithCaption: 'category'. reply ifNil: [^ self]. self chooseCategoryWhoseTranslatedWordingIs: reply asSymbol ! ! !CategoryViewer methodsFor: 'categories' stamp: 'dgd 2/22/2003 14:25' prior: 34538758! chooseCategory "The mouse went down on my category-list control; pop up a list of category choices" | aList aMenu reply aLinePosition lineList | aList := scriptedPlayer categoriesForViewer: self. aLinePosition := aList indexOf: #miscellaneous ifAbsent: [nil]. aList := aList collect: [:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol]. lineList := aLinePosition ifNil: [#()] ifNotNil: [Array with: aLinePosition]. aList isEmpty ifTrue: [aList add: #'instance variables']. aMenu := CustomMenu labels: aList lines: lineList selections: aList. reply := aMenu startUpWithCaption: 'category'. reply ifNil: [^self]. self chooseCategoryWhoseTranslatedWordingIs: reply asSymbol! ! !CategoryViewer methodsFor: 'categories' stamp: 'dgd 10/8/2003 18:50' prior: 34539552! chooseCategory "The mouse went down on my category-list control; pop up a list of category choices" | aList aMenu reply aLinePosition lineList | aList _ scriptedPlayer categoriesForViewer: self. aLinePosition _ aList indexOf: #miscellaneous ifAbsent: [nil]. aList _ aList collect: [:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol]. lineList _ aLinePosition ifNil: [#()] ifNotNil: [Array with: aLinePosition]. aList isEmpty ifTrue: [aList add: #'instance variables']. aMenu _ CustomMenu labels: aList lines: lineList selections: aList. reply _ aMenu startUpWithCaption: 'category' translated. reply ifNil: [^ self]. self chooseCategoryWhoseTranslatedWordingIs: reply asSymbol ! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 3/2/2004 23:53' prior: 34540365! chooseCategory "The mouse went down on my category-list control; pop up a list of category choices" | aList aMenu reply aLinePosition lineList | aList _ scriptedPlayer categoriesForViewer: self. aLinePosition _ aList indexOf: #miscellaneous ifAbsent: [nil]. aList _ aList collect: [:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol]. lineList _ aLinePosition ifNil: [#()] ifNotNil: [Array with: aLinePosition]. aList size == 0 ifTrue: [aList add: ScriptingSystem nameForInstanceVariablesCategory translated]. aMenu _ CustomMenu labels: aList lines: lineList selections: aList. reply _ aMenu startUpWithCaption: 'category' translated. reply ifNil: [^ self]. self chooseCategoryWhoseTranslatedWordingIs: reply asSymbol ! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:56'! chooseCategoryWhoseTranslatedWordingIs: aWording "Choose the category with the given wording" self chosenCategorySymbol: (self categoryNameWhoseTranslatedWordingIs: aWording) ! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 5/29/2001 22:43'! chosenCategorySymbol "Answer the inherent category currently being shown, not necessarily the same as the translated word." ^ chosenCategorySymbol ifNil: [self secreteCategorySymbol]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:49'! chosenCategorySymbol: aCategorySymbol "Make the given category be my current one." | aCategory wording | chosenCategorySymbol _ aCategorySymbol. aCategory _ self currentVocabulary categoryAt: chosenCategorySymbol. wording _ aCategory ifNil: [aCategorySymbol] ifNotNil: [aCategory wording]. self categoryWording: wording! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 2/23/2001 22:29'! currentCategory "Answer the symbol representing the receiver's currently-selected category" | current | current _ namePane renderedMorph firstSubmorph contents. ^ current ifNotNil: [current asSymbol] ifNil: [#basic]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:57'! nextCategory "Change the receiver to point at the category following the one currently seen" | aList anIndex newIndex already aChoice | aList _ (scriptedPlayer categoriesForViewer: self) collect: [:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol]. already _ self outerViewer ifNil: [#()] ifNotNil: [self outerViewer categoriesCurrentlyShowing]. anIndex _ aList indexOf: self currentCategory ifAbsent: [0]. newIndex _ anIndex = aList size ifTrue: [1] ifFalse: [anIndex + 1]. [already includes: (aChoice _ aList at: newIndex)] whileTrue: [newIndex _ (newIndex \\ aList size) + 1]. self chooseCategoryWhoseTranslatedWordingIs: aChoice! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:53'! previousCategory "Change the receiver to point at the category preceding the one currently seen" | aList anIndex newIndex already aChoice | aList _ (scriptedPlayer categoriesForViewer: self) collect: [:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol]. already _ self outerViewer ifNil: [#()] ifNotNil: [self outerViewer categoriesCurrentlyShowing]. anIndex _ aList indexOf: self currentCategory ifAbsent: [aList size + 1]. newIndex _ anIndex = 1 ifTrue: [aList size] ifFalse: [anIndex - 1]. [already includes: (aChoice _ aList at: newIndex)] whileTrue: [newIndex _ newIndex = 1 ifTrue: [aList size] ifFalse: [newIndex - 1]]. self chooseCategoryWhoseTranslatedWordingIs: aChoice! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:50'! secreteCategorySymbol "Set my chosenCategorySymbol by translating back from its representation in the namePane. Answer the chosenCategorySymbol" | aCategory | aCategory _ self currentVocabulary categoryWhoseTranslatedWordingIs: self currentCategory. ^ chosenCategorySymbol _ aCategory ifNotNil: [aCategory categoryName] ifNil: [self currentCategory]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/6/2002 10:55'! showCategoriesFor: aSymbol "Put up a pop-up list of categories in which aSymbol is filed; replace the receiver with a CategoryViewer for the one the user selects, if any" | allCategories aVocabulary hits meths chosen | aVocabulary _ self currentVocabulary. allCategories _ scriptedPlayer categoriesForVocabulary: aVocabulary limitClass: ProtoObject. hits _ allCategories select: [:aCategory | meths _ aVocabulary allMethodsInCategory: aCategory forInstance: scriptedPlayer ofClass: scriptedPlayer class. meths includes: aSymbol]. chosen _ (SelectionMenu selections: hits) startUp. chosen isEmptyOrNil ifFalse: [self outerViewer addCategoryViewerFor: chosen atEnd: true] ! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 5/29/2001 11:41'! updateCategoryNameTo: aName "Update the category name, because of a language change." | actualPane | (actualPane _ namePane firstSubmorph) contents: aName; color: Color black. namePane extent: actualPane extent. self world ifNotNil: [self world startSteppingSubmorphsOf: self] ! ! !CategoryViewer methodsFor: 'e-toy support' stamp: 'sw 9/13/2001 19:16'! adoptVocabulary: aVocabulary "Adopt the given vocabulary as the one used in this viewer." | aCategory | chosenCategorySymbol ifNil: [^ self delete]. aCategory _ aVocabulary categoryAt: chosenCategorySymbol. aCategory ifNil: [self delete] ifNotNil: [self updateCategoryNameTo: aCategory wording]. super adoptVocabulary: aVocabulary! ! !CategoryViewer methodsFor: 'e-toy support' stamp: 'sw 9/27/2001 21:44'! setNaturalLanguageTo: aLanguage "Set the natural language symbol as indicated" chosenCategorySymbol ifNil: [^ self delete]. self updateCategoryNameTo: ((self currentVocabulary ifNil: [Vocabulary eToyVocabulary]) categoryWordingAt: chosenCategorySymbol)! ! !CategoryViewer methodsFor: 'editing pane' stamp: 'nb 6/17/2003 12:25' prior: 18850677! contents: c notifying: k "later, spruce this up so that it can accept input such as new method source" Beeper beep. ^ false! ! !CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:21' prior: 18852556! addIsOverColorDetailTo: aRow | clrTile readout aTile | aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" aRow addMorphBack: (clrTile _ Color blue newTileMorphRepresentative). aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" readout _ UpdatingStringMorphWithArgument new target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil; argumentTarget: clrTile colorSwatch argumentGetSelector: #color. readout useDefaultFormat. aTile _ StringReadoutTile new typeColor: Color lightGray lighter. aTile addMorphBack: readout. aRow addMorphBack: aTile. aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 9/6/2002 11:54'! addOverlapsDetailTo: aRow "Disreputable magic: add necessary items to a viewer row abuilding for the overlaps phrase" aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer". aRow addMorphBack: self tileForSelf. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" ! ! !CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:20' prior: 34548099! addOverlapsDetailTo: aRow "Disreputable magic: add necessary items to a viewer row abuilding for the overlaps phrase" aRow addMorphBack: (Morph new color: self color; extent: 2@10). "spacer" aRow addMorphBack: self tileForSelf. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" ! ! !CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:21' prior: 18853358! addTouchesADetailTo: aRow | clrTile | aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" aRow addMorphBack: (clrTile _ self tileForSelf). aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" "readout _ UpdatingStringMorphWithArgument new target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil; argumentTarget: clrTile colorSwatch argumentGetSelector: #color. readout useDefaultFormat. aTile _ StringReadoutTile new typeColor: Color lightGray lighter. aTile addMorphBack: readout. aRow addMorphBack: aTile. aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30"! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 5/29/2001 11:44'! infoButtonFor: aScriptOrSlotSymbol "Answer a fully-formed morph that will serve as the 'info button' alongside an entry corresponding to the given slot or script symbol. If no such button is appropriate, answer a transparent graphic that fills the same space." | aButton | (self wantsRowMenuFor: aScriptOrSlotSymbol) ifFalse: ["Fill the space with sweet nothing, since there is no meaningful menu to offer". aButton _ RectangleMorph new beTransparent extent: (17@20). aButton borderWidth: 0. ^ aButton]. aButton _ IconicButton new labelGraphic: Cursor menu. aButton target: scriptedPlayer; actionSelector: #infoFor:inViewer:; arguments: (Array with:aScriptOrSlotSymbol with: self); color: Color transparent; borderWidth: 0; shedSelvedge; actWhen: #buttonDown. aButton setBalloonText: 'Press here to get a menu'. ^ aButton! ! !CategoryViewer methodsFor: 'entries' stamp: 'dgd 9/1/2003 13:50' prior: 34549664! infoButtonFor: aScriptOrSlotSymbol "Answer a fully-formed morph that will serve as the 'info button' alongside an entry corresponding to the given slot or script symbol. If no such button is appropriate, answer a transparent graphic that fills the same space." | aButton | (self wantsRowMenuFor: aScriptOrSlotSymbol) ifFalse: ["Fill the space with sweet nothing, since there is no meaningful menu to offer". aButton _ RectangleMorph new beTransparent extent: (17@20). aButton borderWidth: 0. ^ aButton]. aButton _ IconicButton new labelGraphic: Cursor menu. aButton target: scriptedPlayer; actionSelector: #infoFor:inViewer:; arguments: (Array with:aScriptOrSlotSymbol with: self); color: Color transparent; borderWidth: 0; shedSelvedge; actWhen: #buttonDown. aButton setBalloonText: 'Press here to get a menu' translated. ^ aButton! ! !CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:20' prior: 34550603! infoButtonFor: aScriptOrSlotSymbol "Answer a fully-formed morph that will serve as the 'info button' alongside an entry corresponding to the given slot or script symbol. If no such button is appropriate, answer a transparent graphic that fills the same space." | aButton | (self wantsRowMenuFor: aScriptOrSlotSymbol) ifFalse: ["Fill the space with sweet nothing, since there is no meaningful menu to offer" aButton _ RectangleMorph new beTransparent extent: (17@20). aButton borderWidth: 0. ^ aButton]. aButton _ IconicButton new labelGraphic: Cursor menu. aButton target: scriptedPlayer; actionSelector: #infoFor:inViewer:; arguments: (Array with:aScriptOrSlotSymbol with: self); color: Color transparent; borderWidth: 0; shedSelvedge; actWhen: #buttonDown. aButton setBalloonText: 'Press here to get a menu' translated. ^ aButton! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 8/22/2002 14:24'! phraseForCommandFrom: aMethodInterface "Answer a phrase for the non-slot-like command represented by aMethodInterface - classic tiles" | aRow resultType cmd names argType argTile selfTile aPhrase balloonTextSelector stat inst aDocString universal tileBearingHelp | aDocString _ aMethodInterface documentationOrNil. aDocString = 'no help available' ifTrue: [aDocString _ nil]. names _ scriptedPlayer class namedTileScriptSelectors. resultType _ aMethodInterface resultType. cmd _ aMethodInterface selector. (universal _ scriptedPlayer isUniversalTiles) ifTrue: [aPhrase _ scriptedPlayer universalTilesForInterface: aMethodInterface] ifFalse: [cmd numArgs == 0 ifTrue: [aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player] ifFalse: ["only one arg supported in classic tiles, so if this is fed with a selector with > 1 arg, results will be very strange" argType _ aMethodInterface typeForArgumentNumber: 1. aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player argType: argType. argTile _ ScriptingSystem tileForArgType: argType. argTile position: aPhrase lastSubmorph position. aPhrase lastSubmorph addMorph: argTile]]. (scriptedPlayer slotInfo includesKey: cmd) ifTrue: [balloonTextSelector _ #userSlot]. (scriptedPlayer belongsToUniClass and: [scriptedPlayer class includesSelector: cmd]) ifTrue: [aDocString ifNil: [aDocString _ (scriptedPlayer class userScriptForPlayer: scriptedPlayer selector: cmd) documentationOrNil]. aDocString ifNil: [balloonTextSelector _ #userScript]]. tileBearingHelp _ universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]. aDocString ifNotNil: [tileBearingHelp setBalloonText: aDocString] ifNil: [balloonTextSelector ifNil: [tileBearingHelp setProperty: #inherentSelector toValue: cmd. balloonTextSelector _ #methodComment]. tileBearingHelp balloonTextSelector: balloonTextSelector]. aPhrase markAsPartsDonor. cmd == #emptyScript ifTrue: [aPhrase setProperty: #newPermanentScript toValue: true. aPhrase setProperty: #newPermanentPlayer toValue: scriptedPlayer. aPhrase submorphs second setBalloonText: 'drag and drop to add a new script']. universal ifFalse: [selfTile _ self tileForSelf. selfTile position: aPhrase firstSubmorph position. aPhrase firstSubmorph addMorph: selfTile]. aRow _ ViewerLine newRow borderWidth: 0; color: self color. aRow elementSymbol: cmd asSymbol. aRow addMorphBack: (ScriptingSystem tryButtonFor: aPhrase). aRow addMorphBack: (Morph new extent: 2@2; beTransparent). aRow addMorphBack: (self infoButtonFor: cmd). aRow addMorphBack: aPhrase. (names includes: cmd) ifTrue: [aPhrase userScriptSelector: cmd. cmd numArgs == 0 ifTrue: [aPhrase beTransparent. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer. aRow addMorphBack: (stat _ (inst _ scriptedPlayer scriptInstantiationForSelector: cmd) statusControlMorph). inst updateStatusMorph: stat]]. aRow beSticky; disableDragNDrop. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'dgd 9/1/2003 15:01' prior: 34552487! phraseForCommandFrom: aMethodInterface "Answer a phrase for the non-slot-like command represented by aMethodInterface - classic tiles" | aRow resultType cmd names argType argTile selfTile aPhrase balloonTextSelector stat inst aDocString universal tileBearingHelp | aDocString _ aMethodInterface documentationOrNil. aDocString = 'no help available' ifTrue: [aDocString _ nil]. names _ scriptedPlayer class namedTileScriptSelectors. resultType _ aMethodInterface resultType. cmd _ aMethodInterface selector. (universal _ scriptedPlayer isUniversalTiles) ifTrue: [aPhrase _ scriptedPlayer universalTilesForInterface: aMethodInterface] ifFalse: [cmd numArgs == 0 ifTrue: [aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player] ifFalse: ["only one arg supported in classic tiles, so if this is fed with a selector with > 1 arg, results will be very strange" argType _ aMethodInterface typeForArgumentNumber: 1. aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player argType: argType. argTile _ ScriptingSystem tileForArgType: argType. argTile position: aPhrase lastSubmorph position. aPhrase lastSubmorph addMorph: argTile]]. (scriptedPlayer slotInfo includesKey: cmd) ifTrue: [balloonTextSelector _ #userSlot]. (scriptedPlayer belongsToUniClass and: [scriptedPlayer class includesSelector: cmd]) ifTrue: [aDocString ifNil: [aDocString _ (scriptedPlayer class userScriptForPlayer: scriptedPlayer selector: cmd) documentationOrNil]. aDocString ifNil: [balloonTextSelector _ #userScript]]. tileBearingHelp _ universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]. aDocString ifNotNil: [tileBearingHelp setBalloonText: aDocString] ifNil: [balloonTextSelector ifNil: [tileBearingHelp setProperty: #inherentSelector toValue: cmd. balloonTextSelector _ #methodComment]. tileBearingHelp balloonTextSelector: balloonTextSelector]. aPhrase markAsPartsDonor. cmd == #emptyScript ifTrue: [aPhrase setProperty: #newPermanentScript toValue: true. aPhrase setProperty: #newPermanentPlayer toValue: scriptedPlayer. aPhrase submorphs second setBalloonText: 'drag and drop to add a new script' translated]. universal ifFalse: [selfTile _ self tileForSelf. selfTile position: aPhrase firstSubmorph position. aPhrase firstSubmorph addMorph: selfTile]. aRow _ ViewerLine newRow borderWidth: 0; color: self color. aRow elementSymbol: cmd asSymbol. aRow addMorphBack: (ScriptingSystem tryButtonFor: aPhrase). aRow addMorphBack: (Morph new extent: 2@2; beTransparent). aRow addMorphBack: (self infoButtonFor: cmd). aRow addMorphBack: aPhrase. (names includes: cmd) ifTrue: [aPhrase userScriptSelector: cmd. cmd numArgs == 0 ifTrue: [aPhrase beTransparent. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer. aRow addMorphBack: (stat _ (inst _ scriptedPlayer scriptInstantiationForSelector: cmd) statusControlMorph). inst updateStatusMorph: stat]]. aRow beSticky; disableDragNDrop. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 3/4/2004 13:25' prior: 34555782! phraseForCommandFrom: aMethodInterface "Answer a phrase for the non-slot-like command represented by aMethodInterface - classic tiles" | aRow resultType cmd names argType argTile selfTile aPhrase balloonTextSelector stat inst aDocString universal tileBearingHelp | aDocString _ aMethodInterface documentationOrNil. aDocString = 'no help available' ifTrue: [aDocString _ nil]. names _ scriptedPlayer class namedTileScriptSelectors. resultType _ aMethodInterface resultType. cmd _ aMethodInterface selector. (universal _ scriptedPlayer isUniversalTiles) ifTrue: [aPhrase _ scriptedPlayer universalTilesForInterface: aMethodInterface] ifFalse: [cmd numArgs == 0 ifTrue: [aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player] ifFalse: ["only one arg supported in classic tiles, so if this is fed with a selector with > 1 arg, results will be very strange" argType _ aMethodInterface typeForArgumentNumber: 1. aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player argType: argType. argTile _ ScriptingSystem tileForArgType: argType. argTile position: aPhrase lastSubmorph position. aPhrase lastSubmorph addMorph: argTile]]. (scriptedPlayer slotInfo includesKey: cmd) ifTrue: [balloonTextSelector _ #userSlot]. (scriptedPlayer belongsToUniClass and: [scriptedPlayer class includesSelector: cmd]) ifTrue: [aDocString ifNil: [aDocString _ (scriptedPlayer class userScriptForPlayer: scriptedPlayer selector: cmd) documentationOrNil]. aDocString ifNil: [balloonTextSelector _ #userScript]]. tileBearingHelp _ universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]. aDocString ifNotNil: [tileBearingHelp setBalloonText: aDocString translated] ifNil: [balloonTextSelector ifNil: [tileBearingHelp setProperty: #inherentSelector toValue: cmd. balloonTextSelector _ #methodComment]. tileBearingHelp balloonTextSelector: balloonTextSelector]. aPhrase markAsPartsDonor. cmd == #emptyScript ifTrue: [aPhrase setProperty: #newPermanentScript toValue: true. aPhrase setProperty: #newPermanentPlayer toValue: scriptedPlayer. aPhrase submorphs second setBalloonText: 'drag and drop to add a new script' translated]. universal ifFalse: [selfTile _ self tileForSelf. selfTile position: aPhrase firstSubmorph position. aPhrase firstSubmorph addMorph: selfTile]. aRow _ ViewerLine newRow borderWidth: 0; color: self color. aRow elementSymbol: cmd asSymbol. aRow addMorphBack: (ScriptingSystem tryButtonFor: aPhrase). aRow addMorphBack: (Morph new extent: 2@2; beTransparent). aRow addMorphBack: (self infoButtonFor: cmd). aRow addMorphBack: aPhrase. aPhrase on: #mouseEnter send: #addCommandFeedback to: aRow. aPhrase on: #mouseLeave send: #removeHighlightFeedback to: aRow. aPhrase on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. (names includes: cmd) ifTrue: [aPhrase userScriptSelector: cmd. cmd numArgs == 0 ifTrue: [aPhrase beTransparent. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer. aRow addMorphBack: (stat _ (inst _ scriptedPlayer scriptInstantiationForSelector: cmd) statusControlMorph). inst updateStatusMorph: stat]]. aRow beSticky; disableDragNDrop. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 9/6/2002 11:50'! phraseForVariableFrom: aMethodInterface "Return a structure consisting of tiles and controls and a readout representing a 'variable' belonging to the player, complete with an appropriate readout when indicated. Functions in both universalTiles mode and classic mode. Slightly misnamed in that this path is used for any methodInterface that indicates an interesting resultType." | anArrow slotName getterButton cover inner aRow doc setter tryer universal | aRow _ ViewerLine newRow color: self color; beSticky; elementSymbol: (slotName _ aMethodInterface selector); wrapCentering: #center; cellPositioning: #leftCenter. (universal _ scriptedPlayer isUniversalTiles) ifFalse: [aRow addMorphBack: (Morph new color: self color; extent: 11 @ 22; yourself)]. "spacer" aRow addMorphBack: (self infoButtonFor: slotName). aRow addMorphBack: (Morph new color: self color; extent: 0@10). " spacer" universal ifTrue: [inner _ scriptedPlayer universalTilesForGetterOf: aMethodInterface. cover _ Morph new color: Color transparent. cover extent: inner fullBounds extent. (getterButton _ cover copy) addMorph: cover; addMorphBack: inner. cover on: #mouseDown send: #makeUniversalTilesGetter:event:from: to: self withValue: aMethodInterface. aRow addMorphFront: (tryer _ ScriptingSystem tryButtonFor: inner). tryer color: tryer color lighter lighter] ifFalse: [aRow addMorphBack: self tileForSelf bePossessive. aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" getterButton _ self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType]. aRow addMorphBack: getterButton. (doc _ aMethodInterface documentationOrNil) ifNotNil: [getterButton setBalloonText: doc]. universal ifFalse: [(slotName == #seesColor:) ifTrue: [self addIsOverColorDetailTo: aRow. ^ aRow]. (slotName == #touchesA:) ifTrue: [self addTouchesADetailTo: aRow. ^ aRow]. (slotName == #overlaps:) ifTrue: [self addOverlapsDetailTo: aRow. ^ aRow]]. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" (setter _ aMethodInterface companionSetterSelector) ifNotNil: [aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" anArrow _ universal ifTrue: [self arrowSetterButton: #newMakeSetterFromInterface:evt:from: args: aMethodInterface] ifFalse: [self arrowSetterButton: #makeSetter:from:forPart: args: (Array with: slotName with: aMethodInterface resultType)]. aRow addMorphBack: anArrow]. (#(color:sees: playerSeeingColor copy touchesA: overlaps:) includes: slotName) ifFalse: [(universal and: [slotName == #seesColor:]) ifFalse: [aRow addMorphBack: (self readoutFor: slotName type: aMethodInterface resultType readOnly: setter isNil getSelector: aMethodInterface selector putSelector: setter)]]. anArrow ifNotNil: [anArrow step]. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'nk 7/12/2003 06:58' prior: 34562674! phraseForVariableFrom: aMethodInterface "Return a structure consisting of tiles and controls and a readout representing a 'variable' belonging to the player, complete with an appropriate readout when indicated. Functions in both universalTiles mode and classic mode. Slightly misnamed in that this path is used for any methodInterface that indicates an interesting resultType." | anArrow slotName getterButton cover inner aRow doc setter tryer universal buttonFont | aRow := ViewerLine newRow color: self color; beSticky; elementSymbol: (slotName := aMethodInterface selector); wrapCentering: #center; cellPositioning: #leftCenter. (universal := scriptedPlayer isUniversalTiles) ifFalse: [ buttonFont _ Preferences standardEToysFont. aRow addMorphBack: (Morph new color: self color; extent: (((buttonFont widthOfString: '!!') + 6) @ (buttonFont height + 6)); yourself)]. "spacer" aRow addMorphBack: (self infoButtonFor: slotName). aRow addMorphBack: (Morph new color: self color; extent: 0 @ 10). "spacer" universal ifTrue: [inner := scriptedPlayer universalTilesForGetterOf: aMethodInterface. cover := Morph new color: Color transparent. cover extent: inner fullBounds extent. (getterButton := cover copy) addMorph: cover; addMorphBack: inner. cover on: #mouseDown send: #makeUniversalTilesGetter:event:from: to: self withValue: aMethodInterface. aRow addMorphFront: (tryer := ScriptingSystem tryButtonFor: inner). tryer color: tryer color lighter lighter] ifFalse: [aRow addMorphBack: self tileForSelf bePossessive. aRow addMorphBack: (Morph new color: self color; extent: 2 @ 10). "spacer" getterButton := self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType]. aRow addMorphBack: getterButton. (doc := aMethodInterface documentationOrNil) ifNotNil: [getterButton setBalloonText: doc]. universal ifFalse: [slotName == #seesColor: ifTrue: [self addIsOverColorDetailTo: aRow. ^ aRow]. slotName == #touchesA: ifTrue: [self addTouchesADetailTo: aRow. ^ aRow]. slotName == #overlaps: ifTrue: [self addOverlapsDetailTo: aRow. ^ aRow]]. aRow addMorphBack: AlignmentMorph new beTransparent. "flexible spacer" (setter := aMethodInterface companionSetterSelector) ifNotNil: [aRow addMorphBack: (Morph new color: self color; extent: 2 @ 10). "spacer" anArrow := universal ifTrue: [self arrowSetterButton: #newMakeSetterFromInterface:evt:from: args: aMethodInterface] ifFalse: [self arrowSetterButton: #makeSetter:from:forPart: args: (Array with: slotName with: aMethodInterface resultType)]. aRow addMorphBack: anArrow]. (#(#color:sees: #playerSeeingColor #copy #touchesA: #overlaps: ) includes: slotName) ifFalse: [(universal and: [slotName == #seesColor:]) ifFalse: [aRow addMorphBack: (self readoutFor: slotName type: aMethodInterface resultType readOnly: setter isNil getSelector: aMethodInterface selector putSelector: setter)]]. anArrow ifNotNil: [anArrow step]. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 3/4/2004 13:29' prior: 34565673! phraseForVariableFrom: aMethodInterface "Return a structure consisting of tiles and controls and a readout representing a 'variable' belonging to the player, complete with an appropriate readout when indicated. Functions in both universalTiles mode and classic mode. Slightly misnamed in that this path is used for any methodInterface that indicates an interesting resultType." | anArrow slotName getterButton cover inner aRow doc setter tryer universal hotTileForSelf spacer buttonFont | aRow _ ViewerLine newRow color: self color; beSticky; elementSymbol: (slotName _ aMethodInterface selector); wrapCentering: #center; cellPositioning: #leftCenter. (universal _ scriptedPlayer isUniversalTiles) ifFalse: [buttonFont _ Preferences standardEToysFont. aRow addMorphBack: (Morph new color: self color; extent: (((buttonFont widthOfString: '!!') + 6) @ (buttonFont height + 6)); yourself)]. "spacer" aRow addMorphBack: (self infoButtonFor: slotName). aRow addMorphBack: (Morph new color: self color; extent: 0@10). " spacer" universal ifTrue: [inner _ scriptedPlayer universalTilesForGetterOf: aMethodInterface. cover _ Morph new color: Color transparent. cover extent: inner fullBounds extent. (getterButton _ cover copy) addMorph: cover; addMorphBack: inner. cover on: #mouseDown send: #makeUniversalTilesGetter:event:from: to: self withValue: aMethodInterface. aRow addMorphFront: (tryer _ ScriptingSystem tryButtonFor: inner). tryer color: tryer color lighter lighter] ifFalse: [hotTileForSelf _ self tileForSelf bePossessive. hotTileForSelf on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). aRow addMorphBack: hotTileForSelf. aRow addMorphBack: (spacer _ Morph new color: self color; extent: 2@10). spacer on: #mouseEnter send: #addGetterFeedback to: aRow. spacer on: #mouseLeave send: #removeHighlightFeedback to: aRow. spacer on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. spacer on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). hotTileForSelf on: #mouseEnter send: #addGetterFeedback to: aRow. hotTileForSelf on: #mouseLeave send: #removeHighlightFeedback to: aRow. hotTileForSelf on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. getterButton _ self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType]. aRow addMorphBack: getterButton. getterButton on: #mouseEnter send: #addGetterFeedback to: aRow. getterButton on: #mouseLeave send: #removeHighlightFeedback to: aRow. getterButton on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. (doc _ aMethodInterface documentationOrNil) ifNotNil: [getterButton setBalloonText: doc translated]. universal ifFalse: [(slotName == #seesColor:) ifTrue: [self addIsOverColorDetailTo: aRow. ^ aRow]. (slotName == #touchesA:) ifTrue: [self addTouchesADetailTo: aRow. ^ aRow]. (slotName == #overlaps:) ifTrue: [self addOverlapsDetailTo: aRow. ^ aRow]]. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" (setter _ aMethodInterface companionSetterSelector) ifNotNil: [aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" anArrow _ universal ifTrue: [self arrowSetterButton: #newMakeSetterFromInterface:evt:from: args: aMethodInterface] ifFalse: [self arrowSetterButton: #makeSetter:from:forPart: args: (Array with: slotName with: aMethodInterface resultType)]. anArrow beTransparent. universal ifFalse: [anArrow on: #mouseEnter send: #addSetterFeedback to: aRow. anArrow on: #mouseLeave send: #removeHighlightFeedback to: aRow. anArrow on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow]. aRow addMorphBack: anArrow]. (#(color:sees: playerSeeingColor copy touchesA: overlaps:) includes: slotName) ifFalse: [(universal and: [slotName == #seesColor:]) ifFalse: [aMethodInterface wantsReadoutInViewer ifTrue: [aRow addMorphBack: (self readoutFor: slotName type: aMethodInterface resultType readOnly: setter isNil getSelector: aMethodInterface selector putSelector: setter)]]]. anArrow ifNotNil: [anArrow step]. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'nk 7/12/2004 22:55' prior: 34568926! phraseForVariableFrom: aMethodInterface "Return a structure consisting of tiles and controls and a readout representing a 'variable' belonging to the player, complete with an appropriate readout when indicated. Functions in both universalTiles mode and classic mode. Slightly misnamed in that this path is used for any methodInterface that indicates an interesting resultType." | anArrow slotName getterButton cover inner aRow doc setter tryer universal hotTileForSelf spacer buttonFont | aRow _ ViewerLine newRow color: self color; beSticky; elementSymbol: (slotName _ aMethodInterface selector); wrapCentering: #center; cellPositioning: #leftCenter. (universal _ scriptedPlayer isUniversalTiles) ifFalse: [buttonFont _ Preferences standardEToysFont. aRow addMorphBack: (Morph new color: self color; extent: (((buttonFont widthOfString: '!!') + 8) @ (buttonFont height + 6)); yourself)]. "spacer" aRow addMorphBack: (self infoButtonFor: slotName). aRow addMorphBack: (Morph new color: self color; extent: 0@10). " spacer" universal ifTrue: [inner _ scriptedPlayer universalTilesForGetterOf: aMethodInterface. cover _ Morph new color: Color transparent. cover extent: inner fullBounds extent. (getterButton _ cover copy) addMorph: cover; addMorphBack: inner. cover on: #mouseDown send: #makeUniversalTilesGetter:event:from: to: self withValue: aMethodInterface. aRow addMorphFront: (tryer _ ScriptingSystem tryButtonFor: inner). tryer color: tryer color lighter lighter] ifFalse: [hotTileForSelf _ self tileForSelf bePossessive. hotTileForSelf on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). aRow addMorphBack: hotTileForSelf. aRow addMorphBack: (spacer _ Morph new color: self color; extent: 2@10). spacer on: #mouseEnter send: #addGetterFeedback to: aRow. spacer on: #mouseLeave send: #removeHighlightFeedback to: aRow. spacer on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. spacer on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). hotTileForSelf on: #mouseEnter send: #addGetterFeedback to: aRow. hotTileForSelf on: #mouseLeave send: #removeHighlightFeedback to: aRow. hotTileForSelf on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. getterButton _ self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType]. aRow addMorphBack: getterButton. getterButton on: #mouseEnter send: #addGetterFeedback to: aRow. getterButton on: #mouseLeave send: #removeHighlightFeedback to: aRow. getterButton on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. (doc _ aMethodInterface documentationOrNil) ifNotNil: [getterButton setBalloonText: doc translated]. universal ifFalse: [(slotName == #seesColor:) ifTrue: [self addIsOverColorDetailTo: aRow. ^ aRow]. (slotName == #touchesA:) ifTrue: [self addTouchesADetailTo: aRow. ^ aRow]. (slotName == #overlaps:) ifTrue: [self addOverlapsDetailTo: aRow. ^ aRow]]. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" (setter _ aMethodInterface companionSetterSelector) ifNotNil: [aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" anArrow _ universal ifTrue: [self arrowSetterButton: #newMakeSetterFromInterface:evt:from: args: aMethodInterface] ifFalse: [self arrowSetterButton: #makeSetter:from:forPart: args: (Array with: slotName with: aMethodInterface resultType)]. anArrow beTransparent. universal ifFalse: [anArrow on: #mouseEnter send: #addSetterFeedback to: aRow. anArrow on: #mouseLeave send: #removeHighlightFeedback to: aRow. anArrow on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow]. aRow addMorphBack: anArrow]. (#(color:sees: playerSeeingColor copy touchesA: overlaps:) includes: slotName) ifFalse: [(universal and: [slotName == #seesColor:]) ifFalse: [aMethodInterface wantsReadoutInViewer ifTrue: [aRow addMorphBack: (self readoutFor: slotName type: aMethodInterface resultType readOnly: setter isNil getSelector: aMethodInterface selector putSelector: setter)]]]. anArrow ifNotNil: [anArrow step]. ^ aRow ! ! !CategoryViewer methodsFor: 'entries' stamp: 'nk 7/12/2004 22:55' prior: 34573494! phraseForVariableFrom: aMethodInterface "Return a structure consisting of tiles and controls and a readout representing a 'variable' belonging to the player, complete with an appropriate readout when indicated. Functions in both universalTiles mode and classic mode. Slightly misnamed in that this path is used for any methodInterface that indicates an interesting resultType." | anArrow slotName getterButton cover inner aRow doc setter tryer universal hotTileForSelf spacer buttonFont | aRow _ ViewerLine newRow color: self color; beSticky; elementSymbol: (slotName _ aMethodInterface selector); wrapCentering: #center; cellPositioning: #leftCenter. (universal _ scriptedPlayer isUniversalTiles) ifFalse: [buttonFont _ Preferences standardEToysFont. aRow addMorphBack: (Morph new color: self color; extent: (((buttonFont widthOfString: '!!') + 8) @ (buttonFont height + 6)); yourself)]. "spacer" aRow addMorphBack: (self infoButtonFor: slotName). aRow addMorphBack: (Morph new color: self color; extent: 0@10). " spacer" universal ifTrue: [inner _ scriptedPlayer universalTilesForGetterOf: aMethodInterface. cover _ Morph new color: Color transparent. cover extent: inner fullBounds extent. (getterButton _ cover copy) addMorph: cover; addMorphBack: inner. cover on: #mouseDown send: #makeUniversalTilesGetter:event:from: to: self withValue: aMethodInterface. aRow addMorphFront: (tryer _ ScriptingSystem tryButtonFor: inner). tryer color: tryer color lighter lighter] ifFalse: [hotTileForSelf _ self tileForSelf bePossessive. hotTileForSelf on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). aRow addMorphBack: hotTileForSelf. aRow addMorphBack: (spacer _ Morph new color: self color; extent: 2@10). spacer on: #mouseEnter send: #addGetterFeedback to: aRow. spacer on: #mouseLeave send: #removeHighlightFeedback to: aRow. spacer on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. spacer on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). hotTileForSelf on: #mouseEnter send: #addGetterFeedback to: aRow. hotTileForSelf on: #mouseLeave send: #removeHighlightFeedback to: aRow. hotTileForSelf on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. getterButton _ self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType]. aRow addMorphBack: getterButton. getterButton on: #mouseEnter send: #addGetterFeedback to: aRow. getterButton on: #mouseLeave send: #removeHighlightFeedback to: aRow. getterButton on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. (doc _ aMethodInterface documentationOrNil) ifNotNil: [getterButton setBalloonText: doc translated]. universal ifFalse: [(slotName == #seesColor:) ifTrue: [self addIsOverColorDetailTo: aRow. ^ aRow]. (slotName == #touchesA:) ifTrue: [self addTouchesADetailTo: aRow. ^ aRow]. (slotName == #overlaps:) ifTrue: [self addOverlapsDetailTo: aRow. ^ aRow]]. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" (setter _ aMethodInterface companionSetterSelector) ifNotNil: [aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" anArrow _ universal ifTrue: [self arrowSetterButton: #newMakeSetterFromInterface:evt:from: args: aMethodInterface] ifFalse: [self arrowSetterButton: #makeSetter:from:forPart: args: (Array with: slotName with: aMethodInterface resultType)]. anArrow beTransparent. universal ifFalse: [anArrow on: #mouseEnter send: #addSetterFeedback to: aRow. anArrow on: #mouseLeave send: #removeHighlightFeedback to: aRow. anArrow on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow]. aRow addMorphBack: anArrow]. (#(color:sees: playerSeeingColor copy touchesA: overlaps:) includes: slotName) ifFalse: [(universal and: [slotName == #seesColor:]) ifFalse: [aMethodInterface wantsReadoutInViewer ifTrue: [aRow addMorphBack: (self readoutFor: slotName type: aMethodInterface resultType readOnly: setter isNil getSelector: aMethodInterface selector putSelector: setter)]]]. anArrow ifNotNil: [anArrow step]. ^ aRow ! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 11/29/2001 13:15'! readoutFor: partName type: partType readOnly: readOnly getSelector: getSelector putSelector: putSelector "Answer a readout morph for the given part" | readout | readout _ (Vocabulary vocabularyForType: partType) updatingTileForTarget: scriptedPlayer partName: partName getter: getSelector setter: putSelector. "The below is a regrettable temporary expedient" (#(getScaleFactor "etc.") includes: getSelector) ifTrue: [readout setProperty: #arrowDelta toValue: 0.1. (readout findA: UpdatingStringMorph) floatPrecision: 0.1]. readout step. ^ readout! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 9/6/2002 11:31'! wantsRowMenuFor: aSymbol "Answer whether a viewer row for the given symbol should have a menu button on it" | elementType | true ifTrue: [^ true]. "To allow show categories item. So someday this method can be removed, and its sender can stop sending it..." elementType _ scriptedPlayer elementTypeFor: aSymbol vocabulary: self currentVocabulary. (elementType == #systemScript) ifTrue: [^ false]. ((elementType == #systemSlot) and: [#(color:sees: touchesA: overlaps:) includes: aSymbol]) ifTrue: [^ false]. ^ true! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 9/1/2003 13:51' prior: 18858662! arrowSetterButton: sel args: argArray | m | m _ RectangleMorph new color: (ScriptingSystem colorForType: #command); extent: 24@TileMorph defaultH; borderWidth: 0. m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')). m setBalloonText: 'drag from here to obtain an assignment phrase.' translated. m on: #mouseDown send: sel to: self withValue: argArray. ^ m ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:19'! arrowSetterButtonFor: partName type: partType | m | m _ RectangleMorph new color: (ScriptingSystem colorForType: #command); extent: 24@TileMorph defaultH; borderWidth: 0. m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')). m setBalloonText: 'drag from here to obtain an assignment phrase.'. m on: #mouseDown send: #makeSetter:event:from: to: self withValue: (Array with: partName with: partType). ^ m ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 9/1/2003 13:51' prior: 34584163! arrowSetterButtonFor: partName type: partType | m | m _ RectangleMorph new color: (ScriptingSystem colorForType: #command); extent: 24@TileMorph defaultH; borderWidth: 0. m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')). m setBalloonText: 'drag from here to obtain an assignment phrase.' translated. m on: #mouseDown send: #makeSetter:event:from: to: self withValue: (Array with: partName with: partType). ^ m ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 9/27/2001 04:23'! getterButtonFor: getterSelector type: partType "Answer a classic-tiles getter button for a part of the given name" | m inherent wording | m _ TileMorph new adoptVocabulary: self currentVocabulary. inherent _ Utilities inherentSelectorForGetter: getterSelector. wording _ (scriptedPlayer slotInfo includesKey: inherent) ifTrue: [inherent] ifFalse: [self currentVocabulary tileWordingForSelector: getterSelector]. m setOperator: getterSelector andUseWording: wording. m typeColor: (ScriptingSystem colorForType: partType). m on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: getterSelector with: partType). ^ m! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 9/6/2002 11:57'! getterTilesFor: getterSelector type: aType "Answer classic getter for the given name/type" | selfTile selector aPhrase | "aPhrase _ nil, assumed" (#(color:sees: colorSees) includes: getterSelector) ifTrue: [aPhrase _ self colorSeesPhrase]. (#(seesColor: isOverColor) includes: getterSelector) ifTrue: [aPhrase _ self seesColorPhrase]. (#(overlaps: overlaps) includes: getterSelector) ifTrue: [aPhrase _ self overlapsPhrase]. (#(touchesA: touchesA) includes: getterSelector) ifTrue: [aPhrase _ self touchesAPhrase]. aPhrase ifNil: [aPhrase _ PhraseTileMorph new setSlotRefOperator: getterSelector asSymbol type: aType]. selfTile _ self tileForSelf bePossessive. selfTile position: aPhrase firstSubmorph position. aPhrase firstSubmorph addMorph: selfTile. selector _ aPhrase submorphs at: 2. (Vocabulary vocabularyNamed: aType capitalized) ifNotNilDo: [:aVocab | aVocab wantsSuffixArrow ifTrue: [selector addSuffixArrow]]. selector updateLiteralLabel. aPhrase enforceTileColorPolicy. ^ aPhrase! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 2/22/2003 19:00' prior: 34585973! getterTilesFor: getterSelector type: aType "Answer classic getter for the given name/type" "aPhrase _ nil, assumed" | selfTile selector aPhrase | (#(#color:sees: #colorSees) includes: getterSelector) ifTrue: [aPhrase := self colorSeesPhrase]. (#(#seesColor: #isOverColor) includes: getterSelector) ifTrue: [aPhrase := self seesColorPhrase]. (#(#overlaps: #overlaps) includes: getterSelector) ifTrue: [aPhrase := self overlapsPhrase]. (#(#touchesA: #touchesA) includes: getterSelector) ifTrue: [aPhrase := self touchesAPhrase]. aPhrase ifNil: [aPhrase := PhraseTileMorph new setSlotRefOperator: getterSelector asSymbol type: aType]. selfTile := self tileForSelf bePossessive. selfTile position: aPhrase firstSubmorph position. aPhrase firstSubmorph addMorph: selfTile. selector := aPhrase submorphs second. (Vocabulary vocabularyNamed: aType capitalized) ifNotNilDo: [:aVocab | aVocab wantsSuffixArrow ifTrue: [selector addSuffixArrow]]. selector updateLiteralLabel. aPhrase enforceTileColorPolicy. ^aPhrase! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 4/6/2001 00:59'! makeGetter: args event: evt from: aMorph "Hand the user tiles representing a classic getter on the slot represented by aMorph" | tiles | tiles _ self getterTilesFor: args first type: args second. owner ifNotNil: [self primaryHand attachMorph: tiles] ifNil: [^ tiles] ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:26'! makeGetter: arg1 from: arg2 forPart: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self makeGetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 9/14/2002 12:27'! makeSetter: selectorAndTypePair event: evt from: aMorph "Classic tiles: make a Phrase that comprises a setter of a slot, and hand it to the user." | argType m argTile selfTile argValue actualGetter | argType _ selectorAndTypePair second. actualGetter _ selectorAndTypePair first asSymbol. m _ PhraseTileMorph new setAssignmentRoot: (Utilities inherentSelectorForGetter: actualGetter) type: #command rcvrType: #Player argType: argType vocabulary: self currentVocabulary. argValue _ self scriptedPlayer perform: selectorAndTypePair first asSymbol. (argValue isKindOf: Player) ifTrue: [argTile _ argValue tileReferringToSelf] ifFalse: [argTile _ ScriptingSystem tileForArgType: argType. ((argType == #Number) and: [argValue isKindOf: Number]) ifTrue: [(scriptedPlayer decimalPlacesForGetter: actualGetter) ifNotNilDo: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]]. argTile setLiteral: argValue; updateLiteralLabel]. argTile position: m lastSubmorph position. m lastSubmorph addMorph: argTile. selfTile _ self tileForSelf bePossessive. selfTile position: m firstSubmorph position. m firstSubmorph addMorph: selfTile. m enforceTileColorPolicy. m openInHand! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'gm 2/22/2003 13:12' prior: 34588892! makeSetter: selectorAndTypePair event: evt from: aMorph "Classic tiles: make a Phrase that comprises a setter of a slot, and hand it to the user." | argType m argTile selfTile argValue actualGetter | argType := selectorAndTypePair second. actualGetter := selectorAndTypePair first asSymbol. m := PhraseTileMorph new setAssignmentRoot: (Utilities inherentSelectorForGetter: actualGetter) type: #command rcvrType: #Player argType: argType vocabulary: self currentVocabulary. argValue := self scriptedPlayer perform: selectorAndTypePair first asSymbol. (argValue isKindOf: Player) ifTrue: [argTile := argValue tileReferringToSelf] ifFalse: [argTile := ScriptingSystem tileForArgType: argType. (argType == #Number and: [argValue isNumber]) ifTrue: [(scriptedPlayer decimalPlacesForGetter: actualGetter) ifNotNilDo: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]]. argTile setLiteral: argValue; updateLiteralLabel]. argTile position: m lastSubmorph position. m lastSubmorph addMorph: argTile. selfTile := self tileForSelf bePossessive. selfTile position: m firstSubmorph position. m firstSubmorph addMorph: selfTile. m enforceTileColorPolicy. m openInHand! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:27'! makeSetter: arg1 from: arg2 forPart: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self makeSetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'RAA 4/6/2001 13:28'! makeUniversalTilesGetter: aMethodInterface event: evt from: aMorph "Button in viewer performs this to make a universal-tiles getter and attach it to hand." | newTiles | newTiles _ self newGetterTilesFor: scriptedPlayer methodInterface: aMethodInterface. newTiles setProperty: #beScript toValue: true. owner ifNotNil: [ActiveHand attachMorph: newTiles. newTiles align: newTiles topLeft with: evt hand position + (7@14)] ifNil: [^ newTiles] ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 9/6/2002 11:30'! newGetterTilesFor: aPlayer methodInterface: aMethodInterface "Return universal tiles for a getter on this property. Record who self is." | ms argTile argArray | ms _ MessageSend receiver: aPlayer selector: aMethodInterface selector arguments: #(). "Handle three idiosyncratic cases..." aMethodInterface selector == #color:sees: ifTrue: [argTile _ ScriptingSystem tileForArgType: #Color. argArray _ Array with: argTile colorSwatch color with: argTile colorSwatch color copy. ms arguments: argArray]. aMethodInterface selector == #seesColor: ifTrue: [argTile _ ScriptingSystem tileForArgType: #Color. ms arguments: (Array with: argTile colorSwatch color)]. aMethodInterface selector == #touchesA: ifTrue: [argTile _ ScriptingSystem tileForArgType: #Player. ms arguments: (Array with: argTile actualObject)]. aMethodInterface selector == #overlaps: ifTrue: [argTile _ ScriptingSystem tileForArgType: #Player. ms arguments: (Array with: argTile actualObject)]. ^ ms asTilesIn: aPlayer class globalNames: (aPlayer class officialClass ~~ CardPlayer) "For CardPlayers, use 'self'. For others, name it, and use its name."! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 3/28/2001 14:17'! newMakeGetter: arg event: evt from: aMorph "Button in viewer performs this to makea universal-tiles header tile and attach to hand." ^ self makeUniversalTilesGetter: arg event: evt from: aMorph! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 3/28/2001 13:04'! newMakeGetter: arg1 from: arg2 forMethodInterface: arg3 "Button in viewer performs this to make a new style tile and attach to hand. (Reorder the arguments for existing event handlers)" (arg3 isMorph and: [arg3 eventHandler notNil]) ifTrue: [arg3 eventHandler fixReversedValueMessages]. ^ self makeUniversalTilesGetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:27'! newMakeGetter: arg1 from: arg2 forPart: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self newMakeGetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:17'! newMakeSetter: aSpec event: evt from: aMorph "Button in viewer performs this to make a new style tile and attach to hand." | m | m _ self newTilesFor: scriptedPlayer setter: aSpec. owner ifNotNil: [self primaryHand attachMorph: m. m align: m topLeft with: evt hand position + (7@14)] ifNil: [^ m]. ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:27'! newMakeSetter: arg1 from: arg2 forPart: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self newMakeSetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'RAA 4/6/2001 13:28'! newMakeSetterFromInterface: aMethodInterface evt: evt from: aMorph "Button in viewer performs this to make a new style tile and attach to hand." | m | m _ self newSetterTilesFor: scriptedPlayer methodInterface: aMethodInterface. m setProperty: #beScript toValue: true. owner ifNotNil: [self primaryHand attachMorph: m. m align: m topLeft with: evt hand position + (7@14)] ifNil: [^ m] ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 9/30/2001 11:20'! newSetterTilesFor: aPlayer methodInterface: aMethodInterface "Return universal tiles for a setter on this property. Record who self is." | ms argValue makeSelfGlobal phrase | argValue _ aPlayer perform: aMethodInterface selector. ms _ MessageSend receiver: aPlayer selector: aMethodInterface companionSetterSelector arguments: (Array with: argValue). makeSelfGlobal _ aPlayer class officialClass ~~ CardPlayer. phrase _ ms asTilesIn: aPlayer class globalNames: makeSelfGlobal. "For CardPlayers, use 'self'. For others, name it, and use its name." makeSelfGlobal ifFalse: [phrase setProperty: #scriptedPlayer toValue: aPlayer]. ^ phrase! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 11/16/2001 14:44'! newTilesFor: aPlayer setter: aSpec | ms argValue | "Return universal tiles for a getter on this property. Record who self is." argValue _ aPlayer perform: (Utilities getterSelectorFor: aSpec second asSymbol). ms _ MessageSend receiver: aPlayer selector: aSpec ninth arguments: (Array with: argValue). ^ ms asTilesIn: aPlayer class globalNames: (aPlayer class officialClass ~~ CardPlayer) "For CardPlayers, use 'self'. For others, name it, and use its name."! ! !CategoryViewer methodsFor: 'header pane' stamp: 'sw 12/11/2001 19:08'! addHeaderMorph "Add the header at the top of the viewer, with a control for choosing the category, etc." | header aFont aButton | header _ AlignmentMorph newRow color: self color; wrapCentering: #center; cellPositioning: #leftCenter. aFont _ Preferences standardButtonFont. header addMorph: (aButton _ SimpleButtonMorph new label: 'O' font: aFont). aButton target: self; color: Color tan; actionSelector: #delete; setBalloonText: 'remove this pane from the screen don''t worry -- nothing will be lost!!.'. self maybeAddArrowsTo: header. header beSticky. self addMorph: header. self addNamePaneTo: header. chosenCategorySymbol _ #basic! ! !CategoryViewer methodsFor: 'header pane' stamp: 'dgd 9/1/2003 15:02' prior: 34597139! addHeaderMorph "Add the header at the top of the viewer, with a control for choosing the category, etc." | header aFont aButton | header _ AlignmentMorph newRow color: self color; wrapCentering: #center; cellPositioning: #leftCenter. aFont _ Preferences standardButtonFont. header addMorph: (aButton _ SimpleButtonMorph new label: 'O' font: aFont). aButton target: self; color: Color tan; actionSelector: #delete; setBalloonText: 'remove this pane from the screen don''t worry -- nothing will be lost!!.' translated. self maybeAddArrowsTo: header. header beSticky. self addMorph: header. self addNamePaneTo: header. chosenCategorySymbol _ #basic! ! !CategoryViewer methodsFor: 'header pane' stamp: 'sw 12/11/2001 15:37'! addNamePaneTo: header "Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer" | aButton | namePane _ RectangleMorph newSticky color: Color brown veryMuchLighter. namePane borderWidth: 0. aButton _ (StringButtonMorph contents: '-----' font: (StrikeFont familyName: #NewYork size: 12)) color: Color black. aButton target: self; arguments: Array new; actionSelector: #chooseCategory. aButton actWhen: #buttonDown. namePane addMorph: aButton. aButton position: namePane position. namePane align: namePane topLeft with: (bounds topLeft + (50 @ 0)). namePane setBalloonText: 'category (click here to choose a different one)'. header addMorphBack: namePane. (namePane isKindOf: RectangleMorph) ifTrue: [namePane addDropShadow. namePane shadowColor: Color gray]! ! !CategoryViewer methodsFor: 'header pane' stamp: 'dgd 9/1/2003 13:46' prior: 34598631! addNamePaneTo: header "Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer" | aButton | namePane := RectangleMorph newSticky color: Color brown veryMuchLighter. namePane borderWidth: 0. aButton := (StringButtonMorph contents: '-----' font: Preferences standardEToysFont) color: Color black. aButton target: self; arguments: Array new; actionSelector: #chooseCategory. aButton actWhen: #buttonDown. namePane addMorph: aButton. aButton position: namePane position. namePane align: namePane topLeft with: bounds topLeft + (50 @ 0). namePane setBalloonText: 'category (click here to choose a different one)' translated. header addMorphBack: namePane. (namePane isKindOf: RectangleMorph) ifTrue: [namePane addDropShadow. namePane shadowColor: Color gray]! ! !CategoryViewer methodsFor: 'header pane' stamp: 'dgd 11/16/2003 10:38' prior: 34599533! addNamePaneTo: header "Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer" | aButton | namePane := RectangleMorph newSticky color: Color brown veryMuchLighter. namePane borderWidth: 0. aButton := (StringButtonMorph contents: '-----' font: (StrikeFont familyName: #NewYork size: 12)) color: Color black. aButton target: self; arguments: Array new; actionSelector: #chooseCategory. aButton actWhen: #buttonDown. namePane addMorph: aButton. aButton position: namePane position. namePane align: namePane topLeft with: bounds topLeft + (50 @ 0). namePane setBalloonText: 'category (click here to choose a different one)' translated. header addMorphBack: namePane. (namePane isKindOf: RectangleMorph) ifTrue: [namePane addDropShadow. namePane shadowColor: Color gray]! ! !CategoryViewer methodsFor: 'header pane' stamp: 'dgd 11/26/2003 15:04' prior: 34600455! addNamePaneTo: header "Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer" | aButton | namePane := RectangleMorph newSticky color: Color brown veryMuchLighter. namePane borderWidth: 0. aButton := (StringButtonMorph contents: '-----' font: Preferences standardEToysFont) color: Color black. aButton target: self; arguments: Array new; actionSelector: #chooseCategory. aButton actWhen: #buttonDown. namePane addMorph: aButton. aButton position: namePane position. namePane align: namePane topLeft with: bounds topLeft + (50 @ 0). namePane setBalloonText: 'category (click here to choose a different one)' translated. header addMorphBack: namePane. (namePane isKindOf: RectangleMorph) ifTrue: [namePane addDropShadow. namePane shadowColor: Color gray]! ! !CategoryViewer methodsFor: 'header pane' stamp: 'nk 7/12/2004 23:15' prior: 34601390! addNamePaneTo: header "Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer" | aButton | namePane := RectangleMorph newSticky color: Color brown veryMuchLighter. namePane borderWidth: 0. aButton := (StringButtonMorph contents: '-----' font: Preferences standardButtonFont) color: Color black. aButton target: self; arguments: Array new; actionSelector: #chooseCategory. aButton actWhen: #buttonDown. namePane addMorph: aButton. aButton position: namePane position. namePane align: namePane topLeft with: bounds topLeft + (50 @ 0). namePane setBalloonText: 'category (click here to choose a different one)' translated. header addMorphBack: namePane. (namePane isKindOf: RectangleMorph) ifTrue: [namePane addDropShadow. namePane shadowColor: Color gray] ! ! !CategoryViewer methodsFor: 'header pane' stamp: 'nk 7/12/2004 23:15' prior: 34602310! addNamePaneTo: header "Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer" | aButton | namePane := RectangleMorph newSticky color: Color brown veryMuchLighter. namePane borderWidth: 0. aButton := (StringButtonMorph contents: '-----' font: Preferences standardButtonFont) color: Color black. aButton target: self; arguments: Array new; actionSelector: #chooseCategory. aButton actWhen: #buttonDown. namePane addMorph: aButton. aButton position: namePane position. namePane align: namePane topLeft with: bounds topLeft + (50 @ 0). namePane setBalloonText: 'category (click here to choose a different one)' translated. header addMorphBack: namePane. (namePane isKindOf: RectangleMorph) ifTrue: [namePane addDropShadow. namePane shadowColor: Color gray] ! ! !CategoryViewer methodsFor: 'header pane' stamp: 'sw 12/11/2001 19:12'! maybeAddArrowsTo: header "Maybe add up/down arrows to the header" | wrpr | header addTransparentSpacerOfSize: 5@5. header addUpDownArrowsFor: self. (wrpr _ header submorphs last) submorphs second setBalloonText: 'previous category'. wrpr submorphs first setBalloonText: 'next category'! ! !CategoryViewer methodsFor: 'header pane' stamp: 'dgd 9/1/2003 13:47' prior: 34604139! maybeAddArrowsTo: header "Maybe add up/down arrows to the header" | wrpr | header addTransparentSpacerOfSize: 5@5. header addUpDownArrowsFor: self. (wrpr _ header submorphs last) submorphs second setBalloonText: 'previous category' translated. wrpr submorphs first setBalloonText: 'next category' translated! ! !CategoryViewer methodsFor: 'initialization' stamp: 'sw 8/22/2002 23:08'! establishContents "Perform any initialization steps that needed to wait until I am installed in my outer viewer"! ! !CategoryViewer methodsFor: 'initialization' stamp: 'sw 8/17/2002 01:54'! initializeFor: aPlayer categoryChoice: aChoice "Initialize the receiver to be associated with the player and category specified" self listDirection: #topToBottom; hResizing: #spaceFill; vResizing: #spaceFill; borderWidth: 1; beSticky. self color: Color green muchLighter muchLighter. scriptedPlayer _ aPlayer. self addHeaderMorph. self chosenCategorySymbol: aChoice ! ! !CategoryViewer methodsFor: 'initialization' stamp: 'sw 8/17/2002 01:23'! setCategorySymbolFrom: aChoice "Set my category symbol" self chosenCategorySymbol: aChoice asSymbol ! ! !CategoryViewer methodsFor: 'macpal' stamp: 'sw 5/4/2001 05:24'! currentVocabulary "Answer the vocabulary currently installed in the viewer. The outer StandardViewer object holds this information." | outerViewer | ^ (outerViewer _ self outerViewer) ifNotNil: [outerViewer currentVocabulary] ifNil: [(self world ifNil: [ActiveWorld]) currentVocabularyFor: scriptedPlayer]! ! !CategoryViewer methodsFor: 'scripting' stamp: 'sw 9/12/2001 22:58'! isTileScriptingElement "Answer whether the receiver is a tile-scripting element" ^ true! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 9/27/2001 13:28'! booleanPhraseForRetrieverOfType: retrieverType retrieverOp: retrieverOp player: aPlayer "Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result" | outerPhrase getterPhrase receiverTile rel finalTile | rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean. outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType. getterPhrase _ PhraseTileMorph new setOperator: retrieverOp type: retrieverType rcvrType: #Player. getterPhrase submorphs last setSlotRefOperator: retrieverOp. getterPhrase submorphs first changeTableLayout. receiverTile _ aPlayer tileToRefer bePossessive. receiverTile position: getterPhrase firstSubmorph position. getterPhrase firstSubmorph addMorph: receiverTile. outerPhrase firstSubmorph addMorph: getterPhrase. finalTile _ ScriptingSystem tileForArgType: retrieverType. "comes with arrows" outerPhrase submorphs last addMorph: finalTile. outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel). ^ outerPhrase! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 9/27/2001 16:39'! booleanPhraseFromPhrase: phrase "Answer, if possible, a boolean-valued phrase derived from the phrase provided" | retrieverOp retrieverTile | phrase isBoolean ifTrue: [^ phrase]. ((scriptedPlayer respondsTo: #costume) and:[scriptedPlayer costume isInWorld not]) ifTrue: [^ Array new]. ((retrieverTile _ phrase submorphs last) isKindOf: TileMorph) ifFalse: [^ phrase]. retrieverOp _ retrieverTile operatorOrExpression. (Vocabulary vocabularyForType: phrase resultType) affordsCoercionToBoolean ifTrue: [^ self booleanPhraseForRetrieverOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject]. ^ phrase! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 8/17/2002 01:11'! categoryRestorationInfo "Answer info needed to reincarnate myself" ^ self chosenCategorySymbol! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 8/6/2001 19:42'! limitClass "Answer the receiver's limitClass" | outer | ^ (outer _ self outerViewer) ifNotNil: [outer limitClass] ifNil: [ProtoObject]! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 5/4/2001 05:32'! tileForSelf "Return a tile representing the receiver's viewee" ^ scriptedPlayer tileToRefer ! ! !CautiousModel methodsFor: 'updating' stamp: 'nb 6/17/2003 12:25' prior: 18867849! okToChange Preferences cautionBeforeClosing ifFalse: [^ true]. Sensor leftShiftDown ifTrue: [^ true]. Beeper beep. ^ self confirm: 'Warning!! If you answer "yes" here, this window will disappear and its contents will be lost!! Do you really want to do that?' "CautiousModel new okToChange"! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 9/5/2001 13:53'! initialize "Initialize a blank ChangeList. Set the contentsSymbol to reflect whether diffs will initally be shown or not" contentsSymbol _ Preferences diffsInChangeList ifTrue: [self defaultDiffsSymbol] ifFalse: [#source]. changeList _ OrderedCollection new. list _ OrderedCollection new. listIndex _ 0. super initialize! ! !ChangeList methodsFor: 'initialization-release' stamp: 'tpr 10/4/2001 21:58'! openAsMorphName: labelString multiSelect: multiSelect "Open a morphic view for the messageSet, whose label is labelString. The listView may be either single or multiple selection type" | window listHeight listPane | listHeight _ 0.4. window _ (SystemWindow labelled: labelString) model: self. listPane _ multiSelect ifTrue: [PluggableListMorphOfMany on: self list: #list primarySelection: #listIndex changePrimarySelection: #toggleListIndex: listSelection: #listSelectionAt: changeListSelection: #listSelectionAt:put: menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])] ifFalse: [PluggableListMorph on: self list: #list selected: #listIndex changeSelected: #toggleListIndex: menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])]. listPane keystrokeActionSelector: #changeListKey:from:. window addMorph: listPane frame: (0 @ 0 extent: 1 @ listHeight). self addLowerPanesTo: window at: (0 @ listHeight corner: 1 @ 1) with: nil. ^ window openInWorld! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 11/13/2001 08:50'! optionalButtonsView "Answer the a View containing the optional buttons" | view bHeight vWidth first offset previousView bWidth button | vWidth _ 200. bHeight _ self optionalButtonHeight. previousView _ nil. offset _ 0. first _ true. view _ View new model: self; window: (0 @ 0 extent: vWidth @ bHeight). self changeListButtonSpecs do: [:triplet | button _ PluggableButtonView on: self getState: nil action: triplet second. button label: triplet first asParagraph. bWidth _ button label boundingBox width // 2. button window: (offset@0 extent: bWidth@bHeight); borderWidthLeft: 0 right: 1 top: 0 bottom: 0. offset _ offset + bWidth. first ifTrue: [view addSubView: button. first _ false.] ifFalse: [view addSubView: button toRightOf: previousView]. previousView _ button]. button _ PluggableButtonView on: self getState: #showingAnyKindOfDiffs action: #toggleDiffing. button label: 'diffs' asParagraph; window: (offset@0 extent: (vWidth - offset)@bHeight). view addSubView: button toRightOf: previousView. ^ view! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 8/15/2002 22:34'! wantsPrettyDiffOption "Answer whether pretty-diffs are meaningful for this tool" ^ true! ! !ChangeList methodsFor: 'menu actions' stamp: 'nk 1/7/2004 11:08'! browseAllVersionsOfSelections "Opens a Versions browser on all the currently selected methods, showing each alongside all of their historical versions." | oldSelection aList | oldSelection _ self listIndex. aList _ OrderedCollection new. Cursor read showWhile: [ 1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [ listIndex _ i. self browseVersions. aList add: i. ]]]. listIndex _ oldSelection. aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. ! ! !ChangeList methodsFor: 'menu actions' stamp: 'RAA 5/28/2001 11:37'! browseCurrentVersionsOfSelections "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" | aClass aChange aList | aList _ OrderedCollection new. Cursor read showWhile: [ 1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [ aChange _ changeList at: i. (aChange type = #method and: [(aClass _ aChange methodClass) notNil and: [aClass includesSelector: aChange methodSelector]]) ifTrue: [ aList add: ( MethodReference new setStandardClass: aClass methodSymbol: aChange methodSelector ) ]]]]. aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. MessageSet openMessageList: aList name: 'Current versions of selected methods in ', file localName! ! !ChangeList methodsFor: 'menu actions' stamp: 'nk 1/7/2004 10:23'! browseVersions | change class browser | listIndex = 0 ifTrue: [^ nil ]. change _ changeList at: listIndex. ((class _ change methodClass) notNil and: [class includesSelector: change methodSelector]) ifFalse: [ ^nil ]. browser _ super browseVersions. browser ifNotNil: [ browser addedChangeRecord: change ]. ^browser! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 12/3/2002 22:33'! changeListMenu: aMenu "Fill aMenu up so that it comprises the primary changelist-browser menu" Smalltalk isMorphic ifTrue: [aMenu addTitle: 'change list'. aMenu addStayUpItemSpecial]. aMenu addList: #( ('fileIn selections' fileInSelections 'import the selected items into the image') ('fileOut selections... ' fileOutSelections 'create a new file containing the selected items') - ('compare to current' compareToCurrentVersion 'open a separate window which shows the text differences between the on-file version and the in-image version.' ) ('toggle diffing (D)' toggleDiffing 'start or stop showing diffs in the code pane.') - ('select conflicts with any changeset' selectAllConflicts 'select methods in the file which also occur in any change-set in the system') ('select conflicts with current changeset' selectConflicts 'select methods in the file which also occur in the current change-set') ('select conflicts with...' selectConflictsWith 'allows you to designate a file or change-set against which to check for code conflicts.') - ('select unchanged methods' selectUnchangedMethods 'select methods in the file whose in-image versions are the same as their in-file counterparts' ) ('select new methods' selectNewMethods 'select methods in the file that do not current occur in the image') ('select methods for this class' selectMethodsForThisClass 'select all methods in the file that belong to the currently-selected class') - ('select all (a)' selectAll 'select all the items in the list') ('deselect all' deselectAll 'deselect all the items in the list') ('invert selections' invertSelections 'select every item that is not currently selected, and deselect every item that *is* currently selected') - ('browse current versions of selections' browseCurrentVersionsOfSelections 'open a message-list browser showing the current (in-image) counterparts of the selected methods') ('destroy current methods of selections' destroyCurrentCodeOfSelections 'remove (*destroy*) the in-image counterparts of all selected methods') - ('remove doIts' removeDoIts 'remove all items that are doIts rather than methods') ('remove older versions' removeOlderMethodVersions 'remove all but the most recent versions of methods in the list') ('remove up-to-date versions' removeExistingMethodVersions 'remove all items whose code is the same as the counterpart in-image code') ('remove selected items' removeSelections 'remove the selected items from the change-list') ('remove unselected items' removeNonSelections 'remove all the items not currently selected from the change-list')). ^ aMenu ! ! !ChangeList methodsFor: 'menu actions' stamp: 'nk 1/7/2004 11:11' prior: 34614140! changeListMenu: aMenu "Fill aMenu up so that it comprises the primary changelist-browser menu" Smalltalk isMorphic ifTrue: [aMenu addTitle: 'change list'. aMenu addStayUpItemSpecial]. aMenu addList: #( ('fileIn selections' fileInSelections 'import the selected items into the image') ('fileOut selections... ' fileOutSelections 'create a new file containing the selected items') - ('compare to current' compareToCurrentVersion 'open a separate window which shows the text differences between the on-file version and the in-image version.' ) ('toggle diffing (D)' toggleDiffing 'start or stop showing diffs in the code pane.') - ('select conflicts with any changeset' selectAllConflicts 'select methods in the file which also occur in any change-set in the system') ('select conflicts with current changeset' selectConflicts 'select methods in the file which also occur in the current change-set') ('select conflicts with...' selectConflictsWith 'allows you to designate a file or change-set against which to check for code conflicts.') - ('select unchanged methods' selectUnchangedMethods 'select methods in the file whose in-image versions are the same as their in-file counterparts' ) ('select new methods' selectNewMethods 'select methods in the file that do not current occur in the image') ('select methods for this class' selectMethodsForThisClass 'select all methods in the file that belong to the currently-selected class') - ('select all (a)' selectAll 'select all the items in the list') ('deselect all' deselectAll 'deselect all the items in the list') ('invert selections' invertSelections 'select every item that is not currently selected, and deselect every item that *is* currently selected') - ('browse all versions of single selection' browseVersions 'open a version browser showing the versions of the currently selected method') ('browse all versions of selections' browseAllVersionsOfSelections 'open a version browser showing all the versions of all the selected methods') ('browse current versions of selections' browseCurrentVersionsOfSelections 'open a message-list browser showing the current (in-image) counterparts of the selected methods') ('destroy current methods of selections' destroyCurrentCodeOfSelections 'remove (*destroy*) the in-image counterparts of all selected methods') - ('remove doIts' removeDoIts 'remove all items that are doIts rather than methods') ('remove older versions' removeOlderMethodVersions 'remove all but the most recent versions of methods in the list') ('remove up-to-date versions' removeExistingMethodVersions 'remove all items whose code is the same as the counterpart in-image code') ('remove selected items' removeSelections 'remove the selected items from the change-list') ('remove unselected items' removeNonSelections 'remove all the items not currently selected from the change-list')). ^ aMenu ! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 5/20/2001 21:18'! compareToCurrentVersion "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" | change class s1 s2 | listIndex = 0 ifTrue: [^ self]. change _ changeList at: listIndex. ((class _ change methodClass) notNil and: [class includesSelector: change methodSelector]) ifTrue: [s1 _ (class sourceCodeAt: change methodSelector) asString. s2 _ change string. s1 = s2 ifTrue: [^ self inform: 'Exact Match']. (StringHolder new textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: class prettyDiffs: self showingPrettyDiffs)) openLabel: 'Comparison to Current Version'] ifFalse: [self flash]! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 8/15/2002 22:35'! optionalButtonRow "Answer a row of buttons to occur in a tool pane" | aRow aButton | aRow _ AlignmentMorph newRow. aRow hResizing: #spaceFill. aRow clipSubmorphs: true. aRow layoutInset: 5@2; cellInset: 3. aRow wrapCentering: #center; cellPositioning: #leftCenter. self changeListButtonSpecs do: [:triplet | aButton _ PluggableButtonMorph on: self getState: nil action: triplet second. aButton hResizing: #spaceFill; vResizing: #spaceFill; useRoundedCorners; label: triplet first asString; askBeforeChanging: true; onColor: Color transparent offColor: Color transparent. aRow addMorphBack: aButton. aButton setBalloonText: triplet third]. aRow addMorphBack: self regularDiffButton. self wantsPrettyDiffOption ifTrue: [aRow addMorphBack: self prettyDiffButton]. ^ aRow! ! !ChangeList methodsFor: 'menu actions' stamp: 'ar 2/24/2001 18:29'! removeExistingMethodVersions "Remove all up to date version of entries from the receiver" | newChangeList newList str keep cls sel | newChangeList _ OrderedCollection new. newList _ OrderedCollection new. changeList with: list do:[:chRec :strNstamp | keep _ true. (cls _ chRec methodClass) ifNotNil:[ str _ chRec string. sel _ cls parserClass new parseSelector: str. keep _ (cls sourceCodeAt: sel ifAbsent:['']) asString ~= str. ]. keep ifTrue:[ newChangeList add: chRec. newList add: strNstamp]]. newChangeList size < changeList size ifTrue: [changeList _ newChangeList. list _ newList. listIndex _ 0. listSelections _ Array new: list size withAll: false]. self changed: #list! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 6/6/2001 12:54'! selectAllConflicts "Selects all method definitions in the receiver which are also in any existing change set in the system. This makes no statement about whether the content of the methods differ, only whether there is a change represented." | aClass aChange | Cursor read showWhile: [1 to: changeList size do: [:i | aChange _ changeList at: i. listSelections at: i put: (aChange type = #method and: [(aClass _ aChange methodClass) notNil and: [ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector: aChange methodSelector]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'sd 5/23/2003 14:24' prior: 18976609! selectConflicts "Selects all method definitions for which there is ALSO an entry in changes" | change class | Cursor read showWhile: [1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: (change type = #method and: [(class _ change methodClass) notNil and: [(ChangeSet current atSelector: change methodSelector class: class) ~~ #none]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'di 4/6/2001 09:03'! selectConflictsWith "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk" | aStream all index | aStream _ WriteStream on: (String new: 200). (all _ ChangeSorter allChangeSets copy) do: [:sel | aStream nextPutAll: (sel name contractTo: 40); cr]. ChangeList allSubInstancesDo: [:sel | aStream nextPutAll: (sel file name); cr. all addLast: sel]. aStream skip: -1. index _ (PopUpMenu labels: aStream contents) startUp. index > 0 ifTrue: [ self selectConflicts: (all at: index)]. ! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 12/3/2002 22:27'! selectNewMethods "Selects all method definitions for which there is no counterpart method in the current image" | change class | Cursor read showWhile: [1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: ((change type = #method and: [((class _ change methodClass) isNil) or: [(class includesSelector: change methodSelector) not]]))]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'nk 1/7/2004 09:16' prior: 18979759! selectUnchangedMethods "Selects all method definitions for which there is already a method in the current image, whose source is exactly the same. 9/18/96 sw" | change class | Cursor read showWhile: [1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: ((change type = #method and: [(class _ change methodClass) notNil]) and: [(class includesSelector: change methodSelector) and: [change string withBlanksCondensed = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed ]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 6/18/2001 10:44'! annotation "Answer the string to be shown in an annotation pane. Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version, and if the corresponding method is missing from the in-image version, mention that fact." | annot aChange aClass | annot _ super annotation. annot asString = '------' ifTrue: [^ annot]. ^ ((aChange _ self currentChange) notNil and: [aChange methodSelector notNil]) ifFalse: [annot] ifTrue: [((aClass _ aChange methodClass) isNil or: [(aClass includesSelector: aChange methodSelector) not]) ifTrue: [aChange methodClassName, ' >> ', aChange methodSelector, ' is not present in the current image.'] ifFalse: ['current version: ', annot]]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 9/5/2001 13:52'! contents "Answer the contents string, obeying diffing directives if needed" ^ self showingAnyKindOfDiffs ifFalse: [self undiffedContents] ifTrue: [self showsVersions ifTrue: [self diffedVersionContents] ifFalse: [self contentsDiffedFromCurrent]]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 5/19/2001 10:59'! contentsDiffedFromCurrent "Answer the contents diffed forward from current (in-memory) method version" | aChange aClass | listIndex = 0 ifTrue: [^ '']. aChange _ changeList at: listIndex. ^ ((aChange type == #method and: [(aClass _ aChange methodClass) notNil]) and: [aClass includesSelector: aChange methodSelector]) ifTrue: [Utilities methodDiffFor: aChange text class: aClass selector: aChange methodSelector prettyDiffs: self showingPrettyDiffs] ifFalse: [(changeList at: listIndex) text]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 11/13/2001 09:12'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane" ^ self sourceAndDiffsQuintsOnly! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 6/7/2001 23:54'! diffedVersionContents "Answer diffed version contents, maybe pretty maybe not" | change class earlier later | (listIndex = 0 or: [changeList size < listIndex]) ifTrue: [^ '']. change _ changeList at: listIndex. later _ change text. class _ change methodClass. (listIndex == changeList size or: [class == nil]) ifTrue: [^ later]. earlier _ (changeList at: listIndex + 1) text. ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! !ChangeList methodsFor: 'viewing access' stamp: 'NS 1/28/2004 11:18' prior: 18982885! restoreDeletedMethod "If lostMethodPointer is not nil, then this is a version browser for a method that has been removed. In this case we want to establish a sourceCode link to prior versions. We do this by installing a dummy method with the correct source code pointer prior to installing this version." | dummyMethod class selector | dummyMethod _ CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer. class _ (changeList at: listIndex) methodClass. selector _ (changeList at: listIndex) methodSelector. class addSelectorSilently: selector withMethod: dummyMethod. (changeList at: listIndex) fileIn. "IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails." (class compiledMethodAt: selector) == dummyMethod ifTrue: [class basicRemoveSelector: selector]. ^ true! ! !ChangeList methodsFor: 'viewing access' stamp: 'nk 1/7/2004 09:50'! selectedClass ^self selectedClassOrMetaClass theNonMetaClass ! ! !ChangeList methodsFor: 'viewing access' stamp: 'nk 2/26/2004 13:50' prior: 34629185! selectedClass ^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass ! ! !ChangeList class methodsFor: 'public access' stamp: 'HK 4/18/2002 15:02'! browseRecent: charCount "ChangeList browseRecent: 5000" "Opens a changeList on the end of the changes log file" ^ self browseRecent: charCount on: (SourceFiles at: 2) ! ! !ChangeList class methodsFor: 'public access' stamp: 'HK 4/18/2002 15:02'! browseRecent: charCount on: origChangesFile "Opens a changeList on the end of the specified changes log file" | changeList end changesFile | changesFile _ origChangesFile readOnlyCopy. end _ changesFile size. Cursor read showWhile: [changeList _ self new scanFile: changesFile from: (0 max: end - charCount) to: end]. changesFile close. self open: changeList name: 'Recent changes' multiSelect: true! ! !ChangeList class methodsFor: 'public access' stamp: 'HK 4/24/2002 16:55'! browseRecentLog "ChangeList browseRecentLog" "Prompt with a menu of how far back to go to browse the current image's changes log file" ^ self browseRecentLogOn: (SourceFiles at: 2) startingFrom: Smalltalk lastQuitLogPosition! ! !ChangeList class methodsFor: 'public access' stamp: 'sd 11/16/2003 14:10' prior: 34630262! browseRecentLog "ChangeList browseRecentLog" "Prompt with a menu of how far back to go to browse the current image's changes log file" ^ self browseRecentLogOn: (SourceFiles at: 2) startingFrom: SmalltalkImage current lastQuitLogPosition! ! !ChangeList class methodsFor: 'public access' stamp: 'sw 7/4/2002 19:05'! browseRecentLogOn: origChangesFile "figure out where the last snapshot or quit was, then browse the recent entries." | end done block pos chunk changesFile positions prevBlock | changesFile _ origChangesFile readOnlyCopy. positions _ SortedCollection new. end _ changesFile size. prevBlock _ end. block _ end - 1024 max: 0. done _ false. [done or: [positions size > 0]] whileFalse: [changesFile position: block. "ignore first fragment" changesFile nextChunk. [changesFile position < prevBlock] whileTrue: [pos _ changesFile position. chunk _ changesFile nextChunk. ((chunk indexOfSubCollection: '----SNAPSHOT----' startingAt: 1) = 1 or: [(chunk indexOfSubCollection: '----QUIT----' startingAt: 1) = 1]) ifTrue: [positions add: pos]]. block = 0 ifTrue: [done _ true] ifFalse: [prevBlock _ block. block _ block - 1024 max: 0]]. changesFile close. positions isEmpty ifTrue: [self inform: 'File ' , changesFile name , ' does not appear to be a changes file'] ifFalse: [self browseRecentLogOn: origChangesFile startingFrom: positions last]! ! !ChangeList class methodsFor: 'public access' stamp: 'nk 7/8/2003 13:56' prior: 34630913! browseRecentLogOn: origChangesFile "figure out where the last snapshot or quit was, then browse the recent entries." | end done block pos chunk changesFile positions prevBlock | changesFile _ origChangesFile readOnlyCopy. positions _ SortedCollection new. end _ changesFile size. prevBlock _ end. block _ end - 1024 max: 0. done _ false. [done or: [positions size > 0]] whileFalse: [changesFile position: block. "ignore first fragment" changesFile nextChunk. [changesFile position < prevBlock] whileTrue: [pos _ changesFile position. chunk _ changesFile nextChunk. ((chunk indexOfSubCollection: '----' startingAt: 1) = 1) ifTrue: [ ({ '----QUIT'. '----SNAPSHOT' } anySatisfy: [ :str | chunk beginsWith: str ]) ifTrue: [positions add: pos]]]. block = 0 ifTrue: [done _ true] ifFalse: [prevBlock _ block. block _ block - 1024 max: 0]]. changesFile close. positions isEmpty ifTrue: [self inform: 'File ' , changesFile name , ' does not appear to be a changes file'] ifFalse: [self browseRecentLogOn: origChangesFile startingFrom: positions last]! ! !ChangeList class methodsFor: 'public access' stamp: 'sw 1/2/2003 21:39'! browseRecentLogOn: origChangesFile startingFrom: initialPos "Prompt with a menu of how far back to go when browsing a changes file." | end banners positions pos chunk i changesFile | changesFile _ origChangesFile readOnlyCopy. banners _ OrderedCollection new. positions _ OrderedCollection new. end _ changesFile size. pos _ initialPos. [pos = 0 or: [banners size > 20]] whileFalse: [changesFile position: pos. chunk _ changesFile nextChunk. i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. i > 0 ifTrue: [positions addLast: pos. banners addLast: (chunk copyFrom: 5 to: i - 2). pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] ifFalse: [pos _ 0]]. changesFile close. banners size == 0 ifTrue: [^ self inform: 'this image has never been saved since changes were compressed']. pos _ (SelectionMenu labelList: banners selections: positions) startUpWithCaption: 'Browse as far back as...'. pos == nil ifTrue: [^ self]. self browseRecent: end - pos on: origChangesFile! ! !ChangeList class methodsFor: 'public access' stamp: 'sw 7/4/2002 18:54'! browseRecentLogOnPath: fullName "figure out where the last snapshot or quit was, then browse the recent entries." fullName ifNotNil: [self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)] ifNil: [self beep] ! ! !ChangeList class methodsFor: 'public access' stamp: 'nb 6/17/2003 12:25' prior: 34634472! browseRecentLogOnPath: fullName "figure out where the last snapshot or quit was, then browse the recent entries." fullName ifNotNil: [self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)] ifNil: [Beeper beep] ! ! !ChangeList class methodsFor: 'public access' stamp: 'sd 11/16/2003 14:11' prior: 18988048! getRecentLocatorWithPrompt: aPrompt "Prompt with a menu of how far back to go. Return nil if user backs out. Otherwise return the number of characters back from the end of the .changes file the user wishes to include" "ChangeList getRecentPosition" | end changesFile banners positions pos chunk i | changesFile _ (SourceFiles at: 2) readOnlyCopy. banners _ OrderedCollection new. positions _ OrderedCollection new. end _ changesFile size. pos _ SmalltalkImage current lastQuitLogPosition. [pos = 0 or: [banners size > 20]] whileFalse: [changesFile position: pos. chunk _ changesFile nextChunk. i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. i > 0 ifTrue: [positions addLast: pos. banners addLast: (chunk copyFrom: 5 to: i-2). pos _ Number readFrom: (chunk copyFrom: i+13 to: chunk size)] ifFalse: [pos _ 0]]. changesFile close. pos _ (SelectionMenu labelList: banners selections: positions) startUpWithCaption: aPrompt. pos == nil ifTrue: [^ nil]. ^ end - pos! ! !ChangeList class methodsFor: 'instance creation' stamp: 'tpr 10/8/2001 21:02'! open: aChangeList name: aString multiSelect: multiSelect "Create a standard system view for the messageSet, whose label is aString. The listView may be either single or multiple selection type" | topView listHeight annoHeight optButtonHeight codeHeight aListView underPane annotationPane buttonsView aBrowserCodeView | Smalltalk isMorphic ifTrue: [^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect]. listHeight _ 70. annoHeight _ 10. optButtonHeight _ aChangeList optionalButtonHeight. codeHeight _ 110. topView _ (StandardSystemView new) model: aChangeList; label: aString; minimumSize: 200 @ 120; borderWidth: 1. aListView _ (multiSelect ifTrue: [PluggableListViewOfMany on: aChangeList list: #list primarySelection: #listIndex changePrimarySelection: #toggleListIndex: listSelection: #listSelectionAt: changeListSelection: #listSelectionAt:put: menu: (aChangeList showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])] ifFalse: [PluggableListView on: aChangeList list: #list selected: #listIndex changeSelected: #toggleListIndex: menu: (aChangeList showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])]). aListView window: (0 @ 0 extent: 200 @ listHeight). topView addSubView: aListView. underPane _ aListView. aChangeList wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: aChangeList text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0 @ 0 extent: 200 @ 10). topView addSubView: annotationPane below: underPane. underPane _ annotationPane. codeHeight _ codeHeight - annoHeight]. aChangeList wantsOptionalButtons ifTrue: [buttonsView _ aChangeList optionalButtonsView. buttonsView borderWidth: 1. topView addSubView: buttonsView below: underPane. underPane _ buttonsView. codeHeight _ codeHeight - optButtonHeight]. aBrowserCodeView _ PluggableTextView on: aChangeList text: #contents accept: #contents: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. aBrowserCodeView controller: ReadOnlyTextController new; window: (0 @ 0 extent: 200 @ codeHeight). topView addSubView: aBrowserCodeView below: underPane. topView controller open.! ! !ChangeList class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:07'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Change List' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that presents a list of all the changes found in an external file.'! ! !ChangeList class methodsFor: 'initialize-release' stamp: 'hg 8/3/2000 18:14'! initialize FileList registerFileReader: self! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'hg 8/3/2000 18:12'! browseChangesFile: fullName "Browse the selected file in fileIn format." fullName ifNotNil: [ChangeList browseStream: (FileStream oldFileNamed: fullName)] ifNil: [self beep]! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'asm 5/3/2003 10:57' prior: 34639186! browseChangesFile: fullName "Browse the selected file in fileIn format." fullName ifNotNil: [ChangeList browseStream: (FileStream readOnlyFileNamed: fullName)] ifNil: [self beep]! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'md 10/22/2003 16:13' prior: 34639465! browseChangesFile: fullName "Browse the selected file in fileIn format." fullName ifNotNil: [ChangeList browseStream: (FileStream readOnlyFileNamed: fullName)] ifNil: [Beeper beep]! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 11:58'! browseCompressedChangesFile: fullName "Browse the selected file in fileIn format." | zipped unzipped | fullName ifNil: [ ^self beep ]. zipped _ GZipReadStream on: (FileStream readOnlyFileNamed: fullName). unzipped _ ReadStream on: zipped contents asString. ChangeList browseStream: unzipped! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'sw 7/4/2002 18:56'! fileReaderServicesForFile: fullName suffix: suffix ^ (FileStream isSourceFileSuffix: suffix) ifTrue: [Array with: self serviceBrowseChangeFile] ifFalse: [suffix = 'changes' ifTrue: [Array with: self serviceBrowseDotChangesFile] ifFalse: [#()]]! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 12:05' prior: 34640395! fileReaderServicesForFile: fullName suffix: suffix (FileStream isSourceFileSuffix: suffix) ifTrue: [^ Array with: self serviceBrowseChangeFile]. suffix = 'changes' ifTrue: [^ Array with: self serviceBrowseDotChangesFile]. (fullName asLowercase endsWith: '.cs.gz') ifTrue: [^ Array with: self serviceBrowseCompressedChangeFile]. ^ #()! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:48' prior: 34640762! fileReaderServicesForFile: fullName suffix: suffix | services | services _ OrderedCollection new. (FileStream isSourceFileSuffix: suffix) | (suffix = '*') ifTrue: [ services add: self serviceBrowseChangeFile ]. (suffix = 'changes') | (suffix = '*') ifTrue: [ services add: self serviceBrowseDotChangesFile ]. (fullName asLowercase endsWith: '.cs.gz') | (suffix = '*') ifTrue: [ services add: self serviceBrowseCompressedChangeFile ]. ^services! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'sw 2/17/2002 00:13'! serviceBrowseChangeFile "Answer a service for opening a changelist browser on a file" ^ SimpleServiceEntry provider: self label: 'changelist browser' selector: #browseChangesFile: description: 'open a changelist tool on this file' buttonLabel: 'changes'! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 7/24/2003 17:15' prior: 34641731! serviceBrowseChangeFile "Answer a service for opening a changelist browser on a file" ^ (SimpleServiceEntry provider: self label: 'changelist browser' selector: #browseStream: description: 'open a changelist tool on this file' buttonLabel: 'changes') argumentGetter: [ :fileList | fileList directory readOnlyFileNamed: fileList fileName ]! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:35' prior: 34642092! serviceBrowseChangeFile "Answer a service for opening a changelist browser on a file" ^ (SimpleServiceEntry provider: self label: 'changelist browser' selector: #browseStream: description: 'open a changelist tool on this file' buttonLabel: 'changes') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 12:03'! serviceBrowseCompressedChangeFile "Answer a service for opening a changelist browser on a file" ^ SimpleServiceEntry provider: self label: 'changelist browser' selector: #browseCompressedChangesFile: description: 'open a changelist tool on this file' buttonLabel: 'changes'! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'sw 7/4/2002 18:37'! serviceBrowseDotChangesFile "Answer a service for opening a changelist browser on the tail end of a .changes file" ^ SimpleServiceEntry provider: self label: 'recent changes in file' selector: #browseRecentLogOnPath: description: 'open a changelist tool on recent changes in file' buttonLabel: 'recent changes'! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'sw 7/4/2002 19:05'! services "Answer potential file services associated with this class" ^ Array with: self serviceBrowseChangeFile with: self serviceBrowseDotChangesFile! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 12:04' prior: 34643706! services "Answer potential file services associated with this class" ^ { self serviceBrowseChangeFile. self serviceBrowseDotChangesFile. self serviceBrowseCompressedChangeFile }! ! !ChangeList class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !ChangeListForProjects methodsFor: 'contents' stamp: 'sw 9/5/2001 15:25'! contents ^ self showingAnyKindOfDiffs ifFalse: [self undiffedContents] ifTrue: [self currentDiffedFromContents] "Current is writing over one in list. Show how I would change it"! ! !ChangeListForProjects methodsFor: 'contents' stamp: 'sw 5/19/2001 11:06'! currentDiffedFromContents "Answer the current in-memory method diffed from the current contents" | aChange aClass | listIndex = 0 ifTrue: [^ '']. aChange _ changeList at: listIndex. ^ ((aChange type == #method and: [(aClass _ aChange methodClass) notNil]) and: [aClass includesSelector: aChange methodSelector]) ifTrue: [TextDiffBuilder buildDisplayPatchFrom: aChange text to: (aClass sourceCodeAt: aChange methodSelector) inClass: aClass prettyDiffs: self showingPrettyDiffs] ifFalse: [(changeList at: listIndex) text]! ! !ChangeListForProjects commentStamp: '' prior: 0! A ChangeList that looks at the changes in a revokable project. This class has no users at present.! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/1/2003 18:27'! fileIndex ^ (SourceFiles collect: [ :sf | sf name]) indexOf: file name ifAbsent: [^ nil]. ! ! !ChangeRecord methodsFor: 'access' stamp: 'nk 1/7/2004 10:28'! fileName ^(file ifNotNil: [ file name ]) ifNil: [ '' ]! ! !ChangeRecord methodsFor: 'access' stamp: 'sw 10/20/2002 02:53'! fileOutOn: aFileStream "File the receiver out on the given file stream" | aString | type == #method ifTrue: [aFileStream nextPut: $!!. aString _ class asString , (meta ifTrue: [' class methodsFor: '] ifFalse: [' methodsFor: ']) , category asString printString. stamp ifNotNil: [aString _ aString, ' stamp: ''', stamp, '''']. aFileStream nextChunkPut: aString. aFileStream cr]. type == #preamble ifTrue: [aFileStream nextPut: $!!]. type == #classComment ifTrue: [aFileStream nextPut: $!!. aFileStream nextChunkPut: class asString, ' commentStamp: ', stamp storeString. aFileStream cr]. aFileStream nextChunkPut: self string. type == #method ifTrue: [aFileStream nextChunkPut: ' ']. aFileStream cr! ! !ChangeRecord methodsFor: 'access' stamp: 'dew 9/7/2001 00:27'! originalChangeSetForSelector: methodSelector "Returns the original changeset which contained this method version. If it is contained in the .sources file, return #sources. If it is in neither (e.g. its changeset was deleted), return nil. (The selector is passed in purely as an optimization.)" | likelyChangeSets originalChangeSet | (file localName findTokens: '.') last = 'sources' ifTrue: [^ #sources]. likelyChangeSets _ ChangeSorter allChangeSets select: [:cs | (cs atSelector: methodSelector class: self methodClass) ~~ #none]. originalChangeSet _ likelyChangeSets detect: [:cs | cs containsMethodAtPosition: position] ifNone: [nil]. ^ originalChangeSet "(still need to check for sources file)"! ! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 14:07'! position ^ position! ! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 13:33'! prior | currFile preamble prevPos tokens prevFileIndex | currFile _ file readOnlyCopy. currFile position: (0 max: position - 150). [currFile position < (position - 1)] whileTrue: [preamble _ currFile nextChunk]. currFile close. prevPos _ nil. (preamble findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [tokens _ Scanner new scanTokens: preamble] ifFalse: [tokens _ Array new]. ((tokens size between: 7 and: 8) and: [(tokens at: tokens size - 5) == #methodsFor:]) ifTrue: [ (tokens at: tokens size - 3) == #stamp: ifTrue: [ prevPos _ tokens last. prevFileIndex _ SourceFiles fileIndexFromSourcePointer: prevPos. prevPos _ SourceFiles filePositionFromSourcePointer: prevPos] ifFalse: [ prevPos _ tokens at: tokens size - 2. prevFileIndex _ tokens last]. (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]]. prevPos ifNil: [^ nil]. ^ {prevFileIndex. prevPos. SourceFiles sourcePointerFromFileIndex: prevFileIndex andPosition: prevPos}! ! !ChangeRecord methodsFor: 'access' stamp: 'nk 11/25/2003 09:44'! timeStamp "Answer a TimeStamp that corresponds to my (text) stamp" | tokens date time | tokens := self stamp findTokens: Character separators. ^ tokens size > 2 ifTrue: [[date := Date fromString: (tokens at: tokens size - 1). time := Time fromString: tokens last. TimeStamp date: date time: time] on: Error do: [:ex | ex return: (TimeStamp fromSeconds: 0)]] ifFalse: [TimeStamp fromSeconds: 0]! ! !ChangeRecord methodsFor: 'initialization' stamp: 'nk 11/26/2002 12:07'! fileIn "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." | methodClass s aSelector | Cursor read showWhile: [(methodClass _ self methodClass) notNil ifTrue: [methodClass compile: self text classified: category withStamp: stamp notifying: nil. (aSelector _ self methodSelector) ifNotNil: [Utilities noteMethodSubmission: aSelector forClass: methodClass]]. (type == #doIt) ifTrue: [((s _ self string) beginsWith: '----') ifFalse: [Compiler evaluate: s]]. (type == #classComment) ifTrue: [ | cls | (cls _ Smalltalk at: class asSymbol) comment: self text stamp: stamp. Utilities noteMethodSubmission: #Comment forClass: cls ]]! ! !ChangeSet methodsFor: 'initialize-release' stamp: 'di 4/6/2001 09:40'! initialize "Initialize the receiver to be empty." name ifNil: [^ self error: 'All changeSets must be registered, as in ChangeSorter newChangeSet']. revertable _ false. self clear. ! ! !ChangeSet methodsFor: 'change logging' stamp: 'tk 6/11/2001 17:53'! changeClass: class from: oldClass "Remember that a class definition has been changed. Record the original structure, so that a conversion method can be built." class wantsChangeSetLogging ifFalse: [^ self]. isolationSet ifNotNil: ["If there is an isolation layer above me, inform it as well." isolationSet changeClass: class from: oldClass]. class isMeta ifFalse: [self atClass: class add: #change] "normal" ifTrue: [((self classChangeAt: class theNonMetaClass name) includes: #add) ifTrue: [self atClass: class add: #add] "When a class is defined, the metaclass is not recorded, even though it was added. A further change is really just part of the original add." ifFalse: [self atClass: class add: #change]]. self addCoherency: class name. (self changeRecorderFor: class) notePriorDefinition: oldClass. self noteClassStructure: oldClass! ! !ChangeSet methodsFor: 'change logging' stamp: 'NS 1/19/2004 18:30' prior: 34650104! changeClass: class from: oldClass "Remember that a class definition has been changed. Record the original structure, so that a conversion method can be built." class wantsChangeSetLogging ifFalse: [^ self]. isolationSet ifNotNil: ["If there is an isolation layer above me, inform it as well." isolationSet changeClass: class from: oldClass]. class isMeta ifFalse: [self atClass: class add: #change] "normal" ifTrue: [((self classChangeAt: class theNonMetaClass name) includes: #add) ifTrue: [self atClass: class add: #add] "When a class is defined, the metaclass is not recorded, even though it was added. A further change is really just part of the original add." ifFalse: [self atClass: class add: #change]]. self addCoherency: class name. (self changeRecorderFor: class) notePriorDefinition: oldClass. self noteClassStructure: oldClass! ! !ChangeSet methodsFor: 'change logging' stamp: 'NS 1/27/2004 15:55'! event: anEvent "Hook for SystemChangeNotifier" (anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self noteRemovalOf: anEvent item]. (anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self addClass: anEvent item]. (anEvent isModified and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [anEvent anyChanges ifTrue: [self changeClass: anEvent item from: anEvent oldItem]]. (anEvent isCommented and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self commentClass: anEvent item]. (anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: nil]. (anEvent isModified and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: anEvent oldItem]. (anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self removeSelector: anEvent itemSelector class: anEvent itemClass priorMethod: anEvent item lastMethodInfo: {anEvent item sourcePointer. anEvent itemProtocol}]. (anEvent isRenamed and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self renameClass: anEvent item as: anEvent newName]. (anEvent isReorganized and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self reorganizeClass: anEvent item].! ! !ChangeSet methodsFor: 'change logging' stamp: 'NS 4/12/2004 22:44' prior: 34652016! event: anEvent "Hook for SystemChangeNotifier" (anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self noteRemovalOf: anEvent item]. (anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self addClass: anEvent item]. (anEvent isModified and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [anEvent anyChanges ifTrue: [self changeClass: anEvent item from: anEvent oldItem]]. (anEvent isCommented and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self commentClass: anEvent item]. (anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: nil]. (anEvent isModified and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: anEvent oldItem]. (anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self removeSelector: anEvent itemSelector class: anEvent itemClass priorMethod: anEvent item lastMethodInfo: {anEvent item sourcePointer. anEvent itemProtocol}]. (anEvent isRenamed and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self renameClass: anEvent item as: anEvent newName]. (anEvent isReorganized and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self reorganizeClass: anEvent item]. (anEvent isRecategorized and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self reorganizeClass: anEvent itemClass].! ! !ChangeSet methodsFor: 'change logging' stamp: 'tk 6/8/2001 09:27'! renameClass: class as: newName "Include indication that a class has been renamed." | recorder | isolationSet ifNotNil: ["If there is an isolation layer above me, inform it as well." isolationSet renameClass: class as: newName]. (recorder _ self changeRecorderFor: class) noteChangeType: #rename; noteNewName: newName asSymbol. "store under new name (metaclass too)" changeRecords at: newName put: recorder. changeRecords removeKey: class name. self noteClassStructure: class. recorder _ changeRecords at: class class name ifAbsent: [^ nil]. changeRecords at: (newName, ' class') put: recorder. changeRecords removeKey: class class name. recorder noteNewName: newName , ' class'! ! !ChangeSet methodsFor: 'accessing' stamp: 'BJP 4/24/2001 00:23'! author | author | self assurePreambleExists. author _ self preambleString lineNumber: 3. author _ author copyFrom: 8 to: author size. "Strip the 'Author:' prefix. Ugly ugly." ^author withBlanksTrimmed. ! ! !ChangeSet methodsFor: 'accessing' stamp: 'gm 2/16/2003 20:39' prior: 19006728! editPostscript "edit the receiver's postscript, in a separate window. " | deps found | self assurePostscriptExists. deps := postscript dependents select: [:m | (m isSystemWindow) or: [m isKindOf: StandardSystemView]]. deps size > 0 ifTrue: [Smalltalk isMorphic ifTrue: [found := deps detect: [:obj | obj isSystemWindow and: [obj world == self currentWorld]] ifNone: [nil]. found ifNotNil: [^found activate]] ifFalse: [found := deps detect: [:obj | (obj isKindOf: StandardSystemView) and: [ScheduledControllers scheduledControllers includes: obj controller]] ifNone: [nil]. found ifNotNil: [^ScheduledControllers activateController: found controller]]. self inform: 'Caution -- there' , (deps size isOrAreStringWith: 'other window') , ' already open on this postscript elsewhere']. postscript openLabel: 'Postscript for ChangeSet named ' , name! ! !ChangeSet methodsFor: 'testing' stamp: 'sw 8/10/2002 22:21'! containsMethodAtPosition: aFilePosition "Answer whether the receiver contains the method logged at the given file position" "class: aClassSymbol" "(need class parameter to speed up?)" "<- dew 9/6/2001" changeRecords values do: [:classChangeRecord | classChangeRecord methodChanges values do: [:methodChangeRecord | | changeType | changeType _ methodChangeRecord changeType. ((changeType == #add or: [changeType == #change]) and: [methodChangeRecord currentMethod notNil and: [methodChangeRecord currentMethod filePosition = aFilePosition]]) ifTrue: [^ true]]]. ^ false! ! !ChangeSet methodsFor: 'testing' stamp: 'sw 3/29/2001 14:32'! methodsWithoutClassifications "Return a collection representing methods in the receiver which have not been categorized" | slips notClassified aSelector | notClassified _ {'as yet unclassified' asSymbol. #all}. slips _ OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (aClass selectors includes: (aSelector _ mAssoc key)) ifTrue: [(notClassified includes: (aClass organization categoryOfElement: aSelector)) ifTrue: [slips add: aClass name , ' ' , aSelector]]]]. ^ slips "Smalltalk browseMessageList: (Smalltalk changes methodsWithoutClassifications) name: 'unclassified methods'"! ! !ChangeSet methodsFor: 'testing' stamp: 'nk 7/2/2003 10:47' prior: 34658141! methodsWithoutClassifications "Return a collection representing methods in the receiver which have not been categorized" | slips notClassified aSelector | notClassified _ {'as yet unclassified' asSymbol. #all}. slips _ OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (aClass selectors includes: (aSelector _ mAssoc key)) ifTrue: [(notClassified includes: (aClass organization categoryOfElement: aSelector)) ifTrue: [slips add: aClass name , ' ' , aSelector]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithoutClassifications) name: 'unclassified methods'"! ! !ChangeSet methodsFor: 'testing' stamp: 'sd 5/23/2003 14:24' prior: 19010261! okayToRemoveInforming: aBoolean "Answer whether it is okay to remove the receiver. If aBoolean is true, inform the receiver if it is not okay" | aName | aName _ self name. self == self class current ifTrue: [aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" because it is the current change set.']. ^ false]. self belongsToAProject ifTrue: [aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" because it belongs to a project.']. ^ false]. ^ true ! ! !ChangeSet methodsFor: 'method changes' stamp: 'RAA 5/28/2001 13:43'! browseMessagesWithPriorVersions "Open a message list browser on the new and changed methods in the receiver which have at least one prior version. 6/28/96 sw" | aList | aList _ self messageListForChangesWhich: [ :aClass :aSelector | (VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1 ] ifNone: [^self inform: 'None!!']. Smalltalk browseMessageList: aList name: self name, ' methods that have prior versions'! ! !ChangeSet methodsFor: 'method changes' stamp: 'sd 4/16/2003 09:15' prior: 34660249! browseMessagesWithPriorVersions "Open a message list browser on the new and changed methods in the receiver which have at least one prior version. 6/28/96 sw" | aList | aList _ self messageListForChangesWhich: [ :aClass :aSelector | (VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1 ] ifNone: [^self inform: 'None!!']. self systemNavigation browseMessageList: aList name: self name, ' methods that have prior versions'! ! !ChangeSet methodsFor: 'method changes' stamp: 'sw 6/26/2001 12:15'! changedMessageList "Used by a message set browser to access the list view information." | messageList classNameInFull classNameInParts | messageList _ OrderedCollection new. changeRecords associationsDo: [:clAssoc | classNameInFull _ clAssoc key asString. classNameInParts _ classNameInFull findTokens: ' '. (clAssoc value allChangeTypes includes: #comment) ifTrue: [messageList add: (MethodReference new setClassSymbol: classNameInParts first asSymbol classIsMeta: false methodSymbol: #Comment stringVersion: classNameInFull, ' Comment')]. clAssoc value methodChangeTypes associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [messageList add: (MethodReference new setClassSymbol: classNameInParts first asSymbol classIsMeta: classNameInParts size > 1 methodSymbol: mAssoc key stringVersion: classNameInFull, ' ' , mAssoc key)]]]. ^ messageList asSortedArray! ! !ChangeSet methodsFor: 'method changes' stamp: 'sw 4/19/2001 19:45'! hasAnyChangeForSelector: aSelector "Answer whether the receiver has any change under the given selector, whether it be add, change, or remove, for any class" changeRecords do: [:aRecord | (aRecord changedSelectors includes: aSelector) ifTrue: [^ true]]. ^ false! ! !ChangeSet methodsFor: 'method changes' stamp: 'RAA 5/28/2001 12:05'! messageListForChangesWhich: aBlock ifNone: ifEmptyBlock | answer | answer _ self changedMessageListAugmented select: [ :each | aBlock value: each actualClass value: each methodSymbol ]. answer isEmpty ifTrue: [^ifEmptyBlock value]. ^answer ! ! !ChangeSet methodsFor: 'class changes' stamp: 'NS 1/26/2004 09:46' prior: 19016848! commentClass: class "Include indication that a class comment has been changed." class wantsChangeSetLogging ifFalse: [^ self]. self atClass: class add: #comment! ! !ChangeSet methodsFor: 'class changes' stamp: 'nk 6/26/2002 12:30'! containsClass: aClass ^ self changedClasses includes: aClass! ! !ChangeSet methodsFor: 'class changes' stamp: 'NS 1/19/2004 17:49' prior: 19020173! noteRemovalOf: class "The class is about to be removed from the system. Adjust the receiver to reflect that fact." class wantsChangeSetLogging ifFalse: [^ self]. (self changeRecorderFor: class) noteChangeType: #remove fromClass: class. changeRecords removeKey: class class name ifAbsent: [].! ! !ChangeSet methodsFor: 'moving changes' stamp: 'nk 3/30/2002 09:13'! methodsWithAnyInitialsOtherThan: myInits "Return a collection of method refs whose author appears to be different from the given one, even historically" | slips method aTimeStamp | slips _ Set new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [ :mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. method ifNotNil: [ (aClass changeRecordsAt: mAssoc key) do: [ :chg | aTimeStamp _ chg stamp. (aTimeStamp notNil and: [(aTimeStamp beginsWith: myInits) not]) ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]]. ^ slips! ! !ChangeSet methodsFor: 'moving changes' stamp: 'nk 7/2/2003 10:47' prior: 19025601! methodsWithInitialsOtherThan: myInits "Return a collection of method refs whose author appears to be different from the given one" | slips method aTimeStamp | slips _ OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. method ifNotNil: [((aTimeStamp _ Utilities timeStampForMethod: method) notNil and: [(aTimeStamp beginsWith: myInits) not]) ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithInitialsOtherThan: 'sw') name: 'authoring problems'"! ! !ChangeSet methodsFor: 'moving changes' stamp: 'sw 6/6/2001 13:37'! methodsWithoutComments "Return a collection representing methods in the receiver which have no precode comments" | slips | slips _ OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [(aClass selectors includes: mAssoc key) ifTrue: [(aClass firstPrecodeCommentFor: mAssoc key) isEmptyOrNil ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. ^ slips "Smalltalk browseMessageList: (Smalltalk changes methodsWithoutComments) name: 'methods lacking comments'"! ! !ChangeSet methodsFor: 'moving changes' stamp: 'nk 7/2/2003 10:47' prior: 34665436! methodsWithoutComments "Return a collection representing methods in the receiver which have no precode comments" | slips | slips _ OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [(aClass selectors includes: mAssoc key) ifTrue: [(aClass firstPrecodeCommentFor: mAssoc key) isEmptyOrNil ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithoutComments) name: 'methods lacking comments'"! ! !ChangeSet methodsFor: 'moving changes' stamp: 'yo 8/30/2002 13:59' prior: 19027440! removeClassChanges: class "Remove all memory of changes associated with this class" | cname | (class isString) ifTrue: [ cname _ class ] ifFalse: [ cname _ class name ]. changeRecords removeKey: cname ifAbsent: []. self noteClassForgotten: cname.! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'tk 6/8/2001 20:28'! askAddedInstVars: classList | pairList pairClasses index pls newStruct oldStruct | "Ask the author whether these newly added inst vars need to be non-nil" pairList _ OrderedCollection new. pairClasses _ OrderedCollection new. "Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here." classList do: [:cls | newStruct _ (cls allInstVarNames). oldStruct _ (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst. newStruct do: [:instVarName | (oldStruct includes: instVarName) ifFalse: [ pairList add: cls name, ' ', instVarName. pairClasses add: cls]]]. pairList isEmpty ifTrue: [^ #()]. [index _ PopUpMenu withCaption: 'These instance variables were added. When an old project comes in, newly added instance variables will have the value nil. Click on items to remove them from the list. Click on any for which nil is an OK value.' chooseFrom: pairList, #('all of these need a non-nil value' 'all of these are OK with a nil value'). (index <= (pls _ pairList size)) & (index > 0) ifTrue: [ pairList removeAt: index. pairClasses removeAt: index]. index = (pls + 2) ifTrue: ["all are OK" ^ #()]. pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse. ^ pairClasses asSet asArray "non redundant"! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'tk 6/8/2001 20:29'! askRemovedInstVars: classList | pairList pairClasses index pls newStruct oldStruct | "Ask the author whether these newly removed inst vars need to have their info saved" pairList _ OrderedCollection new. pairClasses _ OrderedCollection new. "Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here." classList do: [:cls | newStruct _ (cls allInstVarNames). oldStruct _ (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst. oldStruct do: [:instVarName | (newStruct includes: instVarName) ifFalse: [ pairList add: cls name, ' ', instVarName. pairClasses add: cls]]]. pairList isEmpty ifTrue: [^ #()]. [index _ PopUpMenu withCaption: 'These instance variables were removed. When an old project comes in, instance variables that have been removed will lose their contents. Click on items to remove them from the list. Click on any whose value is unimportant and need not be saved.' chooseFrom: pairList, #('all of these need a conversion method' 'all of these have old values that can be erased'). (index <= (pls _ pairList size)) & (index > 0) ifTrue: [ pairList removeAt: index. pairClasses removeAt: index]. index = (pls + 2) ifTrue: ["all are OK" ^ #()]. pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse. ^ pairClasses asSet asArray "non redundant"! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'tk 6/8/2001 11:12'! askRenames: renamed addTo: msgSet using: smart | list rec ans oldStruct newStruct | "Go through the renamed classes. Ask the user if it could be in a project. Add a method in SmartRefStream, and a conversion method in the new class." list _ OrderedCollection new. renamed do: [:cls | rec _ changeRecords at: cls name. rec priorName ifNotNil: [ ans _ PopUpMenu withCaption: 'You renamed class ', rec priorName, ' to be ', rec thisName, '.\Could an instance of ', rec priorName, ' be in a project on someone''s disk?' chooseFrom: #('Yes, write code to convert those instances' 'No, no instances are in projects'). ans = 1 ifTrue: [ oldStruct _ structures at: rec priorName ifAbsent: [nil]. newStruct _ (Array with: cls classVersion), (cls allInstVarNames). oldStruct ifNotNil: [ smart writeConversionMethodIn: cls fromInstVars: oldStruct to: newStruct renamedFrom: rec priorName. smart writeClassRename: cls name was: rec priorName. list add: cls name, ' convertToCurrentVersion:refStream:']] ifFalse: [structures removeKey: rec priorName ifAbsent: []]]]. list isEmpty ifTrue: [^ msgSet]. msgSet messageList ifNil: [msgSet initializeMessageList: list] ifNotNil: [list do: [:item | msgSet addItem: item]]. ^ msgSet! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'ls 10/21/2001 21:09'! buildMessageForMailOutWithUser: userName | message compressBuffer compressStream data compressedStream compressTarget | "prepare the message" message := MailMessage empty. message setField: 'from' toString: userName. message setField: 'to' toString: 'squeak-dev@lists.squeakfoundation.org'. message setField: 'subject' toString: (self chooseSubjectPrefixForEmail, name). message body: (MIMEDocument contentType: 'text/plain' content: (String streamContents: [ :str | str nextPutAll: 'from preamble:'; cr; cr. self fileOutPreambleOn: str ])). "Prepare the gzipped data" data _ WriteStream on: String new. data header; timeStamp. self fileOutPreambleOn: data. self fileOutOn: data. self fileOutPostscriptOn: data. data trailer. data _ ReadStream on: data contents. compressBuffer _ ByteArray new: 1000. compressStream _ GZipWriteStream on: (compressTarget _ WriteStream on: (ByteArray new: 1000)). [data atEnd] whileFalse: [compressStream nextPutAll: (data nextInto: compressBuffer)]. compressStream close. compressedStream _ ReadStream on: compressTarget contents asString. message addAttachmentFrom: compressedStream withName: (name, '.cs.gz'). ^ message! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:15' prior: 19028808! checkForAlienAuthorship "Check to see if there are any methods in the receiver that have author initials other than that of the current author, and open a browser on all found" | aList initials | (initials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image']. (aList _ self methodsWithInitialsOtherThan: initials) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" have authoring stamps which start with "', initials, '"'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" whose authoring stamps do not start with "', initials, '"']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 3/30/2002 09:03'! checkForAnyAlienAuthorship "Check to see if there are any versions of any methods in the receiver that have author initials other than that of the current author, and open a browser on all found" | aList initials | (initials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image']. (aList _ self methodsWithAnyInitialsOtherThan: initials) size > 0 ifFalse: [^ self inform: 'All versions of all methods in "', self name, '" have authoring stamps which start with "', initials, '"'] ifTrue: [Smalltalk browseMessageList: aList name: 'methods in "', self name, '" with any authoring stamps not starting with "', initials, '"']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34673447! checkForAnyAlienAuthorship "Check to see if there are any versions of any methods in the receiver that have author initials other than that of the current author, and open a browser on all found" | aList initials | (initials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image']. (aList _ self methodsWithAnyInitialsOtherThan: initials) size > 0 ifFalse: [^ self inform: 'All versions of all methods in "', self name, '" have authoring stamps which start with "', initials, '"'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" with any authoring stamps not starting with "', initials, '"']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'tk 6/8/2001 11:48'! checkForConversionMethods "See if any conversion methods are needed" | oldStruct newStruct tell choice list need sel smart restore renamed listAdd listDrop msgSet rec nn | Preferences conversionMethodsAtFileOut ifFalse: [^ self]. "Check preference" structures ifNil: [^ self]. list _ OrderedCollection new. renamed _ OrderedCollection new. self changedClasses do: [:class | need _ (self atClass: class includes: #new) not. need ifTrue: ["Renamed classes." (self atClass: class includes: #rename) ifTrue: [ rec _ changeRecords at: class name. rec priorName ifNotNil: [ (structures includesKey: rec priorName) ifTrue: [ renamed add: class. need _ false]]]]. need ifTrue: [need _ (self atClass: class includes: #change)]. need ifTrue: [oldStruct _ structures at: class name ifAbsent: [need _ false. #()]]. need ifTrue: [ newStruct _ (Array with: class classVersion), (class allInstVarNames). need _ (oldStruct ~= newStruct)]. need ifTrue: [sel _ #convertToCurrentVersion:refStream:. (#(add change) includes: (self atSelector: sel class: class)) ifFalse: [ list add: class]]. ]. list isEmpty & renamed isEmpty ifTrue: [^ self]. "Ask user if want to do this" tell _ 'If there might be instances of ', (list asArray, renamed asArray) printString, '\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\' withCRs, 'After you edit the conversion method, you''ll need to fileOut again.\' withCRs, 'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'. choice _ (PopUpMenu labels: 'Write a conversion method by editing a prototype These classes are not used in any object file. fileOut my changes now. I''m too busy. fileOut my changes now. Don''t ever ask again. fileOut my changes now.') startUpWithCaption: tell. choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut]. choice = 2 ifTrue: ["Don't consider this class again in the changeSet" list do: [:cls | structures removeKey: cls name ifAbsent: []]. renamed do: [:cls | nn _ (changeRecords at: cls name) priorName. structures removeKey: nn ifAbsent: []]]. choice ~= 1 ifTrue: [^ self]. "exit if choice 2,3,4" listAdd _ self askAddedInstVars: list. "Go through each inst var that was added" listDrop _ self askRemovedInstVars: list. "Go through each inst var that was removed" list _ (listAdd, listDrop) asSet asArray. smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345'). smart structures: structures. smart superclasses: superclasses. (restore _ Smalltalk changes) == self ifFalse: [ Smalltalk newChanges: self]. "if not current one" msgSet _ smart conversionMethodsFor: list. "each new method is added to self (a changeSet). Then filed out with the rest." self askRenames: renamed addTo: msgSet using: smart. "renamed classes, add 2 methods" restore == self ifFalse: [Smalltalk newChanges: restore]. msgSet messageList isEmpty ifTrue: [^ self]. self inform: 'Remember to fileOut again after modifying these methods.'. MessageSet open: msgSet name: 'Conversion methods for ', self name.! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 15:14' prior: 34674965! checkForConversionMethods "See if any conversion methods are needed" | oldStruct newStruct tell choice list need sel smart restore renamed listAdd listDrop msgSet rec nn | Preferences conversionMethodsAtFileOut ifFalse: [^ self]. "Check preference" structures ifNil: [^ self]. list _ OrderedCollection new. renamed _ OrderedCollection new. self changedClasses do: [:class | need _ (self atClass: class includes: #new) not. need ifTrue: ["Renamed classes." (self atClass: class includes: #rename) ifTrue: [ rec _ changeRecords at: class name. rec priorName ifNotNil: [ (structures includesKey: rec priorName) ifTrue: [ renamed add: class. need _ false]]]]. need ifTrue: [need _ (self atClass: class includes: #change)]. need ifTrue: [oldStruct _ structures at: class name ifAbsent: [need _ false. #()]]. need ifTrue: [ newStruct _ (Array with: class classVersion), (class allInstVarNames). need _ (oldStruct ~= newStruct)]. need ifTrue: [sel _ #convertToCurrentVersion:refStream:. (#(add change) includes: (self atSelector: sel class: class)) ifFalse: [ list add: class]]. ]. list isEmpty & renamed isEmpty ifTrue: [^ self]. "Ask user if want to do this" tell _ 'If there might be instances of ', (list asArray, renamed asArray) printString, '\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\' withCRs, 'After you edit the conversion method, you''ll need to fileOut again.\' withCRs, 'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'. choice _ (PopUpMenu labels: 'Write a conversion method by editing a prototype These classes are not used in any object file. fileOut my changes now. I''m too busy. fileOut my changes now. Don''t ever ask again. fileOut my changes now.') startUpWithCaption: tell. choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut]. choice = 2 ifTrue: ["Don't consider this class again in the changeSet" list do: [:cls | structures removeKey: cls name ifAbsent: []]. renamed do: [:cls | nn _ (changeRecords at: cls name) priorName. structures removeKey: nn ifAbsent: []]]. choice ~= 1 ifTrue: [^ self]. "exit if choice 2,3,4" listAdd _ self askAddedInstVars: list. "Go through each inst var that was added" listDrop _ self askRemovedInstVars: list. "Go through each inst var that was removed" list _ (listAdd, listDrop) asSet asArray. smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345'). smart structures: structures. smart superclasses: superclasses. (restore _ self class current) == self ifFalse: [ self class newChanges: self]. "if not current one" msgSet _ smart conversionMethodsFor: list. "each new method is added to self (a changeSet). Then filed out with the rest." self askRenames: renamed addTo: msgSet using: smart. "renamed classes, add 2 methods" restore == self ifFalse: [self class current newChanges: restore]. msgSet messageList isEmpty ifTrue: [^ self]. self inform: 'Remember to fileOut again after modifying these methods.'. MessageSet open: msgSet name: 'Conversion methods for ', self name.! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 7/2/2003 09:01' prior: 34678203! checkForConversionMethods "See if any conversion methods are needed" | oldStruct newStruct tell choice list need sel smart restore renamed listAdd listDrop msgSet rec nn | Preferences conversionMethodsAtFileOut ifFalse: [^ self]. "Check preference" structures ifNil: [^ self]. list _ OrderedCollection new. renamed _ OrderedCollection new. self changedClasses do: [:class | need _ (self atClass: class includes: #new) not. need ifTrue: ["Renamed classes." (self atClass: class includes: #rename) ifTrue: [ rec _ changeRecords at: class name. rec priorName ifNotNil: [ (structures includesKey: rec priorName) ifTrue: [ renamed add: class. need _ false]]]]. need ifTrue: [need _ (self atClass: class includes: #change)]. need ifTrue: [oldStruct _ structures at: class name ifAbsent: [need _ false. #()]]. need ifTrue: [ newStruct _ (Array with: class classVersion), (class allInstVarNames). need _ (oldStruct ~= newStruct)]. need ifTrue: [sel _ #convertToCurrentVersion:refStream:. (#(add change) includes: (self atSelector: sel class: class)) ifFalse: [ list add: class]]. ]. list isEmpty & renamed isEmpty ifTrue: [^ self]. "Ask user if want to do this" tell _ 'If there might be instances of ', (list asArray, renamed asArray) printString, '\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\' withCRs, 'After you edit the conversion method, you''ll need to fileOut again.\' withCRs, 'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'. choice _ (PopUpMenu labels: 'Write a conversion method by editing a prototype These classes are not used in any object file. fileOut my changes now. I''m too busy. fileOut my changes now. Don''t ever ask again. fileOut my changes now.') startUpWithCaption: tell. choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut]. choice = 2 ifTrue: ["Don't consider this class again in the changeSet" list do: [:cls | structures removeKey: cls name ifAbsent: []]. renamed do: [:cls | nn _ (changeRecords at: cls name) priorName. structures removeKey: nn ifAbsent: []]]. choice ~= 1 ifTrue: [^ self]. "exit if choice 2,3,4" listAdd _ self askAddedInstVars: list. "Go through each inst var that was added" listDrop _ self askRemovedInstVars: list. "Go through each inst var that was removed" list _ (listAdd, listDrop) asSet asArray. smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345'). smart structures: structures. smart superclasses: superclasses. (restore _ self class current) == self ifFalse: [ self class newChanges: self]. "if not current one" msgSet _ smart conversionMethodsFor: list. "each new method is added to self (a changeSet). Then filed out with the rest." self askRenames: renamed addTo: msgSet using: smart. "renamed classes, add 2 methods" restore == self ifFalse: [self class newChanges: restore]. msgSet messageList isEmpty ifTrue: [^ self]. self inform: 'Remember to fileOut again after modifying these methods.'. MessageSet open: msgSet name: 'Conversion methods for ', self name.! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 7/2/2003 09:01' prior: 34681452! checkForConversionMethods "See if any conversion methods are needed" | oldStruct newStruct tell choice list need sel smart restore renamed listAdd listDrop msgSet rec nn | Preferences conversionMethodsAtFileOut ifFalse: [^ self]. "Check preference" structures ifNil: [^ self]. list _ OrderedCollection new. renamed _ OrderedCollection new. self changedClasses do: [:class | need _ (self atClass: class includes: #new) not. need ifTrue: ["Renamed classes." (self atClass: class includes: #rename) ifTrue: [ rec _ changeRecords at: class name. rec priorName ifNotNil: [ (structures includesKey: rec priorName) ifTrue: [ renamed add: class. need _ false]]]]. need ifTrue: [need _ (self atClass: class includes: #change)]. need ifTrue: [oldStruct _ structures at: class name ifAbsent: [need _ false. #()]]. need ifTrue: [ newStruct _ (Array with: class classVersion), (class allInstVarNames). need _ (oldStruct ~= newStruct)]. need ifTrue: [sel _ #convertToCurrentVersion:refStream:. (#(add change) includes: (self atSelector: sel class: class)) ifFalse: [ list add: class]]. ]. list isEmpty & renamed isEmpty ifTrue: [^ self]. "Ask user if want to do this" tell _ 'If there might be instances of ', (list asArray, renamed asArray) printString, '\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\' withCRs, 'After you edit the conversion method, you''ll need to fileOut again.\' withCRs, 'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'. choice _ (PopUpMenu labels: 'Write a conversion method by editing a prototype These classes are not used in any object file. fileOut my changes now. I''m too busy. fileOut my changes now. Don''t ever ask again. fileOut my changes now.') startUpWithCaption: tell. choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut]. choice = 2 ifTrue: ["Don't consider this class again in the changeSet" list do: [:cls | structures removeKey: cls name ifAbsent: []]. renamed do: [:cls | nn _ (changeRecords at: cls name) priorName. structures removeKey: nn ifAbsent: []]]. choice ~= 1 ifTrue: [^ self]. "exit if choice 2,3,4" listAdd _ self askAddedInstVars: list. "Go through each inst var that was added" listDrop _ self askRemovedInstVars: list. "Go through each inst var that was removed" list _ (listAdd, listDrop) asSet asArray. smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345'). smart structures: structures. smart superclasses: superclasses. (restore _ self class current) == self ifFalse: [ self class newChanges: self]. "if not current one" msgSet _ smart conversionMethodsFor: list. "each new method is added to self (a changeSet). Then filed out with the rest." self askRenames: renamed addTo: msgSet using: smart. "renamed classes, add 2 methods" restore == self ifFalse: [self class newChanges: restore]. msgSet messageList isEmpty ifTrue: [^ self]. self inform: 'Remember to fileOut again after modifying these methods.'. MessageSet open: msgSet name: 'Conversion methods for ', self name.! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 3/29/2001 14:30'! checkForUnclassifiedMethods "Open a message list browser on all methods in the current change set that have not been categorized," | aList | (aList _ self methodsWithoutClassifications) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" are categorized.'] ifTrue: [Smalltalk browseMessageList: aList name: 'methods in "', self name, '" which have not been categorized']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34687919! checkForUnclassifiedMethods "Open a message list browser on all methods in the current change set that have not been categorized," | aList | (aList _ self methodsWithoutClassifications) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" are categorized.'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" which have not been categorized']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 7/19/2002 20:21'! checkForUncommentedClasses "Check to see if any classes involved in this change set do not have class comments. Open up a browser showing all such classes." | aList | aList _ self changedClasses select: [:aClass | aClass theNonMetaClass organization classComment isEmptyOrNil] thenCollect: [:aClass | aClass theNonMetaClass name]. aList size > 0 ifFalse: [^ self inform: 'All classes involved in this change set have class comments'] ifTrue: [ClassListBrowser new initForClassesNamed: aList asSet asSortedArray title: 'Classes in Change Set ', self name, ': classes that lack class comments']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 19032920! checkForUncommentedMethods | aList | "Check to see if there are any methods in the receiver that have no comments, and open a browser on all found" (aList _ self methodsWithoutComments) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" have comments'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" that lack comments']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'RAA 5/28/2001 11:46'! checkForUnsentMessages "Check the change set for unsent messages, and if any are found, open up a message-list browser on them" | nameLine allChangedSelectors augList unsent | nameLine _ '"', self name, '"'. allChangedSelectors _ Set new. (augList _ self changedMessageListAugmented) do: [ :each | each isValid ifTrue: [allChangedSelectors add: each methodSymbol] ]. unsent _ Smalltalk allUnSentMessagesIn: allChangedSelectors. unsent size = 0 ifTrue: [ ^self inform: 'There are no unsent messages in change set ', nameLine ]. Smalltalk browseMessageList: (augList select: [ :each | unsent includes: each methodSymbol]) name: 'Unsent messages in ', nameLine! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34690062! checkForUnsentMessages "Check the change set for unsent messages, and if any are found, open up a message-list browser on them" | nameLine allChangedSelectors augList unsent | nameLine _ '"', self name, '"'. allChangedSelectors _ Set new. (augList _ self changedMessageListAugmented) do: [ :each | each isValid ifTrue: [allChangedSelectors add: each methodSymbol] ]. unsent _ Smalltalk allUnSentMessagesIn: allChangedSelectors. unsent size = 0 ifTrue: [ ^self inform: 'There are no unsent messages in change set ', nameLine ]. self systemNavigation browseMessageList: (augList select: [ :each | unsent includes: each methodSymbol]) name: 'Unsent messages in ', nameLine! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/29/2003 20:19' prior: 34690830! checkForUnsentMessages "Check the change set for unsent messages, and if any are found, open up a message-list browser on them" | nameLine allChangedSelectors augList unsent | nameLine _ '"' , self name , '"'. allChangedSelectors _ Set new. (augList _ self changedMessageListAugmented) do: [:each | each isValid ifTrue: [allChangedSelectors add: each methodSymbol]]. unsent _ self systemNavigation allUnSentMessagesIn: allChangedSelectors. unsent size = 0 ifTrue: [^ self inform: 'There are no unsent messages in change set ' , nameLine]. self systemNavigation browseMessageList: (augList select: [:each | unsent includes: each methodSymbol]) name: 'Unsent messages in ' , nameLine! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'FBS 1/6/2004 16:59' prior: 19034324! chooseSubjectPrefixForEmail | subjectIndex | subjectIndex _ (PopUpMenu labels: 'Bug fix [FIX]\Enhancement [ENH]\Goodie [GOODIE]\Test suite [TEST]\None of the above (will not be archived)' withCRs) startUpWithCaption: 'What type of change set\are you submitting to the list?' withCRs. ^ #('[CS] ' '[FIX] ' '[ENH] ' '[GOODIE] ' '[TEST] ' '[CS] ') at: subjectIndex + 1! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 10/15/2003 09:55'! defaultChangeSetDirectory ^self class defaultChangeSetDirectory! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'tpr 10/9/2001 16:58'! fileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" | file slips nameToUse | self checkForConversionMethods. nameToUse _ Preferences changeSetVersionNumbers ifTrue: [FileDirectory default nextNameFor: self name extension: 'cs'] ifFalse: [(self name, FileDirectory dot, Utilities dateTimeSuffix, FileDirectory dot, 'cs') asFileName]. nameToUse size > 31 ifTrue: [nameToUse _ FillInTheBlank request: (nameToUse , '\has ' , nameToUse size asString , ' letters - too long for Mac OS.\Suggested replacement is:') withCRs initialAnswer: (nameToUse contractTo:30). nameToUse = '' ifTrue:[^self]]. Cursor write showWhile: [[file _ FileStream newFileNamed: nameToUse. file header; timeStamp. self fileOutPreambleOn: file. self fileOutOn: file. self fileOutPostscriptOn: file. file trailer] ensure: [file close]]. Preferences checkForSlips ifFalse: [^ self]. slips _ self checkForSlips. (slips size > 0 and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') = 2]) ifTrue: [Smalltalk browseMessageList: slips name: 'Possible slips in ', name]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34692987! fileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" | file slips nameToUse | self checkForConversionMethods. nameToUse _ Preferences changeSetVersionNumbers ifTrue: [FileDirectory default nextNameFor: self name extension: 'cs'] ifFalse: [(self name, FileDirectory dot, Utilities dateTimeSuffix, FileDirectory dot, 'cs') asFileName]. (Preferences warningForMacOSFileNameLength and: [nameToUse size > 31]) ifTrue: [ nameToUse _ FillInTheBlank request: (nameToUse , '\has ' , nameToUse size asString , ' letters - too long for Mac OS.\Suggested replacement is:') withCRs initialAnswer: (nameToUse contractTo:30). nameToUse = '' ifTrue:[^self]]. Cursor write showWhile: [[file _ FileStream newFileNamed: nameToUse. file header; timeStamp. self fileOutPreambleOn: file. self fileOutOn: file. self fileOutPostscriptOn: file. file trailer] ensure: [file close]]. Preferences checkForSlips ifFalse: [^ self]. slips _ self checkForSlips. (slips size > 0 and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') = 2]) ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ', name]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 1/4/2004 17:07' prior: 34694458! fileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" | file slips nameToUse | self checkForConversionMethods. ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. nameToUse := Preferences changeSetVersionNumbers ifTrue: [self defaultChangeSetDirectory nextNameFor: self name extension: 'cs'] ifFalse: [(self name , FileDirectory dot , Utilities dateTimeSuffix , FileDirectory dot , 'cs') asFileName]. (Preferences warningForMacOSFileNameLength and: [nameToUse size > 31]) ifTrue: [nameToUse := FillInTheBlank request: (nameToUse , '\has ' , nameToUse size asString , ' letters - too long for Mac OS.\Suggested replacement is:') withCRs initialAnswer: (nameToUse contractTo: 30). nameToUse = '' ifTrue: [^ self]]. Cursor write showWhile: [[file := self defaultChangeSetDirectory newFileNamed: nameToUse. file header; timeStamp. self fileOutPreambleOn: file. self fileOutOn: file. self fileOutPostscriptOn: file. file trailer] ensure: [file close]]. Preferences checkForSlips ifFalse: [^ self]. slips := self checkForSlips. (slips size > 0 and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') = 2]) ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/23/2001 13:29'! fileOutOn: stream "Write out all the changes the receiver knows about" | classList | (self isEmpty and: [stream isKindOf: FileStream]) ifTrue: [self inform: 'Warning: no changes to file out']. classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection. "First put out rename, max classDef and comment changes." classList do: [:aClass | self fileOutClassDefinition: aClass on: stream]. "Then put out all the method changes" classList do: [:aClass | self fileOutChangesFor: aClass on: stream]. "Finally put out removals, final class defs and reorganization if any" classList reverseDo: [:aClass | self fileOutPSFor: aClass on: stream]. self classRemoves asSortedCollection do: [:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 19038919! lookForSlips "Scan the receiver for changes that the user may regard as slips to be remedied" | slips nameLine msg | nameLine _ ' "', self name, '" '. (slips _ self checkForSlips) size == 0 ifTrue: [^ self inform: 'No slips detected in change set', nameLine]. msg _ slips size == 1 ifTrue: [ 'One method in change set', nameLine, 'has a halt, reference to the Transcript, and/or some other ''slip'' in it. Would you like to browse it? ?'] ifFalse: [ slips size printString, ' methods in change set', nameLine, 'have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']. (PopUpMenu withCaption: msg chooseFrom: 'Ignore\Browse slips') = 2 ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ', name]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'dew 9/25/2001 23:39'! mailOut "Email a compressed version of this changeset to the squeak-dev list, so that it can be shared with everyone. (You will be able to edit the email before it is sent.)" | usingCeleste userName server message slips | usingCeleste _ (Smalltalk includesKey: #Celeste) and: [Celeste isSmtpServerSet]. usingCeleste ifTrue: [server _ Celeste smtpServer. userName _ Celeste userName.] ifFalse: [server _ FillInTheBlank request: 'What is your mail server for outgoing mail?'. userName _ FillInTheBlank request: 'What is your email address?']. self checkForConversionMethods. Cursor write showWhile: [message _ self buildMessageForMailOutWithUser: userName]. usingCeleste ifTrue: [CelesteComposition openForCeleste: Celeste current initialText: message text] ifFalse: [AdHocComposition openForCeleste: server initialText: message text]. Preferences suppressCheckForSlips ifTrue: [^ self]. slips _ self checkForSlips. (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']) ifTrue: [Smalltalk browseMessageList: slips name: 'Possible slips in ' , name] ! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'dvf 5/11/2002 00:45' prior: 34699408! mailOut "Email a compressed version of this changeset to the squeak-dev list, so that it can be shared with everyone. (You will be able to edit the email before it is sent.)" | userName message slips | userName _ MailSender userName. self checkForConversionMethods. Cursor write showWhile: [message _ self buildMessageForMailOutWithUser: userName]. MailSender sendMessage: message. Preferences suppressCheckForSlips ifTrue: [^ self]. slips _ self checkForSlips. (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']) ifTrue: [Smalltalk browseMessageList: slips name: 'Possible slips in ' , name] ! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16' prior: 34700711! mailOut "Email a compressed version of this changeset to the squeak-dev list, so that it can be shared with everyone. (You will be able to edit the email before it is sent.)" | userName message slips | userName _ MailSender userName. self checkForConversionMethods. Cursor write showWhile: [message _ self buildMessageForMailOutWithUser: userName]. MailSender sendMessage: message. Preferences suppressCheckForSlips ifTrue: [^ self]. slips _ self checkForSlips. (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']) ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name] ! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'md 11/14/2003 16:22' prior: 19041953! objectForDataStream: refStrm "I am about to be written on an object file. Write a path to me in the other system instead." refStrm projectChangeSet == self ifTrue: [^ self]. "try to write reference for me" ^ DiskProxy global: #ChangeSorter selector: #existingOrNewChangeSetNamed: args: (Array with: self name) "=== refStrm replace: self with: nil. ^ nil ===" ! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 7/2/2003 10:47' prior: 19043241! preambleTemplate "Answer a string that will form the default contents for a change set's preamble. Just a first stab at what the content should be." ^ String streamContents: [:strm | strm nextPutAll: '"Change Set:'. "NOTE: fileIn recognizes preambles by this string." strm tab;tab; nextPutAll: self name. strm cr; nextPutAll: 'Date:'; tab; tab; tab; nextPutAll: Date today printString. strm cr; nextPutAll: 'Author:'; tab; tab; tab; nextPutAll: Preferences defaultAuthorName. strm cr; cr; nextPutAll: '"'] "ChangeSet current preambleTemplate"! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 3/30/2001 13:47'! setPreambleToSay: aString "Make aString become the preamble of this change set" preamble _ StringHolder new contents: aString! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 1/16/2004 21:31'! verboseFileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" ChangeSet current fileOut. Transcript cr; show: 'Changes filed out ', Date dateAndTimeNow printString! ! !ChangeSet methodsFor: 'private' stamp: 'yo 8/30/2002 13:59' prior: 19046551! changeRecorderFor: class | cname | (class isString) ifTrue: [ cname _ class ] ifFalse: [ cname _ class name ]. "Later this will init the changeRecords so according to whether they should be revertable." ^ changeRecords at: cname ifAbsent: [^ changeRecords at: cname put: (ClassChangeRecord new initFor: cname revertable: revertable)]! ! !ChangeSet methodsFor: 'private' stamp: 'tk 3/7/2001 14:06'! fileOutClassDefinition: class on: stream "Write out class definition for the given class on the given stream, if the class definition was added or changed." (self atClass: class includes: #rename) ifTrue: [stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr]. (self atClass: class includes: #change) ifTrue: [ "fat definition only needed for changes" stream command: 'H3'; nextChunkPut: (self fatDefForClass: class); cr; command: '/H3'. DeepCopier new checkClass: class. "If veryDeepCopy weakly copies some inst vars in this class, warn author when new ones are added." ] ifFalse: [ (self atClass: class includes: #add) ifTrue: [ "use current definition for add" stream command: 'H3'; nextChunkPut: class definition; cr; command: '/H3'. DeepCopier new checkClass: class. "If veryDeepCopy weakly copies some inst vars in this class, warn author when new ones are added." ]. ]. (self atClass: class includes: #comment) ifTrue: [class theNonMetaClass organization putCommentOnFile: stream numbered: 0 moveSource: false forClass: class theNonMetaClass. stream cr]. ! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 19:59'! browseChangedMessages "Create and schedule a message browser on each method that has been changed." current isEmpty ifTrue: [^ self inform: 'There are no changed messages in the current change set.']. ChangedMessageSet openFor: current! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 21:53'! current "return the current changeset" ^ current! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 22:24'! currentChangeSetString "ChangeSet current currentChangeSetString" ^ 'Current Change Set: ', self current name! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 22:18'! newChanges: aChangeSet "Set the system ChangeSet to be the argument, aChangeSet. Tell the current project that aChangeSet is now its change set. When called from Project enter:, the setChangeSet: call is redundant but harmless; when called from code that changes the current-change-set from within a project, it's vital" current isolationSet: nil. current _ aChangeSet. Smalltalk currentProjectDo: [:proj | proj setChangeSet: aChangeSet. aChangeSet isolationSet: proj isolationSet]! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'NS 1/16/2004 14:49' prior: 34706384! newChanges: aChangeSet "Set the system ChangeSet to be the argument, aChangeSet. Tell the current project that aChangeSet is now its change set. When called from Project enter:, the setChangeSet: call is redundant but harmless; when called from code that changes the current-change-set from within a project, it's vital" SystemChangeNotifier uniqueInstance noMoreNotificationsFor: current. current isolationSet: nil. current _ aChangeSet. SystemChangeNotifier uniqueInstance notify: aChangeSet ofAllSystemChangesUsing: #event:. Smalltalk currentProjectDo: [:proj | proj setChangeSet: aChangeSet. aChangeSet isolationSet: proj isolationSet]! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 22:18'! noChanges "Initialize the system ChangeSet." current initialize! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 1/4/2004 16:10'! defaultChangeSetDirectory "Answer the directory in which to store ChangeSets. Answer the default directory if the preferred directory doesn't exist." | dir directoryName | directoryName := Preferences parameterAt: #defaultChangeSetDirectoryName ifAbsentPut: ['']. dir := FileDirectory default directoryNamed: directoryName. dir exists ifTrue: [^ dir]. ^ FileDirectory default! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 7/18/2004 16:13' prior: 34707856! defaultChangeSetDirectory "Answer the directory in which to store ChangeSets. Answer the default directory if the preferred directory doesn't exist." | dir directoryName | directoryName := Preferences parameterAt: #defaultChangeSetDirectoryName ifAbsentPut: ['']. dir := directoryName isEmptyOrNil ifTrue: [ FileDirectory default ] ifFalse: [ FileDirectory default directoryNamed: directoryName ]. dir exists ifTrue: [^ dir]. ^ FileDirectory default! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 7/18/2004 16:13' prior: 34708339! defaultChangeSetDirectory "Answer the directory in which to store ChangeSets. Answer the default directory if the preferred directory doesn't exist." | dir directoryName | directoryName := Preferences parameterAt: #defaultChangeSetDirectoryName ifAbsentPut: ['']. dir := directoryName isEmptyOrNil ifTrue: [ FileDirectory default ] ifFalse: [ FileDirectory default directoryNamed: directoryName ]. dir exists ifTrue: [^ dir]. ^ FileDirectory default! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 10/15/2003 10:06'! defaultChangeSetDirectory: dirOrName "Set the Preference for storing change sets to the given directory or name (possibly relative). If dirOrName is an empty string, use the default directory." "ChangeSet defaultChangeSetDirectory: 'changeSets'" | dirName | dirName _ dirOrName isString ifTrue: [ FileDirectory default fullNameFor: dirOrName ] ifFalse: [ dirOrName fullName ]. (dirName beginsWith: FileDirectory default fullName) ifTrue: [ dirName _ dirName copyFrom: FileDirectory default fullName size + 2 to: dirName size ]. Preferences setParameter: #defaultChangeSetDirectoryName to: dirName. ! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 3/24/2004 15:52' prior: 34709446! defaultChangeSetDirectory: dirOrName "Set the Preference for storing change sets to the given directory or name (possibly relative). Rewrite directory names below the default directory as relative names. If dirOrName is an empty string, use the default directory." "ChangeSet defaultChangeSetDirectory: 'changeSets'" | dirName defaultFullName | dirName := dirOrName isString ifTrue: [FileDirectory default fullNameFor: dirOrName] ifFalse: [dirOrName fullName]. defaultFullName := FileDirectory default fullName. dirName = defaultFullName ifTrue: [dirName := ''] ifFalse: [(dirName beginsWith: defaultFullName , FileDirectory slash) ifTrue: [dirName := dirName copyFrom: defaultFullName size + 2 to: dirName size]]. Preferences setParameter: #defaultChangeSetDirectoryName to: dirName! ! !ChangeSet class methodsFor: 'defaults' stamp: 'di 4/5/2001 21:33'! defaultName ^ self uniqueNameLike: 'Unnamed'! ! !ChangeSet class methodsFor: 'defaults' stamp: 'dgd 9/6/2003 19:56' prior: 34711027! defaultName ^ self uniqueNameLike: 'Unnamed' translated! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 1/4/2004 16:47'! promptForDefaultChangeSetDirectoryIfNecessary "Check the Preference (if any), and prompt the user to change it if necessary. The default if the Preference is unset is the current directory. Answer the directory." "ChangeSet promptForDefaultChangeSetDirectoryIfNecessary" | choice directoryName dir | directoryName := Preferences parameterAt: #defaultChangeSetDirectoryName ifAbsentPut: ['']. [dir := FileDirectory default directoryNamed: directoryName. dir exists] whileFalse: [choice := PopUpMenu withCaption: ('The preferred change set directory (''{1}'') does not exist. Create it or use the default directory ({2})?' translated format: { directoryName. FileDirectory default pathName }) chooseFrom: (#('Create directory' 'Use default directory and forget preference' 'Choose another directory' ) collect: [ :ea | ea translated ]). choice = 1 ifTrue: [dir assureExistence ]. choice = 3 ifTrue: [dir := FileList2 modalFolderSelector. directoryName := dir ifNil: [ '' ] ifNotNil: [dir pathName ]]]. self defaultChangeSetDirectory: directoryName. ^dir! ! !ChangeSet class methodsFor: 'defaults' stamp: 'di 4/5/2001 21:31'! uniqueNameLike: aString | try | 1 to: 999999 do: [:i | try _ aString , i printString. (ChangeSorter changeSetNamed: try) ifNil: [^ try]]! ! !ChangeSet class methodsFor: 'instance creation' stamp: 'di 4/6/2001 09:43'! basicNewNamed: aName ^ (self basicNew name: aName) initialize! ! !ChangeSet class methodsFor: 'instance creation' stamp: 'di 4/6/2001 10:02'! new "All current changeSets must be registered in the AllChangeSets collection. Due to a quirk of history, this is maintained as class variable of ChangeSorter." ^ ChangeSorter basicNewChangeSet: ChangeSet defaultName! ! !ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 7/27/2001 20:38'! addModelItemsToWindowMenu: aMenu "Add model-related items to the given window menu" | oldTarget | oldTarget _ aMenu defaultTarget. aMenu defaultTarget: self. aMenu addLine. aMenu add: 'rename change set' action: #rename. aMenu add: 'make changes go to me' action: #newCurrent. aMenu addLine. aMenu add: 'file out' action: #fileOut. aMenu add: 'browse methods' action: #browseChangeSet. aMenu addLine. myChangeSet hasPreamble ifTrue: [aMenu add: 'edit preamble' action: #addPreamble. aMenu add: 'remove preamble' action: #removePreamble] ifFalse: [aMenu add: 'add preamble' action: #addPreamble]. myChangeSet hasPostscript ifTrue: [aMenu add: 'edit postscript...' action: #editPostscript. aMenu add: 'remove postscript' action: #removePostscript] ifFalse: [aMenu add: 'add postscript...' action: #editPostscript]. aMenu addLine. aMenu add: 'destroy change set' action: #remove. aMenu addLine. Smalltalk isMorphic ifTrue: [aMenu addLine. aMenu add: 'what to show...' target: self action: #offerWhatToShowMenu]. aMenu addLine. aMenu add: 'more...' action: #offerShiftedChangeSetMenu. aMenu defaultTarget: oldTarget. ^ aMenu! ! !ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/29/2001 23:38'! openAsMorphIn: window rect: rect "Add a set of changeSetBrowser views to the given top view offset by the given amount" | aHeight | contents _ ''. aHeight _ 0.25. self addDependent: window. "so it will get changed: #relabel" window addMorph: (PluggableListMorphByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classListMenu:shifted: keystroke: #classListKey:from:) frame: (((0.0@0 extent: 0.5 @ aHeight) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableListMorphByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:) frame: (((0.5@0 extent: 0.5 @ aHeight) scaleBy: rect extent) translateBy: rect origin). self addLowerPanesTo: window at: (((0@aHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin) with: nil! ! !ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/14/2001 10:03'! wantsAnnotationPane "This kind of browser always wants annotation panes, so answer true" ^ true! ! !ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/9/2001 15:02'! wantsOptionalButtons "Sure, why not?" ^ true! ! !ChangeSetBrowser methodsFor: 'menu' stamp: 'sw 3/12/2001 14:07'! offerUnshiftedChangeSetMenu "The user chose 'more' from the shifted window menu; go back to the regular window menu" self containingWindow ifNotNil: [self containingWindow offerWindowMenu] ! ! !ChangeSetBrowser methodsFor: 'menu' stamp: 'sw 7/20/2002 18:33'! shiftedChangeSetMenu: aMenu "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down" Smalltalk isMorphic ifTrue: [aMenu title: 'Change set (shifted)'. aMenu addStayUpItemSpecial]. aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in at least one other change set.'. aMenu addLine. aMenu add: 'check for slips' action: #lookForSlips. aMenu balloonTextForLastItem: 'Check this change set for halts and references to Transcript.'. aMenu add: 'check for unsent messages' action: #checkForUnsentMessages. aMenu balloonTextForLastItem: 'Check this change set for messages that are not sent anywhere in the system'. aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods. aMenu balloonTextForLastItem: 'Check this change set for methods that do not have comments'. aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses. aMenu balloonTextForLastItem: 'Check for classes with code in this changeset which lack class comments'. Utilities authorInitialsPerSe isEmptyOrNil ifFalse: [aMenu add: 'check for other authors' action: #checkForAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'. aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods any of whose previous authoring stamps do not start with "', Utilities authorInitials, '"']. aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods. aMenu balloonTextForLastItem: 'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'. aMenu addLine. aMenu add: 'inspect change set' action: #inspectChangeSet. aMenu balloonTextForLastItem: 'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'. aMenu add: 'update' action: #update. aMenu balloonTextForLastItem: 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'. aMenu add: 'go to change set''s project' action: #goToChangeSetsProject. aMenu balloonTextForLastItem: 'If this change set is currently associated with a Project, go to that project right now.'. aMenu add: 'trim history' action: #trimHistory. aMenu balloonTextForLastItem: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'. aMenu add: 'clear this change set' action: #clearChangeSet. aMenu balloonTextForLastItem: 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'. aMenu add: 'expunge uniclasses' action: #expungeUniclasses. aMenu balloonTextForLastItem: 'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'. aMenu add: 'uninstall this change set' action: #uninstallChangeSet. aMenu balloonTextForLastItem: 'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'. aMenu addLine. aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu. aMenu balloonTextForLastItem: 'Takes you back to the primary change-set menu.'. ^ aMenu! ! !ChangeSetBrowser commentStamp: '' prior: 0! A tool allowing you to browse the methods of a single change set.! !ChangeSetCategory methodsFor: 'initialization' stamp: 'sw 3/30/2001 12:35'! membershipSelector: aSelector "Set the membershipSelector" membershipSelector _ aSelector! ! !ChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/11/2001 16:11'! acceptsManualAdditions "Answer whether the user is allowed manually to manipulate the contents of the change-set-category." ^ false! ! !ChangeSetCategory methodsFor: 'queries' stamp: 'sw 3/30/2001 14:39'! changeSetList "Answer the list of change-set names in the category" | aChangeSet | self reconstituteList. keysInOrder size == 0 ifTrue: ["don't tolerate emptiness, because ChangeSorters gag when they have no change-set selected" aChangeSet _ ChangeSorter assuredChangeSetNamed: 'New Changes'. self elementAt: aChangeSet name put: aChangeSet]. ^ keysInOrder reversed! ! !ChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/5/2001 17:26'! hasChangeForClassName: aClassName selector: aSelector otherThanIn: excludedChangeSet "Answer whether any change set in this category, other than the excluded one, has a change marked for the given class and selector" self elementsInOrder do: [:aChangeSet | (aChangeSet ~~ excludedChangeSet and: [((aChangeSet methodChangesAtClass: aClassName) includesKey: aSelector)]) ifTrue: [^ true]]. ^ false! ! !ChangeSetCategory methodsFor: 'queries' stamp: 'sw 3/30/2001 14:04'! includesChangeSet: aChangeSet "Answer whether the receiver includes aChangeSet in its retrieval list" ^ ChangeSorter perform: membershipSelector with: aChangeSet! ! !ChangeSetCategory methodsFor: 'services' stamp: 'sw 3/30/2001 14:41'! fileOutAllChangeSets "File out all the nonempty change sets in the current category, suppressing the checks for slips that might otherwise ensue. Obtain user confirmation before undertaking this possibly prodigious task." | aList | aList _ self elementsInOrder select: [:aChangeSet | aChangeSet isEmpty not]. aList size == 0 ifTrue: [^ self inform: 'sorry, all the change sets in this category are empty']. (self confirm: 'This will result in filing out ', aList size printString, ' change set(s) Are you certain you want to do this?') ifFalse: [^ self]. Preferences setFlag: #checkForSlips toValue: false during: [Utilities fileOutChangeSetsNamed: (aList collect: [:m | m name]) asSortedArray]! ! !ChangeSetCategory methodsFor: 'services' stamp: 'sd 1/16/2004 21:37' prior: 34721429! fileOutAllChangeSets "File out all the nonempty change sets in the current category, suppressing the checks for slips that might otherwise ensue. Obtain user confirmation before undertaking this possibly prodigious task." | aList | aList _ self elementsInOrder select: [:aChangeSet | aChangeSet isEmpty not]. aList size == 0 ifTrue: [^ self inform: 'sorry, all the change sets in this category are empty']. (self confirm: 'This will result in filing out ', aList size printString, ' change set(s) Are you certain you want to do this?') ifFalse: [^ self]. Preferences setFlag: #checkForSlips toValue: false during: [ChangeSorter fileOutChangeSetsNamed: (aList collect: [:m | m name]) asSortedArray]! ! !ChangeSetCategory methodsFor: 'services' stamp: 'sw 3/30/2001 13:55'! fillAggregateChangeSet "Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category" | aggChangeSet | aggChangeSet _ ChangeSorter assuredChangeSetNamed: #Aggregate. aggChangeSet clear. aggChangeSet setPreambleToSay: '"Change Set: Aggregate Created at ', Time now printString, ' on ', Date today printString, ' by combining all the changes in all the change sets in the category ', categoryName printString, '"'. (self elementsInOrder copyWithout: aggChangeSet) do: [:aChangeSet | aggChangeSet assimilateAllChangesFoundIn: aChangeSet]. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup] ! ! !ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'sw 3/29/2001 11:47'! defaultChangeSetToShow "Answer the name of a change-set to show" ^ Smalltalk changes! ! !ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'sd 5/23/2003 14:25' prior: 34723786! defaultChangeSetToShow "Answer the name of a change-set to show" ^ ChangeSet current! ! !ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'di 4/6/2001 10:37'! reconstituteList "Clear out the receiver's elements and rebuild them" | newMembers | "First determine newMembers and check if they have not changed..." newMembers _ ChangeSorter allChangeSets select: [:aChangeSet | ChangeSorter perform: membershipSelector with: aChangeSet]. (newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"]. "Things have changed. Need to recompute the whole category" self clear. newMembers do: [:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet] ! ! !ChangeSetCategory commentStamp: '' prior: 0! A ChangeSetCategory represents a list of change sets to be shown in a ChangeSorter. It computes whether a given change set is in the list by sending its membershipSelector to ChangeSorter (i.e. the class object) with the change set as message argument.! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:34'! acceptsManualAdditions "Answer whether the user is allowed manually to manipulate the contents of the change-set-category." ^ true! ! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:43'! addChangeSet: aChangeSet self inform: 'sorry, you can''t do that'! ! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:08'! includesChangeSet: aChangeSet "Answer whether the receiver includes aChangeSet in its retrieval list" ^ ChangeSorter perform: membershipSelector withArguments: { aChangeSet } , parameters! ! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:04'! parameters: anArray parameters _ anArray! ! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:16'! reconstituteList "Clear out the receiver's elements and rebuild them" | newMembers | "First determine newMembers and check if they have not changed..." newMembers _ ChangeSorter allChangeSets select: [:aChangeSet | ChangeSorter perform: membershipSelector withArguments: { aChangeSet }, parameters]. (newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"]. "Things have changed. Need to recompute the whole category" self clear. newMembers do: [:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet]! ! !ChangeSorter methodsFor: 'creation' stamp: 'sd 5/23/2003 14:25' prior: 19050523! morphicWindow "ChangeSorter new openAsMorph" | window | myChangeSet ifNil: [self myChangeSet: ChangeSet current]. window _ (SystemWindow labelled: self labelString) model: self. self openAsMorphIn: window rect: (0@0 extent: 1@1). ^ window ! ! !ChangeSorter methodsFor: 'creation' stamp: 'sd 5/23/2003 14:26' prior: 19050843! open "ChangeSorterPluggable new open" | topView | Smalltalk isMorphic | Sensor leftShiftDown ifTrue: [^ self openAsMorph]. topView _ StandardSystemView new. topView model: self. myChangeSet ifNil: [self myChangeSet: ChangeSet current]. topView label: self labelString. topView borderWidth: 1; minimumSize: 360@360. self openView: topView offsetBy: 0@0. topView controller open. ! ! !ChangeSorter methodsFor: 'creation' stamp: 'sw 2/26/2001 12:00'! openAsMorphIn: window rect: rect "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." | csListHeight msgListHeight csMsgListHeight | contents _ ''. csListHeight _ 0.25. msgListHeight _ 0.25. csMsgListHeight _ csListHeight + msgListHeight. self addDependent: window. "so it will get changed: #relabel" window addMorph: ((PluggableListMorphByItem on: self list: #changeSetList selected: #currentCngSet changeSelected: #showChangeSetNamed: menu: #changeSetMenu:shifted: keystroke: #changeSetListKey:from:) autoDeselect: false) frame: (((0@0 extent: 0.5@csListHeight) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableListMorphByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classListMenu:shifted: keystroke: #classListKey:from:) frame: (((0.5@0 extent: 0.5@csListHeight) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableListMorphByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:) frame: (((0@csListHeight extent: 1@msgListHeight) scaleBy: rect extent) translateBy: rect origin). self addLowerPanesTo: window at: (((0@csMsgListHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin) with: nil.! ! !ChangeSorter methodsFor: 'creation' stamp: 'sps 4/3/2004 20:15' prior: 34727375! openAsMorphIn: window rect: rect "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." | csListHeight msgListHeight csMsgListHeight | contents _ ''. csListHeight _ 0.25. msgListHeight _ 0.25. csMsgListHeight _ csListHeight + msgListHeight. self addDependent: window. "so it will get changed: #relabel" "The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars needs the crrentSelector pane to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added." Preferences scrollBarsOnRight ifFalse: [window addMorph: (PluggableListMorphByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:) frame: (((0@csListHeight extent: 1@msgListHeight) scaleBy: rect extent) translateBy: rect origin)]. window addMorph: ((PluggableListMorphByItem on: self list: #changeSetList selected: #currentCngSet changeSelected: #showChangeSetNamed: menu: #changeSetMenu:shifted: keystroke: #changeSetListKey:from:) autoDeselect: false) frame: (((0@0 extent: 0.5@csListHeight) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableListMorphByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classListMenu:shifted: keystroke: #classListKey:from:) frame: (((0.5@0 extent: 0.5@csListHeight) scaleBy: rect extent) translateBy: rect origin). Preferences scrollBarsOnRight ifTrue: [window addMorph: (PluggableListMorphByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:) frame: (((0@csListHeight extent: 1@msgListHeight) scaleBy: rect extent) translateBy: rect origin)]. self addLowerPanesTo: window at: (((0@csMsgListHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin) with: nil. ! ! !ChangeSorter methodsFor: 'creation' stamp: 'sw 2/26/2001 12:00'! openView: topView offsetBy: offset "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 360@0." | classView messageView codeView cngSetListView basePane annoPane annoHeight | contents _ ''. annoHeight _ 20. self addDependent: topView. "so it will get changed: #relabel" cngSetListView _ PluggableListViewByItem on: self list: #changeSetList selected: #currentCngSet changeSelected: #showChangeSetNamed: menu: #changeSetMenu:shifted: keystroke: #changeSetListKey:from:. cngSetListView window: ((0@0 extent: 180@100) translateBy: offset). topView addSubView: cngSetListView. classView _ PluggableListViewByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classListMenu:shifted: keystroke: #classListKey:from:. classView window: ((0@0 extent: 180@100) translateBy: offset). topView addSubView: classView toRightOf: cngSetListView. messageView _ PluggableListViewByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:. messageView menuTitleSelector: #messageListSelectorTitle. messageView window: ((0@0 extent: 360@100) translateBy: offset). topView addSubView: messageView below: cngSetListView. self wantsAnnotationPane ifFalse: [basePane _ messageView] ifTrue: [annoPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annoPane window: ((0@0 extent: 360@annoHeight) translateBy: offset). topView addSubView: annoPane below: messageView. basePane _ annoPane]. codeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. codeView window: ((0 @ 0 extent: 360 @ 180) translateBy: offset). topView addSubView: codeView below: basePane.! ! !ChangeSorter methodsFor: 'creation' stamp: 'sw 3/29/2001 14:46'! setDefaultChangeSetCategory "Set a default ChangeSetCategory for the receiver, and answer it" ^ changeSetCategory _ self class changeSetCategoryNamed: #All! ! !ChangeSorter methodsFor: 'creation' stamp: 'sw 3/29/2001 13:01'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared." super veryDeepInner: deepCopier. "parent _ parent. Weakly copied" "myChangeSet _ myChangeSet. Weakly copied" currentClassName _ currentClassName veryDeepCopyWith: deepCopier. "currentSelector _ currentSelector. Symbol" priorChangeSetList _ priorChangeSetList veryDeepCopyWith: deepCopier. changeSetCategory _ changeSetCategory. ! ! !ChangeSorter methodsFor: 'access' stamp: 'sw 3/29/2001 14:45'! changeSetCategory "Answer the current changeSetCategory object that governs which change sets are shown in this ChangeSorter" ^ changeSetCategory ifNil: [self setDefaultChangeSetCategory]! ! !ChangeSorter methodsFor: 'access' stamp: 'sw 3/29/2001 22:53'! labelString "The label for my entire window. The large button that displays my name is gotten via mainButtonName" ^ String streamContents: [:aStream | aStream nextPutAll: (Smalltalk changes == myChangeSet ifTrue: ['Changes go to "', myChangeSet name, '"'] ifFalse: ['ChangeSet: ', myChangeSet name]). (self changeSetCategory categoryName ~~ #All) ifTrue: [aStream nextPutAll: ' - ', self parenthesizedCategoryName]]! ! !ChangeSorter methodsFor: 'access' stamp: 'sd 5/23/2003 14:25' prior: 34734644! labelString "The label for my entire window. The large button that displays my name is gotten via mainButtonName" ^ String streamContents: [:aStream | aStream nextPutAll: (ChangeSet current == myChangeSet ifTrue: ['Changes go to "', myChangeSet name, '"'] ifFalse: ['ChangeSet: ', myChangeSet name]). (self changeSetCategory categoryName ~~ #All) ifTrue: [aStream nextPutAll: ' - ', self parenthesizedCategoryName]]! ! !ChangeSorter methodsFor: 'access' stamp: 'sw 3/29/2001 22:51'! parenthesizedCategoryName "Answer my category name in parentheses" ^ ' (', self changeSetCategory categoryName, ')'! ! !ChangeSorter methodsFor: 'access' stamp: 'di 4/5/2001 21:20'! showChangeSetNamed: aName self showChangeSet: (ChangeSorter changeSetNamed: aName) ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:30'! addToCategoryOpposite "Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that" | categoryOpposite | categoryOpposite _ (parent other: self) changeSetCategory. categoryOpposite acceptsManualAdditions ifTrue: [categoryOpposite addChangeSet: myChangeSet. categoryOpposite reconstituteList. self update] ifFalse: [self inform: 'sorry, this command only makes sense if the category showing on the opposite side is a static category whose members are manually maintained']! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/28/2001 12:06'! browseMethodConflicts "Check to see if any other change set also holds changes to any methods in the selected change set; if so, open a browser on all such." | aList | aList _ myChangeSet messageListForChangesWhich: [ :aClass :aSelector | (ChangeSorter allChangeSetsWithClass: aClass selector: aSelector) size > 1 ] ifNone: [^ self inform: 'No other change set has changes for any method in this change set.']. MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" that are also in other change sets (', aList size printString, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 8/12/2002 17:29'! categorySubmenu: aMenu shifted: shiftedIgnored "Fill aMenu with less-frequently-needed category items" aMenu title: 'Change set category'. aMenu addStayUpItem. aMenu addList: #( ('make a new category...' makeNewCategory 'Creates a new change-set-category (you will be asked to supply a name) which will start out its life with this change set in it') ('make a new category with class...' makeNewCategoryShowingClassChanges 'Creates a new change-set-category that includes change sets that change a particular class (you will be asked to supply a name)') ('rename this category' renameCategory 'Rename this change-set category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.') ('remove this category' removeCategory 'Remove this change-set category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.') ('show categories of this changeset' showCategoriesOfChangeSet 'Show a list of all the change-set categories that contain this change-set; if the you choose one of the categories from this pop-up, that category will be installed in this change sorter') -). parent ifNotNil: [aMenu addList: #( ('add change set to category opposite' addToCategoryOpposite 'Adds this change set to the category on the other side of the change sorter. Only applies if the category shown on the opposite side is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.'))]. aMenu addList: #( ('remove change set from this category' removeFromCategory 'Removes this change set from the current category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.') - ('file out category''s change sets' fileOutAllChangeSets 'File out every change set in this category that has anything in it. The usual checks for slips are suppressed when this command is done.') ('set recent-updates marker' setRecentUpdatesMarker 'Allows you to specify a number that will demarcate which updates are considered "recent" and which are not. This will govern which updates are included in the RecentUpdates category in a change sorter') ('fill aggregate change set' fillAggregateChangeSet 'Creates a change-set named Aggregate into which all the changes in all the change sets in this category will be copied.') - ('back to main menu' offerUnshiftedChangeSetMenu 'Takes you back to the shifted change-set menu.') ('back to shifted menu' offerShiftedChangeSetMenu 'Takes you back to the primary change-set menu.')). ^ aMenu! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 00:00'! changeSetList "Answer a list of ChangeSet names to be shown in the change sorter." ^ self changeSetCategory changeSetList! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/17/2002 11:37'! changeSetListKey: aChar from: view "Respond to a Command key. I am a model with a listView that has a list of changeSets." aChar == $b ifTrue: [^ self browseChangeSet]. aChar == $B ifTrue: [^ self openChangeSetBrowser]. aChar == $c ifTrue: [^ self copyAllToOther]. aChar == $D ifTrue: [^ self toggleDiffing]. aChar == $f ifTrue: [^ self findCngSet]. aChar == $m ifTrue: [^ self newCurrent]. aChar == $n ifTrue: [^ self newSet]. aChar == $o ifTrue: [^ self fileOut]. aChar == $p ifTrue: [^ self addPreamble]. aChar == $r ifTrue: [^ self rename]. aChar == $s ifTrue: [^ self chooseChangeSetCategory]. aChar == $x ifTrue: [^ self remove]. aChar == $- ifTrue: [^ self subtractOtherSide]. ^ self messageListKey: aChar from: view! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/17/2002 11:37'! changeSetMenu: aMenu shifted: isShifted "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" isShifted ifTrue: [^ self shiftedChangeSetMenu: aMenu]. Smalltalk isMorphic ifTrue: [aMenu title: 'Change Set'. aMenu addStayUpItemSpecial] ifFalse: [aMenu title: 'Change Set: ' , myChangeSet name]. aMenu add: 'make changes go to me (m)' action: #newCurrent. aMenu addLine. aMenu add: 'new change set... (n)' action: #newSet. aMenu add: 'find...(f)' action: #findCngSet. aMenu add: 'show category... (s)' action: #chooseChangeSetCategory. aMenu balloonTextForLastItem: 'Lets you choose which change sets should be listed in this change sorter'. aMenu add: 'select change set...' action: #chooseCngSet. aMenu addLine. aMenu add: 'rename change set (r)' action: #rename. aMenu add: 'file out (o)' action: #fileOut. aMenu add: 'mail to list' action: #mailOut. aMenu add: 'browse methods (b)' action: #browseChangeSet. aMenu add: 'browse change set (B)' action: #openChangeSetBrowser. aMenu addLine. parent ifNotNil: [aMenu add: 'copy all to other side (c)' action: #copyAllToOther. aMenu add: 'submerge into other side' action: #submergeIntoOtherSide. aMenu add: 'subtract other side (-)' action: #subtractOtherSide. aMenu addLine]. myChangeSet hasPreamble ifTrue: [aMenu add: 'edit preamble (p)' action: #addPreamble. aMenu add: 'remove preamble' action: #removePreamble] ifFalse: [aMenu add: 'add preamble (p)' action: #addPreamble]. myChangeSet hasPostscript ifTrue: [aMenu add: 'edit postscript...' action: #editPostscript. aMenu add: 'remove postscript' action: #removePostscript] ifFalse: [aMenu add: 'add postscript...' action: #editPostscript]. aMenu addLine. aMenu add: 'category functions...' action: #offerCategorySubmenu. aMenu balloonTextForLastItem: 'Various commands relating to change-set-categories'. aMenu addLine. aMenu add: 'destroy change set (x)' action: #remove. aMenu addLine. aMenu add: 'more...' action: #offerShiftedChangeSetMenu. ^ aMenu! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nk 3/30/2002 08:56'! checkForAnyAlienAuthorship "Open a message list browser on all uncommented methods in the current change set that have alien authorship, even historically" myChangeSet checkForAnyAlienAuthorship ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/29/2001 12:47'! checkForUnclassifiedMethods "Open a message list browser on all methods in the current change set that have not been categorized" myChangeSet checkForUnclassifiedMethods ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/18/2002 17:58'! checkForUncommentedClasses "Open a class list browser on classes in the change set that lack class comments" myChangeSet checkForUncommentedClasses! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 4/5/2001 17:56'! chooseChangeSetCategory "Present the user with a list of change-set-categories and let her choose one" | cats aMenu result | self okToChange ifFalse: [^ self]. Smalltalk isMorphic ifTrue: [^ self chooseChangeSetCategoryInMorphic]. "gives balloon help" cats _ ChangeSetCategories elementsInOrder. aMenu _ SelectionMenu labels: (cats collect: [:cat | cat categoryName]) selections: cats. result _ aMenu startUp. result ifNotNil: [changeSetCategory _ result. self changed: #changeSetList. (self changeSetList includes: myChangeSet name) ifFalse: [self showChangeSet: (ChangeSorter changeSetNamed: self changeSetList first)]. self changed: #relabel]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 13:24'! chooseChangeSetCategoryInMorphic "Present the user with a list of change-set-categories and let her choose one. In this morphic variant, we include balloon help" | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu title: 'Choose the category of change sets to show in this Change Sorter (red = current choice)'. ChangeSetCategories elementsInOrder do: [:aCategory | aMenu add: aCategory categoryName target: self selector: #showChangeSetCategory: argument: aCategory. aCategory == changeSetCategory ifTrue: [aMenu lastItem color: Color red]. aMenu balloonTextForLastItem: aCategory documentation]. aMenu popUpInWorld! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 4/5/2001 17:56'! chooseCngSet "Present the user with an alphabetical list of change set names, and let her choose one" | changeSetsSortedAlphabetically chosen | self okToChange ifFalse: [^ self]. changeSetsSortedAlphabetically _ self changeSetList asSortedCollection: [:a :b | a asLowercase withoutLeadingDigits < b asLowercase withoutLeadingDigits]. chosen _ (SelectionMenu selections: changeSetsSortedAlphabetically) startUp. chosen ifNil: [^ self]. self showChangeSet: (ChangeSorter changeSetNamed: chosen)! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nk 1/4/2004 17:07' prior: 19065575! fileIntoNewChangeSet "Obtain a file designation from the user, and file its contents into a new change set whose name is a function of the filename. Show the new set and leave the current changeSet unaltered." | aNewChangeSet stream | self okToChange ifFalse: [^ self]. ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. stream := StandardFileMenu oldFileStreamFrom: ChangeSet defaultChangeSetDirectory. stream ifNil: [^ self]. aNewChangeSet := self class newChangesFromStream: stream named: (FileDirectory localNameFor: stream name). aNewChangeSet ifNotNil: [self showChangeSet: aNewChangeSet]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 00:57'! fileOutAllChangeSets "File out all nonempty change sets in the current category, probably" self changeSetCategory fileOutAllChangeSets! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 01:26'! fillAggregateChangeSet "Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category" self changeSetCategory fillAggregateChangeSet! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/2/2001 13:22'! findCngSet "Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed" | index pattern candidates nameList | self okToChange ifFalse: [^ self]. pattern _ FillInTheBlank request: 'ChangeSet name or fragment?'. pattern isEmpty ifTrue: [^ self]. nameList _ self changeSetList asSet. candidates _ AllChangeSets select: [:c | (nameList includes: c name) and: [c name includesSubstring: pattern caseSensitive: false]]. candidates size = 0 ifTrue: [^ self beep]. candidates size = 1 ifTrue: [^ self showChangeSet: candidates first]. index _ (PopUpMenu labels: (candidates collect: [:each | each name]) asStringWithCr) startUp. index = 0 ifFalse: [self showChangeSet: (candidates at: index)]. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nb 6/17/2003 12:25' prior: 34747559! findCngSet "Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed" | index pattern candidates nameList | self okToChange ifFalse: [^ self]. pattern _ FillInTheBlank request: 'ChangeSet name or fragment?'. pattern isEmpty ifTrue: [^ self]. nameList _ self changeSetList asSet. candidates _ AllChangeSets select: [:c | (nameList includes: c name) and: [c name includesSubstring: pattern caseSensitive: false]]. candidates size = 0 ifTrue: [^ Beeper beep]. candidates size = 1 ifTrue: [^ self showChangeSet: candidates first]. index _ (PopUpMenu labels: (candidates collect: [:each | each name]) asStringWithCr) startUp. index = 0 ifFalse: [self showChangeSet: (candidates at: index)]. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:43'! makeNewCategory "Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it" | catName aCategory | catName _ FillInTheBlank request: 'Please give the new category a name' initialAnswer: ''. catName isEmptyOrNil ifTrue: [^ self]. catName _ catName asSymbol. (ChangeSetCategories includesKey: catName) ifTrue: [^ self inform: 'Sorry, there is already a category of that name']. aCategory _ StaticChangeSetCategory new categoryName: catName. ChangeSetCategories elementAt: catName put: aCategory. aCategory addChangeSet: myChangeSet. self showChangeSetCategory: aCategory! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nk 6/26/2002 12:28'! makeNewCategoryShowingClassChanges "Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it" | catName aCategory clsName | clsName _ self selectedClass ifNotNil: [self selectedClass name ] ifNil: ['']. clsName _ FillInTheBlank request: 'Which class?' initialAnswer: clsName. clsName isEmptyOrNil ifTrue: [^ self]. catName _ ('Changes to ', clsName) asSymbol. (ChangeSetCategories includesKey: catName) ifTrue: [^ self inform: 'Sorry, there is already a category of that name']. aCategory _ ChangeSetCategoryWithParameters new categoryName: catName. aCategory membershipSelector: #changeSet:containsClass: ; parameters: { clsName }. ChangeSetCategories elementAt: catName put: aCategory. aCategory reconstituteList. self showChangeSetCategory: aCategory! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/28/2001 12:07'! methodConflictsWithOppositeCategory "Check to see if ANY change set on the other side shares any methods with the selected change set; if so, open a browser on all such." | aList otherCategory | otherCategory _ (parent other: self) changeSetCategory. aList _ myChangeSet messageListForChangesWhich: [ :aClass :aSelector | aClass notNil and: [otherCategory hasChangeForClassName: aClass name selector: aSelector otherThanIn: myChangeSet] ] ifNone: [^ self inform: 'There are no methods that appear both in this change set and in any change set (other than this one) on the other side.']. MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" also in some other change set in category ', otherCategory categoryName,' (', aList size printString, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/28/2001 12:07'! methodConflictsWithOtherSide "Check to see if the change set on the other side shares any methods with the selected change set; if so, open a browser on all such." | aList other | self checkThatSidesDiffer: [^ self]. other _ (parent other: self) changeSet. aList _ myChangeSet messageListForChangesWhich: [ :aClass :aSelector | aClass notNil and: [(other methodChangesAtClass: aClass name) includesKey: aSelector] ] ifNone: [^ self inform: 'There are no methods that appear both in this change set and in the one on the other side.']. MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" that are also in ', other name,' (', aList size printString, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 10/5/2001 08:52'! newCurrent "make my change set be the current one that changes go into" Smalltalk newChanges: myChangeSet. self update. "Because list of changes in a category may thus have changed" self changed: #relabel.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 5/23/2003 15:15' prior: 34752703! newCurrent "make my change set be the current one that changes go into" ChangeSet newChanges: myChangeSet. self update. "Because list of changes in a category may thus have changed" self changed: #relabel.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:26'! newSet "Create a new changeSet and show it., making it the current one. Reject name if already in use." | aSet | self okToChange ifFalse: [^ self]. aSet _ self class newChangeSet. aSet ifNotNil: [self changeSetCategory acceptsManualAdditions ifTrue: [changeSetCategory addChangeSet: aSet]. self update. (changeSetCategory includesChangeSet: aSet) ifTrue: [self showChangeSet: aSet]. self changed: #relabel]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 17:41'! offerCategorySubmenu "Offer a menu of category-related items" self offerMenuFrom: #categorySubmenu:shifted: shifted: false! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 2/27/2001 21:55'! offerShiftedChangeSetMenu "Offer the shifted version of the change set menu" self offerMenuFrom: #changeSetMenu:shifted: shifted: true! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/6/2001 14:41'! offerUnshiftedChangeSetMenu "Offer the unshifted version of the change set menu" self offerMenuFrom: #changeSetMenu:shifted: shifted: false! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/9/2001 15:30'! openChangeSetBrowser "Open a ChangeSet browser on the current change set" Smalltalk isMorphic ifFalse: [self browseChangeSet] "msg-list browser only" ifTrue: [(ChangeSetBrowser new myChangeSet: myChangeSet) openAsMorph]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 12/13/2003 18:14' prior: 19070283! promoteToTopChangeSet "Move the selected change-set to the top of the list" self class promoteToTop: myChangeSet. (parent ifNil: [self]) modelWakeUp! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 20:03'! removeCategory "Remove the current category" | itsName | self changeSetCategory acceptsManualAdditions ifFalse: [^ self inform: 'sorry, you can only remove manually-added categories.']. (self confirm: 'Really remove the change-set-category named ', (itsName _ changeSetCategory categoryName), '?') ifFalse: [^ self]. ChangeSetCategories removeElementAt: itsName. self setDefaultChangeSetCategory. self update! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'MU 7/1/2002 18:38'! removeContainedInClassCategories | matchExpression | myChangeSet removePreamble. matchExpression := FillInTheBlank request: 'Enter class category name (wildcard is ok)' initialAnswer: 'System-*'. (SystemOrganization categories select: [:each | matchExpression match: each]) do: [:eachCat | | classNames | classNames := SystemOrganization listAtCategoryNamed: eachCat. classNames do: [:eachClassName | myChangeSet removeClassChanges: eachClassName. myChangeSet removeClassChanges: eachClassName , ' class']. self showChangeSet: myChangeSet]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:31'! removeFromCategory "Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that" | aCategory | (aCategory _ self changeSetCategory) acceptsManualAdditions ifTrue: [aCategory removeElementAt: myChangeSet name. aCategory reconstituteList. self update] ifFalse: [self inform: 'sorry, this command only makes sense for static categories whose members are manually maintained']! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/16/2002 00:18'! removePrompting: doPrompt "Completely destroy my change set. Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first." | message aName changeSetNumber msg | aName _ myChangeSet name. myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project" (myChangeSet isEmpty or: [doPrompt not]) ifFalse: [message _ 'Are you certain that you want to remove (destroy) the change set named "', aName, '" ?'. (self confirm: message) ifFalse: [^ self]]. doPrompt ifTrue: [msg _ myChangeSet hasPreamble ifTrue: [myChangeSet hasPostscript ifTrue: ['a preamble and a postscript'] ifFalse: ['a preamble']] ifFalse: [myChangeSet hasPostscript ifTrue: ['a postscript'] ifFalse: ['']]. msg isEmpty ifFalse: [(self confirm: 'Caution!! This change set has ', msg, ' which will be lost if you destroy the change set. Do you really want to go ahead with this?') ifFalse: [^ self]]]. "Go ahead and remove the change set" changeSetNumber _ myChangeSet name initialIntegerOrNil. changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber]. ChangeSorter removeChangeSet: myChangeSet. self showChangeSet: Smalltalk changes.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 5/23/2003 14:26' prior: 34756670! removePrompting: doPrompt "Completely destroy my change set. Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first." | message aName changeSetNumber msg | aName _ myChangeSet name. myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project" (myChangeSet isEmpty or: [doPrompt not]) ifFalse: [message _ 'Are you certain that you want to remove (destroy) the change set named "', aName, '" ?'. (self confirm: message) ifFalse: [^ self]]. doPrompt ifTrue: [msg _ myChangeSet hasPreamble ifTrue: [myChangeSet hasPostscript ifTrue: ['a preamble and a postscript'] ifFalse: ['a preamble']] ifFalse: [myChangeSet hasPostscript ifTrue: ['a postscript'] ifFalse: ['']]. msg isEmpty ifFalse: [(self confirm: 'Caution!! This change set has ', msg, ' which will be lost if you destroy the change set. Do you really want to go ahead with this?') ifFalse: [^ self]]]. "Go ahead and remove the change set" changeSetNumber _ myChangeSet name initialIntegerOrNil. changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber]. ChangeSorter removeChangeSet: myChangeSet. self showChangeSet: ChangeSet current.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/16/2002 22:36'! rename "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" | newName | newName _ FillInTheBlank request: 'New name for this change set' initialAnswer: myChangeSet name. (newName = myChangeSet name or: [newName size == 0]) ifTrue: [^ self beep]. (self class changeSetNamed: newName) ifNotNil: [^ Utilities inform: 'Sorry that name is already used']. myChangeSet name: newName. self update. self changed: #mainButtonName. self changed: #relabel.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nb 6/17/2003 12:25' prior: 34759372! rename "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" | newName | newName _ FillInTheBlank request: 'New name for this change set' initialAnswer: myChangeSet name. (newName = myChangeSet name or: [newName size == 0]) ifTrue: [^ Beeper beep]. (self class changeSetNamed: newName) ifNotNil: [^ Utilities inform: 'Sorry that name is already used']. myChangeSet name: newName. self update. self changed: #mainButtonName. self changed: #relabel.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 18:18'! renameCategory "Obtain a new name for the category and, if acceptable, apply it" | catName oldName | self changeSetCategory acceptsManualAdditions ifFalse: [^ self inform: 'sorry, you can only rename manually-added categories.']. catName _ FillInTheBlank request: 'Please give the new category a name' initialAnswer: (oldName _ changeSetCategory categoryName). catName isEmptyOrNil ifTrue: [^ self]. (catName _ catName asSymbol) = oldName ifTrue: [^ self inform: 'no change.']. (ChangeSetCategories includesKey: catName) ifTrue: [^ self inform: 'Sorry, there is already a category of that name']. changeSetCategory categoryName: catName. ChangeSetCategories removeElementAt: oldName. ChangeSetCategories elementAt: catName put: changeSetCategory. self update! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/5/2001 11:03'! reorderChangeSets "apply a standard reordering -- let the class handle this" ^ self class reorderChangeSets! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 13:37'! setRecentUpdatesMarker "Allow the user to change the recent-updates marker" | result | result _ FillInTheBlank request: ('Enter the lowest change-set number that you wish to consider "recent"? (note: highest change-set number in this image at this time is ', self class highestNumberedChangeSet asString, ')') initialAnswer: self class recentUpdateMarker asString. (result notNil and: [result startsWithDigit]) ifTrue: [self class recentUpdateMarker: result asInteger. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/27/2002 16:24'! shiftedChangeSetMenu: aMenu "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down" Smalltalk isMorphic ifTrue: [aMenu title: 'Change set (shifted)'. aMenu addStayUpItemSpecial]. "CONFLICTS SECTION" aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in at least one other change set.'. parent ifNotNil: [aMenu add: 'conflicts with change set opposite' action: #methodConflictsWithOtherSide. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.'. aMenu add: 'conflicts with category opposite' action: #methodConflictsWithOppositeCategory. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in ANY change set in the category list on the opposite side of this change sorter, other of course than this change set itself. (Caution -- this could be VERY slow)']. aMenu addLine. "CHECKS SECTION" aMenu add: 'check for slips' action: #lookForSlips. aMenu balloonTextForLastItem: 'Check this change set for halts and references to Transcript.'. aMenu add: 'check for unsent messages' action: #checkForUnsentMessages. aMenu balloonTextForLastItem: 'Check this change set for messages that are not sent anywhere in the system'. aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods. aMenu balloonTextForLastItem: 'Check this change set for methods that do not have comments'. aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses. aMenu balloonTextForLastItem: 'Check for classes with code in this changeset which lack class comments'. Utilities authorInitialsPerSe isEmptyOrNil ifFalse: [aMenu add: 'check for other authors' action: #checkForAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'. aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods any of whose authoring stamps do not start with "', Utilities authorInitials, '"']. aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods. aMenu balloonTextForLastItem: 'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'. aMenu addLine. aMenu add: 'inspect change set' action: #inspectChangeSet. aMenu balloonTextForLastItem: 'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'. aMenu add: 'update' action: #update. aMenu balloonTextForLastItem: 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'. aMenu add: 'go to change set''s project' action: #goToChangeSetsProject. aMenu balloonTextForLastItem: 'If this change set is currently associated with a Project, go to that project right now.'. aMenu add: 'promote to top of list' action: #promoteToTopChangeSet. aMenu balloonTextForLastItem: 'Make this change set appear first in change-set lists in all change sorters.'. aMenu add: 'trim history' action: #trimHistory. aMenu balloonTextForLastItem: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'. aMenu add: 'clear this change set' action: #clearChangeSet. aMenu balloonTextForLastItem: 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'. aMenu add: 'expunge uniclasses' action: #expungeUniclasses. aMenu balloonTextForLastItem: 'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'. aMenu add: 'uninstall this change set' action: #uninstallChangeSet. aMenu balloonTextForLastItem: 'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'. aMenu addLine. aMenu add: 'file into new...' action: #fileIntoNewChangeSet. aMenu balloonTextForLastItem: 'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)'. aMenu add: 'reorder all change sets' action: #reorderChangeSets. aMenu balloonTextForLastItem: 'Applies a standard reordering of all change-sets in the system -- at the bottom will come the sets that come with the release; next will come all the numbered updates; finally, at the top, will come all other change sets'. aMenu addLine. aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu. aMenu balloonTextForLastItem: 'Takes you back to the primary change-set menu.'. ^ aMenu! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'mu 12/11/2003 20:05' prior: 34762245! shiftedChangeSetMenu: aMenu "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down" Smalltalk isMorphic ifTrue: [aMenu title: 'Change set (shifted)'. aMenu addStayUpItemSpecial]. "CONFLICTS SECTION" aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in at least one other change set.'. parent ifNotNil: [aMenu add: 'conflicts with change set opposite' action: #methodConflictsWithOtherSide. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.'. aMenu add: 'conflicts with category opposite' action: #methodConflictsWithOppositeCategory. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in ANY change set in the category list on the opposite side of this change sorter, other of course than this change set itself. (Caution -- this could be VERY slow)']. aMenu addLine. "CHECKS SECTION" aMenu add: 'check for slips' action: #lookForSlips. aMenu balloonTextForLastItem: 'Check this change set for halts and references to Transcript.'. aMenu add: 'check for unsent messages' action: #checkForUnsentMessages. aMenu balloonTextForLastItem: 'Check this change set for messages that are not sent anywhere in the system'. aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods. aMenu balloonTextForLastItem: 'Check this change set for methods that do not have comments'. aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses. aMenu balloonTextForLastItem: 'Check for classes with code in this changeset which lack class comments'. Utilities authorInitialsPerSe isEmptyOrNil ifFalse: [aMenu add: 'check for other authors' action: #checkForAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'. aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods any of whose authoring stamps do not start with "', Utilities authorInitials, '"']. aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods. aMenu balloonTextForLastItem: 'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'. aMenu addLine. aMenu add: 'inspect change set' action: #inspectChangeSet. aMenu balloonTextForLastItem: 'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'. aMenu add: 'update' action: #update. aMenu balloonTextForLastItem: 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'. aMenu add: 'go to change set''s project' action: #goToChangeSetsProject. aMenu balloonTextForLastItem: 'If this change set is currently associated with a Project, go to that project right now.'. aMenu add: 'promote to top of list' action: #promoteToTopChangeSet. aMenu balloonTextForLastItem: 'Make this change set appear first in change-set lists in all change sorters.'. aMenu add: 'trim history' action: #trimHistory. aMenu balloonTextForLastItem: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'. aMenu add: 'remove contained in class categories...' action: #removeContainedInClassCategories. aMenu balloonTextForLastItem: ' Drops any changes in given class categories'. aMenu add: 'clear this change set' action: #clearChangeSet. aMenu balloonTextForLastItem: 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'. aMenu add: 'expunge uniclasses' action: #expungeUniclasses. aMenu balloonTextForLastItem: 'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'. aMenu add: 'uninstall this change set' action: #uninstallChangeSet. aMenu balloonTextForLastItem: 'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'. aMenu addLine. aMenu add: 'file into new...' action: #fileIntoNewChangeSet. aMenu balloonTextForLastItem: 'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)'. aMenu add: 'reorder all change sets' action: #reorderChangeSets. aMenu balloonTextForLastItem: 'Applies a standard reordering of all change-sets in the system -- at the bottom will come the sets that come with the release; next will come all the numbered updates; finally, at the top, will come all other change sets'. aMenu addLine. aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu. aMenu balloonTextForLastItem: 'Takes you back to the primary change-set menu.'. ^ aMenu! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 8/11/2002 01:11'! showCategoriesOfChangeSet "Show a list of all the categories in which the selected change-set occurs at the moment. Install the one the user chooses, if any." | aMenu | Smalltalk isMorphic ifFalse: [self inform: 'Only available in morphic, right now, sorry. It would not take much to make this also work in mvc, so if you are inclined to do that, thanks in advance...'] ifTrue: [aMenu _ MenuMorph new defaultTarget: self. aMenu title: 'Categories which contain change set "', myChangeSet name, '"'. ChangeSetCategories elementsInOrder do: [:aCategory | (aCategory includesChangeSet: myChangeSet) ifTrue: [aMenu add: aCategory categoryName target: self selector: #showChangeSetCategory: argument: aCategory. aCategory == changeSetCategory ifTrue: [aMenu lastItem color: Color red]]. aMenu balloonTextForLastItem: aCategory documentation]. aMenu popUpInWorld]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 13:27'! showChangeSetCategory: aChangeSetCategory "Show the given change-set category" changeSetCategory _ aChangeSetCategory. self changed: #changeSetList. (self changeSetList includes: myChangeSet name) ifFalse: [self showChangeSet: (ChangeSorter changeSetNamed: self changeSetList first)]. self changed: #relabel! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 4/5/2001 21:22'! submergeIntoOtherSide "Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well." | other message nextToView i | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ self]. other _ (parent other: self) changeSet. other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!']. myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy. To remove, simply choose "remove".']. myChangeSet okayToRemove ifFalse: [^ self]. message _ 'Please confirm: copy all changes in "', myChangeSet name, '" into "', other name, '" and then destroy the change set named "', myChangeSet name, '"?'. (self confirm: message) ifFalse: [^ self]. (myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue: [(self confirm: 'Caution!! This change set has a preamble or a postscript or both. If you submerge it into the other side, these will be lost. Do you really want to go ahead with this?') ifFalse: [^ self]]. other assimilateAllChangesFoundIn: myChangeSet. nextToView _ ((AllChangeSets includes: myChangeSet) and: [(i _ AllChangeSets indexOf: myChangeSet) < AllChangeSets size]) ifTrue: [AllChangeSets at: i+1] ifFalse: [other]. self removePrompting: false. self showChangeSet: nextToView. parent modelWakeUp. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/20/2001 09:37'! updateIfNecessary "Recompute all of my panes." | newList | self okToChange ifFalse: [^ self]. myChangeSet ifNil: [^ self]. "Has been known to happen though shouldn't" (myChangeSet isMoribund or: [(changeSetCategory notNil and: [changeSetCategory includesChangeSet: myChangeSet]) not]) ifTrue: [self changed: #changeSetList. ^ self showChangeSet: self changeSetCategory defaultChangeSetToShow]. newList _ self changeSetList. (priorChangeSetList == nil or: [priorChangeSetList ~= newList]) ifTrue: [priorChangeSetList _ newList. self changed: #changeSetList]. self showChangeSet: myChangeSet! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 3/29/2001 15:19'! classList "Computed. View should try to preserve selections, even though index changes" ^ myChangeSet ifNotNil: [myChangeSet changedClassNames] ifNil: [OrderedCollection new] ! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 3/5/2001 18:24'! classListKey: aChar from: view "Respond to a Command key in the class-list pane." aChar == $x ifTrue: [^ self removeClass]. aChar == $d ifTrue: [^ self forgetClass]. ^ self messageListKey: aChar from: view "picks up b,h,p"! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 11/3/2001 09:34'! classListMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the class list" aMenu title: 'class list'. Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial]. (parent notNil and: [shifted not]) ifTrue: [aMenu addList: #( "These two only apply to dual change sorters" ('copy class chgs to other side' copyClassToOther) ('move class chgs to other side' moveClassToOther))]. aMenu addList: (shifted ifFalse: [#( - ('delete class from change set (d)' forgetClass) ('remove class from system (x)' removeClass) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse protocol (p)' browseFullProtocol) - ('printOut' printOutClass) ('fileOut' fileOutClass) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class vars' browseClassVariables) ('class refs (N)' browseClassRefs) - ('more...' offerShiftedClassListMenu))] ifTrue: [#( - ('unsent methods' browseUnusedMethods) ('unreferenced inst vars' showUnreferencedInstVars) ('unreferenced class vars' showUnreferencedClassVars) - ('sample instance' makeSampleInstance) ('inspect instances' inspectInstances) ('inspect subinstances' inspectSubInstances) - ('more...' offerUnshiftedClassListMenu ))]). ^ aMenu! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 2/26/2001 12:00'! classMenu: aMenu "Set up aMenu for the class-list. Retained for backward compatibility with old change sorters in image segments" ^ self classListMenu: aMenu shifted: false! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 3/6/2001 12:40'! classMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the class list. Retained for bkwd compatibility" ^ self classListMenu: aMenu shifted: shifted! ! !ChangeSorter methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25' prior: 19082416! copyClassToOther "Place these changes in the other changeSet also" | otherSorter otherChangeSet | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ Beeper beep]. currentClassName ifNil: [^ Beeper beep]. otherSorter _ parent other: self. otherChangeSet _ otherSorter changeSet. otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet. otherSorter showChangeSet: otherChangeSet.! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 3/5/2001 18:30'! messageListKey: aChar from: view "Respond to a Command key in the message-list pane." aChar == $d ifTrue: [^ self forget]. super messageListKey: aChar from: view! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 10/1/2001 10:43'! moveClassToOther "Place class changes in the other changeSet and remove them from this one" self checkThatSidesDiffer: [^ self]. (self okToChange and: [currentClassName notNil]) ifFalse: [^ self beep]. self copyClassToOther. self forgetClass! ! !ChangeSorter methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25' prior: 34779543! moveClassToOther "Place class changes in the other changeSet and remove them from this one" self checkThatSidesDiffer: [^ self]. (self okToChange and: [currentClassName notNil]) ifFalse: [^ Beeper beep]. self copyClassToOther. self forgetClass! ! !ChangeSorter methodsFor: 'message list' stamp: 'sw 3/9/2001 14:27'! messageListMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" ^ self messageMenu: aMenu shifted: shifted! ! !ChangeSorter methodsFor: 'message list' stamp: 'sw 3/5/2001 18:26'! messageMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" shifted ifTrue: [^ self shiftedMessageMenu: aMenu]. aMenu title: 'message list'. Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial]. parent ifNotNil: [aMenu addList: #( ('copy method to other side' copyMethodToOther) ('move method to other side' moveMethodToOther))]. aMenu addList: #( ('delete method from changeSet (d)' forget) - ('remove method from system (x)' removeMessage) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) - ('more...' shiftedYellowButtonActivity)). ^ aMenu ! ! !ChangeSorter methodsFor: 'message list' stamp: 'nb 6/17/2003 12:25' prior: 19088794! moveMethodToOther "Place this change in the other changeSet and remove it from this side" | other cls sel | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ Beeper beep]. currentSelector ifNotNil: [other _ (parent other: self) changeSet. other == myChangeSet ifTrue: [^ self beep]. cls _ self selectedClassOrMetaClass. sel _ currentSelector asSymbol. other absorbMethod: sel class: cls from: myChangeSet. (parent other: self) showChangeSet: other. self forget "removes the method from this side"] ! ! !ChangeSorter methodsFor: 'message list' prior: 19089662! removeMessage "Remove the selected msg from the system. Real work done by the parent, a ChangeSorter" | confirmation sel | self okToChange ifFalse: [^ self]. currentSelector ifNotNil: [confirmation _ SystemNavigation new confirmRemovalOf: (sel _ self selectedMessageName) on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: sel. self update. confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: sel]]! ! !ChangeSorter methodsFor: 'message list' stamp: 'sd 4/15/2003 16:13' prior: 34782241! removeMessage "Remove the selected msg from the system. Real work done by the parent, a ChangeSorter" | confirmation sel | self okToChange ifFalse: [^ self]. currentSelector ifNotNil: [confirmation _ self systemNavigation confirmRemovalOf: (sel _ self selectedMessageName) on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: sel. self update. confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: sel]]! ! !ChangeSorter methodsFor: 'message list' stamp: 'nk 6/26/2003 21:42' prior: 34782830! removeMessage "Remove the selected msg from the system. Real work done by the parent, a ChangeSorter" | confirmation sel | self okToChange ifFalse: [^ self]. currentSelector ifNotNil: [confirmation _ self systemNavigation confirmRemovalOf: (sel _ self selectedMessageName) on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: sel. self update. confirmation == 2 ifTrue: [self systemNavigation browseAllCallsOn: sel]]! ! !ChangeSorter methodsFor: 'message list' stamp: 'sd 5/11/2003 18:38' prior: 34783421! removeMessage "Remove the selected msg from the system. Real work done by the parent, a ChangeSorter" | confirmation sel | self okToChange ifFalse: [^ self]. currentSelector ifNotNil: [confirmation _ self systemNavigation confirmRemovalOf: (sel _ self selectedMessageName) on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: sel. self update. confirmation == 2 ifTrue: [self systemNavigation browseAllCallsOn: sel]]! ! !ChangeSorter methodsFor: 'code pane' stamp: 'sw 11/13/2001 07:35'! setContents "return the source code that shows in the bottom pane" | sel class strm changeType | self clearUserEditFlag. currentClassName ifNil: [^ contents _ myChangeSet preambleString ifNil: ['']]. class _ self selectedClassOrMetaClass. (sel _ currentSelector) == nil ifFalse: [changeType _ (myChangeSet atSelector: (sel _ sel asSymbol) class: class). changeType == #remove ifTrue: [^ contents _ 'Method has been removed (see versions)']. changeType == #addedThenRemoved ifTrue: [^ contents _ 'Added then removed (see versions)']. class ifNil: [^ contents _ 'Method was added, but cannot be found!!']. (class includesSelector: sel) ifFalse: [^ contents _ 'Method was added, but cannot be found!!']. contents _ class sourceCodeAt: sel. (#(prettyPrint colorPrint prettyDiffs altSyntax) includes: contentsSymbol) ifTrue: [contents _ class compilerClass new format: contents in: class notifying: nil contentsSymbol: contentsSymbol]. self showingAnyKindOfDiffs ifTrue: [contents _ self diffFromPriorSourceFor: contents]. ^ contents _ contents asText makeSelectorBoldIn: class] ifTrue: [strm _ WriteStream on: (String new: 100). (myChangeSet classChangeAt: currentClassName) do: [:each | each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr]. each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.']. each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.'; cr]. each = #add ifTrue: [strm nextPutAll: 'Class definition was added.'; cr]. each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr]. each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.'; cr]. each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr. ]]. ^ contents _ strm contents].! ! !ChangeSorter methodsFor: 'code pane' stamp: 'sw 11/13/2001 07:34'! toggleDiffing "Toggle whether diffs should be shown in the code pane" self okToChange ifTrue: [super toggleDiffing. self changed: #contents. self update] ! ! !ChangeSorter methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:35'! addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior version is pointed to by the lost-method pointer in the change held on to by the changeset" (aClass includesSelector: aSelector) ifTrue: [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. aStream nextPutAll: ((myChangeSet methodInfoFromRemoval: {aClass name. aSelector}) ifNil: ['no prior versions'] ifNotNil: ['version(s) retrievable here']), self annotationSeparator! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:33'! allChangeSetNames ^ self allChangeSets collect: [:c | c name]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:27'! allChangeSets "Return the list of all current ChangeSets" ^ AllChangeSets! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:34'! allChangeSetsWithClass: class selector: selector class ifNil: [^ #()]. ^ self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'nk 6/26/2002 12:39'! changeSet: aChangeSet containsClass: aClass | theClass | theClass _ Smalltalk classNamed: aClass. theClass ifNil: [^ false]. ^ aChangeSet containsClass: theClass! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 19:42'! changeSetNamed: aName "Return the change set of the given name, or nil if none found. 1/22/96 sw" ^ AllChangeSets detect: [:aChangeSet | aChangeSet name = aName] ifNone: [nil]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 19:42'! changeSetsNamedSuchThat: nameBlock "(ChangeSorter changeSetsNamedSuchThat: [:name | name first isDigit and: [name initialInteger >= 373]]) do: [:cs | AllChangeSets remove: cs wither]" ^ AllChangeSets select: [:aChangeSet | nameBlock value: aChangeSet name]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/6/2001 09:49'! existingOrNewChangeSetNamed: aName | newSet | ^(self changeSetNamed: aName) ifNil: [ newSet _ ChangeSet basicNewNamed: aName. AllChangeSets add: newSet. newSet ]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:37'! mostRecentChangeSetWithChangeForClass: class selector: selector | hits | hits _ self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. hits isEmpty ifTrue: [^ 'not in any change set']. ^ 'recent cs: ', hits last name! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 20:03'! promoteToTop: aChangeSet "make aChangeSet the first in the list from now on" AllChangeSets remove: aChangeSet ifAbsent: [^ self]. AllChangeSets add: aChangeSet. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'sw 12/13/2003 18:22' prior: 34789460! promoteToTop: aChangeSet "Make aChangeSet the first in the list from now on" AllChangeSets remove: aChangeSet ifAbsent: [^ self]. AllChangeSets add: aChangeSet! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 16:01'! belongsInAdditions: aChangeSet "Answer whether a change set belongs in the Additions category, which is fed by all change sets that are neither numbered nor in the initial release" ^ (((self belongsInProjectsInRelease: aChangeSet) or: [self belongsInNumbered: aChangeSet])) not! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:38'! belongsInAll: aChangeSet "Answer whether a change set belongs in the All category" ^ true ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:47'! belongsInMyInitials: aChangeSet "Answer whether a change set belongs in the MyInitials category. " ^ aChangeSet name endsWith: ('-', Utilities authorInitials)! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:45'! belongsInNumbered: aChangeSet "Answer whether a change set belongs in the Numbered category. " ^ aChangeSet name startsWithDigit! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:49'! belongsInProjectChangeSets: aChangeSet "Answer whether a change set belongs in the MyInitials category. " ^ aChangeSet belongsToAProject! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:44'! belongsInProjectsInRelease: aChangeSet "Answer whether a change set belongs in the ProjectsInRelease category. You can hand-tweak this to suit your working style. This just covers the space of project names in the 2.9, 3.0, and 3.1a systems" | aString | ^ ((aString _ aChangeSet name) beginsWith: 'Play With Me') or: [self changeSetNamesInReleaseImage includes: aString]! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:56'! belongsInRecentUpdates: aChangeSet "Answer whether a change set belongs in the RecentUpdates category." ^ aChangeSet name startsWithDigit and: [aChangeSet name asInteger >= self recentUpdateMarker]! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/29/2001 14:44'! changeSetCategoryNamed: aName "Answer the changeSetCategory of the given name, or nil if none" ^ ChangeSetCategories elementAt: aName asSymbol ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 4/16/2002 00:47'! changeSetNamesInReleaseImage "Answer a list of names of project change sets that come pre-shipped in the latest sytem release. On the brink of shipping a new release, call 'ChangeSorter noteChangeSetsInRelease' " ^ ChangeSetNamesInRelease ifNil: [ChangeSetNamesInRelease _ self changeSetNamesInThreeOh]! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 4/16/2002 00:45'! changeSetNamesInThreeOh "Hard-coded: answer a list of names of project change sets that came pre-shipped in Squeak 3.0" ^ #('The Worlds of Squeak' 'Fun with Morphic' 'Games' 'Fun With Music' 'Building with Squeak' 'Squeak and the Internet' 'Squeak in 3D' 'More About Sound' ) ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'LEG 10/24/2001 21:21'! initialize "Initialize the class variables" AllChangeSets == nil ifTrue: [AllChangeSets _ OrderedCollection new]. self gatherChangeSets. ChangeSetCategories ifNil: [self initializeChangeSetCategories]. RecentUpdateMarker _ 0. "ChangeSorter initialize" FileList registerFileReader: self ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:41' prior: 34793057! initialize "Initialize the class variables" AllChangeSets == nil ifTrue: [AllChangeSets _ OrderedCollection new]. self gatherChangeSets. ChangeSetCategories ifNil: [self initializeChangeSetCategories]. RecentUpdateMarker _ 0. "ChangeSorter initialize" FileList registerFileReader: self. self registerInFlapsRegistry. ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 13:30'! initializeChangeSetCategories "Initialize the set of change-set categories" "ChangeSorter initializeChangeSetCategories" | aCategory | ChangeSetCategories _ ElementCategory new categoryName: #ChangeSetCategories. aCategory _ ChangeSetCategory new categoryName: #All. aCategory membershipSelector: #belongsInAll:. aCategory documentation: 'All change sets known to the system'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #Additions. aCategory membershipSelector: #belongsInAdditions:. aCategory documentation: 'All unnumbered change sets except those representing projects in the system as initially released.'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #MyInitials. aCategory membershipSelector: #belongsInMyInitials:. aCategory documentation: 'All change sets whose names end with the current author''s initials.'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #Numbered. aCategory membershipSelector: #belongsInNumbered:. aCategory documentation: 'All change sets whose names start with a digit -- normally these will be the official updates to the system.'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #ProjectChangeSets. aCategory membershipSelector: #belongsInProjectChangeSets:. aCategory documentation: 'All change sets that are currently associated with projects present in the system right now.'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #ProjectsInRelease. aCategory membershipSelector: #belongsInProjectsInRelease:. aCategory documentation: 'All change sets belonging to projects that were shipped in the initial release of this version of Squeak'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #RecentUpdates. aCategory membershipSelector: #belongsInRecentUpdates:. aCategory documentation: 'Updates whose numbers are at or beyond the number I have designated as the earliest one to qualify as Recent'. ChangeSetCategories addCategoryItem: aCategory. ChangeSetCategories elementsInOrder do: [:anElem | anElem reconstituteList] ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 4/16/2002 00:47'! noteChangeSetsInRelease "Freshly compute what the change sets in the release are; to be called manually just before a release" ChangeSetNamesInRelease _ (Project allProjects collect: [:p | p name]) asSet asOrderedCollection. "ChangeSorter noteChangeSetsInRelease"! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:42'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(ChangeSorter prototypicalToolWindow 'Change Set' 'A tool that allows you to view and manipulate all the code changes in a single change set') forFlapNamed: 'Tools']! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:32' prior: 34797041! unload "Unload the receiver from global registries" self environment at: #FileList ifPresent: [:cl | cl unregisterFileReader: self]. self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !ChangeSorter class methodsFor: 'adding' stamp: 'di 4/6/2001 09:46'! basicNewChangeSet: newName | newSet | newName ifNil: [^ nil]. (self changeSetNamed: newName) ifNotNil: [self inform: 'Sorry that name is already used'. ^ nil]. newSet _ ChangeSet basicNewNamed: newName. AllChangeSets add: newSet. ^ newSet! ! !ChangeSorter class methodsFor: 'adding' stamp: 'sw 12/18/2001 23:27'! newChangeSet "Prompt the user for a name, and establish a new change set of that name (if ok), making it the current changeset. Return nil of not ok, else return the actual changeset." | newName newSet | newName _ FillInTheBlank request: 'Please name the new change set:' initialAnswer: ChangeSet defaultName. newName isEmptyOrNil ifTrue: [^ nil]. newSet _ self basicNewChangeSet: newName. newSet ifNotNil: [Smalltalk newChanges: newSet]. ^ newSet! ! !ChangeSorter class methodsFor: 'adding' stamp: 'sd 5/23/2003 15:15' prior: 34797813! newChangeSet "Prompt the user for a name, and establish a new change set of that name (if ok), making it the current changeset. Return nil of not ok, else return the actual changeset." | newName newSet | newName _ FillInTheBlank request: 'Please name the new change set:' initialAnswer: ChangeSet defaultName. newName isEmptyOrNil ifTrue: [^ nil]. newSet _ self basicNewChangeSet: newName. newSet ifNotNil: [ChangeSet newChanges: newSet]. ^ newSet! ! !ChangeSorter class methodsFor: 'adding' stamp: 'tk 12/14/2001 11:14'! newChangesFromStream: aStream named: aName "File in the code from the stream into a new change set whose name is derived from aName. Leave the 'current change set' unchanged. Return the new change set or nil on failure." | oldChanges newName newSet | oldChanges _ Smalltalk changes. PreviousSet _ oldChanges name. "so a Bumper update can find it" newName _ aName sansPeriodSuffix. newSet _ self basicNewChangeSet: newName. [newSet ifNotNil: [Smalltalk newChanges: newSet. aStream fileInAnnouncing: 'Loading ', newName, '...'. Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName]. aStream close] ensure: [ Smalltalk newChanges: oldChanges]. ^ newSet! ! !ChangeSorter class methodsFor: 'adding' stamp: 'sd 5/23/2003 15:15' prior: 34798913! newChangesFromStream: aStream named: aName "File in the code from the stream into a new change set whose name is derived from aName. Leave the 'current change set' unchanged. Return the new change set or nil on failure." | oldChanges newName newSet | oldChanges _ ChangeSet current. PreviousSet _ oldChanges name. "so a Bumper update can find it" newName _ aName sansPeriodSuffix. newSet _ self basicNewChangeSet: newName. [newSet ifNotNil: [ChangeSet newChanges: newSet. aStream fileInAnnouncing: 'Loading ', newName, '...'. Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName]. aStream close] ensure: [ ChangeSet newChanges: oldChanges]. ^ newSet! ! !ChangeSorter class methodsFor: 'removing' stamp: 'di 4/5/2001 21:12'! removeChangeSetsNamedSuchThat: nameBlock (ChangeSorter changeSetsNamedSuchThat: nameBlock) do: [:cs | self removeChangeSet: cs]! ! !ChangeSorter class methodsFor: 'removing' stamp: 'di 4/5/2001 21:13'! removeEmptyUnnamedChangeSets "Remove all change sets that are empty, whose names start with Unnamed, and which are not nailed down by belonging to a Project." "ChangeSorter removeEmptyUnnamedChangeSets" | toGo | (toGo _ (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed']) select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]]) do: [:cs | self removeChangeSet: cs]. self inform: toGo size printString, ' change set(s) removed.'! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 3/30/2001 13:43'! assuredChangeSetNamed: aName "Answer a change set of the given name. If one already exists, answer that, else create a new one and answer it." | existing | ^ (existing _ self changeSetNamed: aName) ifNotNil: [existing] ifNil: [self basicNewChangeSet: aName]! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 5/23/2001 13:30'! browseChangeSetsWithClass: class selector: selector "Put up a menu comprising a list of change sets that hold changes for the given class and selector. If the user selects one, open a single change-sorter onto it" | hits index | hits _ self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. hits isEmpty ifTrue: [^ self inform: class name, '.', selector , ' is not in any change set']. index _ hits size == 1 ifTrue: [1] ifFalse: [(PopUpMenu labelArray: (hits collect: [:cs | cs name]) lines: #()) startUp]. index = 0 ifTrue: [^ self]. (ChangeSorter new myChangeSet: (hits at: index)) open. ! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 5/23/2001 13:31'! browseChangeSetsWithSelector: aSelector "Put up a list of all change sets that contain an addition, deletion, or change of any method with the given selector" | hits index | hits _ self allChangeSets select: [:cs | cs hasAnyChangeForSelector: aSelector]. hits isEmpty ifTrue: [^ self inform: aSelector , ' is not in any change set']. index _ hits size == 1 ifTrue: [1] ifFalse: [(PopUpMenu labelArray: (hits collect: [:cs | cs name]) lines: #()) startUp]. index = 0 ifTrue: [^ self]. (ChangeSetBrowser new myChangeSet: (hits at: index)) open "ChangeSorter browseChangeSetsWithSelector: #clearPenTrails" ! ! !ChangeSorter class methodsFor: 'services' stamp: 'di 4/5/2001 21:36'! buildAggregateChangeSet "Establish a change-set named Aggregate which bears the union of all the changes in all the existing change-sets in the system (other than any pre-existing Aggregate). This can be useful when wishing to discover potential conflicts between a disk-resident change-set and an image. Formerly very useful, now some of its unique contributions have been overtaken by new features" | aggregateChangeSet | aggregateChangeSet _ self existingOrNewChangeSetNamed: 'Aggregate'. aggregateChangeSet clear. self allChangeSets do: [:aChangeSet | aChangeSet == aggregateChangeSet ifFalse: [aggregateChangeSet assimilateAllChangesFoundIn: aChangeSet]] "ChangeSorter buildAggregateChangeSet" ! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 6/6/2001 12:51'! countOfChangeSetsWithClass: aClass andSelector: aSelector "Answer how many change sets record a change for the given class and selector" ^ (self allChangeSetsWithClass: aClass selector: aSelector) size! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 6/6/2001 12:52'! doesAnyChangeSetHaveClass: aClass andSelector: aSelector "Answer whether any known change set bears a change for the given class and selector" ^ (self countOfChangeSetsWithClass: aClass andSelector: aSelector) > 0! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 6/13/2001 00:56'! prototypicalToolWindow "Answer a window representing a prototypical instance of the receiver" ^ self new morphicWindow applyModelExtent! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 3/30/2001 00:30'! recentUpdateMarker "Answer the number representing the threshold of what counts as 'recent' for an update number. This allow you to use the RecentUpdates category in a ChangeSorter to advantage" ^ RecentUpdateMarker ifNil: [RecentUpdateMarker _ 0]! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 3/30/2001 00:30'! recentUpdateMarker: aNumber "Set the recent update marker as indicated" ^ RecentUpdateMarker _ aNumber! ! !ChangeSorter class methodsFor: 'services' stamp: 'di 4/5/2001 21:14'! reorderChangeSets "Change the order of the change sets to something more convenient: First come the project changesets that come with the release. These are mostly empty. Next come all numbered updates. Next come all remaining changesets In a ChangeSorter, they will appear in the reversed order." "ChangeSorter reorderChangeSets" | newHead newMid newTail | newHead _ OrderedCollection new. newMid _ OrderedCollection new. newTail _ OrderedCollection new. AllChangeSets do: [:aChangeSet | (self belongsInProjectsInRelease: aChangeSet) ifTrue: [newHead add: aChangeSet] ifFalse: [(self belongsInNumbered: aChangeSet) ifTrue: [newMid add: aChangeSet] ifFalse: [newTail add: aChangeSet]]]. AllChangeSets _ newHead, newMid, newTail. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! ! !ChangeSorter class methodsFor: 'services' stamp: 'di 4/5/2001 21:15'! secondaryChangeSet "Answer a likely change set to use as the second initial one in a Dual Change Sorter. " AllChangeSets size = 1 ifTrue: [^ AllChangeSets first]. AllChangeSets last == Smalltalk changes ifTrue: [^ AllChangeSets at: (AllChangeSets size - 1)] ifFalse: [^ AllChangeSets last]! ! !ChangeSorter class methodsFor: 'services' stamp: 'sd 5/23/2003 14:27' prior: 34806042! secondaryChangeSet "Answer a likely change set to use as the second initial one in a Dual Change Sorter. " AllChangeSets size = 1 ifTrue: [^ AllChangeSets first]. AllChangeSets last == ChangeSet current ifTrue: [^ AllChangeSets at: (AllChangeSets size - 1)] ifFalse: [^ AllChangeSets last]! ! !ChangeSorter class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:09'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Change Sorter' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that lets you see the code for one change set at a time.'! ! !ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sw 2/16/2002 01:31'! fileIntoNewChangeSet: fullName "File in all of the contents of the currently selected file, if any, into a new change set." | fn ff | fullName ifNil: [^ self beep]. ff _ FileStream readOnlyFileNamed: (fn _ GZipReadStream uncompressedFileName: fullName). ((FileDirectory extensionFor: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml]. self newChangesFromStream: ff named: (FileDirectory localNameFor: fn)! ! !ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'nb 6/17/2003 12:25' prior: 34807175! fileIntoNewChangeSet: fullName "File in all of the contents of the currently selected file, if any, into a new change set." | fn ff | fullName ifNil: [^ Beeper beep]. ff _ FileStream readOnlyFileNamed: (fn _ GZipReadStream uncompressedFileName: fullName). ((FileDirectory extensionFor: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml]. self newChangesFromStream: ff named: (FileDirectory localNameFor: fn)! ! !ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:29'! fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'st') | (suffix = 'cs') | (suffix = '*') ifTrue: [ self services] ifFalse: [#()]! ! !ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sw 2/17/2002 01:36'! serviceFileIntoNewChangeSet "Answer a service for installing a file into a new change set" ^ SimpleServiceEntry provider: self label: 'install into new change set' selector: #fileIntoNewChangeSet: description: 'install the file as a body of code in the image: create a new change set and file-in the selected file into it' buttonLabel: 'install'! ! !ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:47'! services ^ Array with: self serviceFileIntoNewChangeSet ! ! !ChangeSorter class methodsFor: 'utilities' stamp: 'sd 1/16/2004 21:36'! fileOutChangeSetsNamed: nameList "File out the list of change sets whose names are provided" "ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')" | notFound aChangeSet infoString empty | notFound _ OrderedCollection new. empty _ OrderedCollection new. nameList do: [:aName | (aChangeSet _ self changeSetNamed: aName) ifNotNil: [aChangeSet isEmpty ifTrue: [empty add: aName] ifFalse: [aChangeSet fileOut]] ifNil: [notFound add: aName]]. infoString _ (nameList size - notFound size) printString, ' change set(s) filed out'. notFound size > 0 ifTrue: [infoString _ infoString, ' ', notFound size printString, ' change set(s) not found:'. notFound do: [:aName | infoString _ infoString, ' ', aName]]. empty size > 0 ifTrue: [infoString _ infoString, ' ', empty size printString, ' change set(s) were empty:'. empty do: [:aName | infoString _ infoString, ' ', aName]]. self inform: infoString! ! !ChangedMessageSet methodsFor: 'acceptance' stamp: 'sw 6/26/2001 11:42'! contents: aString notifying: aController "Accept the string as new source for the current method, and make certain the annotation pane gets invalidated" | existingSelector existingClass superResult newSelector | existingSelector _ self selectedMessageName. existingClass _ self selectedClassOrMetaClass. superResult _ super contents: aString notifying: aController. superResult ifTrue: "succeeded" [newSelector _ Parser new parseSelector: aString. newSelector ~= existingSelector ifTrue: "Selector changed -- maybe an addition" [self reformulateList. self changed: #messageList. self messageList doWithIndex: [:aMethodReference :anIndex | (aMethodReference actualClass == existingClass and: [aMethodReference methodSymbol == newSelector]) ifTrue: [self messageListIndex: anIndex]]]]. ^ superResult! ! !ChangedMessageSet methodsFor: 'reformulation' stamp: 'sw 6/26/2001 11:20'! reformulateList "Reformulate the message list of the receiver" self initializeMessageList: (changeSet changedMessageListAugmented select: [:each | each isValid]) ! ! !ChangedMessageSet commentStamp: '' prior: 0! A ChangedMessageSet is a message set associated with a change-set; it bears an entry for every method added or changed in the change set, as well as for every class-comment of which the change-set bears a note.! !ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'RAA 5/29/2001 10:19'! openFor: aChangeSet "Open up a ChangedMessageSet browser on the given change set; this is a conventional message-list browser whose message-list consists of all the methods in aChangeSet. After any method submission, the message list is refigured, making it plausibly dynamic" | messageSet | messageSet _ aChangeSet changedMessageListAugmented select: [ :each | each isValid]. self openMessageList: messageSet name: 'Methods in Change Set ', aChangeSet name autoSelect: nil changeSet: aChangeSet! ! !ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 11:42'! openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet | messageSet | messageSet _ self messageList: messageList. messageSet changeSet: aChangeSet. messageSet autoSelectString: autoSelectString. Smalltalk isMorphic ifTrue: [self openAsMorph: messageSet name: labelString] ifFalse: [ScheduledControllers scheduleActive: (self open: messageSet name: labelString)]! ! !Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:11'! charCode ^ (value bitAnd: 16r3FFFFF). ! ! !Character methodsFor: 'accessing' stamp: 'RAH 4/25/2000 19:49'! codePoint "Return the encoding value of the receiver." #Fundmntl. ^ self asciiValue! ! !Character methodsFor: 'accessing' stamp: 'yo 12/1/2003 19:30' prior: 19122253! digitValue "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 otherwise. This is used to parse literal numbers of radix 2-36." ^ (EncodedCharSet charsetAt: self leadingChar) digitValue: self. ! ! !Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:14'! leadingChar ^ (value bitAnd: (16r3FC00000)) bitShift: -22. ! ! !Character methodsFor: 'comparing' stamp: 'yo 8/27/2002 15:16' prior: 19122766! = aCharacter "Primitive. Answer true if the receiver and the argument are the same object (have the same object pointer) and false otherwise. Optional. See Object documentation whatIsAPrimitive." "" ^ self == aCharacter or: [aCharacter class == MultiCharacter and: [aCharacter asciiValue = self asciiValue]]. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:57'! canBeGlobalVarInitial ^ (EncodedCharSet charsetAt: self leadingChar) canBeGlobalVarInitial: self. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:58'! canBeNonGlobalVarInitial ^ (EncodedCharSet charsetAt: self leadingChar) canBeNonGlobalVarInitial: self. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/28/2002 13:42'! isCharacter ^ true. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43' prior: 19123452! isDigit ^ (EncodedCharSet charsetAt: self leadingChar) isDigit: self. ! ! !Character methodsFor: 'testing' stamp: 'dgd 8/24/2003 14:50' prior: 19123575! isLetter "Answer whether the receiver is a letter." ^ (ClassificationTable at: value + 1) anyMask: LetterBits! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43' prior: 34814302! isLetter ^ (EncodedCharSet charsetAt: self leadingChar) isLetter: self. ! ! !Character methodsFor: 'testing' stamp: 'dgd 8/24/2003 14:51' prior: 19123753! isLowercase "Answer whether the receiver is a lowercase letter. (The old implementation answered whether the receiver is not an uppercase letter.)" ^ ((ClassificationTable at: value + 1) bitAnd: LowercaseBit) = LowercaseBit! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43' prior: 34814656! isLowercase ^ (EncodedCharSet charsetAt: self leadingChar) isLowercase: self. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/27/2002 15:18'! isOctetCharacter ^ value < 256. ! ! !Character methodsFor: 'testing' stamp: 'dgd 8/24/2003 14:52' prior: 19124009! isSafeForHTTP "whether a character is 'safe', or needs to be escaped when used, eg, in a URL" ^ value < 128 and: [self isAlphaNumeric or: ['.~-_' includes: self]]! ! !Character methodsFor: 'testing' stamp: 'yo 12/30/2002 15:55'! isUnicode ^ false. ! ! !Character methodsFor: 'testing' stamp: 'yo 12/30/2002 16:14'! isUnicodeCJK ^ self isUnicode and: [Unicode isCJK: self charCode]. ! ! !Character methodsFor: 'testing' stamp: 'dgd 8/24/2003 14:52' prior: 19124727! isUppercase "Answer whether the receiver is an uppercase letter. (The old implementation answered whether the receiver is not a lowercase letter.)" ^ ((ClassificationTable at: value + 1) bitAnd: UppercaseBit) = UppercaseBit! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43' prior: 34815714! isUppercase ^ (EncodedCharSet charsetAt: self leadingChar) isUppercase: self. ! ! !Character methodsFor: 'copying' stamp: 'tk 12/9/2000 11:46'! clone "Answer with the receiver, because Characters are unique."! ! !Character methodsFor: 'converting' stamp: 'dgd 8/24/2003 14:53' prior: 19126781! asLowercase "If the receiver is uppercase, answer its matching lowercase Character." ^ Character value: ((ClassificationTable at: value + 1) bitAnd: 255)! ! !Character methodsFor: 'converting' stamp: 'yo 10/4/2003 15:00' prior: 34816326! asLowercase "If the receiver is uppercase, answer its matching lowercase Character." (8r101 <= value and: [value <= 8r132]) "self isUppercase" ifTrue: [^ Character value: value + 8r40] ifFalse: [^ self]! ! !Character methodsFor: 'converting' stamp: 'raa 5/26/2001 09:54'! asSymbol "Answer a Symbol consisting of the receiver as the only element." ^Symbol internCharacter: self! ! !Character methodsFor: 'converting' stamp: 'yo 12/30/2002 11:36'! asUnicode ^ value ! ! !Character methodsFor: 'converting' stamp: 'dgd 8/24/2003 14:53' prior: 19127412! asUppercase "If the receiver is lowercase, answer its matching uppercase Character." ^ Character value: (((ClassificationTable at: value + 1) bitShift: -8) bitAnd: 255)! ! !Character methodsFor: 'converting' stamp: 'yo 10/4/2003 15:00' prior: 34817143! asUppercase "If the receiver is lowercase, answer its matching uppercase Character." (8r141 <= value and: [value <= 8r172]) "self isLowercase" ifTrue: [^ Character value: value - 8r40] ifFalse: [^ self]! ! !Character methodsFor: 'converting' stamp: 'yo 8/11/2003 21:18'! basicSqueakToIso | asciiValue | value < 128 ifTrue: [^ self]. value > 255 ifTrue: [^ self]. asciiValue _ #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 253 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 254 255 256 ) at: self asciiValue - 127. ^ Character value: asciiValue. ! ! !Character methodsFor: 'converting' stamp: 'yo 8/18/2003 19:25' prior: 19127694! isoToSqueak "Convert receiver from iso8895-1 (actually CP1252) to mac encoding. Does not do lf/cr conversion!! To make the round-trip conversion possible, each undefined code point is mapped to a unique value. For each c in Character, c squeakToIso isoToSqueak = c, and c isoToSqueak squeakToIso = c is true. Also, for each array literals in squeakToIso and isoToSqueak, self size = self asSet size is true. Finally, the table is compabie with the 'keymap' table in the Windows VM. " value < 128 ifTrue: [^ self]. value > 255 ifTrue: [^ self]. ^ Character value: (#( 173 176 226 196 227 201 160 224 246 228 178 220 206 179 182 183 "80-8F" 184 212 213 210 211 165 208 209 247 170 185 221 207 186 189 217 "90-9F" 202 193 162 163 219 180 195 164 172 169 187 199 194 197 168 248 "A0-AF" 161 177 198 215 171 181 166 225 252 218 188 200 222 223 240 192 "B0-BF" 203 231 229 204 128 129 174 130 233 131 230 232 237 234 235 236 "C0-CF" 245 132 241 238 239 205 133 249 175 244 242 243 134 250 251 167 "D0-DF" 136 135 137 139 138 140 190 141 143 142 144 145 147 146 148 149 "E0-EF" 253 150 152 151 153 155 154 214 191 157 156 158 159 254 255 216 "F0-FF" ) at: value - 127) ! ! !Character methodsFor: 'converting' stamp: 'yo 8/18/2003 17:02' prior: 19128636! squeakToIso | asciiValue | value < 128 ifTrue: [^ self]. value > 255 ifTrue: [^ self]. asciiValue _ #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 255 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 253 254 ) at: self asciiValue - 127. ^ Character value: asciiValue. ! ! !Character methodsFor: 'object fileIn' stamp: 'tk 2/16/2001 14:52'! objectForDataStream: refStrm "I am being collected for inclusion in a segment. Do not include Characters!! Let them be in outPointers." refStrm insideASegment ifFalse: ["Normal use" ^ self] ifTrue: ["recording objects to go into an ImageSegment" "remove it from references. Do not trace." refStrm references removeKey: self ifAbsent: []. ^ nil] ! ! !Character methodsFor: '*packageinfo-base' stamp: 'ab 5/31/2003 17:15'! escapeEntities #($< '<' $> '>' $& '&') pairsDo: [:k :v | self = k ifTrue: [^ v]]. ^ String with: self! ! !Character methodsFor: '*packageinfo-base' stamp: 'ab 5/31/2003 17:15' prior: 34820944! escapeEntities #($< '<' $> '>' $& '&') pairsDo: [:k :v | self = k ifTrue: [^ v]]. ^ String with: self! ! !Character class methodsFor: 'class initialization' stamp: 'dgd 8/24/2003 14:47' prior: 19129854! initialize "Create the table of unique Characters." self initializeClassificationTable! ! !Character class methodsFor: 'class initialization' stamp: 'yo 10/4/2003 16:03' prior: 34821378! initialize "Create the table of unique Characters." " self initializeClassificationTable"! ! !Character class methodsFor: 'class initialization' stamp: 'dgd 8/24/2003 15:10'! initializeClassificationTable " Initialize the classification table. The classification table is a compact encoding of upper and lower cases of characters with - bits 0-7: The lower case value of this character. - bits 8-15: The upper case value of this character. - bit 16: lowercase bit (e.g., isLowercase == true) - bit 17: uppercase bit (e.g., isUppercase == true) " | ch1 ch2 | LowercaseBit := 1 bitShift: 16. UppercaseBit := 1 bitShift: 17. "Initialize the letter bits (e.g., isLetter == true)" LetterBits := LowercaseBit bitOr: UppercaseBit. ClassificationTable := Array new: 256. "Initialize the defaults (neither lower nor upper case)" 0 to: 255 do:[:i| ClassificationTable at: i+1 put: (i bitShift: 8) + i. ]. "Initialize character pairs (upper-lower case)" #( "Basic roman" ($A $a) ($B $b) ($C $c) ($D $d) ($E $e) ($F $f) ($G $g) ($H $h) ($I $i) ($J $j) ($K $k) ($L $l) ($M $m) ($N $n) ($O $o) ($P $p) ($Q $q) ($R $r) ($S $s) ($T $t) ($U $u) ($V $v) ($W $w) ($X $x) ($Y $y) ($Z $z) "International" ($Ä $ä) ($Å $å) ($Ç $ç) ($É $é) ($Ñ $ñ) ($Ö $ö) ($Ü $ü) ($À $à) ($à $ã) ($Õ $õ) ($Œ $œ) ($Æ $æ) "International - Spanish" ($Á $á) ($Í $í) ($Ó $ó) ($Ú $ú) "International - PLEASE CHECK" ($È $è) ($Ì $ì) ($Ò $ò) ($Ù $ù) ($Ë $ë) ($Ï $ï) ($ $â) ($Ê $ê) ($Î $î) ($Ô $ô) ($Û $û) ) do:[:pair| ch1 := pair first asciiValue. ch2 := pair last asciiValue. ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch2 + UppercaseBit. ClassificationTable at: ch2+1 put: (ch1 bitShift: 8) + ch2 + LowercaseBit. ]. "Initialize a few others for which we only have lower case versions." #($ß $Ø $ø $ÿ) do:[:char| ch1 := char asciiValue. ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch1 + LowercaseBit. ]. ! ! !Character class methodsFor: 'instance creation' stamp: 'RAH 4/25/2000 19:49'! codePoint: integer "Return a character whose encoding value is integer." #Fundmntl. (0 > integer or: [255 < integer]) ifTrue: [self error: 'parameter out of range 0..255']. ^ CharacterTable at: integer + 1! ! !Character class methodsFor: 'instance creation' stamp: 'yo 8/27/2002 15:15' prior: 19130853! value: anInteger "Answer the Character whose value is anInteger." anInteger > 255 ifTrue: [^ MultiCharacter value: anInteger]. ^ CharacterTable at: anInteger + 1. ! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowDown ^ self value: 31! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowLeft ^ self value: 28! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowRight ^ self value: 29! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowUp ^ self value: 30! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! delete ^ self value: 127! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! end ^ self value: 4! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! home ^ self value: 1! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! insert ^ self value: 5! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! pageDown ^ self value: 12! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! pageUp ^ self value: 11! ! !CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'! max: aCharacterBlock aCharacterBlock ifNil:[^self]. ^aCharacterBlock > self ifTrue:[ aCharacterBlock] ifFalse:[self].! ! !CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'! min: aCharacterBlock aCharacterBlock ifNil:[^self]. ^aCharacterBlock < self ifTrue:[ aCharacterBlock] ifFalse:[self].! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'RAA 2/25/2001 14:55'! cr "Answer a CharacterBlock that specifies the current location of the mouse relative to a carriage return stop condition that has just been encountered. The ParagraphEditor convention is to denote selections by CharacterBlocks, sometimes including the carriage return (cursor is at the end) and sometimes not (cursor is in the middle of the text)." ((characterIndex ~= nil and: [characterIndex > text size]) or: [(line last = text size) and: [(destY + line lineHeight) < characterPoint y]]) ifTrue: ["When off end of string, give data for next character" destY _ destY + line lineHeight. lastCharacter _ nil. characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ destY. lastIndex _ lastIndex + 1. self lastCharacterExtentSetX: 0. ^ true]. lastCharacter _ CR. characterPoint _ destX @ destY. self lastCharacterExtentSetX: rightMargin - destX. ^true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'! crossedX "Text display has wrapping. The scanner just found a character past the x location of the cursor. We know that the cursor is pointing at a character or before one." | leadingTab currentX | characterIndex == nil ifFalse: [ "If the last character of the last line is a space, and it crosses the right margin, then locating the character block after it is impossible without this hack." characterIndex > text size ifTrue: [ lastIndex _ characterIndex. characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight). ^true]]. characterPoint x <= (destX + (lastCharacterExtent x // 2)) ifTrue: [lastCharacter _ (text at: lastIndex). characterPoint _ destX @ destY. ^true]. lastIndex >= line last ifTrue: [lastCharacter _ (text at: line last). characterPoint _ destX @ destY. ^true]. "Pointing past middle of a character, return the next character." lastIndex _ lastIndex + 1. lastCharacter _ text at: lastIndex. currentX _ destX + lastCharacterExtent x + kern. self lastCharacterExtentSetX: (font widthOf: lastCharacter). characterPoint _ currentX @ destY. lastCharacter = Space ifFalse: [^ true]. "Yukky if next character is space or tab." alignment = Justified ifTrue: [self lastCharacterExtentSetX: (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1))). ^ true]. true ifTrue: [^ true]. "NOTE: I find no value to the following code, and so have defeated it - DI" "See tabForDisplay for illumination on the following awfulness." leadingTab _ true. line first to: lastIndex - 1 do: [:index | (text at: index) ~= Tab ifTrue: [leadingTab _ false]]. (alignment ~= Justified or: [leadingTab]) ifTrue: [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX leftMargin: leftMargin rightMargin: rightMargin) - currentX] ifFalse: [self lastCharacterExtentSetX: (((currentX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount))) - currentX) max: 0)]. ^ true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'! endOfRun "Before arriving at the cursor location, the selection has encountered an end of run. Answer false if the selection continues, true otherwise. Set up indexes for building the appropriate CharacterBlock." | runLength lineStop | ((characterIndex ~~ nil and: [runStopIndex < characterIndex and: [runStopIndex < text size]]) or: [characterIndex == nil and: [lastIndex < line last]]) ifTrue: ["We're really at the end of a real run." runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). characterIndex ~~ nil ifTrue: [lineStop _ characterIndex "scanning for index"] ifFalse: [lineStop _ line last "scanning for point"]. (runStopIndex _ lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex _ lineStop]. self setStopConditions. ^false]. lastCharacter _ text at: lastIndex. characterPoint _ destX @ destY. ((lastCharacter = Space and: [alignment = Justified]) or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]]) ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent]. characterIndex ~~ nil ifTrue: ["If scanning for an index and we've stopped on that index, then we back destX off by the width of the character stopped on (it will be pointing at the right side of the character) and return" runStopIndex = characterIndex ifTrue: [self characterPointSetX: destX - lastCharacterExtent x. ^true]. "Otherwise the requested index was greater than the length of the string. Return string size + 1 as index, indicate further that off the string by setting character to nil and the extent to 0." lastIndex _ lastIndex + 1. lastCharacter _ nil. self lastCharacterExtentSetX: 0. ^true]. "Scanning for a point and either off the end of the line or off the end of the string." runStopIndex = text size ifTrue: ["off end of string" lastIndex _ lastIndex + 1. lastCharacter _ nil. self lastCharacterExtentSetX: 0. ^true]. "just off end of line without crossing x" lastIndex _ lastIndex + 1. ^true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 11/18/2002 13:16' prior: 34828970! endOfRun "Before arriving at the cursor location, the selection has encountered an end of run. Answer false if the selection continues, true otherwise. Set up indexes for building the appropriate CharacterBlock." | runLength lineStop | (((characterIndex ~~ nil and: [runStopIndex < characterIndex and: [runStopIndex < text size]]) or: [characterIndex == nil and: [lastIndex < line last]]) or: [ ((lastIndex < line last) and: [((text at: lastIndex) leadingChar ~= (text at: lastIndex+1) leadingChar) and: [lastIndex ~= characterIndex]])]) ifTrue: ["We're really at the end of a real run." runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). characterIndex ~~ nil ifTrue: [lineStop _ characterIndex "scanning for index"] ifFalse: [lineStop _ line last "scanning for point"]. (runStopIndex _ lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex _ lineStop]. self setStopConditions. ^false]. lastCharacter _ text at: lastIndex. characterPoint _ destX @ destY. ((lastCharacter = Space and: [alignment = Justified]) or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]]) ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent]. characterIndex ~~ nil ifTrue: ["If scanning for an index and we've stopped on that index, then we back destX off by the width of the character stopped on (it will be pointing at the right side of the character) and return" runStopIndex = characterIndex ifTrue: [self characterPointSetX: destX - lastCharacterExtent x. ^true]. "Otherwise the requested index was greater than the length of the string. Return string size + 1 as index, indicate further that off the string by setting character to nil and the extent to 0." lastIndex _ lastIndex + 1. lastCharacter _ nil. self lastCharacterExtentSetX: 0. ^true]. "Scanning for a point and either off the end of the line or off the end of the string." runStopIndex = text size ifTrue: ["off end of string" lastIndex _ lastIndex + 1. lastCharacter _ nil. self lastCharacterExtentSetX: 0. ^true]. "just off end of line without crossing x" lastIndex _ lastIndex + 1. ^true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. alignment = Justified ifTrue:[ "Make a local copy of stop conditions so we don't modify the default" stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #paddedSpace]! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 10/4/2002 20:44' prior: 34833429! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (textStyle alignment = Justified ifTrue: [#paddedSpace]). ! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'! tab | currentX | currentX _ (alignment == Justified and: [self leadingTab not]) ifTrue: "imbedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]. lastSpaceOrTabExtent _ lastCharacterExtent copy. self lastSpaceOrTabExtentSetX: (currentX - destX max: 0). currentX >= characterPoint x ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy. ^ self crossedX]. destX _ currentX. lastIndex _ lastIndex + 1. ^false! ! !CharacterBlockScanner methodsFor: 'private' stamp: 'ar 12/19/2001 11:24'! buildCharacterBlockIn: para | lineIndex runLength lineStop done stopCondition | "handle nullText" (para numberOfLines = 0 or: [text size = 0]) ifTrue: [^ CharacterBlock new stringIndex: 1 "like being off end of string" text: para text topLeft: (para leftMarginForDisplayForLine: 1 alignment: (alignment ifNil:[textStyle alignment])) @ para compositionRectangle top extent: 0 @ textStyle lineGrid]. "find the line" lineIndex _ para lineIndexOfTop: characterPoint y. destY _ para topAtLineIndex: lineIndex. line _ para lines at: lineIndex. rightMargin _ para rightMarginForDisplay. (lineIndex = para numberOfLines and: [(destY + line lineHeight) < characterPoint y]) ifTrue: ["if beyond lastLine, force search to last character" self characterPointSetX: rightMargin] ifFalse: [characterPoint y < (para compositionRectangle) top ifTrue: ["force search to first line" characterPoint _ (para compositionRectangle) topLeft]. characterPoint x > rightMargin ifTrue: [self characterPointSetX: rightMargin]]. destX _ (leftMargin _ para leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment])). nextLeftMargin_ para leftMarginForDisplayForLine: lineIndex+1 alignment: (alignment ifNil:[textStyle alignment]). lastIndex _ line first. self setStopConditions. "also sets font" runLength _ (text runLengthFor: line first). characterIndex == nil ifTrue: [lineStop _ line last "characterBlockAtPoint"] ifFalse: [lineStop _ characterIndex "characterBlockForIndex"]. (runStopIndex _ lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex _ lineStop]. lastCharacterExtent _ 0 @ line lineHeight. spaceCount _ 0. done _ false. self handleIndentation. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)). (self perform: stopCondition) ifTrue: [characterIndex == nil ifTrue: ["characterBlockAtPoint" ^ CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent] ifFalse: ["characterBlockForIndex" ^ CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterExtent]]]! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 18:14'! characterBlockAtPoint: aPoint index: index in: textLine "This method is the Morphic characterBlock finder. It combines MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:" | runLength lineStop done stopCondition | line _ textLine. rightMargin _ line rightMargin. lastIndex _ line first. self setStopConditions. "also sets font" characterIndex _ index. " == nil means scanning for point" characterPoint _ aPoint. (characterPoint == nil or: [characterPoint y > line bottom]) ifTrue: [characterPoint _ line bottomRight]. (text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left]) or: [characterIndex ~~ nil and: [characterIndex < line first]]]) ifTrue: [^ (CharacterBlock new stringIndex: line first text: text topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid) textLine: line]. destX _ leftMargin _ line leftMarginForAlignment: alignment. destY _ line top. runLength _ text runLengthFor: line first. characterIndex ~~ nil ifTrue: [lineStop _ characterIndex "scanning for index"] ifFalse: [lineStop _ line last "scanning for point"]. runStopIndex _ lastIndex + (runLength - 1) min: lineStop. lastCharacterExtent _ 0 @ line lineHeight. spaceCount _ 0. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (specialWidth == nil ifTrue: [font widthOf: (text at: lastIndex)] ifFalse: [specialWidth]). (self perform: stopCondition) ifTrue: [characterIndex == nil ifTrue: ["Result for characterBlockAtPoint: " ^ (CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent - (font baseKern @ 0)) textLine: line] ifFalse: ["Result for characterBlockForIndex: " ^ (CharacterBlock new stringIndex: characterIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterExtent) textLine: line]]]! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'hmm 2/2/2001 15:07'! indentationLevel: anInteger super indentationLevel: anInteger. nextLeftMargin _ leftMargin. indentationLevel timesRepeat: [ nextLeftMargin _ textStyle nextTabXFrom: nextLeftMargin leftMargin: leftMargin rightMargin: rightMargin]! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 19:27'! placeEmbeddedObject: anchoredMorph "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. specialWidth _ anchoredMorph width. ^ true! ! !CharacterBlockScanner commentStamp: '' prior: 0! My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.! !CharacterScanner methodsFor: 'private' stamp: 'ar 12/15/2001 23:31'! setAlignment: style alignment _ style. ! ! !CharacterScanner methodsFor: 'private' stamp: 'yo 10/7/2002 14:33'! setConditionArray: aSymbol aSymbol == #paddedSpace ifTrue: [^stopConditions _ PaddedSpaceCondition copy]. aSymbol == #space ifTrue: [^stopConditions _ SpaceCondition copy]. aSymbol == nil ifTrue: [^stopConditions _ NilCondition copy]. self error: 'undefined stopcondition for space character'. ! ! !CharacterScanner methodsFor: 'scanning' stamp: 'yo 9/23/2002 16:13'! basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "Primitive. This is the inner loop of text display--but see scanCharactersFrom: to:rightX: which would get the string, stopConditions and displaying from the instance. March through source String from startIndex to stopIndex. If any character is flagged with a non-nil entry in stops, then return the corresponding value. Determine width of each character from xTable, indexed by map. If dextX would exceed rightX, then return stops at: 258. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Optional. See Object documentation whatIsAPrimitive." | ascii nextDestX char | lastIndex _ startIndex. [lastIndex <= stopIndex] whileTrue: [char _ (sourceString at: lastIndex). ascii _ char asciiValue + 1. (stops at: ascii) == nil ifFalse: [^stops at: ascii]. "Note: The following is querying the font about the width since the primitive may have failed due to a non-trivial mapping of characters to glyphs or a non-existing xTable." nextDestX _ destX + (font widthOf: char). nextDestX > rightX ifTrue: [^stops at: CrossedX]. destX _ nextDestX + kernDelta. lastIndex _ lastIndex + 1]. lastIndex _ stopIndex. ^stops at: EndOfRun! ! !CharacterScanner methodsFor: 'scanning' stamp: 'RAA 5/4/2001 13:53'! columnBreak ^true! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 01:50'! embeddedObject | savedIndex | savedIndex _ lastIndex. text attributesAt: lastIndex do:[:attr| attr anchoredMorph ifNotNil:[ "Following may look strange but logic gets reversed. If the morph fits on this line we're not done (return false for true) and if the morph won't fit we're done (return true for false)" (self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^true]]]. lastIndex _ savedIndex + 1. "for multiple(!!) embedded morphs" ^false! ! !CharacterScanner methodsFor: 'scanning' stamp: 'hmm 7/15/2000 22:40'! handleIndentation self indentationLevel timesRepeat: [ self plainTab]! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/31/2001 00:52'! measureString: aString inFont: aFont from: startIndex to: stopIndex "WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer" destX _ destY _ lastIndex _ 0. xTable _ aFont xTable. map _ aFont characterToGlyphMap. self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999 stopConditions: stopConditions kern: 0. ^destX! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 19:27'! placeEmbeddedObject: anchoredMorph "Place the anchoredMorph or return false if it cannot be placed. In any event, advance destX by its width." | w | "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. destX _ destX + (w _ anchoredMorph width). (destX > rightMargin and: [(leftMargin + w) <= rightMargin]) ifTrue: ["Won't fit, but would on next line" ^ false]. lastIndex _ lastIndex + 1. self setFont. "Force recalculation of emphasis for next run" ^ true! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/15/2001 23:28'! plainTab "This is the basic method of adjusting destX for a tab." destX _ (alignment == Justified and: [self leadingTab not]) ifTrue: "embedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 02:08'! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "Primitive. This is the inner loop of text display--but see scanCharactersFrom: to:rightX: which would get the string, stopConditions and displaying from the instance. March through source String from startIndex to stopIndex. If any character is flagged with a non-nil entry in stops, then return the corresponding value. Determine width of each character from xTable, indexed by map. If dextX would exceed rightX, then return stops at: 258. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Optional. See Object documentation whatIsAPrimitive." | ascii nextDestX char | lastIndex _ startIndex. [lastIndex <= stopIndex] whileTrue: [char _ (sourceString at: lastIndex). ascii _ char asciiValue + 1. (stops at: ascii) == nil ifFalse: [^stops at: ascii]. "Note: The following is querying the font about the width since the primitive may have failed due to a non-trivial mapping of characters to glyphs or a non-existing xTable." nextDestX _ destX + (font widthOf: char). nextDestX > rightX ifTrue: [^stops at: CrossedX]. destX _ nextDestX + kernDelta. lastIndex _ lastIndex + 1]. lastIndex _ stopIndex. ^stops at: EndOfRun! ! !CharacterScanner methodsFor: 'scanning' stamp: 'yo 12/27/2002 04:32' prior: 34844898! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | startEncoding selector | (sourceString isKindOf: String) ifTrue: [^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta.]. (sourceString isKindOf: MultiString) ifTrue: [ startIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. selector _ (EncodedCharSet charsetAt: startEncoding) scanSelector. ^ self perform: selector withArguments: (Array with: startIndex with: stopIndex with: sourceString with: rightX with: stopConditions with: kernDelta). ]. ^ stops at: EndOfRun ! ! !CharacterScanner methodsFor: 'initialize' stamp: 'ls 1/14/2002 21:26'! initialize destX _ destY _ leftMargin _ 0.! ! !CharacterScanner methodsFor: 'initialize' stamp: 'ar 12/31/2001 00:52'! initializeStringMeasurer stopConditions _ Array new: 258. stopConditions at: CrossedX put: #crossedX. stopConditions at: EndOfRun put: #endOfRun. ! ! !CharacterScanner methodsFor: 'initialize' stamp: 'RAA 5/7/2001 10:11'! wantsColumnBreaks: aBoolean wantsColumnBreaks _ aBoolean! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/18/2002 12:32'! isBreakableAtIndex: index ^ (EncodedCharSet at: ((text at: index) leadingChar + 1)) isBreakableAt: index in: text. ! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/13/2003 11:57'! scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ maxAscii _ font maxAsciiFor: startEncoding. f _ font fontArray at: startEncoding + 1. "xTable _ f xTable. maxAscii _ xTable size - 2." spaceWidth _ f widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. ]. [lastIndex <= stopIndex] whileTrue: [ encoding _ (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun]. ascii _ (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ascii _ maxAscii]. (encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1]. nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)). nextDestX > rightX ifTrue: [^ stops at: CrossedX]. destX _ nextDestX + kernDelta. "destX printString displayAt: 0@(lastIndex*20)." lastIndex _ lastIndex + 1. ]. lastIndex _ stopIndex. ^ stops at: EndOfRun! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/27/2002 04:33'! scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ maxAscii _ font maxAsciiFor: startEncoding. f _ font fontArray at: startEncoding + 1. spaceWidth _ f widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. ]. [lastIndex <= stopIndex] whileTrue: [ encoding _ (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun]. ascii _ (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ascii _ maxAscii]. (encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1]. nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)). nextDestX > rightX ifTrue: [^ stops at: CrossedX]. destX _ nextDestX + kernDelta. "destX printString displayAt: 0@(lastIndex*20)." lastIndex _ lastIndex + 1. ]. lastIndex _ stopIndex. ^ stops at: EndOfRun! ! !CharacterScanner commentStamp: '' prior: 0! My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.! !CharacterScanner class methodsFor: 'class initialization' stamp: 'ar 12/17/2001 02:17'! initialize "CharacterScanner initialize" "NewCharacterScanner initialize" | stopConditions | stopConditions _ Array new: 258. stopConditions atAllPut: nil. stopConditions at: 1+1 put: #embeddedObject. stopConditions at: Space asciiValue + 1 put: nil. stopConditions at: Tab asciiValue + 1 put: #tab. stopConditions at: CR asciiValue + 1 put: #cr. stopConditions at: EndOfRun put: #endOfRun. stopConditions at: CrossedX put: #crossedX. DefaultStopConditions _ stopConditions.! ! !CharacterScanner class methodsFor: 'class initialization' stamp: 'yo 12/18/2002 14:09' prior: 34850984! initialize " CharacterScanner initialize " | a | a _ Array new: 258. a at: 1 + 1 put: #embeddedObject. a at: Tab asciiValue + 1 put: #tab. a at: CR asciiValue + 1 put: #cr. a at: EndOfRun put: #endOfRun. a at: CrossedX put: #crossedX. NilCondition _ a copy. DefaultStopConditions _ a copy. PaddedSpaceCondition _ a copy. PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace. SpaceCondition _ a copy. SpaceCondition at: Space asciiValue + 1 put: #space. ! ! !CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:58'! = anObject ^self species == anObject species and: [ self byteArrayMap = anObject byteArrayMap ]! ! !CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:57'! species ^CharacterSet! ! !CharacterTest methodsFor: 'testing - Class Methods' stamp: 'md 4/18/2003 09:59'! testNew self should: [Character new] raise: Error.! ! !CharacterTest commentStamp: '' prior: 0! This is the unit test for the class Character. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !ChatButtonMorph methodsFor: 'event handling' stamp: 'ar 6/4/2001 00:40'! mouseDown: evt oldColor _ self fillStyle. self label: labelDown. self doButtonDownAction. ! ! !ChatButtonMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 18:40' prior: 19162787! doButtonDownAction (target notNil and: [actionDownSelector notNil]) ifTrue: [Cursor normal showWhile: [target perform: actionDownSelector]]! ! !ChatButtonMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 18:40' prior: 19163009! doButtonUpAction (target notNil and: [actionUpSelector notNil]) ifTrue: [Cursor normal showWhile: [target perform: actionUpSelector]]! ! !ChatNotes methodsFor: 'initialization' stamp: 'mir 11/27/2001 12:01'! loadNotes "Load notes from the files" | dir | names _ OrderedCollection new. notes _ OrderedCollection new. (FileDirectory default directoryExists: 'audio') ifFalse: [^self]. dir _ self audioDirectory. dir fileNames do: [:fname | (fname endsWith: '.name') ifTrue: [ names add: ((dir fileNamed: fname) contentsOfEntireFile). notes add: (fname copyFrom: 1 to: (fname size - 4))]].! ! !ChatNotes methodsFor: 'file i/o' stamp: 'mir 11/27/2001 12:04'! audioDirectory (FileDirectory default directoryExists: 'audio') ifFalse: [FileDirectory default createDirectory: 'audio']. ^FileDirectory default directoryNamed: 'audio'! ! !ChronologyConstants commentStamp: 'brp 3/12/2004 14:34' prior: 0! ChronologyConstants is a SharedPool for the constants used by the Kernel-Chronology classes.! !ChronologyConstants class methodsFor: 'as yet unclassified' stamp: 'brp 9/25/2003 10:49'! initialize "ChronologyConstants initialize" SqueakEpoch _ 2415386. "Julian day number of 1 Jan 1901" SecondsInDay _ 86400. SecondsInHour _ 3600. SecondsInMinute _ 60. NanosInSecond _ 10 raisedTo: 9. NanosInMillisecond _ 10 raisedTo: 6. DayNames _ #(Sunday Monday Tuesday Wednesday Thursday Friday Saturday). MonthNames _ #(January February March April May June July August September October November December). DaysInMonth _ #(31 28 31 30 31 30 31 31 30 31 30 31). ! ! !Class methodsFor: 'initialize-release' stamp: 'hg 10/30/2001 13:38'! deactivate "A remnant from the 3.3a modules work, retained . Does nothing, but may be overridden in Metaclasses."! ! !Class methodsFor: 'initialize-release' stamp: 'ar 5/17/2003 14:14' prior: 19209575! declare: varString "Declare class variables common to all instances. Answer whether recompilation is advisable." | newVars conflicts | newVars _ (Scanner new scanFieldNames: varString) collect: [:x | x asSymbol]. newVars do: [:var | var first isLowercase ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']]. conflicts _ false. classPool == nil ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: [:var | self removeClassVarName: var]]. (newVars reject: [:var | self classPool includesKey: var]) do: [:var | "adding" "check if new vars defined elsewhere" (self bindingOf: var) notNil ifTrue: [self error: var , ' is defined elsewhere'. conflicts _ true]]. newVars size > 0 ifTrue: [classPool _ self classPool. "in case it was nil" newVars do: [:var | classPool declare: var from: Undeclared]]. ^conflicts! ! !Class methodsFor: 'initialize-release' stamp: 'yo 7/15/2003 20:58' prior: 34855257! declare: varString "Declare class variables common to all instances. Answer whether recompilation is advisable." | newVars conflicts | newVars _ (Scanner new scanFieldNames: varString) collect: [:x | x asSymbol]. newVars do: [:var | var first canBeGlobalVarInitial ifFalse: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']]. conflicts _ false. classPool == nil ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: [:var | self removeClassVarName: var]]. (newVars reject: [:var | self classPool includesKey: var]) do: [:var | "adding" "check if new vars defined elsewhere" (self bindingOf: var) notNil ifTrue: [self error: var , ' is defined elsewhere'. conflicts _ true]]. newVars size > 0 ifTrue: [classPool _ self classPool. "in case it was nil" newVars do: [:var | classPool declare: var from: Undeclared]]. ^conflicts! ! !Class methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 22:28'! removeFromSystem "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." self removeFromSystem: true.! ! !Class methodsFor: 'initialize-release' stamp: 'sw 11/2/2002 22:46'! removeFromSystem: logged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." "tell class to deactivate and unload itself-- two separate events in the module system" self deactivate; unload. self superclass ifNotNil: ["If we have no superclass there's nothing to be remembered" self superclass addObsoleteSubclass: self]. Smalltalk removeClassFromSystem: self logged: logged. self obsolete! ! !Class methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:24' prior: 34857556! removeFromSystem: logged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." "tell class to deactivate and unload itself-- two separate events in the module system" self deactivate; unload. self superclass ifNotNil: ["If we have no superclass there's nothing to be remembered" self superclass addObsoleteSubclass: self]. self environment removeClassFromSystem: self logged: logged. self obsolete! ! !Class methodsFor: 'initialize-release' stamp: 'dtl 9/16/2003 22:08' prior: 34858130! removeFromSystem: logged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." "tell class to deactivate and unload itself-- two separate events in the module system" self deactivate; unload. self superclass ifNotNil: ["If we have no superclass there's nothing to be remembered" self superclass addObsoleteSubclass: self]. self environment forgetClass: self logged: logged. self obsolete! ! !Class methodsFor: 'initialize-release' stamp: 'NS 1/16/2004 15:16' prior: 34858712! removeFromSystem: logged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." "keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want." "tell class to deactivate and unload itself-- two separate events in the module system" self deactivate; unload. self superclass ifNotNil: ["If we have no superclass there's nothing to be remembered" self superclass addObsoleteSubclass: self]. self environment forgetClass: self logged: logged. self obsolete.! ! !Class methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 22:29'! removeFromSystemUnlogged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver. Do not log the removal either to the current change set nor to the system changes log" ^self removeFromSystem: false! ! !Class methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 16:09' prior: 19211742! sharing: poolString "Set up sharedPools. Answer whether recompilation is advisable." | oldPools found | oldPools _ self sharedPools. sharedPools _ OrderedCollection new. (Scanner new scanFieldNames: poolString) do: [:poolName | sharedPools add: (self environment at: poolName asSymbol ifAbsent:[ (self confirm: 'The pool dictionary ', poolName,' does not exist.', '\Do you want it automatically created?' withCRs) ifTrue:[self environment at: poolName asSymbol put: Dictionary new] ifFalse:[^self error: poolName,' does not exist']])]. sharedPools isEmpty ifTrue: [sharedPools _ nil]. oldPools do: [:pool | found _ false. self sharedPools do: [:p | p == pool ifTrue: [found _ true]]. found ifFalse: [^ true "A pool got deleted"]]. ^ false! ! !Class methodsFor: 'initialize-release' stamp: 'NS 4/6/2004 15:32' prior: 19212580! superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet "Answer an instance of me, a new class, using the arguments of the message as the needed information. Must only be sent to a new instance; else we would need Object flushCache." superclass _ sup. methodDict _ md. format _ ft. name _ nm. instanceVariables _ nilOrArray. classPool _ pool. sharedPools _ poolSet. self organization: org.! ! !Class methodsFor: 'initialize-release' stamp: 'hg 12/12/2001 12:00'! unload "Sent when a the class is removed. Does nothing, but may be overridden by (class-side) subclasses." ! ! !Class methodsFor: 'accessing' stamp: 'BG 8/11/2002 20:53'! classPoolFrom: aClass "share the classPool with aClass." classPool := aClass classPool! ! !Class methodsFor: 'class name' stamp: 'sw 12/1/2000 20:39'! externalName "Answer a name by which the receiver can be known." ^ name! ! !Class methodsFor: 'class name' stamp: 'sw 12/18/2000 15:50'! nameForViewer "Answer the name to be shown in the header of a viewer looking at the receiver" ^ self name ifNil: ['Unnamed class']! ! !Class methodsFor: 'class name' stamp: 'sw 5/23/2001 13:32'! rename: aString "The new name of the receiver is the argument, aString." | newName | (newName _ aString asSymbol) ~= self name ifTrue: [(Smalltalk includesKey: newName) ifTrue: [^self error: newName , ' already exists']. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.']. Smalltalk renameClass: self as: newName. name _ newName]! ! !Class methodsFor: 'class name' stamp: 'sd 3/28/2003 15:25' prior: 34862453! rename: aString "The new name of the receiver is the argument, aString." | newName | (newName _ aString asSymbol) ~= self name ifTrue: [(self environment includesKey: newName) ifTrue: [^self error: newName , ' already exists']. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.']. self environment renameClass: self as: newName. name _ newName]! ! !Class methodsFor: 'class name' stamp: 'rw 8/23/2003 15:45' prior: 34862998! rename: aString "The new name of the receiver is the argument, aString." | newName | (newName _ aString asSymbol) ~= self name ifFalse: [^ self]. (self environment includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.']. self environment renameClass: self as: newName! ! !Class methodsFor: 'class name' stamp: 'NS 1/15/2004 15:41' prior: 34863557! rename: aString "The new name of the receiver is the argument, aString." | newName | (newName _ aString asSymbol) ~= self name ifFalse: [^ self]. (self environment includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.']. self environment renameClass: self as: newName. name _ newName! ! !Class methodsFor: 'instance variables' stamp: 'sw 12/26/2003 19:30' prior: 19215776! addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." ^(ClassBuilder new) name: self name inEnvironment: self environment subclassOf: superclass type: self typeOfClass instanceVariableNames: self instanceVariablesString, ' ', aString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category ! ! !Class methodsFor: 'class variables' stamp: 'sd 3/28/2003 15:24' prior: 19216988! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol | aString first isLowercase ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol _ aString asSymbol. self withAllSubclasses do: [:subclass | subclass scopeHas: symbol ifTrue: [:temp | ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. classPool == nil ifTrue: [classPool _ Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" self environment changes changeClass: self from: self. classPool declare: symbol from: Undeclared]! ! !Class methodsFor: 'class variables' stamp: 'sd 5/23/2003 14:29' prior: 34865159! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol | aString first isLowercase ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol _ aString asSymbol. self withAllSubclasses do: [:subclass | subclass scopeHas: symbol ifTrue: [:temp | ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. classPool == nil ifTrue: [classPool _ Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" ChangeSet current changeClass: self from: self. classPool declare: symbol from: Undeclared]! ! !Class methodsFor: 'class variables' stamp: 'ar 5/17/2003 14:12' prior: 34866078! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol | aString first isLowercase ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol _ aString asSymbol. self withAllSubclasses do: [:subclass | (subclass bindingOf: symbol) ifNotNil:[ ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. classPool == nil ifTrue: [classPool _ Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" ChangeSet current changeClass: self from: self. classPool declare: symbol from: Undeclared]! ! !Class methodsFor: 'class variables' stamp: 'NS 1/27/2004 14:19' prior: 34866990! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol oldState | oldState _ self copy. aString first isLowercase ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol _ aString asSymbol. self withAllSubclasses do: [:subclass | (subclass bindingOf: symbol) ifNotNil:[ ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. classPool == nil ifTrue: [classPool _ Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" classPool declare: symbol from: Undeclared. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]! ! !Class methodsFor: 'class variables' stamp: 'yo 7/15/2003 20:55' prior: 34867889! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol | aString first canBeGlobalVarInitial ifFalse: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol _ aString asSymbol. self withAllSubclasses do: [:subclass | (subclass bindingOf: symbol) ifNotNil:[ ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. classPool == nil ifTrue: [classPool _ Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" Smalltalk changes changeClass: self from: self. classPool declare: symbol from: Undeclared]! ! !Class methodsFor: 'pool variables' stamp: 'tpr 5/30/2003 13:04' prior: 19219729! addSharedPool: aSharedPool "Add the argument, aSharedPool, as one of the receiver's shared pools. Create an error if the shared pool is already one of the pools. This method will work with shared pools that are plain Dictionaries or thenewer SharedPool subclasses" (self sharedPools includes: aSharedPool) ifTrue: [^self error: 'This is already in my shared pool list']. sharedPools == nil ifTrue: [sharedPools _ OrderedCollection with: aSharedPool] ifFalse: [sharedPools add: aSharedPool]! ! !Class methodsFor: 'pool variables' prior: 19220173! allSharedPools "Answer a Set of the pools the receiver shares, including those defined in the superclasses of the receiver." | aSet | ^ superclass == nil ifTrue: [self sharedPools copy] ifFalse: [aSet _ superclass allSharedPools. aSet addAll: self sharedPools. aSet]! ! !Class methodsFor: 'compiling' stamp: 'ar 5/17/2003 14:06'! bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" | aSymbol binding | aSymbol := varName asSymbol. "First look in classVar dictionary." binding := self classPool bindingOf: aSymbol. binding ifNotNil:[^binding]. "Next look in shared pools." self sharedPools do:[:pool | binding := pool bindingOf: aSymbol. binding ifNotNil:[^binding]. ]. "Next look in declared environment." binding := self environment bindingOf: aSymbol. binding ifNotNil:[^binding]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ nil] ifFalse: [^ superclass bindingOf: aSymbol]. ! ! !Class methodsFor: 'compiling' stamp: 'ar 5/17/2003 14:13' prior: 19222394! canFindWithoutEnvironment: varName "This method is used for analysis of system structure -- see senders." "Look up varName, in the context of the receiver. Return true if it can be found without using the declared environment." "First look in classVar dictionary." (self classPool bindingOf: varName) ifNotNil:[^true]. "Next look in shared pools." self sharedPools do:[:pool | (pool bindingOf: varName) ifNotNil:[^true]. ]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ false] ifFalse: [^ (superclass bindingOf: varName) notNil]. ! ! !Class methodsFor: 'compiling' stamp: 'sd 3/28/2003 15:24' prior: 19223643! possibleVariablesFor: misspelled continuedFrom: oldResults | results | results _ misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults. self sharedPools do: [:pool | results _ misspelled correctAgainstDictionary: pool continuedFrom: results ]. superclass == nil ifTrue: [ ^ misspelled correctAgainstDictionary: self environment continuedFrom: results ] ifFalse: [ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! ! !Class methodsFor: 'subclass creation' stamp: 'sd 3/28/2003 15:24' prior: 19225285! newSubclass | i className | i _ 1. [className _ (self name , i printString) asSymbol. self environment includesKey: className] whileTrue: [i _ i + 1]. ^ self subclass: className instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: Object categoryForUniclasses "Point newSubclass new"! ! !Class methodsFor: 'fileIn/Out' stamp: 'tk 3/7/2001 13:57'! fileOutAsHtml: useHtml "File a description of the receiver onto a new file whose base name is the name of the receiver." | fileStream | fileStream _ useHtml ifTrue: [(FileStream newFileNamed: self name, FileDirectory dot, 'html') asHtml] ifFalse: [FileStream newFileNamed: self name, FileDirectory dot, 'st']. fileStream header; timeStamp. self sharedPools size > 0 ifTrue: [ self shouldFileOutPools ifTrue: [self fileOutSharedPoolsOn: fileStream]]. self fileOutOn: fileStream moveSource: false toFile: 0. fileStream trailer; close. "DeepCopier new checkVariables." ! ! !Class methodsFor: 'fileIn/Out' stamp: 'yo 8/30/2002 14:00' prior: 34873064! fileOutAsHtml: useHtml "File a description of the receiver onto a new file whose base name is the name of the receiver." | fileStream | fileStream _ useHtml ifTrue: [(FileStream newFileNamed: self name, FileDirectory dot, 'html') asHtml] ifFalse: [FileStream newFileNamed: (self name, FileDirectory dot, 'st') asFileName]. fileStream header; timeStamp. self sharedPools size > 0 ifTrue: [ self shouldFileOutPools ifTrue: [self fileOutSharedPoolsOn: fileStream]]. self fileOutOn: fileStream moveSource: false toFile: 0. fileStream trailer; close. "DeepCopier new checkVariables." ! ! !Class methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:24' prior: 19230421! fileOutPool: aPool onFileStream: aFileStream | aPoolName aValue | aPoolName _ self environment keyAtIdentityValue: aPool. Transcript cr; show: aPoolName. aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. aPool keys asSortedCollection do: [ :aKey | aValue _ aPool at: aKey. aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put: '. (aValue isKindOf: Number) ifTrue: [aValue printOn: aFileStream] ifFalse: [aFileStream nextPutAll: '('. aValue printOn: aFileStream. aFileStream nextPutAll: ')']. aFileStream nextPutAll: '!!'; cr]. aFileStream cr! ! !Class methodsFor: 'fileIn/Out' stamp: 'tpr 5/30/2003 13:01' prior: 34874411! fileOutPool: aPool onFileStream: aFileStream | aPoolName aValue | (aPool isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now']. aPoolName _ self environment keyAtIdentityValue: aPool. Transcript cr; show: aPoolName. aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. aPool keys asSortedCollection do: [ :aKey | aValue _ aPool at: aKey. aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put: '. (aValue isKindOf: Number) ifTrue: [aValue printOn: aFileStream] ifFalse: [aFileStream nextPutAll: '('. aValue printOn: aFileStream. aFileStream nextPutAll: ')']. aFileStream nextPutAll: '!!'; cr]. aFileStream cr! ! !Class methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:24' prior: 19231190! fileOutSharedPoolsOn: aFileStream "file out the shared pools of this class after prompting the user about each pool" | poolsToFileOut | poolsToFileOut _ self sharedPools select: [:aPool | (self shouldFileOutPool: (self environment keyAtIdentityValue: aPool))]. poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream]. ! ! !Class methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:24' prior: 19232499! removeFromChanges "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet. 7/18/96 sw: call removeClassAndMetaClassChanges:" self environment changes removeClassAndMetaClassChanges: self! ! !Class methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:33' prior: 34876546! removeFromChanges "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet. 7/18/96 sw: call removeClassAndMetaClassChanges:" ChangeSet current removeClassAndMetaClassChanges: self! ! !Class methodsFor: 'private' stamp: 'sd 2/1/2004 15:18'! spaceUsed "Object spaceUsed" ^ super spaceUsed + self class spaceUsed! ! !Class methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57'! sunitName ^self name! ! !Class methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57' prior: 34877311! sunitName ^self name! ! !Class class methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:25' prior: 19236523! fileOutPool: aString "file out the global pool named aString" | f | f _ FileStream newFileNamed: aString, '.st'. self new fileOutPool: (self environment at: aString asSymbol) onFileStream: f. f close. ! ! !ClassBuilder methodsFor: 'initialize' stamp: 'ar 3/3/2001 00:29'! doneCompiling: aClass "The receiver has finished modifying the class hierarchy. Do any necessary cleanup." aClass doneCompiling. Behavior flushObsoleteSubclasses.! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 02:57'! class: oldClass instanceVariableNames: instVarString unsafe: unsafe "This is the basic initialization message to change the definition of an existing Metaclass" | instVars newClass needNew | environ _ oldClass environment. instVars _ Scanner new scanFieldNames: instVarString. unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. "See if we need a new subclass or not" needNew _ self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. needNew ifNil:[^nil]. "some error" needNew ifFalse:[^oldClass]. "no new class needed" "Create the new class" newClass _ self newSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. newClass _ self recompile: false from: oldClass to: newClass mutate: false. self doneCompiling: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:20' prior: 34878071! class: oldClass instanceVariableNames: instVarString unsafe: unsafe "This is the basic initialization message to change the definition of an existing Metaclass" | instVars newClass needNew copyOfOldClass | environ _ oldClass environment. instVars _ Scanner new scanFieldNames: instVarString. unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. "See if we need a new subclass or not" needNew _ self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. needNew ifNil:[^nil]. "some error" needNew ifFalse:[^oldClass]. "no new class needed" "Create the new class" copyOfOldClass _ oldClass copy. newClass _ self newSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. newClass _ self recompile: false from: oldClass to: newClass mutate: false. self doneCompiling: newClass. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 03:00'! name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe "Define a new class in the given environment. If unsafe is true do not run any validation checks. This facility is provided to implement important system changes." | oldClass newClass organization instVars classVars force needNew | environ _ env. instVars _ Scanner new scanFieldNames: instVarString. classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. "Validate the proposed name" unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. oldClass _ env at: className ifAbsent:[nil]. oldClass isBehavior ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. "See if we need a new subclass" needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. needNew == nil ifTrue:[^nil]. "some error" (needNew and:[unsafe not]) ifTrue:[ "Make sure we don't redefine any dangerous classes" (self tooDangerousClasses includes: oldClass name) ifTrue:[ self error: oldClass name, ' cannot be changed'. ]. "Check if the receiver should not be redefined" (oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[ self notify: oldClass name asText allBold, ' should not be redefined!! \Proceed to store over it.' withCRs]]. needNew ifTrue:[ "Create the new class" newClass _ self newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. newClass == nil ifTrue:[^nil]. "Some error" newClass setName: className. ] ifFalse:[ "Reuse the old class" newClass _ oldClass. ]. "Install the class variables and pool dictionaries... " force _ (newClass declare: classVarString) | (newClass sharing: poolString). "... classify ..." organization _ environ ifNotNil:[environ organization]. organization classify: newClass name under: category asSymbol. newClass environment: environ. "... recompile ..." newClass _ self recompile: force from: oldClass to: newClass mutate: false. "... export if not yet done ..." (environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[ [environ at: newClass name put: newClass] on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. Smalltalk flushClassNameCache. ]. self doneCompiling: newClass. ^newClass ! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/20/2004 19:46' prior: 34880678! name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe "Define a new class in the given environment. If unsafe is true do not run any validation checks. This facility is provided to implement important system changes." | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory | environ _ env. instVars _ Scanner new scanFieldNames: instVarString. classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. "Validate the proposed name" unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. oldClass _ env at: className ifAbsent:[nil]. oldClass isBehavior ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" copyOfOldClass _ oldClass copy. unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. "See if we need a new subclass" needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. needNew == nil ifTrue:[^nil]. "some error" (needNew and:[unsafe not]) ifTrue:[ "Make sure we don't redefine any dangerous classes" (self tooDangerousClasses includes: oldClass name) ifTrue:[ self error: oldClass name, ' cannot be changed'. ]. "Check if the receiver should not be redefined" (oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[ self notify: oldClass name asText allBold, ' should not be redefined!! \Proceed to store over it.' withCRs]]. needNew ifTrue:[ "Create the new class" newClass _ self newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. newClass == nil ifTrue:[^nil]. "Some error" newClass setName: className. ] ifFalse:[ "Reuse the old class" newClass _ oldClass. ]. "Install the class variables and pool dictionaries... " force _ (newClass declare: classVarString) | (newClass sharing: poolString). "... classify ..." newCategory _ category asSymbol. organization _ environ ifNotNil:[environ organization]. oldClass isNil ifFalse: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. organization classify: newClass name under: newCategory. newClass environment: environ. "... recompile ..." newClass _ self recompile: force from: oldClass to: newClass mutate: false. "... export if not yet done ..." (environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[ [environ at: newClass name put: newClass] on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. Smalltalk flushClassNameCache. ]. self doneCompiling: newClass. "... notify interested clients ..." oldClass isNil ifTrue: [ SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. ^ newClass]. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. newCategory ~= oldCategory ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category]. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 02:57'! needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Answer whether we need a new subclass to conform to the requested changes" | newFormat | "Compute the format of the new class" newFormat _ self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. "Check if we really need a new subclass" oldClass ifNil:[^true]. "yes, it's a new class" newSuper == oldClass superclass ifFalse:[^true]. "yes, it's a superclass change" newFormat = oldClass format ifFalse:[^true]. "yes, it's a format change" instVars = oldClass instVarNames ifFalse:[^true]. "yes, it's an iVar change" ^false ! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 03:16'! newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Create a new subclass of the given superclass with the given specification." | newFormat newClass | "Compute the format of the new class" newFormat _ self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. (oldClass == nil or:[oldClass isMeta not]) ifTrue:[newClass _ self newSubclassOf: newSuper from: oldClass] ifFalse:[newClass _ oldClass clone]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: newFormat; setInstVarNames: instVars. oldClass ifNotNil:[ newClass organization: oldClass organization. "Recompile the new class" oldClass hasMethods ifTrue:[newClass compileAllFrom: oldClass]. self recordClass: oldClass replacedBy: newClass. ]. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 2/27/2003 22:56' prior: 34888086! newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Create a new subclass of the given superclass with the given specification." | newFormat newClass | "Compute the format of the new class" newFormat _ self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. (oldClass == nil or:[oldClass isMeta not]) ifTrue:[newClass _ self privateNewSubclassOf: newSuper from: oldClass] ifFalse:[newClass _ oldClass clone]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: newFormat; setInstVarNames: instVars. oldClass ifNotNil:[ newClass organization: oldClass organization. "Recompile the new class" oldClass hasMethods ifTrue:[newClass compileAllFrom: oldClass]. self recordClass: oldClass replacedBy: newClass. ]. (oldClass == nil or:[oldClass isObsolete not]) ifTrue:[newSuper addSubclass: newClass] ifFalse:[newSuper addObsoleteSubclass: newClass]. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 03:12'! recompile: force from: oldClass to: newClass mutate: forceMutation "Do the necessary recompilation after changine oldClass to newClass. If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass and all its subclasses. If forceMutation is true force a mutation even if oldClass and newClass are the same." oldClass == nil ifTrue:[ "newClass has an empty method dictionary so we don't need to recompile" Smalltalk changes addClass: newClass. newClass superclass addSubclass: newClass. ^newClass]. (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ "No recompilation necessary but we might have added class vars or class pools so record the change" Smalltalk changes changeClass: newClass from: oldClass. ^newClass]. currentClassIndex _ 0. maxClassIndex _ oldClass withAllSubclasses size. (oldClass == newClass and:[forceMutation not]) ifTrue:[ Smalltalk changes changeClass: newClass from: oldClass. "Recompile from newClass without mutating" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. newClass withAllSubclassesDo:[:cl| self showProgressFor: cl. cl compileAll]]. ^newClass]. "Recompile and mutate oldClass to newClass" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. Smalltalk changes changeClass: newClass from: oldClass. self mutate: oldClass to: newClass. ]. ^oldClass "now mutated to newClass"! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 2/27/2003 22:24' prior: 34890265! recompile: force from: oldClass to: newClass mutate: forceMutation "Do the necessary recompilation after changine oldClass to newClass. If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass and all its subclasses. If forceMutation is true force a mutation even if oldClass and newClass are the same." oldClass == nil ifTrue:[ "newClass has an empty method dictionary so we don't need to recompile" Smalltalk changes addClass: newClass. ^newClass]. (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ "No recompilation necessary but we might have added class vars or class pools so record the change" Smalltalk changes changeClass: newClass from: oldClass. ^newClass]. currentClassIndex _ 0. maxClassIndex _ oldClass withAllSubclasses size. (oldClass == newClass and:[forceMutation not]) ifTrue:[ Smalltalk changes changeClass: newClass from: oldClass. "Recompile from newClass without mutating" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. newClass withAllSubclassesDo:[:cl| self showProgressFor: cl. cl compileAll]]. ^newClass]. "Recompile and mutate oldClass to newClass" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. Smalltalk changes changeClass: newClass from: oldClass. self mutate: oldClass to: newClass. ]. ^oldClass "now mutated to newClass"! ! !ClassBuilder methodsFor: 'class definition' stamp: 'sd 5/23/2003 14:51' prior: 34891815! recompile: force from: oldClass to: newClass mutate: forceMutation "Do the necessary recompilation after changine oldClass to newClass. If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass and all its subclasses. If forceMutation is true force a mutation even if oldClass and newClass are the same." oldClass == nil ifTrue:[ "newClass has an empty method dictionary so we don't need to recompile" ChangeSet current addClass: newClass. ^newClass]. (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ "No recompilation necessary but we might have added class vars or class pools so record the change" ChangeSet current changeClass: newClass from: oldClass. ^newClass]. currentClassIndex _ 0. maxClassIndex _ oldClass withAllSubclasses size. (oldClass == newClass and:[forceMutation not]) ifTrue:[ ChangeSet current changeClass: newClass from: oldClass. "Recompile from newClass without mutating" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. newClass withAllSubclassesDo:[:cl| self showProgressFor: cl. cl compileAll]]. ^newClass]. "Recompile and mutate oldClass to newClass" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. ChangeSet current changeClass: newClass from: oldClass. self mutate: oldClass to: newClass. ]. ^oldClass "now mutated to newClass"! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:53' prior: 34893320! recompile: force from: oldClass to: newClass mutate: forceMutation "Do the necessary recompilation after changine oldClass to newClass. If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass and all its subclasses. If forceMutation is true force a mutation even if oldClass and newClass are the same." oldClass == nil ifTrue:[^ newClass]. (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ ^newClass]. currentClassIndex _ 0. maxClassIndex _ oldClass withAllSubclasses size. (oldClass == newClass and:[forceMutation not]) ifTrue:[ "Recompile from newClass without mutating" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. newClass withAllSubclassesDo:[:cl| self showProgressFor: cl. cl compileAll]]. ^newClass]. "Recompile and mutate oldClass to newClass" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. self mutate: oldClass to: newClass. ]. ^oldClass "now mutated to newClass"! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 5/16/2003 00:48' prior: 19248726! silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName "Move the instvar from srcClass to dstClass. Do not perform any checks." | srcVars dstVars dstIndex newClass | srcVars _ srcClass instVarNames copyWithout: instVarName. srcClass == dstClass ifTrue:[dstVars _ srcVars] ifFalse:[dstVars _ dstClass instVarNames]. dstIndex _ dstVars indexOf: prevInstVarName. dstVars _ (dstVars copyFrom: 1 to: dstIndex), (Array with: instVarName), (dstVars copyFrom: dstIndex+1 to: dstVars size). instVarMap at: srcClass name put: srcVars. instVarMap at: dstClass name put: dstVars. (srcClass inheritsFrom: dstClass) ifTrue:[ newClass _ self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. ] ifFalse:[ (dstClass inheritsFrom: srcClass) ifTrue:[ newClass _ self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ] ifFalse:[ "Disjunct hierarchies" srcClass == dstClass ifFalse:[ newClass _ self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. ]. newClass _ self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ]. ]. self doneCompiling: srcClass. self doneCompiling: dstClass.! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:21' prior: 34895934! silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName "Move the instvar from srcClass to dstClass. Do not perform any checks." | srcVars dstVars dstIndex newClass copyOfSrcClass copyOfDstClass | copyOfSrcClass _ srcClass copy. copyOfDstClass _ dstClass copy. srcVars _ srcClass instVarNames copyWithout: instVarName. srcClass == dstClass ifTrue:[dstVars _ srcVars] ifFalse:[dstVars _ dstClass instVarNames]. dstIndex _ dstVars indexOf: prevInstVarName. dstVars _ (dstVars copyFrom: 1 to: dstIndex), (Array with: instVarName), (dstVars copyFrom: dstIndex+1 to: dstVars size). instVarMap at: srcClass name put: srcVars. instVarMap at: dstClass name put: dstVars. (srcClass inheritsFrom: dstClass) ifTrue:[ newClass _ self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. ] ifFalse:[ (dstClass inheritsFrom: srcClass) ifTrue:[ newClass _ self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ] ifFalse:[ "Disjunct hierarchies" srcClass == dstClass ifFalse:[ newClass _ self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. ]. newClass _ self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ]. ]. self doneCompiling: srcClass. self doneCompiling: dstClass. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfSrcClass to: srcClass. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfDstClass to: dstClass.! ! !ClassBuilder methodsFor: 'validation' stamp: 'yo 11/11/2002 10:22' prior: 19253789! validateClassName: aString "Validate the new class name" aString first canBeGlobalVarInitial ifFalse:[ self error: 'Class names must be capitalized'. ^false]. environ at: aString ifPresent:[:old| (old isKindOf: Behavior) ifFalse:[ self notify: aString asText allBold, ' already exists!!\Proceed will store over it.' withCRs]]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ajh 10/17/2002 11:10' prior: 19255642! validateInstvars: instVarArray from: oldClass forSuper: newSuper "Check if any of the instVars of oldClass conflict with the new superclass" | instVars usedNames temp | instVarArray isEmpty ifTrue:[^true]. "Okay" newSuper allowsSubInstVars ifFalse: [ self error: newSuper printString, ' does not allow subclass inst vars. See allowsSubInstVars.'. ^ false]. "Validate the inst var names" usedNames _ instVarArray asSet. usedNames size = instVarArray size ifFalse:[ instVarArray do:[:var| usedNames remove: var ifAbsent:[temp _ var]]. self error: temp,' is multiply defined'. ^false]. (usedNames includesAnyOf: self reservedNames) ifTrue:[ self reservedNames do:[:var| (usedNames includes: var) ifTrue:[temp _ var]]. self error: temp,' is a reserved name'. ^false]. newSuper == nil ifFalse:[ usedNames _ newSuper allInstVarNames asSet. instVarArray do:[:iv| (usedNames includes: iv) ifTrue:[ newSuper withAllSuperclassesDo:[:cl| (cl instVarNames includes: iv) ifTrue:[temp _ cl]]. self error: iv,' is already defined in ', temp name. ^false]]]. oldClass == nil ifFalse:[ usedNames _ Set new: 20. oldClass allSubclassesDo:[:cl| usedNames addAll: cl instVarNames]. instVars _ instVarArray. newSuper == nil ifFalse:[instVars _ instVars, newSuper allInstVarNames]. instVars do:[:iv| (usedNames includes: iv) ifTrue:[ self error: iv, ' is already defined in a subclass of ', oldClass name. ^false]]]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'bkv 4/2/2003 17:13'! validateSubclass: subclass canKeepLayoutFrom: oldClass forSubclassFormat: newType "Returns whether the immediate subclasses of oldClass can keep its layout" "Note: Squeak does not appear to model classFormat relationships.. so I'm putting some logic here. bkv 4/2/2003" "isWeak implies isVariant" (oldClass isVariable and: [ subclass isWeak ]) ifFalse: [ "In general we discourage format mis-matches" (subclass typeOfClass == newType) ifFalse: [ self error: subclass name,' cannot be recompiled'. ^ false ]]. ^ true! ! !ClassBuilder methodsFor: 'validation' stamp: 'bkv 4/2/2003 17:19' prior: 19257052! validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize "Validate the # of instVars and the format of the subclasses" | deltaSize | oldClass == nil ifTrue: [^ true]. "No subclasses" "Compute the # of instvars needed for all subclasses" deltaSize _ newInstSize. (oldClass notNil) ifTrue: [deltaSize _ deltaSize - oldClass instVarNames size]. (newSuper notNil) ifTrue: [deltaSize _ deltaSize + newSuper instSize]. (oldClass notNil and: [oldClass superclass notNil]) ifTrue: [deltaSize _ deltaSize - oldClass superclass instSize]. (oldClass == nil) ifTrue: [ (deltaSize > 254) ifTrue: [ self error: 'More than 254 instance variables'. ^ false]. ^ true]. oldClass withAllSubclassesDo: [:sub | ( sub instSize + deltaSize > 254 ) ifTrue: [ self error: sub name,' has more than 254 instance variables'. ^ false]. "If we get this far, check whether the immediate subclasses of oldClass can keep its layout." (newType ~~ #normal) ifTrue: [ self validateSubclass: sub canKeepLayoutFrom: oldClass forSubclassFormat: newType ]]. ^ true! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'! privateNewSubclassOf: newSuper "Create a new meta and non-meta subclass of newSuper" "WARNING: This method does not preserve the superclass/subclass invariant!!" | newSuperMeta newMeta | newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class]. newMeta _ Metaclass new. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: newSuperMeta format. ^newMeta new ! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'! privateNewSubclassOf: newSuper from: oldClass "Create a new meta and non-meta subclass of newSuper using oldClass as template" "WARNING: This method does not preserve the superclass/subclass invariant!!" | newSuperMeta oldMeta newMeta | oldClass ifNil:[^self privateNewSubclassOf: newSuper]. newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class]. oldMeta _ oldClass class. newMeta _ oldMeta clone. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: (self computeFormat: oldMeta typeOfClass instSize: oldMeta instVarNames size forSuper: newSuperMeta ccIndex: 0); setInstVarNames: oldMeta instVarNames; organization: oldMeta organization. "Recompile the meta class" oldMeta hasMethods ifTrue:[newMeta compileAllFrom: oldMeta]. "Record the meta class change" self recordClass: oldMeta replacedBy: newMeta. "And create a new instance" ^newMeta adoptInstance: oldClass from: oldMeta! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 3/2/2001 01:05'! recordClass: oldClass replacedBy: newClass "Keep the changes up to date when we're moving instVars around" (instVarMap includesKey: oldClass name) ifTrue:[ Smalltalk changes changeClass: newClass from: oldClass. ].! ! !ClassBuilder methodsFor: 'private' stamp: 'sd 5/23/2003 14:33' prior: 34904645! recordClass: oldClass replacedBy: newClass "Keep the changes up to date when we're moving instVars around" (instVarMap includesKey: oldClass name) ifTrue:[ ChangeSet current changeClass: newClass from: oldClass. ].! ! !ClassBuilder methodsFor: 'private' stamp: 'NS 1/27/2004 14:21' prior: 34904950! recordClass: oldClass replacedBy: newClass "Keep the changes up to date when we're moving instVars around" (instVarMap includesKey: oldClass name) ifTrue:[ SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldClass to: newClass. ].! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 3/5/2001 12:00'! showProgressFor: aClass "Announce that we're processing aClass" progress == nil ifTrue:[^self]. aClass isObsolete ifTrue:[^self]. currentClassIndex _ currentClassIndex + 1. (aClass hasMethods and: [aClass wantsRecompilationProgressReported]) ifTrue: [progress value: ('Recompiling ', aClass name,' (', currentClassIndex printString,'/', maxClassIndex printString,')')]! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 9/22/2002 03:11'! mutate: oldClass to: newClass "Mutate the old class and subclasses into newClass and subclasses. Note: This method is slightly different from: #mutate:toSuper: since here we are at the root of reshaping and have two distinct roots." | newSubclass oldSuper newSuper | self showProgressFor: oldClass. oldSuper _ oldClass superclass. newSuper _ newClass superclass. oldSuper isObsolete ifTrue:[oldSuper removeObsoleteSubclass: oldClass] ifFalse:[oldSuper removeSubclass: oldClass]. "Convert the subclasses" oldClass subclasses do:[:oldSubclass| oldClass removeSubclass: oldSubclass. newSubclass _ self mutate: oldSubclass toSuper: newClass. newClass addSubclass: newSubclass. ]. "And any obsolete ones" oldClass obsoleteSubclasses do:[:oldSubclass| oldSubclass ifNotNil:[ oldClass removeObsoleteSubclass: oldSubclass. newSubclass _ self mutate: oldSubclass toSuper: newClass. newClass addObsoleteSubclass: newSubclass. ]. ]. self update: oldClass to: newClass. newSuper isObsolete ifTrue:[newSuper addObsoleteSubclass: newClass] ifFalse:[newSuper addSubclass: newClass].! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 22:44' prior: 34906026! mutate: oldClass to: newClass "Mutate the old class and subclasses into newClass and subclasses. Note: This method is slightly different from: #mutate:toSuper: since here we are at the root of reshaping and have two distinct roots." | newSubclass | self showProgressFor: oldClass. "Convert the subclasses" oldClass subclasses do:[:oldSubclass| newSubclass _ self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. ]. "And any obsolete ones" oldClass obsoleteSubclasses do:[:oldSubclass| oldSubclass ifNotNil:[ newSubclass _ self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. ]. ]. self update: oldClass to: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 9/22/2002 03:16'! reshapeClass: oldClass toSuper: newSuper "Reshape the given class to the new super class. Recompile all the methods in the newly created class. Answer the new class." | instVars | "ar 9/22/2002: The following is a left-over from some older code. I do *not* know why we uncompact oldClass here. If you do, then please let me know so I can put a comment here..." oldClass becomeUncompact. instVars _ instVarMap at: oldClass name ifAbsent:[oldClass instVarNames]. ^self newSubclassOf: newSuper type: oldClass typeOfClass instanceVariables: instVars from: oldClass! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 9/21/2002 15:34'! update: oldClass to: newClass "Convert oldClass, all its instances and possibly its meta class into newClass, instances of newClass and possibly its meta class. The process is surprisingly simple since we can rely on two assumptions (those are critical): #1: The method #updateInstancesFrom: will not create any lasting pointers to 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do a become of the old vs. the new instances and therefore it will not create pointers to *new* instances before the #become: which are *old* afterwards) #2: The non-preemptive execution of the critical piece of code guarantees that nobody can get a hold by 'other means' (such as process interruption and reflection) on the old instances. Given the above two, we know that after #updateInstancesFrom: there are no pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone. There's no need to worry. " | meta | meta _ oldClass isMeta. "Note: Everything from here on will run without the ability to get interrupted to prevent any other process to create new instances of the old class." [ "Convert the instances of oldClass into instances of newClass" newClass updateInstancesFrom: oldClass. meta ifTrue:[oldClass becomeForward: newClass] ifFalse:[(Array with: oldClass with: oldClass class) elementsForwardIdentityTo: (Array with: newClass with: newClass class)]. Smalltalk garbageCollect. ] valueUnpreemptively. ! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 23:42' prior: 34908702! update: oldClass to: newClass "Convert oldClass, all its instances and possibly its meta class into newClass, instances of newClass and possibly its meta class. The process is surprisingly simple in its implementation and surprisingly complex in its nuances and potentially bad side effects. We can rely on two assumptions (which are critical): #1: The method #updateInstancesFrom: will not create any lasting pointers to 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do a become of the old vs. the new instances and therefore it will not create pointers to *new* instances before the #become: which are *old* afterwards) #2: The non-preemptive execution of the critical piece of code guarantees that nobody can get a hold by 'other means' (such as process interruption and reflection) on the old instances. Given the above two, we know that after #updateInstancesFrom: there are no pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone (but see the comment right there). There's no need to worry. " | meta | meta _ oldClass isMeta. "Note: Everything from here on will run without the ability to get interrupted to prevent any other process to create new instances of the old class." [ "Note: The following removal may look somewhat obscure and needs an explanation. When we mutate the class hierarchy we create new classes for any existing subclass. So it may look as if we don't have to remove the old class from its superclass. However, at the top of the hierarchy (the first class we reshape) that superclass itself is not newly created so therefore it will hold both the oldClass and newClass in its (obsolete or not) subclasses. Since the #become: below will transparently replace the pointers to oldClass with newClass the superclass would have newClass in its subclasses TWICE. With rather unclear effects if we consider that we may convert the meta-class hierarchy itself (which is derived from the non-meta class hierarchy). Due to this problem ALL classes are removed from their superclass just prior to converting them. Here, breaking the superclass/subclass invariant really doesn't matter since we will effectively remove the oldClass (become+GC) just a few lines below." oldClass superclass removeSubclass: oldClass. oldClass superclass removeObsoleteSubclass: oldClass. "Convert the instances of oldClass into instances of newClass" newClass updateInstancesFrom: oldClass. meta ifTrue:[oldClass becomeForward: newClass] ifFalse:[(Array with: oldClass with: oldClass class) elementsForwardIdentityTo: (Array with: newClass with: newClass class)]. Smalltalk garbageCollect. "Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout). The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives: On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants. Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear). Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc. Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it." ] valueUnpreemptively. ! ! !ClassBuilder commentStamp: 'ar 2/27/2003 22:55' prior: 0! Responsible for creating a new class or changing the format of an existing class (from a class definition in a browser or a fileIn). This includes validating the definition, computing the format of instances, creating or modifying the accompanying Metaclass, setting up the class and metaclass objects themselves, registering the class as a global, recompiling methods, modifying affected subclasses, mutating existing instances to the new format, and more. You typically only need to use or modify this class, or even know how it works, when making fundamental changes to how the Smalltalk system and language works. Implementation notes: ClassBuilder relies on the assumption that it can see ALL subclasses of some class. If there are any existing subclasses of some class, regardless of whether they have instances or not, regardless of whether they are considered obsolete or not, ClassBuilder MUST SEE THEM. ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'! checkClassHierarchyConsistency "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" Utilities informUserDuring:[:bar| self checkClassHierarchyConsistency: bar. ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:03'! checkClassHierarchyConsistency: informer "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" | classes | Transcript cr; show: 'Start checking the class hierarchy...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'. meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. self checkClassHierarchyConsistencyFor: meta. ]. Transcript show: 'OK'.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:48'! checkClassHierarchyConsistencyFor: aClassDescription "Check whether aClassDescription has a consistent superclass and consistent regular and obsolete subclasses" | mySuperclass | mySuperclass _ aClassDescription superclass. (mySuperclass subclasses includes: aClassDescription) = aClassDescription isObsolete ifTrue: [self error: 'Something wrong!!']. mySuperclass ifNil: [^ self]. "Obsolete subclasses of nil cannot be stored" (mySuperclass obsoleteSubclasses includes: aClassDescription) = aClassDescription isObsolete ifFalse: [self error: 'Something wrong!!']. aClassDescription subclasses do: [:each | each isObsolete ifTrue: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ]. aClassDescription obsoleteSubclasses do: [:each | each isObsolete ifFalse: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:00'! cleanupAndCheckClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." Utilities informUserDuring:[:bar| self cleanupAndCheckClassHierarchy: bar. ]. ! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 15:58'! cleanupAndCheckClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." Transcript cr; show: '*** Before cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses. self cleanupClassHierarchy: informer. self checkClassHierarchyConsistency: informer. Transcript cr; cr; show: '*** After cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'! cleanupClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." Utilities informUserDuring:[:bar| self cleanupClassHierarchy: bar. ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:02'! cleanupClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." | classes | Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer value:'Fixing class hierarchy ', (index * 100 // classes size) printString,'%'. "Check classes before metaclasses (because Metaclass>>isObsolete checks whether the related class is obsolete)" meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. self cleanupClassHierarchyFor: meta. ]. Transcript show: 'DONE'.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 5/8/2002 10:55'! cleanupClassHierarchyFor: aClassDescription | myName mySuperclass | mySuperclass _ aClassDescription superclass. (self isReallyObsolete: aClassDescription) ifTrue: [ "Remove class >>>from SystemDictionary if it is obsolete" myName _ aClassDescription name asString. Smalltalk keys asArray do: [:each | (each asString = myName and: [(Smalltalk at: each) == aClassDescription]) ifTrue: [Smalltalk removeKey: each]]. "Make class officially obsolete if it is not" (aClassDescription name asString beginsWith: 'AnObsolete') ifFalse: [aClassDescription obsolete]. aClassDescription isObsolete ifFalse: [self error: 'Something wrong!!']. "Add class to obsoleteSubclasses of its superclass" mySuperclass ifNil: [self error: 'Obsolete subclasses of nil cannot be stored']. (mySuperclass obsoleteSubclasses includes: aClassDescription) ifFalse: [mySuperclass addObsoleteSubclass: aClassDescription]. ] ifFalse:[ "check if superclass has aClassDescription in its obsolete subclasses" mySuperclass ifNil:[mySuperclass _ Class]. "nil subclasses" mySuperclass removeObsoleteSubclass: aClassDescription. ]. "And remove its obsolete subclasses if not actual superclass" aClassDescription obsoleteSubclasses do:[:obs| obs superclass == aClassDescription ifFalse:[ aClassDescription removeObsoleteSubclass: obs]]. ! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'! countReallyObsoleteClassesAndMetaclasses "Counting really obsolete classes and metaclasses" | metaSize classSize | Smalltalk garbageCollect. metaSize _ self reallyObsoleteMetaclasses size. Transcript cr; show: 'Really obsolete metaclasses: ', metaSize printString. classSize _ self reallyObsoleteClasses size. Transcript cr; show: 'Really obsolete classes: ', classSize printString; cr. "Metaclasses must correspond to classes!!" metaSize ~= classSize ifTrue: [self error: 'Serious metalevel inconsistency!!!!'].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'! isReallyObsolete: aClassDescription "Returns whether the argument class is *really* obsolete. (Due to a bug, the method isObsolete isObsolete does not always return the right answer" ^ aClassDescription isObsolete or: [(aClassDescription superclass subclasses includes: aClassDescription) not]! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! reallyObsoleteClasses | obsoleteClasses | obsoleteClasses _ OrderedCollection new. Metaclass allInstances do: [:meta | meta allInstances do: [:each | (self isReallyObsolete: each) ifTrue: [obsoleteClasses add: each]]]. ^ obsoleteClasses! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! reallyObsoleteMetaclasses ^ Metaclass allInstances select: [:each | self isReallyObsolete: each].! ! !ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:49'! baseClassName ^'TestClassForClassChangeTest'! ! !ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:51'! cleanup baseClass ifNotNil:[baseClass removeFromSystem].! ! !ClassBuilderChangeClassTypeTest methodsFor: 'testing' stamp: 'BG 1/6/2004 00:04'! testClassCreationAndChange | success | [baseClass := Object subclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. self assert: baseClass isPointers. self deny: baseClass isVariable. success := true. [Object variableSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'.] on: Error do: [:exception | success := false]. self assert: (success and: [baseClass isVariable]). ] ensure: [self cleanup] ! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! baseClassName ^#DummyClassBuilderFormatTestSuperClass! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! cleanup subClass ifNotNil:[subClass removeFromSystem]. baseClass ifNotNil:[baseClass removeFromSystem].! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! makeByteVariableSubclassOf: aClass subClass := aClass variableByteSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! makeIVarsSubclassOf: aClass subClass := aClass subclass: self subClassName instanceVariableNames: 'var3 var4' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! makeNormalSubclassOf: aClass subClass := aClass subclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! makeVariableSubclassOf: aClass subClass := aClass variableSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'.! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! makeWeakSubclassOf: aClass subClass := aClass weakSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! makeWordVariableSubclassOf: aClass subClass := aClass variableWordSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! subClassName ^#DummyClassBuilderFormatTestSubClass! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:21'! testByteVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableByteSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). subClass removeFromSystem. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! testSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object subclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "pointer classes" self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert:(subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert:(subClass isVariable). self assert:(subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:21'! testSubclassWithInstanceVariables "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object subclass: self baseClassName instanceVariableNames: 'var1 var2' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "pointer classes" self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! testVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ "pointer classes" self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! testWeakSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object weakSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ "pointer classes" self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! testWordVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableWordSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. ] ensure:[self cleanup].! ! !ClassCategoryReader methodsFor: 'private' stamp: 'ajh 1/18/2002 01:14'! theClass ^ class! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'sw 4/3/2001 14:16'! noteChangeType: changeSymbol fromClass: class (changeSymbol = #new or: [changeSymbol = #add]) ifTrue: [changeTypes add: #add. changeTypes remove: #change ifAbsent: []. revertable _ false. ^ self]. changeSymbol = #change ifTrue: [(changeTypes includes: #add) ifTrue: [^ self]. ^ changeTypes add: changeSymbol]. changeSymbol == #addedThenRemoved ifTrue: [^ self]. "An entire class was added but then removed" changeSymbol = #comment ifTrue: [^ changeTypes add: changeSymbol]. changeSymbol = #reorganize ifTrue: [^ changeTypes add: changeSymbol]. changeSymbol = #rename ifTrue: [^ changeTypes add: changeSymbol]. (changeSymbol beginsWith: 'oldName: ') ifTrue: ["Must only be used when assimilating other changeSets" (changeTypes includes: #add) ifTrue: [^ self]. priorName _ changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size. ^ changeTypes add: #rename]. changeSymbol = #remove ifTrue: [(changeTypes includes: #add) ifTrue: [changeTypes add: #addedThenRemoved] ifFalse: [changeTypes add: #remove]. ^ changeTypes removeAllFoundIn: #(add change comment reorganize)]. self error: 'Unrecognized changeType'! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'tk 6/8/2001 09:11'! thisName ^ thisName! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'sw 8/14/2002 11:11'! removeSelector: selector "Remove all memory of changes associated with the argument, selector, in this class." selector == #Comment ifTrue: [changeTypes remove: #comment ifAbsent: []] ifFalse: [methodChanges removeKey: selector ifAbsent: []]! ! !ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'sw 7/31/2002 10:40'! scanFrom: aStream "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." class theNonMetaClass classComment: (aStream nextChunkText) stamp: changeStamp "Writes it on the disk and saves a RemoteString ref"! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:33'! compareToCurrentVersion "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" | change s1 s2 | listIndex = 0 ifTrue: [^ self]. change _ changeList at: listIndex. s1 _ classOfMethod organization classComment. s2 _ change string. s1 = s2 ifTrue: [^ self inform: 'Exact Match']. (StringHolder new textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: classOfMethod prettyDiffs: self showingPrettyDiffs)) openLabel: 'Comparison to Current Version'! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:02'! offerVersionsHelp (StringHolder new contents: self versionsHelpString) openLabel: 'Class Comment Versions Browsers'! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 23:37'! openSingleMessageBrowser | mr | "Create and schedule a message list browser populated only by the currently selected message" mr _ MethodReference new setStandardClass: self selectedClass methodSymbol: #Comment. Smalltalk browseMessageList: (Array with: mr) name: mr asStringOrText autoSelect: nil! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'sd 4/16/2003 08:52' prior: 34939567! openSingleMessageBrowser | mr | "Create and schedule a message list browser populated only by the currently selected message" mr _ MethodReference new setStandardClass: self selectedClass methodSymbol: #Comment. self systemNavigation browseMessageList: (Array with: mr) name: mr asStringOrText autoSelect: nil! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:53'! versionsMenu: aMenu "Fill aMenu with menu items appropriate to the receiver" Smalltalk isMorphic ifTrue: [aMenu title: 'versions'. aMenu addStayUpItemSpecial]. ^ aMenu addList: #( ('compare to current' compareToCurrentVersion 'compare selected version to the current version') ('revert to selected version' fileInSelections 'resubmit the selected version, so that it becomes the current version') ('remove from changes' removeMethodFromChanges 'remove this method from the current change set, if present') ('edit current method (O)' openSingleMessageBrowser 'open a single-message browser on the current version of this method') - ('toggle diffing (D)' toggleDiffing 'toggle whether or not diffs should be shown here') ('update list' reformulateList 'reformulate the list of versions, in case it somehow got out of synch with reality') - ('help...' offerVersionsHelp 'provide an explanation of the use of this tool')) ! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'asm 8/13/2002 22:26'! diffedVersionContents "Answer diffed version contents, maybe pretty maybe not" | change class earlier later | (listIndex = 0 or: [changeList size < listIndex]) ifTrue: [^ '']. change _ changeList at: listIndex. later _ change text. class _ self selectedClass. (listIndex == changeList size or: [class == nil]) ifTrue: [^ later]. earlier _ (changeList at: listIndex + 1) text. ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'asm 8/13/2002 21:28'! reformulateList classOfMethod organization classComment ifNil: [^ self]. self scanVersionsOf: classOfMethod. self changed: #list. "for benefit of mvc" listIndex _ 1. self changed: #listIndex. self contentsChanged! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'asm 1/3/2003 16:06'! scanVersionsOf: class "Scan for all past versions of the class comment of the given class" | oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex | classOfMethod _ class. oldCommentRemoteStr _ class organization commentRemoteStr. currentCompiledMethod _ oldCommentRemoteStr. selectorOfMethod _ #Comment. changeList _ OrderedCollection new. list _ OrderedCollection new. listIndex _ 0. oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer]. sourceFilesCopy _ SourceFiles collect: [:x | x isNil ifTrue: [ nil ] ifFalse: [x readOnlyCopy]]. position _ oldCommentRemoteStr position. file _ sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber. [position notNil & file notNil] whileTrue: [file position: (0 max: position-150). " Skip back to before the preamble" [file position < (position-1)] "then pick it up from the front" whileTrue: [preamble _ file nextChunk]. prevPos _ nil. stamp _ ''. (preamble findString: 'commentStamp:' startingAt: 1) > 0 ifTrue: [tokens _ Scanner new scanTokens: preamble. (tokens at: tokens size-3) = #commentStamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokens size-2. prevPos _ tokens last. prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos]] ifFalse: ["The stamp get lost, maybe after a condenseChanges" stamp _ '']. self addItem: (ChangeRecord new file: file position: position type: #classComment class: class name category: nil meta: class stamp: stamp) text: stamp , ' ' , class name , ' class comment'. prevPos = 0 ifTrue:[prevPos _ nil]. position _ prevPos. prevPos notNil ifTrue:[file _ sourceFilesCopy at: prevFileIndex]]. sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. listSelections _ Array new: list size withAll: false! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'asm 8/13/2002 21:33'! updateListsAndCodeIn: aWindow | aComment | aComment _ classOfMethod organization commentRemoteStr. aComment == currentCompiledMethod ifFalse: ["Do not attempt to formulate if there is no source pointer. It probably means it has been recompiled, but the source hasn't been written (as during a display of the 'save text simply?' confirmation)." aComment last ~= 0 ifTrue: [self reformulateList]]. ^ true ! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/17/2002 21:57'! classCommentIndicated "Answer whether the receiver is pointed at a class comment" ^ true! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/15/2002 22:38'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane" ^ #( (source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') (showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version'))! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'asm 8/13/2002 22:14'! priorSourceOrNil "If the currently-selected method has a previous version, return its source, else return nil" | aClass aSelector changeRecords | (aClass _ self selectedClass) ifNil: [^ nil]. (aSelector _ self selectedMessageName) ifNil: [^ nil]. changeRecords _ self class commentRecordsOf: self selectedClass. (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil]. ^ (changeRecords at: 2) string ! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'asm 8/13/2002 20:59'! selectedClass "Answer the class currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" ^ classOfMethod! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/15/2002 22:35'! wantsPrettyDiffOption "Answer whether pretty-diffs are meaningful for this tool" ^ false! ! !ClassCommentVersionsBrowser commentStamp: 'asm 8/13/2002 23:20' prior: 0! A class-comment-versions-browser tool! !ClassCommentVersionsBrowser class methodsFor: 'instance creation' stamp: 'asm 8/12/2002 22:46'! browseCommentOf: class | changeList | Cursor read showWhile: [changeList _ self new scanVersionsOf: class. changeList ifNil: [^ self inform: 'No versions available']. self open: changeList name: 'Recent versions of ',class name,'''s comments' multiSelect: false ] ! ! !ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'asm 8/13/2002 22:09'! commentRecordsOf: aClass "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." | aList | aList _ self new scanVersionsOf: aClass. ^ aList ifNotNil: [aList changeList]! ! !ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'asm 8/13/2002 20:54'! timeStampFor: aSelector class: aClass reverseOrdinal: anInteger "Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc." | aChangeList | aChangeList _ self new scanVersionsOf: aClass. ^ aChangeList ifNil: [nil] ifNotNil: [aChangeList list size >= anInteger ifTrue: [(aChangeList changeList at: anInteger) stamp] ifFalse: [nil]]! ! !ClassCommentVersionsBrowser class methodsFor: 'window color' stamp: 'asm 8/13/2002 20:57'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Class Comment Versions Browser' brightColor: #(0.769 0.653 1.0) pastelColor: #(0.819 0.753 1.0) helpMessage: 'A tool for viewing prior versions of a class comment.'! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/6/2004 15:32' prior: 19292817! obsolete "Make the receiver obsolete." superclass removeSubclass: self. self organization: nil. super obsolete.! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/6/2004 15:31' prior: 19293013! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. instanceVariables _ nil. self organization: nil.! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 23:25'! updateInstances: oldInstances from: oldClass isMeta: isMeta "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." "If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout." | map variable instSize newInstances | oldInstances isEmpty ifTrue:[^#()]. "no instances to convert" isMeta ifTrue: [ oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance']. self soleInstance class == self ifTrue:[ ^self error:'Metaclasses can only have one instance']]. map _ self instVarMappingFrom: oldClass. variable _ self isVariable. instSize _ self instSize. newInstances _ Array new: oldInstances size. 1 to: oldInstances size do:[:i| newInstances at: i put: ( self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. "Now perform a bulk mutation of old instances into new ones" oldInstances elementsExchangeIdentityWith: newInstances. ^newInstances "which are now old"! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 20:48'! updateInstancesFrom: oldClass "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." "ar 7/15/1999: The updating below is possibly dangerous. If there are any contexts having an old instance as receiver it might crash the system if the new receiver in which the context is executed has a different layout. See bottom below for a simple example:" | oldInstances | oldInstances _ oldClass allInstances asArray. oldInstances _ self updateInstances: oldInstances from: oldClass isMeta: self isMeta. "Now fix up instances in segments that are out on the disk." ImageSegment allSubInstancesDo: [:seg | seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta]. ^oldInstances " | crashingBlock class | class _ Object subclass: #CrashTestDummy instanceVariableNames: 'instVar' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. class compile:'instVar: value instVar _ value'. class compile:'crashingBlock ^[instVar]'. crashingBlock _ (class new) instVar: 42; crashingBlock. Object subclass: #CrashTestDummy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. crashingBlock. crashingBlock value. " ! ! !ClassDescription methodsFor: 'accessing' stamp: 'sd 6/27/2003 23:57' prior: 19295975! classVersion "Default. Any class may return a later version to inform readers that use ReferenceStream. 8/17/96 tk" "This method allows you to distinguish between class versions when the shape of the class hasn't changed (when there's no change in the instVar names). In the conversion methods you usually can tell by the inst var names what old version you have. In a few cases, though, the same inst var names were kept but their interpretation changed (like in the layoutFrame). By changing the class version when you keep the same instVars you can warn older and newer images that they have to convert." ^ 0! ! !ClassDescription methodsFor: 'accessing' stamp: 'sw 11/5/2001 00:53'! comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText. Smalltalk changes commentClass: self. Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! ! !ClassDescription methodsFor: 'accessing' stamp: 'sd 3/28/2003 15:32' prior: 34952535! comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText. self environment changes commentClass: self. Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! ! !ClassDescription methodsFor: 'accessing' stamp: 'sd 5/23/2003 14:34' prior: 34952878! comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText. ChangeSet current commentClass: self. Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! ! !ClassDescription methodsFor: 'accessing' stamp: 'NS 1/27/2004 14:54' prior: 34953228! comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText.! ! !ClassDescription methodsFor: 'accessing' stamp: 'sw 11/5/2001 00:55'! comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText stamp: aStamp. Smalltalk changes commentClass: self theNonMetaClass. Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! ! !ClassDescription methodsFor: 'accessing' stamp: 'sd 3/28/2003 15:32' prior: 34953786! comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText stamp: aStamp. self environment changes commentClass: self theNonMetaClass. Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! ! !ClassDescription methodsFor: 'accessing' stamp: 'sd 5/23/2003 14:34' prior: 34954173! comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText stamp: aStamp. ChangeSet current commentClass: self theNonMetaClass. Utilities noteMethodSubmission: #Comment forClass: self theNonMetaClass! ! !ClassDescription methodsFor: 'accessing' stamp: 'NS 1/27/2004 14:54' prior: 34954567! comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText stamp: aStamp.! ! !ClassDescription methodsFor: 'accessing' stamp: 'ls 10/28/2003 12:32'! hasComment "return whether this class truly has a comment other than the default" | org | org := self theNonMetaClass organization. ^org classComment notNil and: [ org classComment isEmpty not ]. ! ! !ClassDescription methodsFor: 'accessing' stamp: 'sd 6/27/2003 22:50'! theMetaClass "Sent to a class or metaclass, always return the metaclass" ^self class! ! !ClassDescription methodsFor: 'copying' stamp: 'NS 4/6/2004 15:31' prior: 19300462! copyMethodDictionaryFrom: donorClass "Copy the method dictionary of the donor class over to the receiver" methodDict _ donorClass copyOfMethodDictionary. self organization: donorClass organization deepCopy.! ! !ClassDescription methodsFor: 'printing' stamp: 'lr 11/24/2003 17:21' prior: 19300715! classVariablesString "Answer a string of my class variable names separated by spaces." ^String streamContents: [ :stream | self classPool keys asSortedCollection do: [ :each | stream nextPutAll: each ] separatedBy: [ stream space ] ]! ! !ClassDescription methodsFor: 'printing' stamp: 'lr 11/24/2003 17:20' prior: 19301039! instanceVariablesString "Answer a string of my instance variable names separated by spaces." ^String streamContents: [ :stream | self instVarNames do: [ :each | stream nextPutAll: each ] separatedBy: [ stream space ] ]! ! !ClassDescription methodsFor: 'printing' stamp: 'lr 11/24/2003 17:24' prior: 19301535! sharedPoolsString "Answer a string of my shared pool names separated by spaces." ^String streamContents: [ :stream | self sharedPools do: [ :each | stream nextPutAll: (self environment keyAtIdentityValue: each ifAbsent: [ 'private' ]) ] separatedBy: [ stream space ] ]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'sw 3/20/2001 20:38'! chooseClassVarName "Present the user with a list of class variable names and answer the one selected, or nil if none" | lines labelStream vars allVars index | lines _ OrderedCollection new. allVars _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). self withAllSuperclasses reverseDo: [:class | vars _ class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^1 beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index _ (PopUpMenu labels: labelStream contents lines: lines) startUp. index = 0 ifTrue: [^ nil]. ^ allVars at: index! ! !ClassDescription methodsFor: 'instance variables' stamp: 'nb 6/17/2003 12:25' prior: 34956995! chooseClassVarName "Present the user with a list of class variable names and answer the one selected, or nil if none" | lines labelStream vars allVars index | lines _ OrderedCollection new. allVars _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). self withAllSuperclasses reverseDo: [:class | vars _ class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index _ (PopUpMenu labels: labelStream contents lines: lines) startUp. index = 0 ifTrue: [^ nil]. ^ allVars at: index! ! !ClassDescription methodsFor: 'instance variables' stamp: 'sw 3/20/2001 20:51'! classThatDefinesClassVariable: classVarName "Answer the class that defines the given class variable" (self classPool includesKey: classVarName asSymbol) ifTrue: [^ self]. ^ superclass ifNotNil: [superclass classThatDefinesClassVariable: classVarName]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'NS 1/27/2004 11:49' prior: 19308671! renameSilentlyInstVar: old to: new | i oldName newName | oldName _ old asString. newName _ new asString. (i _ instanceVariables indexOf: oldName) = 0 ifTrue: [self error: oldName , ' is not defined in ', self name]. self allSuperclasses , self withAllSubclasses asOrderedCollection do: [:cls | (cls instVarNames includes: newName) ifTrue: [self error: newName , ' is already used in ', cls name]]. instanceVariables replaceFrom: i to: i with: (Array with: newName). self replaceSilently: oldName to: newName. "replace in text body of all methods"! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 14:12'! addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor | priorMethodOrNil | priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. SystemChangeNotifier uniqueInstance doSilently: [self organization classify: selector under: category]. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 14:10'! addSelector: selector withMethod: compiledMethod notifying: requestor | priorMethodOrNil | priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 1/5/2001 06:53'! allMethodCategoriesIntegratedThrough: mostGenericClass "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" | aColl | aColl _ OrderedCollection new. self withAllSuperclasses do: [:aClass | (aClass includesBehavior: mostGenericClass) ifTrue: [aColl addAll: aClass organization categories]]. aColl remove: 'no messages' asSymbol ifAbsent: []. ^ (aColl asSet asSortedCollection: [:a :b | a asLowercase < b asLowercase]) asArray "ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 12/12/2000 12:26'! allMethodsInCategory: aName "Answer a list of all the method categories of the receiver and all its superclasses" | aColl | aColl _ OrderedCollection new. self withAllSuperclasses do: [:aClass | aColl addAll: (aName = ClassOrganizer allCategory ifTrue: [aClass organization allMethodSelectors] ifFalse: [aClass organization listAtCategoryNamed: aName])]. ^ aColl asSet asSortedArray "TileMorph allMethodsInCategory: #initialization"! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 4/18/2003 10:26' prior: 34961770! allMethodsInCategory: aName "Answer a list of all the method categories of the receiver and all its superclasses " | aColl | aColl _ OrderedCollection new. self withAllSuperclasses do: [:aClass | aColl addAll: (aName = ClassOrganizer allCategory ifTrue: [aClass organization allMethodSelectors] ifFalse: [aClass organization listAtCategoryNamed: aName])]. ^ aColl asSet asSortedArray "TileMorph allMethodsInCategory: #initialization"! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 12/11/2000 14:00'! isUniClass "Answer whether the receiver is a uniclass." ^ self name endsWithDigit! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 3/20/2001 13:26'! namedTileScriptSelectors "Answer a list of all the selectors of named tile scripts. Initially, only Player reimplements, but if we switch to a scheme in which every class can have uniclass subclasses, this would kick in elsewhere" ^ OrderedCollection new! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'di 3/7/2001 17:05'! recoverFromMDFault "This method handles methodDict faults to support, eg, discoverActiveClasses (qv)." (organization isMemberOf: Array) ifFalse: [^ self error: 'oops']. methodDict _ organization first. organization _ organization second. ! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'di 3/7/2001 16:16'! recoverFromMDFaultWithTrace "This method handles emthodDict faults to support, eg, discoverActiveClasses (qv)." self recoverFromMDFault. Smalltalk at: #MDFaultDict ifPresent: [:faultDict | faultDict at: self name put: (String streamContents: [:strm | (thisContext stackOfSize: 20) do: [:item | strm print: item; cr]])] "Execute the following statement to induce MD fault tracing. This means that, not only will all active classes be recorded but, after a test run, MDFaultDict will contain, for every class used, a stack trace showing how it came to be used. This statement should be executed just prior to any such text, in order to clear the traces. Smalltalk at: #MDFaultDict put: Dictionary new. "! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 3/28/2003 15:32' prior: 34963762! recoverFromMDFaultWithTrace "This method handles emthodDict faults to support, eg, discoverActiveClasses (qv)." self recoverFromMDFault. self environment at: #MDFaultDict ifPresent: [:faultDict | faultDict at: self name put: (String streamContents: [:strm | (thisContext stackOfSize: 20) do: [:item | strm print: item; cr]])] "Execute the following statement to induce MD fault tracing. This means that, not only will all active classes be recorded but, after a test run, MDFaultDict will contain, for every class used, a stack trace showing how it came to be used. This statement should be executed just prior to any such text, in order to clear the traces. Smalltalk at: #MDFaultDict put: Dictionary new. "! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 3/28/2003 15:32' prior: 19311634! removeSelector: selector | priorMethod | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." (self methodDict includesKey: selector) ifFalse: [^ nil]. priorMethod _ self compiledMethodAt: selector. self environment changes removeSelector: selector class: self priorMethod: priorMethod lastMethodInfo: {priorMethod sourcePointer. (self whichCategoryIncludesSelector: selector)}. super removeSelector: selector. self organization removeElement: selector. self acceptsLoggingOfCompilation ifTrue: [self environment logChange: self name , ' removeSelector: #' , selector]! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 5/23/2003 14:34' prior: 34965427! removeSelector: selector | priorMethod | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." (self methodDict includesKey: selector) ifFalse: [^ nil]. priorMethod _ self compiledMethodAt: selector. ChangeSet current removeSelector: selector class: self priorMethod: priorMethod lastMethodInfo: {priorMethod sourcePointer. (self whichCategoryIncludesSelector: selector)}. super removeSelector: selector. self organization removeElement: selector. self acceptsLoggingOfCompilation ifTrue: [self environment logChange: self name , ' removeSelector: #' , selector]! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/16/2004 15:41' prior: 34966204! removeSelector: selector | priorMethod priorProtocol | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." (self methodDict includesKey: selector) ifFalse: [^ nil]. priorMethod _ self compiledMethodAt: selector. priorProtocol := self whichCategoryIncludesSelector: selector. ChangeSet current removeSelector: selector class: self priorMethod: priorMethod lastMethodInfo: {priorMethod sourcePointer. priorProtocol}. super removeSelector: selector. self organization removeElement: selector. self acceptsLoggingOfCompilation ifTrue: [SmalltalkImage current logChange: self name , ' removeSelector: #' , selector]. SystemChangeNotifier uniqueInstance methodRemoved: selector inProtocol: priorProtocol fromClass: self! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:11' prior: 34966974! removeSelector: selector | priorMethod priorProtocol | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." (self methodDict includesKey: selector) ifFalse: [^ nil]. priorMethod _ self compiledMethodAt: selector. priorProtocol := self whichCategoryIncludesSelector: selector. super removeSelector: selector. self organization removeElement: selector. SystemChangeNotifier uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:26' prior: 34967903! removeSelector: selector | priorMethod priorProtocol | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil]. priorProtocol _ self whichCategoryIncludesSelector: selector. super removeSelector: selector. self organization removeElement: selector. SystemChangeNotifier uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 4/7/2004 13:33' prior: 34968574! removeSelector: selector | priorMethod priorProtocol | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil]. priorProtocol _ self whichCategoryIncludesSelector: selector. SystemChangeNotifier uniqueInstance doSilently: [ self organization removeElement: selector]. super removeSelector: selector. SystemChangeNotifier uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! ! !ClassDescription methodsFor: 'organization' stamp: 'rw 8/2/2003 11:05' prior: 19313338! category: cat "Categorize the receiver under the system category, cat, removing it from any previous categorization." | oldCat | oldCat := self category. (cat isKindOf: String) ifTrue: [SystemOrganization classify: self name under: cat asSymbol] ifFalse: [self errorCategoryName]. SystemChangeNotifier uniqueInstance class: self recategorizedFrom: oldCat to: cat asSymbol! ! !ClassDescription methodsFor: 'organization' stamp: 'nk 3/8/2004 13:18'! forgetDoIts "get rid of old DoIt methods and bogus entries in the ClassOrganizer." super forgetDoIts. self organization removeElement: #DoIt; removeElement: #DoItIn:.! ! !ClassDescription methodsFor: 'organization' stamp: 'NS 4/7/2004 13:33' prior: 34970332! forgetDoIts "get rid of old DoIt methods and bogus entries in the ClassOrganizer." SystemChangeNotifier uniqueInstance doSilently: [ self organization removeElement: #DoIt; removeElement: #DoItIn:. ]. super forgetDoIts.! ! !ClassDescription methodsFor: 'organization' stamp: 'di 3/7/2001 17:05'! organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." organization ifNil: [organization _ ClassOrganizer defaultList: self methodDict keys asSortedCollection asArray]. (organization isMemberOf: Array) ifTrue: [self recoverFromMDFaultWithTrace]. ^ organization! ! !ClassDescription methodsFor: 'organization' stamp: 'NS 4/6/2004 15:46' prior: 34970908! organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." organization ifNil: [self organization: (ClassOrganizer defaultList: self methodDict keys asSortedCollection asArray)]. (organization isMemberOf: Array) ifTrue: [self recoverFromMDFaultWithTrace]. "Making sure that subject is set correctly. It should not be necessary." organization ifNotNil: [organization setSubject: self]. ^ organization! ! !ClassDescription methodsFor: 'organization' stamp: 'NS 4/6/2004 15:26' prior: 19314082! organization: aClassOrg "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." aClassOrg ifNotNil: [aClassOrg setSubject: self]. organization _ aClassOrg! ! !ClassDescription methodsFor: 'organization' stamp: 'NS 4/6/2004 15:30' prior: 19314922! zapOrganization "Remove the organization of this class by message categories. This is typically done to save space in small systems. Classes and methods created or filed in subsequently will, nonetheless, be organized" self organization: nil. self isMeta ifFalse: [self class zapOrganization]! ! !ClassDescription methodsFor: 'compiling' stamp: 'di 5/4/2001 11:35'! compile: text classified: category withStamp: changeStamp notifying: requestor ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! ! !ClassDescription methodsFor: 'compiling' stamp: 'sw 9/25/2001 02:08'! compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | selector priorMethod method methodNode newText | method _ self compile: text asString notifying: requestor trailer: #(0 0 0 0) ifFail: [^nil] elseSetSelectorAndNode: [:sel :node | selector _ sel. priorMethod _ self methodDict at: selector ifAbsent: [nil]. methodNode _ node]. logSource ifTrue: [newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not and: [Preferences confirmFirstUseOfStyle]) ifTrue: [text askIfAddStyle: priorMethod req: requestor] ifFalse: [text]. method putSource: newText fromParseNode: methodNode class: self category: category withStamp: changeStamp inFile: 2 priorMethod: priorMethod]. self organization classify: selector under: category. self theNonMetaClass noteCompilationOf: selector meta: self isMeta. ^ selector! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/26/2004 13:33' prior: 34972873! compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | selector priorMethodOrNil method methodNode newText | SystemChangeNotifier uniqueInstance doSilently: [method _ self compile: text asString notifying: requestor trailer: #(0 0 0 0) ifFail: [^nil] elseSetSelectorAndNode: [:sel :node | selector _ sel. priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil]. methodNode _ node]]. logSource ifTrue: [newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not and: [Preferences confirmFirstUseOfStyle]) ifTrue: [text askIfAddStyle: priorMethodOrNil req: requestor] ifFalse: [text]. method putSource: newText fromParseNode: methodNode class: self category: category withStamp: changeStamp inFile: 2 priorMethod: priorMethodOrNil]. SystemChangeNotifier uniqueInstance doSilently: [self organization classify: selector under: category]. self theNonMetaClass noteCompilationOf: selector meta: self isMeta. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: method selector: selector inProtocol: category class: self requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: method selector: selector inClass: self requestor: requestor]. ^ selector! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:25' prior: 34973882! compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | methodAndNode | methodAndNode _ self basicCompile: text asString notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. logSource ifTrue: [ self logMethodSource: text forMethodWithNode: methodAndNode inCategory: category withStamp: changeStamp notifying: requestor. ]. self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode method inProtocol: category notifying: requestor. self theNonMetaClass noteCompilationOf: methodAndNode selector meta: self isMeta. ^ methodAndNode selector! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:45'! compileSilently: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." ^ self compileSilently: code classified: category notifying: nil.! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:45'! compileSilently: code classified: category notifying: requestor "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." ^ SystemChangeNotifier uniqueInstance doSilently: [self compile: code classified: category withStamp: nil notifying: requestor logSource: false].! ! !ClassDescription methodsFor: 'compiling' stamp: 'sw 9/25/2001 02:11'! noteCompilationOf: aSelector meta: isMeta "A hook allowing some classes to react to recompilation of certain selectors"! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:48' prior: 19320026! wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" ^ true! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 9/8/1998 14:44'! classComment: aString "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." ^ self classComment: aString stamp: ''! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 8/1/2002 14:23'! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [Smalltalk changes commentClass: self. ^ self organization classComment: aString stamp: aStamp]. oldCommentRemoteStr _ self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. Smalltalk changes commentClass: self. organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:32' prior: 34977782! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [self environment changes commentClass: self. ^ self organization classComment: aString stamp: aStamp]. oldCommentRemoteStr _ self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. self environment changes commentClass: self. organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:51' prior: 34979099! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [ChangeSet current commentClass: self. ^ self organization classComment: aString stamp: aStamp]. oldCommentRemoteStr _ self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. ChangeSet current commentClass: self. organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 1/27/2004 14:54' prior: 34980430! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [SystemChangeNotifier uniqueInstance classCommented: self. ^ self organization classComment: aString stamp: aStamp]. oldCommentRemoteStr _ self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. SystemChangeNotifier uniqueInstance classCommented: self. organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'nk 3/8/2004 17:28' prior: 34981747! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [SystemChangeNotifier uniqueInstance classCommented: self. ^ self organization classComment: aString stamp: aStamp]. oldCommentRemoteStr _ self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. SystemChangeNotifier uniqueInstance classCommented: self. ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 4/8/2004 11:35' prior: 34983103! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [SystemChangeNotifier uniqueInstance classCommented: self. ^ self organization classComment: aString stamp: aStamp]. oldCommentRemoteStr _ self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. SystemChangeNotifier uniqueInstance classCommented: self. ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'ls 10/9/2001 00:12'! definitionST80 "Answer a String that defines the receiver." | aStream path | aStream _ WriteStream on: (String new: 300). superclass == nil ifTrue: [aStream nextPutAll: 'ProtoObject'] ifFalse: [path _ ''. self environment scopeFor: superclass name from: nil envtAndPathIfFound: [:envt :remotePath | path _ remotePath]. aStream nextPutAll: path , superclass name]. aStream nextPutAll: self kindOfSubclass; store: self name. aStream cr; tab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '; store: self classVariablesString. aStream cr; tab; nextPutAll: 'poolDictionaries: '; store: self sharedPoolsString. aStream cr; tab; nextPutAll: 'category: '; store: (SystemOrganization categoryOfElement: self name) asString. superclass ifNil: [ aStream nextPutAll: '.'; cr. aStream nextPutAll: self name. aStream space; nextPutAll: 'superclass: nil'. ]. ^ aStream contents! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'ls 10/9/2001 00:12'! definitionST80: isST80 "Answer a String that defines the receiver." | aStream path | isST80 ifTrue: [^ self definitionST80]. aStream _ WriteStream on: (String new: 300). superclass == nil ifTrue: [aStream nextPutAll: 'ProtoObject'] ifFalse: [path _ ''. self environment scopeFor: superclass name from: nil envtAndPathIfFound: [:envt :remotePath | path _ remotePath]. aStream nextPutAll: path , superclass name]. aStream nextPutKeyword: self kindOfSubclass withArg: self name. aStream cr; tab; nextPutKeyword: 'instanceVariableNames: ' withArg: self instanceVariablesString. aStream cr; tab; nextPutKeyword: 'classVariableNames: 'withArg: self classVariablesString. aStream cr; tab; nextPutKeyword: 'poolDictionaries: ' withArg: self sharedPoolsString. aStream cr; tab; nextPutKeyword: 'category: ' withArg: (SystemOrganization categoryOfElement: self name) asString. superclass ifNil: [ aStream nextPutAll: '.'; cr. aStream nextPutAll: self name. aStream space; nextPutAll: 'superclass (nil)'. ]. ^ aStream contents! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 8/30/2002 14:00' prior: 19325012! fileOutCategory: catName asHtml: useHtml "FileOut the named category, possibly in Html format." | fileStream | fileStream _ useHtml ifTrue: [(FileStream newFileNamed: self name , '-' , catName , '.html') asHtml] ifFalse: [FileStream newFileNamed: (self name , '-' , catName , '.st') asFileName]. fileStream header; timeStamp. self fileOutCategory: catName on: fileStream moveSource: false toFile: 0. fileStream trailer; close! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sumim 9/2/2003 14:36'! fileOutChangedMessagesHistorically: aSet on: aFileStream moveSource: moveSource toFile: fileIndex "File all historical description of the messages of this class that have been changed (i.e., are entered into the argument, aSet) onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .changes file, and should only write a preamble for every method." | org sels | (org _ self organization) categories do: [:cat | sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. sels do: [:sel | self printMethodChunkHistorically: sel on: aFileStream moveSource: moveSource toFile: fileIndex]]! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 8/1/2002 14:39'! fileOutMethod: selector asHtml: useHtml "Write source code of a single method on a file in .st or .html format" | fileStream nameBody | (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. nameBody _ self name , '-' , (selector copyReplaceAll: ':' with: ''). fileStream _ useHtml ifTrue: [(FileStream newFileNamed: nameBody , '.html') asHtml] ifFalse: [FileStream newFileNamed: nameBody , '.st']. fileStream header; timeStamp. self printMethodChunk: selector withPreamble: true on: fileStream moveSource: false toFile: 0. fileStream close! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 7/15/2003 20:51' prior: 34989390! fileOutMethod: selector asHtml: useHtml "Write source code of a single method on a file in .st or .html format" | fileStream nameBody | (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. nameBody _ self name , '-' , (selector copyReplaceAll: ':' with: ''). fileStream _ useHtml ifTrue: [(FileStream newFileNamed: nameBody , '.html') asHtml] ifFalse: [FileStream newFileNamed: (nameBody , '.st') asFileName]. fileStream header; timeStamp. self printMethodChunk: selector withPreamble: true on: fileStream moveSource: false toFile: 0. fileStream close! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 1/2/2003 21:50'! moveChangesTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | changes _ self methodDict keys select: [:sel | (self methodDict at: sel) fileIndex > 1]. self fileOutChangedMessages: changes on: newFile moveSource: true toFile: 2! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sumim 9/2/2003 14:37'! moveChangesWithVersionsTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | changes _ self methodDict keys select: [:sel | (self methodDict at: sel) fileIndex > 1]. self fileOutChangedMessagesHistorically: changes on: newFile moveSource: true toFile: 2! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 10/15/2003 17:10' prior: 19333524! printMethodChunk: selector withPreamble: doPreamble on: outStream moveSource: moveSource toFile: fileIndex "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." | preamble method oldPos newPos sourceFile endPos | doPreamble ifTrue: [preamble _ self name , ' methodsFor: ' , (self organization categoryOfElement: selector) asString printString] ifFalse: [preamble _ '']. method _ self methodDict at: selector. ((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [(oldPos _ method filePosition) = 0]) ifTrue: ["The source code is not accessible. We must decompile..." preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr]. outStream nextChunkPut: (self decompilerClass new decompile: selector in: self method: method) decompileString] ifFalse: [sourceFile _ SourceFiles at: method fileIndex. preamble size > 0 ifTrue: "Copy the preamble" [outStream copyPreamble: preamble from: sourceFile at: oldPos]. "Copy the method chunk" newPos _ outStream position. outStream copyMethodChunkFrom: sourceFile. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile]. moveSource ifTrue: "Set the new method source pointer" [endPos _ outStream position. method checkOKToAdd: endPos - newPos at: newPos. method setSourcePosition: newPos inFile: fileIndex]]. preamble size > 0 ifTrue: [outStream nextChunkPut: ' ']. ^ outStream cr! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 10/15/2003 17:10'! printMethodChunkHistorically: selector on: outStream moveSource: moveSource toFile: fileIndex "Copy all source codes historically for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." | preamble method newPos sourceFile endPos category changeList prior | category _ self organization categoryOfElement: selector. preamble _ self name , ' methodsFor: ', category asString printString. method _ self methodDict at: selector. ((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [method filePosition = 0]) ifTrue: [ outStream cr; nextPut: $!!; nextChunkPut: preamble; cr. outStream nextChunkPut: ( self decompilerClass new decompile: selector in: self method: method) decompileString. outStream nextChunkPut: ' '; cr] ifFalse: [ changeList _ (VersionsBrowser new scanVersionsOf: method class: self meta: self isMeta category: category selector: selector) changeList. newPos _ nil. sourceFile _ SourceFiles at: method fileIndex. changeList reverseDo: [ :chgRec | chgRec fileIndex = fileIndex ifTrue: [ outStream copyPreamble: preamble from: sourceFile at: chgRec position. (prior _ chgRec prior) ifNotNil: [ outStream position: outStream position - 2. outStream nextPutAll: ' prior: ', ( prior first = method fileIndex ifFalse: [prior third] ifTrue: [ SourceFiles sourcePointerFromFileIndex: method fileIndex andPosition: newPos]) printString. outStream nextPut: $!!; cr]. "Copy the method chunk" newPos _ outStream position. outStream copyMethodChunkFrom: sourceFile at: chgRec position. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile]. outStream nextChunkPut: ' '; cr]]. moveSource ifTrue: [ endPos _ outStream position. method checkOKToAdd: endPos - newPos at: newPos. method setSourcePosition: newPos inFile: fileIndex]]. ^ outStream! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 1/14/2003 15:36'! putClassCommentToCondensedChangesFile: aFileStream "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." | header aStamp aCommentRemoteStr | self isMeta ifTrue: [^ self]. "bulletproofing only" ((aCommentRemoteStr _ self organization commentRemoteStr) isNil or: [aCommentRemoteStr sourceFileNumber == 1]) ifTrue: [^ self]. aFileStream cr; nextPut: $!!. header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. (aStamp _ self organization commentStamp ifNil: ['']) storeOn: strm. strm nextPutAll: ' prior: 0']. aFileStream nextChunkPut: header. aFileStream cr. organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 4/8/2004 11:32' prior: 34995847! putClassCommentToCondensedChangesFile: aFileStream "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." | header aStamp aCommentRemoteStr | self isMeta ifTrue: [^ self]. "bulletproofing only" ((aCommentRemoteStr _ self organization commentRemoteStr) isNil or: [aCommentRemoteStr sourceFileNumber == 1]) ifTrue: [^ self]. aFileStream cr; nextPut: $!!. header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. (aStamp _ self organization commentStamp ifNil: ['']) storeOn: strm. strm nextPutAll: ' prior: 0']. aFileStream nextChunkPut: header. aFileStream cr. self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:32' prior: 19335935! reorganize "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" self environment changes reorganizeClass: self. ^self organization! ]style[(10 156 22 87)f1b,f1,f1LReadWriteStream fileIn;,f1! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:35' prior: 34998227! reorganize "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" ChangeSet current reorganizeClass: self. ^self organization! ]style[(10 156 22 80)f1b,f1,f1LReadWriteStream fileIn;,f1! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 1/27/2004 14:55' prior: 34998656! reorganize "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" SystemChangeNotifier uniqueInstance classReorganized: self. ^self organization! ]style[(10 156 22 20 59 20)f1b,f1,f1LReadWriteStream fileIn;,f1,f2,f1! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 23:01' prior: 34999078! reorganize "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" ^self organization! ]style[(10 156 22 38)f1b,f1,f1LReadWriteStream fileIn;,f1! ! !ClassDescription methodsFor: 'private' stamp: 'NS 1/28/2004 14:22'! logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor | priorMethodOrNil newText | priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: []. newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not and: [Preferences confirmFirstUseOfStyle]) ifTrue: [aText askIfAddStyle: priorMethodOrNil req: requestor] ifFalse: [aText]. aCompiledMethodWithNode method putSource: newText fromParseNode: aCompiledMethodWithNode node class: self category: category withStamp: changeStamp inFile: 2 priorMethod: priorMethodOrNil.! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:32' prior: 19341520! removeUninstantiatedSubclassesSilently "Remove the classes of any subclasses that have neither instances nor subclasses. Answer the number of bytes reclaimed" "Player removeUninstantiatedSubclassesSilently" | candidatesForRemoval oldFree | oldFree _ self environment garbageCollect. candidatesForRemoval _ self subclasses select: [:c | (c instanceCount = 0) and: [c subclasses size = 0]]. candidatesForRemoval do: [:c | c removeFromSystem]. ^ self environment garbageCollect - oldFree! ! !ClassDescription methodsFor: 'deprecated' stamp: 'sw 10/29/2001 17:41'! categoryFromUserWithPrompt: aPrompt "SystemDictionary categoryFromUserWithPrompt: 'testing'" | labels myCategories reject lines cats newName menuIndex | labels _ OrderedCollection with: 'new...'. labels addAll: (myCategories _ self organization categories asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject _ myCategories asSet. reject add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines _ OrderedCollection with: 1 with: (myCategories size + 1). self allSuperclasses do: [:cls | cats _ cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [lines add: labels size. labels addAll: (cats asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject addAll: cats]]. newName _ (labels size = 1 or: [menuIndex _ (PopUpMenu labelArray: labels lines: lines) startUpWithCaption: aPrompt. menuIndex = 0 ifTrue: [^ nil]. menuIndex = 1]) ifTrue: [FillInTheBlank request: 'Please type new category name' initialAnswer: 'category name'] ifFalse: [labels at: menuIndex]. ^ newName ifNotNil: [newName asSymbol]! ! !ClassDescription methodsFor: 'deprecated' stamp: 'sd 2/1/2004 17:59' prior: 35001234! categoryFromUserWithPrompt: aPrompt "SystemDictionary categoryFromUserWithPrompt: 'testing'" self deprecated: 'Use CodeHolder>>categoryFromUserWithPrompt: aPrompt for: aClass instead'. "this deprecation helps to remove UI dependency from the core of Squeak. Normally only CodeHolder was calling this method" CodeHolder new categoryFromUserWithPrompt: aPrompt for: self! ! !ClassDescription methodsFor: 'deprecated' stamp: 'sw 2/18/2001 21:14'! compileInobtrusively: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." | methodNode newMethod | methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^ nil]. self addSelector: methodNode selector withMethod: (newMethod _ methodNode generate: #(0 0 0 0)). self organization classify: methodNode selector under: category. ^ newMethod! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:42' prior: 35002929! compileInobtrusively: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." | methodNode newMethod | self deprecated: 'Use compileSilently:classified: instead.'. methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^ nil]. self addSelectorSilently: methodNode selector withMethod: (newMethod _ methodNode generate: #(0 0 0 0)). SystemChangeNotifier doSilently: [self organization classify: methodNode selector under: category]. ^ newMethod! ! !ClassDescription methodsFor: 'deprecated' stamp: 'avi 2/17/2004 01:59' prior: 35003624! compileInobtrusively: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." | methodNode newMethod | self deprecated: 'Use compileSilently:classified: instead.'. methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^ nil]. self addSelectorSilently: methodNode selector withMethod: (newMethod _ methodNode generate: #(0 0 0 0)). SystemChangeNotifier uniqueInstance doSilently: [self organization classify: methodNode selector under: category]. ^ newMethod! ! !ClassDescription methodsFor: 'deprecated' stamp: 'sw 2/18/2001 16:59'! compileProgrammatically: code classified: cat "compile the given code programmatically. In the current theory, we always do this unlogged as well, and do not accumulate the change in the current change set" ^ self compileInobtrusively: code classified: cat " | oldInitials | oldInitials _ Utilities authorInitialsPerSe. Utilities setAuthorInitials: 'programmatic'. self compile: code classified: cat. Utilities setAuthorInitials: oldInitials. "! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:43' prior: 35005228! compileProgrammatically: code classified: cat "compile the given code programmatically. In the current theory, we always do this unlogged as well, and do not accumulate the change in the current change set" self deprecated: 'Use compileSilently:classified: instead.'. ^ self compileSilently: code classified: cat " | oldInitials | oldInitials _ Utilities authorInitialsPerSe. Utilities setAuthorInitials: 'programmatic'. self compile: code classified: cat. Utilities setAuthorInitials: oldInitials. "! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:47' prior: 19319132! compileUnlogged: text classified: category notifying: requestor self deprecated: 'Use compileSilently:classified:notifying: instead.'. ^ self compileSilently: text classified: category notifying: requestor. " | selector | self compile: text asString notifying: requestor trailer: #(0 0 0 0) ifFail: [^ nil] elseSetSelectorAndNode: [:sel :node | selector _ sel]. self organization classify: selector under: category. ^ selector "! ! !ClassDescription methodsFor: 'deprecated' stamp: 'sw 10/29/2001 06:58'! letUserReclassify: anElement "Put up a list of categories and solicit one from the user. Answer true if user indeed made a change, else false" "ClassOrganizer organization letUserReclassify: #letUserReclassify:" | currentCat newCat | currentCat _ self organization categoryOfElement: anElement. newCat _ self categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")'. (newCat ~~ nil and: [newCat ~= currentCat]) ifTrue: [self organization classify: anElement under: newCat suppressIfDefault: false. ^ true] ifFalse: [^ false]! ! !ClassDescription methodsFor: 'deprecated' stamp: 'sd 2/1/2004 18:01' prior: 35006909! letUserReclassify: anElement "Put up a list of categories and solicit one from the user. Answer true if user indeed made a change, else false" self deprecated: 'Use CodeHolder>>letUserReclassify: anElement in: aClass'. CodeHolder new letUserReclassify: anElement in: self.! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/30/2004 13:14' prior: 19312371! removeSelectorUnlogged: aSymbol "Remove the message whose selector is aSymbol from the method dictionary of the receiver, if it is there. Answer nil otherwise. Do not log the action either to the current change set or to the changes log" self deprecated: 'Use removeSelectorSilently: instead'. (self methodDict includesKey: aSymbol) ifFalse: [^ nil]. super removeSelector: aSymbol. self organization removeElement: aSymbol! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 4/7/2004 13:33' prior: 35007939! removeSelectorUnlogged: aSymbol "Remove the message whose selector is aSymbol from the method dictionary of the receiver, if it is there. Answer nil otherwise. Do not log the action either to the current change set or to the changes log" self deprecated: 'Use removeSelectorSilently: instead'. (self methodDict includesKey: aSymbol) ifFalse: [^ nil]. SystemChangeNotifier uniqueInstance doSilently: [ self organization removeElement: aSymbol]. super removeSelector: aSymbol.! ! !ClassDescription methodsFor: '*system-support' stamp: 'sw 9/26/2001 01:51'! allUnreferencedClassVariables "Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses" | aList | aList _ OrderedCollection new. self withAllSuperclasses reverseDo: [:aClass | aClass classVarNames do: [:var | (Smalltalk allCallsOn: (aClass classPool associationAt: var)) size == 0 ifTrue: [aList add: var]]]. ^ aList! ! !ClassDescription methodsFor: '*system-support' stamp: 'sd 3/28/2003 15:31' prior: 35009027! allUnreferencedClassVariables "Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses" | aList | aList _ OrderedCollection new. self withAllSuperclasses reverseDo: [:aClass | aClass classVarNames do: [:var | (self environment allCallsOn: (aClass classPool associationAt: var)) size == 0 ifTrue: [aList add: var]]]. ^ aList! ! !ClassDescription methodsFor: '*system-support' stamp: 'sd 4/29/2003 13:10' prior: 35009528! allUnreferencedClassVariables self flag: #deprecated. self error: 'Method Deprecated: Use SystemNavigation>>allUnreferencedClassVariablesOf: instead'! ! !ClassDescription methodsFor: '*system-support' stamp: 'rw 5/13/2003 15:19' prior: 35010036! allUnreferencedClassVariables "Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses" | aList | self deprecatedExplanation: 'Method Deprecated: Use SystemNavigation>>allUnreferencedClassVariablesOf: instead'. aList _ OrderedCollection new. self withAllSuperclasses reverseDo: [:aClass | aClass classVarNames do: [:var | (self environment allCallsOn: (aClass classPool associationAt: var)) size == 0 ifTrue: [aList add: var]]]. ^ aList! ! !ClassDescription methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:45' prior: 35010285! allUnreferencedClassVariables "Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses" ^ self systemNavigation allUnreferencedClassVariablesOf: self! ! !ClassDescriptionTest methodsFor: 'initialize-release' stamp: 'md 3/26/2003 17:34'! setUp "I am the method in which your test is initialized. If you have ressources to build, put them here."! ! !ClassDescriptionTest methodsFor: 'initialize-release' stamp: 'md 3/26/2003 17:34'! tearDown "I am called whenever your test ends. I am the place where you release the ressources"! ! !ClassDescriptionTest methodsFor: 'testing' stamp: 'md 3/26/2003 17:37'! testOrganization | aClassOrganizer | aClassOrganizer := ClassDescription organization. self should: [aClassOrganizer isKindOf: ClassOrganizer].! ! !ClassDescriptionTest commentStamp: '' prior: 0! This is the unit test for the class ClassDescription. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !ClassDiffBuilder methodsFor: 'printing' stamp: 'nk 4/24/2004 08:49' prior: 19343229! printPatchSequence: ps on: aStream | type line | ps do: [:assoc | type := assoc key. line := assoc value. aStream withAttributes: (self attributesOf: type) do: [aStream nextPutAll: line]]! ! !ClassListBrowser methodsFor: 'initialization' stamp: 'sw 7/18/2002 22:43'! initForClassesNamed: nameList title: aTitle "Initialize the receiver for the class-name-list and title provided" self systemOrganizer: SystemOrganization. metaClassIndicated _ false. defaultTitle _ aTitle. classList _ nameList copy. self class openBrowserView: (self openSystemCatEditString: nil) label: aTitle "ClassListBrowser new initForClassesNamed: #(Browser CategoryViewer) title: 'Frogs'"! ! !ClassListBrowser methodsFor: 'title' stamp: 'sw 7/18/2002 22:42'! defaultTitle: aTitle "Set the browser's default title" defaultTitle _ aTitle! ! !ClassListBrowser methodsFor: 'title' stamp: 'sw 7/18/2002 22:43'! labelString "Answer the label strilng to use on the browser" ^ defaultTitle ifNil: [super labelString]! ! !ClassListBrowser commentStamp: '' prior: 0! A ClassListBrowser displays the code for an arbitrary list of classes. ClassListBrowser example1. "all classes that have the string 'Pluggable' in their names" ClassListBrowser example2. "all classes whose names start with the letter S" ClassListBrowser example3. "all variable classes" ClassListBrowser example4. "all classes with more than 100 methods" ClassListBrowser example5. "all classes that lack class comments" ClassListBrowser example6. "all classes that have class instance variables" ClassListBrowser new initForClassesNamed: #(Browser Boolean) title: 'Browser and Boolean!!'. ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:01'! example1 "Put up a ClassListBrowser that shows all classes that have the string 'Pluggable' in their names" self browseClassesSatisfying: [:cl | cl name includesSubString: 'Pluggable'] title: 'Pluggables' "ClassListBrowser example1" ! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 14:34'! example2 "Put up a ClassListBrowser that shows all classes whose names start with the letter S" self new initForClassesNamed: (Smalltalk allClasses collect: [:c | c name] thenSelect: [:aName | aName first == $S]) title: 'All classes starting with S' "ClassListBrowser example2" ! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sd 4/17/2003 21:21' prior: 35014326! example2 "Put up a ClassListBrowser that shows all classes whose names start with the letter S" self new initForClassesNamed: (self systemNavigation allClasses collect: [:c | c name] thenSelect: [:aName | aName first == $S]) title: 'All classes starting with S' "ClassListBrowser example2"! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:03'! example3 "Put up a ClassListBrowser that shows all Variable classes" self browseClassesSatisfying: [:c | c isVariable] title: 'All Variable classes' "ClassListBrowser example3" ! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:04'! example4 "Put up a ClassListBrowser that shows all classes implementing more than 100 methods" self browseClassesSatisfying: [:c | (c selectors size + c class selectors size) > 100] title: 'Classes with more than 100 methods' "ClassListBrowser example4" ! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 14:32'! example5 "Put up a ClassListBrowser that shows all classes that lack class comments" self browseClassesSatisfying: [:c | c organization classComment isEmptyOrNil] title: 'Classes lacking class comments' "ClassListBrowser example5" ! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 14:33'! example6 "Put up a ClassListBrowser that shows all classes that have class instance variables" self browseClassesSatisfying: [:c | c class instVarNames size > 0] title: 'Classes that define class-side instance variables' "ClassListBrowser example6"! ! !ClassListBrowser class methodsFor: 'instance creation' stamp: 'sw 7/27/2002 14:28'! browseClassesSatisfying: classBlock title: aTitle "Put up a ClassListBrowser showing all classes that satisfy the classBlock." self new initForClassesNamed: (Smalltalk allClasses select: [:c | (classBlock value: c) == true] thenCollect: [:c | c name]) title: aTitle! ! !ClassListBrowser class methodsFor: 'instance creation' stamp: 'sd 4/17/2003 21:21' prior: 35016379! browseClassesSatisfying: classBlock title: aTitle "Put up a ClassListBrowser showing all classes that satisfy the classBlock." self new initForClassesNamed: (self systemNavigation allClasses select: [:c | (classBlock value: c) == true] thenCollect: [:c | c name]) title: aTitle! ! !ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 10:15'! notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil (self hasSubject and: [oldCollectionOrNil ~= newCollectionOrNil]) ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! ! !ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 23:02'! notifyOfChangedCategoryFrom: oldNameOrNil to: newNameOrNil (self hasSubject and: [oldNameOrNil ~= newNameOrNil]) ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! ! !ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 22:52'! notifyOfChangedSelector: element from: oldCategory to: newCategory (self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [ SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self subject ].! ! !ClassOrganizer methodsFor: 'private' stamp: 'NS 4/12/2004 20:56'! notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil | newCat | (oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil]) ifTrue: [^ self]. oldDictionaryOrNil isNil ifTrue: [ newDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: nil to: cat]. ^ self. ]. newDictionaryOrNil isNil ifTrue: [ oldDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: cat to: nil]. ^ self. ]. oldDictionaryOrNil keysAndValuesDo: [:el :cat | newCat _ newDictionaryOrNil at: el. self notifyOfChangedSelector: el from: cat to: newCat. ].! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! addCategory: catString before: nextCategory | oldCategories | oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super addCategory: catString before: nextCategory]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:28'! changeFromCategorySpecs: categorySpecs | oldDict oldCategories | oldDict _ self elementCategoryDict. oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super changeFromCategorySpecs: categorySpecs]. self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! classify: element under: heading suppressIfDefault: aBoolean | oldCat newCat | oldCat _ self categoryOfElement: element. SystemChangeNotifier uniqueInstance doSilently: [ super classify: element under: heading suppressIfDefault: aBoolean]. newCat _ self categoryOfElement: element. self notifyOfChangedSelector: element from: oldCat to: newCat.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! removeCategory: cat | oldCategories | oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super removeCategory: cat]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! removeElement: element | oldCat | oldCat _ self categoryOfElement: element. SystemChangeNotifier uniqueInstance doSilently: [ super removeElement: element]. self notifyOfChangedSelector: element from: oldCat to: (self categoryOfElement: element).! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'! removeEmptyCategories | oldCategories | oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super removeEmptyCategories]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'! renameCategory: oldCatString toBe: newCatString | oldCat newCat oldElementsBefore oldElementsAfter | oldCat _ oldCatString asSymbol. newCat _ newCatString asSymbol. oldElementsBefore _ self listAtCategoryNamed: oldCat. SystemChangeNotifier uniqueInstance doSilently: [ super renameCategory: oldCatString toBe: newCatString]. oldElementsAfter _ (self listAtCategoryNamed: oldCat) asSet. oldElementsBefore do: [:each | (oldElementsAfter includes: each) ifFalse: [self notifyOfChangedSelector: each from: oldCat to: newCat]. ]. self notifyOfChangedCategoryFrom: oldCat to: newCat.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/12/2004 20:57'! setDefaultList: aSortedCollection | oldDict oldCategories | oldDict _ self elementCategoryDict. oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super setDefaultList: aSortedCollection]. self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'! sortCategories | oldCategories | oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super sortCategories]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer commentStamp: 'NS 4/6/2004 16:13' prior: 0! I represent method categorization information for classes. The handling of class comments has gone through a tortuous evolution. Grandfathered class comments (before late aug 98) have no time stamps, and historically, fileouts of class comments always substituted the timestamp reflecting the author and date/time at the moment of fileout; and historically any timestamps in a filed out class comment were dropped on the floor, with the author & time prevailing at the moment of filein being substituted. Such grandfathered comments now go out on fileouts with '' timestamp; class comments created after the 8/98 changes will have their correct timestamps preserved, though there is not yet a decent ui for reading those stamps other than filing out and looking at the file; nor is there yet any ui for browsing and recovering past versions of such comments. Everything in good time!!! !ClassRenameFixTest methodsFor: 'Private' stamp: 'rw 8/23/2003 16:04'! newUniqueClassName "Return a class name that is not used in the system." "self new newClassName" | baseName newName | baseName := 'AutoGeneratedClassForTestingSystemChanges'. 1 to: 9999 do: [:number | newName := baseName , number printString. (Smalltalk hasClassNamed: newName) ifFalse: [^newName asSymbol]]. ^self error: 'Can no longer find a new and unique class name for the SystemChangeTest !!'! ! !ClassRenameFixTest methodsFor: 'Private' stamp: 'rw 8/23/2003 16:17'! removeEverythingInSetFromSystem: aChangeSet aChangeSet changedMessageList do: [:methodRef | methodRef actualClass removeSelector: methodRef methodSymbol]. aChangeSet changedClasses do: [:each | each isMeta ifFalse: [each removeFromSystemUnlogged]]! ! !ClassRenameFixTest methodsFor: 'Tests' stamp: 'rw 8/23/2003 16:46'! renameClassUsing: aBlock | originalName createdClass newClassName foundClasses | originalName := self newUniqueClassName. createdClass := Object subclass: originalName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ClassRenameFix-GeneradClass'. newClassName := self newUniqueClassName. aBlock value: createdClass value: newClassName. self assert: (Smalltalk classNamed: originalName) isNil. self assert: (Smalltalk classNamed: newClassName) notNil. foundClasses := Smalltalk organization listAtCategoryNamed: 'ClassRenameFix-GeneradClass'. self assert: (foundClasses notEmpty). self assert: (foundClasses includes: newClassName). self assert: (createdClass name = newClassName).! ! !ClassRenameFixTest methodsFor: 'Tests' stamp: 'rw 8/23/2003 16:45'! testRenameClassUsingClass "self run: #testRenameClassUsingClass" self renameClassUsing: [:class :newName | class rename: newName].! ! !ClassRenameFixTest methodsFor: 'Tests' stamp: 'rw 8/23/2003 16:45'! testRenameClassUsingSystemDictionary "self run: #testRenameClassUsingSystemDictionary" self renameClassUsing: [:class :newName | Smalltalk renameClass: class as: newName].! ! !ClassRenameFixTest methodsFor: 'Running' stamp: 'rw 8/23/2003 16:16'! setUp previousChangeSet := ChangeSet current. testsChangeSet := ChangeSet new. ChangeSet newChanges: testsChangeSet. super setUp! ! !ClassRenameFixTest methodsFor: 'Running' stamp: 'rw 8/23/2003 16:17'! tearDown self removeEverythingInSetFromSystem: testsChangeSet. ChangeSet newChanges: previousChangeSet. ChangeSorter removeChangeSet: testsChangeSet. previousChangeSet := nil. testsChangeSet := nil. super tearDown.! ! !ClassTest methodsFor: 'setup' stamp: 'md 1/5/2004 14:59'! setUp Smalltalk removeClassNamed: #TUTU. Object subclass: #TUTU instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Kernel-Classes'! ! !ClassTest methodsFor: 'setup' stamp: 'sd 12/28/2003 10:53'! tearDown Smalltalk removeClassNamed: #TUTU. ! ! !ClassTest methodsFor: 'testing' stamp: 'md 1/5/2004 14:59'! testAddInstVarName "self run: #testAddInstVarName" | tutu | tutu := Smalltalk at: #TUTU. tutu addInstVarName: 'x'. self assert: (tutu instVarNames = #('x')). tutu addInstVarName: 'y'. self assert: (tutu instVarNames = #('x' 'y')) ! ! !ClassTest methodsFor: 'testing - compiling' stamp: 'md 4/16/2003 14:54'! testCompileAll self shouldnt: [ClassTest compileAll] raise: Error.! ! !ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:32'! categoriesForClass: aClass ^ aClass organization allMethodSelectors collect: [:each | aClass organization categoryOfElement: each]. ! ! !ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:32' prior: 35026720! categoriesForClass: aClass ^ aClass organization allMethodSelectors collect: [:each | aClass organization categoryOfElement: each]. ! ! !ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:28'! targetClass |className| className := self class name asText copyFrom: 0 to: self class name size - 4. ^ Smalltalk at: (className asString asSymbol). ! ! !ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:28' prior: 35027156! targetClass |className| className := self class name asText copyFrom: 0 to: self class name size - 4. ^ Smalltalk at: (className asString asSymbol). ! ! !ClassTestCase methodsFor: 'testing' stamp: 'md 3/26/2003 17:39'! testClassComment self shouldnt: [self targetClass organization hasNoComment].! ! !ClassTestCase methodsFor: 'testing' stamp: 'md 3/26/2003 17:39' prior: 35027626! testClassComment self shouldnt: [self targetClass organization hasNoComment].! ! !ClassTestCase methodsFor: 'testing' stamp: 'md 3/25/2003 23:07'! testNew self shouldnt: [self targetClass new] raise: Error.! ! !ClassTestCase methodsFor: 'testing' stamp: 'md 3/25/2003 23:07' prior: 35027940! testNew self shouldnt: [self targetClass new] raise: Error.! ! !ClassTestCase methodsFor: 'testing' stamp: 'md 3/26/2003 17:24'! testUnCategorizedMethods | categories slips | categories := self categoriesForClass: self targetClass. slips := categories select: [:each | each = #'as yet unclassified']. self should: [slips isEmpty]. ! ! !ClassTestCase methodsFor: 'testing' stamp: 'md 3/26/2003 17:24' prior: 35028218! testUnCategorizedMethods | categories slips | categories := self categoriesForClass: self targetClass. slips := categories select: [:each | each = #'as yet unclassified']. self should: [slips isEmpty]. ! ! !ClassTestCase methodsFor: 'Tests' stamp: 'brp 12/14/2003 15:51'! testCoverage | untested | self class mustTestCoverage ifTrue: [ untested := self selectorsNotTested. self assert: untested isEmpty description: untested size asString, ' selectors are not covered' ]! ! !ClassTestCase methodsFor: 'Private' stamp: 'brp 8/6/2003 19:24'! resumeFromDeprecatedMethods: autoResume "If true, make the default action for all Deprecation warnings to resume" | da | autoResume ifTrue: [Deprecation compiledMethodAt: #defaultAction ifAbsent: [ Deprecation addSelector: #defaultAction withMethod: (Notification >> #defaultAction) ] ] ifFalse: [da _ Deprecation compiledMethodAt: #defaultAction ifAbsent: []. da == (Notification >> #defaultAction) ifTrue: [ Deprecation removeSelectorSimply: #defaultAction] ] ! ! !ClassTestCase methodsFor: 'Private' stamp: 'rhi 5/27/2004 14:04' prior: 35029070! resumeFromDeprecatedMethods: autoResume "If true, make the default action for all Deprecation warnings to resume" | da | autoResume ifTrue: [Deprecation compiledMethodAt: #defaultAction ifAbsent: [ Deprecation addSelector: #defaultAction withMethod: (Notification >> #defaultAction) ] ] ifFalse: [da _ Deprecation compiledMethodAt: #defaultAction ifAbsent: []. da == (Notification >> #defaultAction) ifTrue: [ Deprecation basicRemoveSelector: #defaultAction] ]! ! !ClassTestCase methodsFor: 'Running' stamp: 'brp 8/6/2003 19:25'! setUp self resumeFromDeprecatedMethods: true.! ! !ClassTestCase methodsFor: 'Running' stamp: 'brp 8/6/2003 19:26'! tearDown self resumeFromDeprecatedMethods: false.! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:39'! classToBeTested self subclassResponsibility! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/26/2003 16:35'! selectorsNotTested ^ self selectorsToBeTested difference: self selectorsTested. ! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/26/2003 17:36'! selectorsTested | literals | literals _ Set new. self class selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test') ifTrue: [ literals addAll: (m literals select: [ :l | l isSymbol and: [l first isLowercase]]) ] ]. ^ literals! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/26/2003 17:22'! selectorsToBeIgnored ^ #(#DoIt #DoItIn:)! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:40'! selectorsToBeTested ^ ( { self classToBeTested. self classToBeTested class } gather: [:c | c selectors]) difference: self selectorsToBeIgnored! ! !ClassTestCase commentStamp: 'brp 7/26/2003 16:57' prior: 0! This class is intended for unit tests of individual classes and their metaclasses. It provides methods to determine the coverage of the unit tests. Subclasses are expected to re-implement #classesToBeTested and #selectorsToBeIgnored. They should also implement to confirm that all methods have been tested. #testCoverage super testCoverage. ! !ClassTestCase class methodsFor: 'Testing' stamp: 'md 1/28/2004 11:50'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self sunitName = #ClassTestCase ! ! !ClassTestCase class methodsFor: 'Testing' stamp: 'brp 7/27/2003 12:53' prior: 35031807! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self sunitName = #ClassTestCase ! ! !ClassTestCase class methodsFor: 'Testing' stamp: 'brp 12/14/2003 15:50'! mustTestCoverage ^ false! ! !CleanKernelTest methodsFor: 'utility'! classesCreated classesCreated ifNil: [ classesCreated := OrderedCollection new]. ^ classesCreated! ! !CleanKernelTest methodsFor: 'utility'! createClassNamed: aClassname ^ self createClassNamed: aClassname superClass: Object! ! !CleanKernelTest methodsFor: 'utility' stamp: 'rw 5/12/2003 12:33'! createClassNamed: aClassname superClass: aClass ^self createClassNamed: aClassname superClass: aClass instanceVariables: ''! ! !CleanKernelTest methodsFor: 'utility' stamp: 'md 10/30/2003 09:49'! createClassNamed: aClassname superClass: aClass instanceVariables: instvarString | r | r := aClass subclass: aClassname instanceVariableNames: instvarString classVariableNames: '' poolDictionaries: '' category: 'Tests-KCP'. self classesCreated add: r. ^ r! ! !CleanKernelTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:45'! isSelector: aSymbol definedInClass: aClassSymbol | cls | cls := Smalltalk at: aClassSymbol ifAbsent: [^ false]. ^ cls selectors includes: aSymbol! ! !CleanKernelTest methodsFor: 'utility' stamp: 'sd 4/29/2003 21:43'! isSelector: aSymbol definedInClassOrMetaClass: aClass ^ (aClass selectors includes: aSymbol)! ! !CleanKernelTest methodsFor: 'utility' stamp: 'rw 5/13/2003 16:19'! isSelector: aSymbol deprecatedInClass: aClassSymbol | cls | cls _ Smalltalk at: aClassSymbol ifAbsent: [^ false]. ^ (cls >> aSymbol) literals includesAllOf: #(deprecatedExplanation:)! ! !CleanKernelTest methodsFor: 'utility'! removeClassNamedIfExists: aClassname Smalltalk at: aClassname ifPresent: [:cls| cls removeFromSystem]. Smalltalk at: aClassname ifPresent: [:clss| self error: 'Error !!!!']! ! !CleanKernelTest methodsFor: 'Running' stamp: 'rw 5/12/2003 12:52'! setUp | classBuilderTestClass classBuilderTestSubClass | self createClassNamed: #ClassBuilderTestClass superClass: Object instanceVariables: 'var1 var2'. classBuilderTestClass := (Smalltalk at: #ClassBuilderTestClass). classBuilderTestClass compile: 'var1 ^var1'. classBuilderTestClass compile: 'var1: object var1 := object'. classBuilderTestClass compile: 'var2 ^var2'. classBuilderTestClass compile: 'var2: object var2 := object'. self createClassNamed: #ClassBuilderTestSubClass superClass: classBuilderTestClass instanceVariables: 'var3 var4'. classBuilderTestSubClass := (Smalltalk at: #ClassBuilderTestSubClass). classBuilderTestSubClass compile: 'var3 ^var3'. classBuilderTestSubClass compile: 'var3: object var3 := object'. classBuilderTestSubClass compile: 'var4 ^var4'. classBuilderTestSubClass compile: 'var4: object var4 := object'.! ! !CleanKernelTest methodsFor: 'Running' stamp: 'sd 5/23/2003 14:52'! tearDown | name | self classesCreated do: [:cls | name _ cls name. self removeClassNamedIfExists: name. ChangeSet current removeClassChanges: name]. classesCreated _ nil! ! !CleanKernelTest methodsFor: 'behavior'! testAccessingClassHierarchy "self run: #testAccessingClassHierarchy" | clsRoot clsA clsB clsC1 clsC2 | clsRoot _ self createClassNamed: #Root. clsA _ self createClassNamed: #A superClass: clsRoot. clsB _ self createClassNamed: #B superClass: clsA. clsC1 _ self createClassNamed: #C1 superClass: clsB. clsC2 _ self createClassNamed: #C2 superClass: clsB. "--------" self assert: clsRoot subclasses size = 1. self assert: (clsRoot subclasses includes: clsA). self assert: clsB subclasses size = 2. self assert: (clsB subclasses includesAllOf: (Array with: clsC1 with: clsC2)). self assert: clsC1 subclasses isEmpty. "--------" self assert: clsRoot allSubclasses size = 4. self assert: (clsRoot allSubclasses includesAllOf: (Array with: clsA with: clsB with: clsC1 with: clsC2)). "--------" self assert: clsRoot withAllSubclasses size = 5. self assert: (clsRoot withAllSubclasses includesAllOf: (Array with: clsA with: clsB with: clsC1 with: clsC2 with: clsRoot)). ! ! !CleanKernelTest methodsFor: 'behavior'! testAccessingClassHierarchySuperclasses "self run: #testAccessingClassHierarchySuperclasses" | clsRoot clsA clsB clsC1 clsC2 | clsRoot _ self createClassNamed: #Root. clsA _ self createClassNamed: #A superClass: clsRoot. clsB _ self createClassNamed: #B superClass: clsA. clsC1 _ self createClassNamed: #C1 superClass: clsB. clsC2 _ self createClassNamed: #C2 superClass: clsB. "--------" self assert: clsC2 superclass == clsB. self assert: (clsC2 allSuperclasses includes: clsA). self assert: clsC2 allSuperclasses size = 5. self assert: (clsC2 allSuperclasses includesAllOf: (Array with: clsB with: clsA with: clsRoot with: Object with: ProtoObject)). "--------" self assert: clsC1 superclass == clsB. self assert: (clsC1 allSuperclasses includes: clsA). self assert: clsC1 allSuperclasses size = 5. self assert: (clsC1 allSuperclasses includesAllOf: (Array with: clsB with: clsA with: clsRoot with: Object with: ProtoObject)). "--------" self assert: clsC2 withAllSuperclasses size = (clsC2 allSuperclasses size + 1). self assert: (clsC2 withAllSuperclasses includesAllOf: clsC2 allSuperclasses). self assert: (clsC2 withAllSuperclasses includes: clsC2). "--------" self assert: clsC1 withAllSuperclasses size = (clsC1 allSuperclasses size + 1). self assert: (clsC1 withAllSuperclasses includesAllOf: clsC1 allSuperclasses). self assert: (clsC1 withAllSuperclasses includes: clsC1)! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/29/2003 13:15'! testAllCallsOn "self run: #testAllCallsOn" self class forgetDoIts. self assert: (SystemNavigation new allCallsOn: #zoulouSymbol) size = 7. self assert: (SystemNavigation new allCallsOn: #callingAnotherMethod) size = 2! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/29/2003 13:17'! testAllCallsOnAnd "self run: #testAllCallsOnAnd" self class forgetDoIts. self assert: (SystemNavigation new allCallsOn: #zoulouSymbol and: #callingAThirdMethod) size = 2. self assert: (SystemNavigation new allCallsOn: #callingAThirdMethod and: #inform:) size = 1! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/29/2003 20:43'! testAllMethodsSelect "self run: #testAllMethodsSelect" | res | res _ SystemNavigation new allMethodsSelect: [:each | each messages includes: #zoulouSymbol]. self assert: res size = 1. self assert: (res at: 1) methodSymbol = #callingAThirdMethod! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/18/2003 10:44'! testIsThereAnImplementorOf "self run: #testIsThereAnImplementorOf" self deny: (SystemNavigation new isThereAnImplementorOf: #nobodyImplementsThis) . self assert: (SystemNavigation new isThereAnImplementorOf: #zoulouSymbol).! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/18/2003 10:41'! testNumberOfImplementors "self run: #testNumberOfImplementors" self assert: (SystemNavigation new numberOfImplementorsOf: #nobodyImplementsThis) isZero. self assert: (SystemNavigation new numberOfImplementorsOf: #zoulouSymbol) = 2.! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:29'! testBehaviorDefineIsMeta self deny: Behavior new isMeta! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:29'! testMetaclassDefineIsMeta self assert: Metaclass new isMeta! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:37'! testMovePowerManagementToPwerManagement self assert: (self isSelector: #disablePowerManager definedInClassOrMetaClass: PowerManagement class). self assert: (self isSelector: #enablePowerManager definedInClassOrMetaClass: PowerManagement class). self assert: (self isSelector: #disablePowerManager: definedInClassOrMetaClass: PowerManagement class). self assert: (self isSelector: #itsyVoltage definedInClassOrMetaClass: PowerManagement class)! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:45'! testMoveSortAllCategoriesToClassOrganizer self assert: (self isSelector: #sortAllCategories definedInClassOrMetaClass: ClassOrganizer class). ! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:29'! testPullUpIsMeta self deny: (self isSelector: #isMeta definedInClass: #ClassDescription). self deny: (self isSelector: #isMeta definedInClass: #Class). self assert: (self isSelector: #isMeta definedInClass: #Behavior)! ! !CleanKernelTest methodsFor: 'isMeta'! testPullUpIsWithAllSubclasses "self run: #testPullUpIsWithAllSubclasses" self deny: (self isSelector: #withAllSubclasses definedInClass: #ClassDescription). self assert: (self isSelector: #withAllSubclasses definedInClass: #Behavior)! ! !CleanKernelTest methodsFor: 'environment' stamp: 'sd 3/28/2003 16:08'! testMetaclassClassClassDescriptionDoesNotReferToSmalltalk "self run: #testMetaclassClassClassDescriptionDoesNotReferToSmalltalk" self deny: ((Analyzer externalReferenceOf: (Array with: Metaclass)) includes: #Smalltalk). self deny: ((Analyzer externalReferenceOf: (Array with: ClassDescription)) includes: #Smalltalk). self deny: ((Analyzer externalReferenceOf: (Array with: Class)) includes: #Smalltalk).! ! !CleanKernelTest methodsFor: 'environment' stamp: 'sd 3/28/2003 16:06'! testMetaclassDoesNotReferToSmalltalk "self run: #testMetaclassDoesNotReferToSmalltalk" self deny: ((Analyzer externalReferenceOf: (Array with: Metaclass)) includes: #Smalltalk).! ! !CleanKernelTest methodsFor: 'environment' stamp: 'sd 3/28/2003 15:16'! testNilEnvironment "self run: #testNilEnvironment" self assert: nil environment == Smalltalk! ! !CleanKernelTest methodsFor: 'allSubclasses' stamp: 'md 10/30/2003 09:30'! testPullUpAllSubclasses self deny: (self isSelector: #allSubclasses definedInClass: #ClassDescription). self assert: (self isSelector: #allSubclasses definedInClass: #Behavior)! ! !CleanKernelTest methodsFor: 'browing' stamp: 'sd 3/28/2003 17:00'! testRemoveBroweMethod self deny: (self isSelector: #browse definedInClass: #Behavior)! ! !CleanKernelTest methodsFor: 'module reference' stamp: 'md 10/29/2003 23:44'! testRemoveSubclassModuleMethod self deny: (self isSelector: #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:module: definedInClass: #Class)! ! !CleanKernelTest methodsFor: 'module reference' stamp: 'sd 3/28/2003 18:15'! testRemoveSubclassModuleMethodInClass self deny: (self isSelector: #existingCategoryFor:orConvert: definedInClass: #Class). self deny: (self isSelector: #subclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). self deny: (self isSelector: #variableByteSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). self deny: (self isSelector: #variableSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). self deny: (self isSelector: #variableWordSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). self deny: (self isSelector: #weakSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). ! ! !CleanKernelTest methodsFor: 'classBuilder' stamp: 'rw 5/12/2003 12:48'! testReshapeClass "see if reshaping classes works" "self run: #testReshapeClass" | testInstance testClass testMeta newClass newMeta | testClass _ Smalltalk at: #ClassBuilderTestClass. testMeta _ testClass class. testInstance _ testClass new. testInstance var1: 42. testInstance var2: 'hello'. newClass _ self createClassNamed: #ClassBuilderTestClass superClass: Object instanceVariables: 'foo var1 bar var2 mumble'. newMeta _ newClass class. "test transparency of mapping" self assert: testInstance var1 = 42. self assert: testInstance var2 = 'hello'. self assert: (testInstance instVarAt: 1) isNil. self assert: (testInstance instVarAt: 2) = 42. self assert: (testInstance instVarAt: 3) isNil. self assert: (testInstance instVarAt: 4) = 'hello'. self assert: (testInstance instVarAt: 5) isNil. "test transparency of reshapes" self assert: testInstance class == newClass. self assert: testClass == newClass. self assert: testMeta == newMeta! ! !CleanKernelTest methodsFor: 'classBuilder' stamp: 'rw 5/12/2003 12:49'! testReshapeClassWithJugglingInstVars "see if reshapes of classes juggle their instVars correctly" | testInstance testClass testMeta newClass newMeta | testClass _ Smalltalk at: #ClassBuilderTestClass. testMeta _ testClass class. testInstance _ testClass new. testInstance var1: 42. testInstance var2: 'hello'. newClass _ self createClassNamed: #ClassBuilderTestClass superClass: Object instanceVariables: 'var2 foo bar mumble var1'. newMeta _ newClass class. "test transparency of mapping" self assert: testInstance var1 = 42. self assert: testInstance var2 = 'hello'. self assert: (testInstance instVarAt: 1) = 'hello'. self assert: (testInstance instVarAt: 2) isNil. self assert: (testInstance instVarAt: 3) isNil. self assert: (testInstance instVarAt: 4) isNil. self assert: (testInstance instVarAt: 5) = 42. "test transparency of reshapes" self assert: testInstance class == newClass. self assert: testClass == newClass. self assert: testMeta == newMeta! ! !CleanKernelTest methodsFor: 'classBuilder' stamp: 'rw 5/12/2003 12:55'! testReshapeSubClass "self run: #testReshapeSubClass" "self debug: #testReshapeSubClass" | testInstance testClass testMeta | testClass _ Smalltalk at: #ClassBuilderTestSubClass. testMeta _ testClass class. testInstance _ testClass new. testInstance var1: 42. testInstance var2: 'hello'. testInstance var3: 'foo'. testInstance var4: #bar. self createClassNamed: #ClassBuilderTestClass superClass: Object instanceVariables: 'var1 foo var2 bar mumble '. self assert: testInstance var1 = 42. self assert: testInstance var2 = 'hello'. self assert: testInstance var3 = 'foo'. self assert: testInstance var4 = #bar. self assert: (testInstance instVarAt: 1) = 42. self assert: (testInstance instVarAt: 2) isNil. self assert: (testInstance instVarAt: 3) = 'hello'. self assert: (testInstance instVarAt: 4) isNil. self assert: (testInstance instVarAt: 5) isNil. self assert: (testInstance instVarAt: 6) = 'foo'. self assert: (testInstance instVarAt: 7) = #bar. self assert: testInstance class == (Smalltalk at: #ClassBuilderTestSubClass). self assert: testClass == (Smalltalk at: #ClassBuilderTestSubClass). self assert: testMeta == (Smalltalk at: #ClassBuilderTestSubClass) class! ! !CleanKernelTest methodsFor: 'classBuilder' stamp: 'sd 5/23/2003 14:52'! testValidateSubclassFormatFix "Recompiling Array" self shouldnt: [ArrayedCollection variableSubclass: #Array instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'] raise: Error. ChangeSet current removeClassChanges: #Array! ! !CleanKernelTest methodsFor: 'theNonMetaclass' stamp: 'sd 6/27/2003 23:09'! testTheMetaClass "self run: #testTheMetaClass" self assert: Class class theMetaClass == Class class. self assert: Class theMetaClass == Class class.! ! !CleanKernelTest methodsFor: 'theNonMetaclass' stamp: 'sd 6/27/2003 23:10'! testTheNonMetaClass "self run: #testTheNonMetaClass" self assert: Class class theNonMetaClass == Class. self assert: Class theNonMetaClass == Class.! ! !Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:07'! clearInterpreter interpreter _ nil. ! ! !Clipboard methodsFor: 'accessing' stamp: 'RAA 2/6/2001 11:18'! clipboardText "Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard." | s | s _ self primitiveClipboardText. (s isEmpty or: [s = contents asString]) ifTrue: [^ contents] ifFalse: [^ s asText]! ! !Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:04' prior: 35047868! clipboardText "Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard." | string decodedString | string _ self primitiveClipboardText. (string isEmpty or: [string = contents asString]) ifTrue: [^ contents]. decodedString _ self interpreter fromSystemClipboard: string. ^ decodedString = contents asString ifTrue: [contents] ifFalse: [decodedString asText]. ! ! !Clipboard methodsFor: 'accessing' stamp: 'RAA 2/6/2001 11:21'! clipboardText: text "Set text currently on the clipboard. Also export to OS" contents _ text. self noteRecentClipping: text asText. self primitiveClipboardText: text asString! ! !Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:12' prior: 35049095! clipboardText: text | string | string _ text asString. self noteRecentClipping: text asText. contents _ text asText. string _ self interpreter toSystemClipboard: string. self primitiveClipboardText: string. ! ! !Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 18:23'! interpreter interpreter ifNil: [self setInterpreter]. ^ interpreter. ! ! !Clipboard methodsFor: 'accessing' stamp: 'yo 9/26/2003 11:51'! setInterpreter interpreter _ Smalltalk systemLanguage defaultClipboardInterpreter. interpreter ifNil: [interpreter _ NoConversionClipboardInterpreter new]. ! ! !Clipboard class methodsFor: 'class initialization' stamp: 'yo 8/11/2003 22:43'! clearInterpreters self allInstances do: [:each | each clearInterpreter]. ! ! !ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 19:03'! fromSystemClipboard: aString self subclassResponsibility. ! ! !ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 19:03'! toSystemClipboard: aString self subclassResponsibility. ! ! !ClipboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color r: 1.0 g: 0.355 b: 0.452! ! !ClipboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 6! ! !ClipboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color blue! ! !ClipboardMorph methodsFor: 'parts bin' stamp: 'sw 7/30/2001 23:31'! initializeToStandAlone super initializeToStandAlone. self initialize. color _ Color blue. self borderWidth: 6; borderColor: (Color r: 1.0 g: 0.355 b: 0.452). self extent: 200 @ 100. self backgroundColor: (Color r: 0.484 g: 1.0 b: 0.484). self setBalloonText: 'This shows the current contents of the text clipboard'. self newContents: Clipboard clipboardText! ! !ClipboardMorph methodsFor: 'parts bin' stamp: 'dgd 2/14/2003 22:09' prior: 35050994! initializeToStandAlone super initializeToStandAlone. "" self initialize. "" self extent: 200 @ 100. self backgroundColor: (Color r: 0.484 g: 1.0 b: 0.484). self setBalloonText: 'This shows the current contents of the text clipboard'. self newContents: Clipboard clipboardText! ! !ClipboardMorph methodsFor: 'stepping and presenter' stamp: 'sw 6/27/2001 14:15'! step self newContents: Clipboard clipboardText! ! !ClipboardMorph methodsFor: 'testing' stamp: 'sw 6/27/2001 14:18'! stepTime "Answer the interval between steps -- in this case a leisurely 1 seconds" ^ 1000! ! !ClipboardMorph methodsFor: 'testing' stamp: 'sw 6/27/2001 13:40'! wantsSteps ^ true! ! !ClipboardMorph commentStamp: '' prior: 0! A morph that always displays the current contents of the text clipboard.! !ClipboardMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:21'! descriptionForPartsBin ^ self partName: 'Clipboard' categories: #('Useful') documentation: 'This object will always show whatever is on the text clipboard'! ! !ClockMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42' prior: 19372485! initialize "initialize the state of the receiver" super initialize. "" showSeconds _ true. self step! ! !ClockMorph methodsFor: 'initialization' stamp: 'fc 2/8/2004 11:33' prior: 35052595! initialize "initialize the state of the receiver" super initialize. "" showSeconds _ true. show24hr _ false. self step! ! !ClockMorph methodsFor: 'parts bin' stamp: 'sw 7/12/2001 17:41'! initializeToStandAlone super initializeToStandAlone. showSeconds _ true. self step! ! !ClockMorph methodsFor: 'stepping and presenter' stamp: 'fc 2/8/2004 11:40' prior: 19372751! step | time | super step. time _ String streamContents: [:aStrm | Time now print24: (show24hr == true) showSeconds: (showSeconds == true) on: aStrm]. self contents: time ! ! !ClockMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:17' prior: 19372018! addCustomMenuItems: aCustomMenu hand: aHandMorph "Note minor loose end here -- if the menu is persistent, then the wording will be wrong half the time" | item | super addCustomMenuItems: aCustomMenu hand: aHandMorph. item _ showSeconds == true ifTrue: ['stop showing seconds'] ifFalse: ['start showing seconds']. aCustomMenu add: item translated target: self action: #toggleShowingSeconds ! ! !ClockMorph methodsFor: 'menu' stamp: 'fc 2/8/2004 11:57' prior: 35053424! addCustomMenuItems: aCustomMenu hand: aHandMorph "Note minor loose end here -- if the menu is persistent, then the wording will be wrong half the time" | item | super addCustomMenuItems: aCustomMenu hand: aHandMorph. item _ showSeconds == true ifTrue: ['stop showing seconds'] ifFalse: ['start showing seconds']. aCustomMenu add: item translated target: self action: #toggleShowingSeconds. item _ show24hr == true ifTrue: ['display Am/Pm'] ifFalse: ['display 24 hour']. aCustomMenu add: item translated target: self action: #toggleShowing24hr. ! ! !ClockMorph methodsFor: '24hr' stamp: 'fc 2/8/2004 11:38'! show24hr: aBoolean show24hr _ aBoolean! ! !ClockMorph methodsFor: '24hr' stamp: 'fc 2/8/2004 11:39'! toggleShowing24hr show24hr _ (show24hr == true) not ! ! !ClockMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:22'! descriptionForPartsBin ^ self partName: 'Clock' categories: #('Useful') documentation: 'A digital clock'! ! !ClockMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:00'! initialize self registerInFlapsRegistry. ! ! !ClockMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:02'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(ClockMorph authoringPrototype 'Clock' 'A simple digital clock') forFlapNamed: 'Supplies'. cl registerQuad: #(ClockMorph authoringPrototype 'Clock' 'A simple digital clock') forFlapNamed: 'PlugIn Supplies'.]! ! !ClockMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:33'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !CodeHolder methodsFor: 'annotation' stamp: 'jcg 9/22/2001 00:41'! addOptionalAnnotationsTo: window at: fractions plus: verticalOffset "Add an annotation pane to the window if preferences indicate a desire for it, and return the incoming verticalOffset plus the height of the added pane, if any" | aTextMorph divider delta | self wantsAnnotationPane ifFalse: [^ verticalOffset]. aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: #annotationPaneMenu:shifted:. aTextMorph askBeforeDiscardingEdits: false; borderWidth: 0; hideScrollBarIndefinitely. divider _ BorderedSubpaneDividerMorph forBottomEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. delta _ self defaultAnnotationPaneHeight. window addMorph: aTextMorph fullFrame: (LayoutFrame fractions: fractions offsets: (0@verticalOffset corner: 0@(verticalOffset + delta - 1))). window addMorph: divider fullFrame: (LayoutFrame fractions: fractions offsets: (0@(verticalOffset + delta - 1) corner: 0@(verticalOffset + delta))). ^ verticalOffset + delta! ! !CodeHolder methodsFor: 'annotation' stamp: 'nk 4/28/2004 10:16' prior: 35055769! addOptionalAnnotationsTo: window at: fractions plus: verticalOffset "Add an annotation pane to the window if preferences indicate a desire for it, and return the incoming verticalOffset plus the height of the added pane, if any" | aTextMorph divider delta | self wantsAnnotationPane ifFalse: [^ verticalOffset]. aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: #annotationPaneMenu:shifted:. aTextMorph askBeforeDiscardingEdits: false; borderWidth: 0; hideScrollBarsIndefinitely. divider _ BorderedSubpaneDividerMorph forBottomEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. delta _ self defaultAnnotationPaneHeight. window addMorph: aTextMorph fullFrame: (LayoutFrame fractions: fractions offsets: (0@verticalOffset corner: 0@(verticalOffset + delta - 1))). window addMorph: divider fullFrame: (LayoutFrame fractions: fractions offsets: (0@(verticalOffset + delta - 1) corner: 0@(verticalOffset + delta))). ^ verticalOffset + delta! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:00'! addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream "add an annotation detailing the prior versions count" | versionsCount | versionsCount _ VersionsBrowser versionCountForSelector: aSelector class: aClass. aStream nextPutAll: ((versionsCount > 1 ifTrue: [versionsCount == 2 ifTrue: ['1 prior version'] ifFalse: [versionsCount printString, ' prior versions']] ifFalse: ['no prior versions']), self annotationSeparator)! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 9/11/2002 21:30'! annotationForClassCommentFor: aClass "Provide a line of content for an annotation pane, given that the receiver is pointing at the clas comment of the given class." | aStamp nonMeta | aStamp _ (nonMeta _ aClass theNonMetaClass) organization commentStamp. ^ aStamp ifNil: [nonMeta name, ' has no class comment'] ifNotNil: ['class comment for ', nonMeta name, (aStamp = '' ifFalse: [' - ', aStamp] ifTrue: [''])]! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'! annotationForClassDefinitionFor: aClass "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." ^ 'Class definition for ', aClass name! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'! annotationForHierarchyFor: aClass "Provide a line of content for an annotation pane, given that the receiver is pointing at the hierarchy of the given class." ^ 'Hierarchy for ', aClass name! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:15'! annotationForSelector: aSelector ofClass: aClass "Provide a line of content for an annotation pane, representing information about the given selector and class" | stamp sendersCount implementorsCount aCategory separator aString aList aComment aStream requestList | aSelector == #Comment ifTrue: [^ self annotationForClassCommentFor: aClass]. aSelector == #Definition ifTrue: [^ self annotationForClassDefinitionFor: aClass]. aSelector == #Hierarchy ifTrue: [^ self annotationForHierarchyFor: aClass]. aStream _ ReadWriteStream on: ''. requestList _ self annotationRequests. separator _ requestList size > 1 ifTrue: [self annotationSeparator] ifFalse: ['']. requestList do: [:aRequest | aRequest == #firstComment ifTrue: [aComment _ aClass firstCommentAt: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment, separator]]. aRequest == #masterComment ifTrue: [aComment _ aClass supermostPrecodeCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment, separator]]. aRequest == #documentation ifTrue: [aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment, separator]]. aRequest == #timeStamp ifTrue: [stamp _ self timeStamp. aStream nextPutAll: (stamp size > 0 ifTrue: [stamp, separator] ifFalse: ['no timeStamp', separator])]. aRequest == #messageCategory ifTrue: [aCategory _ aClass organization categoryOfElement: aSelector. aCategory ifNotNil: "woud be nil for a method no longer present, e.g. in a recent-submissions browser" [aStream nextPutAll: aCategory, separator]]. aRequest == #sendersCount ifTrue: [sendersCount _ (Smalltalk allCallsOn: aSelector) size. sendersCount _ sendersCount == 1 ifTrue: ['1 sender'] ifFalse: [sendersCount printString, ' senders']. aStream nextPutAll: sendersCount, separator]. aRequest == #implementorsCount ifTrue: [implementorsCount _ Smalltalk numberOfImplementorsOf: aSelector. implementorsCount _ implementorsCount == 1 ifTrue: ['1 implementor'] ifFalse: [implementorsCount printString, ' implementors']. aStream nextPutAll: implementorsCount, separator]. aRequest == #priorVersionsCount ifTrue: [self addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. aRequest == #priorTimeStamp ifTrue: [stamp _ VersionsBrowser timeStampFor: aSelector class: aClass reverseOrdinal: 2. stamp ifNotNil: [aStream nextPutAll: 'prior time stamp: ', stamp, separator]]. aRequest == #recentChangeSet ifTrue: [aString _ ChangeSorter mostRecentChangeSetWithChangeForClass: aClass selector: aSelector. aString size > 0 ifTrue: [aStream nextPutAll: aString, separator]]. aRequest == #allChangeSets ifTrue: [aList _ ChangeSorter allChangeSetsWithClass: aClass selector: aSelector. aList size > 0 ifTrue: [aList size = 1 ifTrue: [aStream nextPutAll: 'only in change set '] ifFalse: [aStream nextPutAll: 'in change sets: ']. aList do: [:aChangeSet | aStream nextPutAll: aChangeSet name, ' ']] ifFalse: [aStream nextPutAll: 'in no change set']. aStream nextPutAll: separator]]. ^ aStream contents! ! !CodeHolder methodsFor: 'annotation' stamp: 'sd 4/29/2003 11:54' prior: 35059834! annotationForSelector: aSelector ofClass: aClass "Provide a line of content for an annotation pane, representing information about the given selector and class" | stamp sendersCount implementorsCount aCategory separator aString aList aComment aStream requestList | aSelector == #Comment ifTrue: [^ self annotationForClassCommentFor: aClass]. aSelector == #Definition ifTrue: [^ self annotationForClassDefinitionFor: aClass]. aSelector == #Hierarchy ifTrue: [^ self annotationForHierarchyFor: aClass]. aStream _ ReadWriteStream on: ''. requestList _ self annotationRequests. separator _ requestList size > 1 ifTrue: [self annotationSeparator] ifFalse: ['']. requestList do: [:aRequest | aRequest == #firstComment ifTrue: [aComment _ aClass firstCommentAt: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #masterComment ifTrue: [aComment _ aClass supermostPrecodeCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #documentation ifTrue: [aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #timeStamp ifTrue: [stamp _ self timeStamp. aStream nextPutAll: (stamp size > 0 ifTrue: [stamp , separator] ifFalse: ['no timeStamp' , separator])]. aRequest == #messageCategory ifTrue: [aCategory _ aClass organization categoryOfElement: aSelector. aCategory ifNotNil: ["woud be nil for a method no longer present, e.g. in a recent-submissions browser" aStream nextPutAll: aCategory , separator]]. aRequest == #sendersCount ifTrue: [sendersCount _ (self systemNavigation allCallsOn: aSelector) size. sendersCount _ sendersCount == 1 ifTrue: ['1 sender'] ifFalse: [sendersCount printString , ' senders']. aStream nextPutAll: sendersCount , separator]. aRequest == #implementorsCount ifTrue: [implementorsCount _ self systemNavigation numberOfImplementorsOf: aSelector. implementorsCount _ implementorsCount == 1 ifTrue: ['1 implementor'] ifFalse: [implementorsCount printString , ' implementors']. aStream nextPutAll: implementorsCount , separator]. aRequest == #priorVersionsCount ifTrue: [self addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. aRequest == #priorTimeStamp ifTrue: [stamp _ VersionsBrowser timeStampFor: aSelector class: aClass reverseOrdinal: 2. stamp ifNotNil: [aStream nextPutAll: 'prior time stamp: ' , stamp , separator]]. aRequest == #recentChangeSet ifTrue: [aString _ ChangeSorter mostRecentChangeSetWithChangeForClass: aClass selector: aSelector. aString size > 0 ifTrue: [aStream nextPutAll: aString , separator]]. aRequest == #allChangeSets ifTrue: [aList _ ChangeSorter allChangeSetsWithClass: aClass selector: aSelector. aList size > 0 ifTrue: [aList size = 1 ifTrue: [aStream nextPutAll: 'only in change set '] ifFalse: [aStream nextPutAll: 'in change sets: ']. aList do: [:aChangeSet | aStream nextPutAll: aChangeSet name , ' ']] ifFalse: [aStream nextPutAll: 'in no change set']. aStream nextPutAll: separator]]. ^ aStream contents! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:02'! annotationSeparator "Answer the separator to be used between annotations" ^ ' • '! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 9/28/2001 08:43'! defaultAnnotationPaneHeight "Answer the receiver's preferred default height for new annotation panes." ^ Preferences parameterAt: #defaultAnnotationPaneHeight ifAbsentPut: [25]! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 9/28/2001 08:44'! defaultButtonPaneHeight "Answer the user's preferred default height for new button panes." ^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 2/1/2004 17:56'! categoryFromUserWithPrompt: aPrompt for: aClass "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" | labels myCategories reject lines cats newName menuIndex | labels _ OrderedCollection with: 'new...'. labels addAll: (myCategories _ aClass organization categories asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject _ myCategories asSet. reject add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines _ OrderedCollection with: 1 with: (myCategories size + 1). aClass allSuperclasses do: [:cls | cats _ cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [lines add: labels size. labels addAll: (cats asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject addAll: cats]]. newName _ (labels size = 1 or: [menuIndex _ (PopUpMenu labelArray: labels lines: lines) startUpWithCaption: aPrompt. menuIndex = 0 ifTrue: [^ nil]. menuIndex = 1]) ifTrue: [FillInTheBlank request: 'Please type new category name' initialAnswer: 'category name'] ifFalse: [labels at: menuIndex]. ^ newName ifNotNil: [newName asSymbol]! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 2/1/2004 17:55' prior: 19377943! categoryOfCurrentMethod "Answer the category that owns the current method. If unable to determine a category, answer nil." | aClass aSelector | ^ (aClass _ self selectedClassOrMetaClass) ifNotNil: [(aSelector _ self selectedMessageName) ifNotNil: [aClass whichCategoryIncludesSelector: aSelector]]! ! !CodeHolder methodsFor: 'categories' stamp: 'sw 10/29/2001 06:58'! changeCategory "Present a menu of the categories of messages for the current class, and let the user choose a new category for the current message" | aClass aSelector | (aClass _ self selectedClassOrMetaClass) ifNotNil: [(aSelector _ self selectedMessageName) ifNotNil: [(aClass letUserReclassify: aSelector) ifTrue: ["Smalltalk changes reorganizeClass: aClass." "Decided on further review that the above, when present, could cause more unexpected harm than good" self methodCategoryChanged]]]! ! !CodeHolder methodsFor: 'categories' stamp: 'nk 7/2/2003 10:47' prior: 35069048! changeCategory "Present a menu of the categories of messages for the current class, and let the user choose a new category for the current message" | aClass aSelector | (aClass _ self selectedClassOrMetaClass) ifNotNil: [(aSelector _ self selectedMessageName) ifNotNil: [(aClass letUserReclassify: aSelector) ifTrue: ["ChangeSet current reorganizeClass: aClass." "Decided on further review that the above, when present, could cause more unexpected harm than good" self methodCategoryChanged]]]! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 2/1/2004 17:55' prior: 35069668! changeCategory "Present a menu of the categories of messages for the current class, and let the user choose a new category for the current message" | aClass aSelector | (aClass _ self selectedClassOrMetaClass) ifNotNil: [(aSelector _ self selectedMessageName) ifNotNil: [(self letUserReclassify: aSelector in: aClass) ifTrue: ["ChangeSet current reorganizeClass: aClass." "Decided on further review that the above, when present, could cause more unexpected harm than good" self methodCategoryChanged]]]! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 2/1/2004 17:54'! letUserReclassify: anElement in: aClass "Put up a list of categories and solicit one from the user. Answer true if user indeed made a change, else false" | currentCat newCat | currentCat _ aClass organization categoryOfElement: anElement. newCat _ self categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")' for: aClass. (newCat ~~ nil and: [newCat ~= currentCat]) ifTrue: [aClass organization classify: anElement under: newCat suppressIfDefault: false. ^ true] ifFalse: [^ false]! ! !CodeHolder methodsFor: 'contents' stamp: 'di 10/1/2001 22:25'! contents "Answer the source code or documentation for the selected method" self showingByteCodes ifTrue: [^ self selectedBytecodes]. self showingDocumentation ifTrue: [^ self commentContents]. ^ self selectedMessage! ! !CodeHolder methodsFor: 'contents' stamp: 'rhi 12/3/2001 22:25'! contentsChanged super contentsChanged. self changed: #annotation! ! !CodeHolder methodsFor: 'contents' stamp: 'sw 5/20/2001 10:21'! contentsSymbol "Answer a symbol indicating what kind of content should be shown for the method; for normal showing of source code, this symbol is #source. A nil value in the contentsSymbol slot will be set to #source by this method" ^ contentsSymbol ifNil: [contentsSymbol _ Preferences printAlternateSyntax ifTrue: [#altSyntax] ifFalse: [Preferences browseWithPrettyPrint ifTrue: [Preferences colorWhenPrettyPrinting ifTrue: [#colorPrint] ifFalse: [#prettyPrint]] ifFalse: [#source]]]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 7/30/2001 16:31'! abbreviatedWordingFor: aButtonSelector "Answer the abbreviated form of wording, from a static table which you're welcome to edit. Answer nil if there is no entry -- in which case the long firm will be used on the corresponding browser button." #( (browseMethodFull 'browse') (browseSendersOfMessages 'senders') (browseMessages 'impl') (browseVersions 'vers') (methodHierarchy 'inher') (classHierarchy 'hier') (browseInstVarRefs 'iVar') (browseClassVarRefs 'cVar') (offerMenu 'menu')) do: [:pair | pair first == aButtonSelector ifTrue: [^ pair second]]. ^ nil! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 5/23/2003 14:35' prior: 19383134! adoptMessageInCurrentChangeset "Add the receiver's method to the current change set if not already there" self setClassAndSelectorIn: [:cl :sel | cl ifNotNil: [ChangeSet current adoptSelector: sel forClass: cl. self changed: #annotation]] ! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 07:26'! browseImplementors "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." | aMessageName | (aMessageName _ self selectedMessageName) ifNotNil: [Smalltalk browseAllImplementorsOf: aMessageName]! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 4/16/2003 09:33' prior: 35073562! browseImplementors "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." | aMessageName | (aMessageName _ self selectedMessageName) ifNotNil: [self systemNavigation browseAllImplementorsOf: aMessageName]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/19/2001 06:08'! browseSenders "Create and schedule a message set browser on all senders of the currently selected message selector. Of there is no message currently selected, offer a type-in" self sendQuery: #browseAllCallsOn: to: Smalltalk! ! !CodeHolder methodsFor: 'commands' stamp: 'nk 6/26/2003 21:43' prior: 35074308! browseSenders "Create and schedule a message set browser on all senders of the currently selected message selector. Of there is no message currently selected, offer a type-in" self sendQuery: #browseAllCallsOn: to: self systemNavigation! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/20/2001 15:33'! copyUpOrCopyDown "Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing. Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established." | aClass aSelector allClasses implementors aMenu aColor | Smalltalk isMorphic ifFalse: [^ self inform: 'Sorry, for the moment you have to be in Morphic to use this feature.']. ((aClass _ self selectedClassOrMetaClass) isNil or: [(aSelector _ self selectedMessageName) == nil]) ifTrue: [^ self beep]. allClasses _ Utilities hierarchyOfClassesSurrounding: aClass. implementors _ Utilities hierarchyOfImplementorsOf: aSelector forClass: aClass. aMenu _ MenuMorph new defaultTarget: self. aMenu title: aClass name, '.', aSelector, ' Choose where to insert a copy of this method (blue = current, black = available, red = other implementors'. allClasses do: [:cl | aColor _ cl == aClass ifTrue: [#blue] ifFalse: [(implementors includes: cl) ifTrue: [#red] ifFalse: [#black]]. (aColor == #red) ifFalse: [aMenu add: cl name selector: #spawnToClass: argument: cl] ifTrue: [aMenu add: cl name selector: #spawnToCollidingClass: argument: cl]. aMenu lastItem color: (Color colorFrom: aColor)]. aMenu popUpInWorld! ! !CodeHolder methodsFor: 'commands' stamp: 'nb 6/17/2003 12:25' prior: 35074930! copyUpOrCopyDown "Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing. Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established." | aClass aSelector allClasses implementors aMenu aColor | Smalltalk isMorphic ifFalse: [^ self inform: 'Sorry, for the moment you have to be in Morphic to use this feature.']. ((aClass _ self selectedClassOrMetaClass) isNil or: [(aSelector _ self selectedMessageName) == nil]) ifTrue: [^ Beeper beep]. allClasses _ Utilities hierarchyOfClassesSurrounding: aClass. implementors _ Utilities hierarchyOfImplementorsOf: aSelector forClass: aClass. aMenu _ MenuMorph new defaultTarget: self. aMenu title: aClass name, '.', aSelector, ' Choose where to insert a copy of this method (blue = current, black = available, red = other implementors'. allClasses do: [:cl | aColor _ cl == aClass ifTrue: [#blue] ifFalse: [(implementors includes: cl) ifTrue: [#red] ifFalse: [#black]]. (aColor == #red) ifFalse: [aMenu add: cl name selector: #spawnToClass: argument: cl] ifTrue: [aMenu add: cl name selector: #spawnToCollidingClass: argument: cl]. aMenu lastItem color: (Color colorFrom: aColor)]. aMenu popUpInWorld! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 1/16/2004 21:05' prior: 35076422! copyUpOrCopyDown "Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing. Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established." | aClass aSelector allClasses implementors aMenu aColor | Smalltalk isMorphic ifFalse: [^ self inform: 'Sorry, for the moment you have to be in Morphic to use this feature.']. ((aClass _ self selectedClassOrMetaClass) isNil or: [(aSelector _ self selectedMessageName) == nil]) ifTrue: [^ Beeper beep]. allClasses _ self systemNavigation hierarchyOfClassesSurrounding: aClass. implementors _ self systemNavigation hierarchyOfImplementorsOf: aSelector forClass: aClass. aMenu _ MenuMorph new defaultTarget: self. aMenu title: aClass name, '.', aSelector, ' Choose where to insert a copy of this method (blue = current, black = available, red = other implementors'. allClasses do: [:cl | aColor _ cl == aClass ifTrue: [#blue] ifFalse: [(implementors includes: cl) ifTrue: [#red] ifFalse: [#black]]. (aColor == #red) ifFalse: [aMenu add: cl name selector: #spawnToClass: argument: cl] ifTrue: [aMenu add: cl name selector: #spawnToCollidingClass: argument: cl]. aMenu lastItem color: (Color colorFrom: aColor)]. aMenu popUpInWorld! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 5/18/2001 17:51'! offerMenu "Offer a menu to the user from the bar of tool buttons" self offerDurableMenuFrom: #messageListMenu:shifted: shifted: false! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:14'! offerShiftedClassListMenu "Offer the shifted class-list menu." ^ self offerMenuFrom: #classListMenu:shifted: shifted: true! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:15'! offerUnshiftedClassListMenu "Offer the shifted class-list menu." ^ self offerMenuFrom: #classListMenu:shifted: shifted: false! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 11/15/2002 13:16'! removeClass "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | message className classToRemove result | self okToChange ifFalse: [^ false]. classToRemove _ self selectedClassOrMetaClass ifNil: [self beep. ^ false]. classToRemove _ classToRemove theNonMetaClass. className _ classToRemove name. message _ 'Are you certain that you want to REMOVE the class ', className, ' from the system?'. (result _ self confirm: message) ifTrue: [classToRemove subclasses size > 0 ifTrue: [(self confirm: 'class has subclasses: ' , message) ifFalse: [^ false]]. classToRemove removeFromSystem. self changed: #classList. true]. ^ result! ! !CodeHolder methodsFor: 'commands' stamp: 'nb 6/17/2003 12:25' prior: 35080015! removeClass "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | message className classToRemove result | self okToChange ifFalse: [^ false]. classToRemove _ self selectedClassOrMetaClass ifNil: [Beeper beep. ^ false]. classToRemove _ classToRemove theNonMetaClass. className _ classToRemove name. message _ 'Are you certain that you want to REMOVE the class ', className, ' from the system?'. (result _ self confirm: message) ifTrue: [classToRemove subclasses size > 0 ifTrue: [(self confirm: 'class has subclasses: ' , message) ifFalse: [^ false]]. classToRemove removeFromSystem. self changed: #classList. true]. ^ result! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:18'! shiftedYellowButtonActivity "Offer the shifted selector-list menu" ^ self offerMenuFrom: #messageListMenu:shifted: shifted: true! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 9/27/2001 00:11'! showUnreferencedClassVars "Search for all class variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each class variable in order to determine whether it is unreferenced" | cls aList aReport | (cls _ self selectedClass) ifNil: [^ self]. aList _ cls allUnreferencedClassVariables. aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced class variables in ', cls name]. aReport _ String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced class variable(s) in ', cls name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. Transcript cr; show: aReport. (SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced class variables in ', cls name! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 4/29/2003 13:09' prior: 35081968! showUnreferencedClassVars "Search for all class variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each class variable in order to determine whether it is unreferenced" | cls aList aReport | (cls _ self selectedClass) ifNil: [^ self]. aList _ self systemNavigation allUnreferencedClassVariablesOf: cls. aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced class variables in ' , cls name]. aReport _ String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced class variable(s) in ' , cls name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. Transcript cr; show: aReport. (SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced class variables in ' , cls name! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 9/26/2001 01:55'! showUnreferencedInstVars "Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced" | cls aList aReport | (cls _ self selectedClassOrMetaClass) ifNil: [^ self]. aList _ cls allUnreferencedInstanceVariables. aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced instance variables in ', cls name]. aReport _ String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced instance variable(s) in ', cls name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. Transcript cr; show: aReport. (SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced instance variables in ', cls name! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 2/22/2001 06:38'! spawn: aString "Create and schedule a spawned message category browser for the currently selected message category. The initial text view contains the characters in aString. In the spawned browser, preselect the current selector (if any) as the going-in assumption, though upon acceptance this will often change" | newBrowser aCategory aClass | (aClass _ self selectedClassOrMetaClass) isNil ifTrue: [^ aString isEmptyOrNil ifFalse: [(Workspace new contents: aString) openLabel: 'spawned workspace']]. (aCategory _ self categoryOfCurrentMethod) ifNil: [self buildClassBrowserEditString: aString] ifNotNil: [newBrowser _ Browser new setClass: aClass selector: self selectedMessageName. self suggestCategoryToSpawnedBrowser: newBrowser. Browser openBrowserView: (newBrowser openMessageCatEditString: aString) label: 'category "', aCategory, '" in ', newBrowser selectedClassOrMetaClassName]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 11/12/2002 13:41'! spawnHierarchy "Create and schedule a new hierarchy browser on the currently selected class or meta." | newBrowser aSymbol aBehavior messageCatIndex selectedClassOrMetaClass | (selectedClassOrMetaClass _ self selectedClassOrMetaClass) ifNil: [^ self]. newBrowser _ HierarchyBrowser new initHierarchyForClass: selectedClassOrMetaClass. ((aSymbol _ self selectedMessageName) notNil and: [(MessageSet isPseudoSelector: aSymbol) not]) ifTrue: [aBehavior _ selectedClassOrMetaClass. messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol. newBrowser messageCategoryListIndex: messageCatIndex + 1. newBrowser messageListIndex: ((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)]. Browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: newBrowser labelString. Smalltalk isMorphic ifTrue: ["this workaround only needed in morphic" newBrowser assureSelectionsShow]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/20/2001 15:10'! spawnToClass: aClass "Used to copy down code from a superclass to a subclass in one easy step, if you know what you're doing. Spawns a new message-category browser for the indicated class, populating it with the source code seen in the current tool." | aCategory newBrowser org | (aCategory _ self categoryOfCurrentMethod) ifNil: [self buildClassBrowserEditString: self contents] ifNotNil: [((org _ aClass organization) categories includes: aCategory) ifFalse: [org addCategory: aCategory]. newBrowser _ Browser new setClass: aClass selector: nil. newBrowser selectMessageCategoryNamed: aCategory. Browser openBrowserView: (newBrowser openMessageCatEditString: self contents) label: 'category "', aCategory, '" in ', newBrowser selectedClassOrMetaClassName]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/20/2001 15:11'! spawnToCollidingClass: aClass "Potentially used to copy down code from a superclass to a subclass in one easy step, in the case where the given class already has its own version of code, which would consequently be clobbered if the spawned code were accepted." self inform: 'That would be destructive of some pre-existing code already in that class for this selector. For the moment, we will not let you do this to yourself.'! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:19'! unshiftedYellowButtonActivity "Offer the unshifted shifted selector-list menu" ^ self offerMenuFrom: #messageListMenu:shifted: shifted: false! ! !CodeHolder methodsFor: 'construction' stamp: 'nk 11/9/2003 08:06' prior: 19393697! buildMorphicCodePaneWith: editString "Construct the pane that shows the code. Respect the Preference for standardCodeFont." | codePane | codePane := PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. codePane font: Preferences standardCodeFont. editString ifNotNil: [codePane editString: editString. codePane hasUnacceptedEdits: true]. ^ codePane! ! !CodeHolder methodsFor: 'controls' stamp: 'ar 8/19/2001 16:15'! addOptionalButtonsTo: window at: fractions plus: verticalOffset "If the receiver wishes it, add a button pane to the window, and answer the verticalOffset plus the height added" | delta buttons divider | self wantsOptionalButtons ifFalse: [^verticalOffset]. delta _ self defaultButtonPaneHeight. buttons _ self optionalButtonRow color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]); borderWidth: 0. Preferences alternativeWindowLook ifTrue:[ buttons color: Color transparent. buttons submorphsDo:[:m| m borderWidth: 2; borderColor: #raised]. ]. divider _ BorderedSubpaneDividerMorph forBottomEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. window addMorph: buttons fullFrame: (LayoutFrame fractions: fractions offsets: (0@verticalOffset corner: 0@(verticalOffset + delta - 1))). window addMorph: divider fullFrame: (LayoutFrame fractions: fractions offsets: (0@(verticalOffset + delta - 1) corner: 0@(verticalOffset + delta))). ^ verticalOffset + delta! ! !CodeHolder methodsFor: 'controls' stamp: 'gm 2/16/2003 20:37' prior: 19394087! buttonWithSelector: aSelector "If receiver has a control button with the given action selector answer it, else answer nil. morphic only at this point" | aWindow aPane | ((aWindow := self containingWindow) isSystemWindow) ifFalse: [^nil]. (aPane := aWindow submorphNamed: 'buttonPane') ifNil: [^nil]. ^aPane submorphThat: [:m | (m isKindOf: PluggableButtonMorph) and: [m actionSelector == aSelector]] ifNone: [^nil]! ! !CodeHolder methodsFor: 'controls' stamp: 'ar 8/19/2001 16:28'! codePaneProvenanceButton "Answer a button that reports on, and allow the user to modify, the code-pane-provenance setting" | aButton | aButton _ UpdatingSimpleButtonMorph newWithLabel: 'source'. aButton setNameTo: 'codeProvenance'. aButton useSquareCorners. aButton target: self; wordingSelector: #codePaneProvenanceString; actionSelector: #offerWhatToShowMenu. aButton setBalloonText: 'Governs what view is shown in the code pane. Click here to change the view'. aButton actWhen: #buttonDown. aButton beTransparent. aButton borderColor: Color black. ^aButton! ! !CodeHolder methodsFor: 'controls' stamp: 'sw 5/19/2001 01:12'! codePaneProvenanceString "Answer a string that reports on code-pane-provenance" | symsAndWordings | (symsAndWordings _ self contentsSymbolQuints) do: [:aQuad | contentsSymbol == aQuad first ifTrue: [^ aQuad fourth]]. ^ symsAndWordings first fourth "default to plain source, for example if nil as initially"! ! !CodeHolder methodsFor: 'controls' stamp: 'sw 11/13/2001 07:48'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane first element: the contentsSymbol used second element: the selector to call when this item is chosen. third element: the selector to call to obtain the wording of the menu item. fourth element: the wording to represent this view fifth element: balloon help A hypen indicates a need for a seperator line in a menu of such choices" ^ #( (source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') (documentation toggleShowDocumentation showingDocumentationString 'documentation' 'the first comment in the method') - (prettyPrint togglePrettyPrint prettyPrintString 'prettyPrint' 'the method source presented in a standard text format') (colorPrint toggleColorPrint colorPrintString 'colorPrint' 'the method source in a standard text format with colors to distinguish structural parts') (altSyntax toggleAltSyntax showingAltSyntaxString 'altSyntax' 'alternative syntax') - (showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version') (prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'prettyDiffs' 'formatted textual source diffed from formatted form of prior version') - (decompile toggleDecompile showingDecompileString 'decompile' 'source code decompiled from byteCodes') (byteCodes toggleShowingByteCodes showingByteCodesString 'byteCodes' 'the bytecodes that comprise the compiled method') - (tiles toggleShowingTiles showingTilesString 'tiles' 'universal tiles representing the method'))! ! !CodeHolder methodsFor: 'controls' stamp: 'sw 7/31/2002 13:12'! decorateForInheritance "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." | aColor aButton | (aButton _ self inheritanceButton) ifNil: [^ self]. aColor _ (((currentCompiledMethod isKindOf: CompiledMethod) not) or: [Preferences decorateBrowserButtons not]) ifTrue: [Color transparent] ifFalse: [currentCompiledMethod sendsToSuper ifTrue: [self isThereAnOverride ifTrue: [Color blue muchLighter] ifFalse: [Color green muchLighter ]] ifFalse: [self isThereAnOverride ifTrue: [Color tan lighter] ifFalse: [Color transparent]]]. aButton offColor: aColor! ! !CodeHolder methodsFor: 'controls' stamp: 'nk 7/6/2003 08:29' prior: 35093574! decorateForInheritance "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." | aColor aButton flags | (aButton _ self inheritanceButton) ifNil: [^ self]. ((currentCompiledMethod isKindOf: CompiledMethod) and: [Preferences decorateBrowserButtons]) ifFalse: [^aButton offColor: Color transparent]. "This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it." flags _ 0. self isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. currentCompiledMethod sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. self isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. aColor _ { Color transparent. Color tan lighter. Color green muchLighter. Color blue muchLighter. Color red muchLighter. "has super but doesn't call it" (Color r: 0.94 g: 0.823 b: 0.673). "has sub; has super but doesn't call it" Color green muchLighter. Color blue muchLighter. } at: flags + 1. aButton offColor: aColor! ! !CodeHolder methodsFor: 'controls' stamp: 'sw 10/2/2001 00:22'! optionalButtonPairs "Answer a tuple (formerly pairs) defining buttons, in the format: button label selector to send help message" | aList | aList _ #( ('browse' browseMethodFull 'view this method in a browser') ('senders' browseSendersOfMessages 'browse senders of...') ('implementors' browseMessages 'browse implementors of...') ('versions' browseVersions 'browse versions')), (Preferences decorateBrowserButtons ifTrue: [{#('inheritance' methodHierarchy 'browse method inheritance green: sends to super tan: has override(s) mauve: both of the above' )}] ifFalse: [{#('inheritance' methodHierarchy 'browse method inheritance')}]), #( ('hierarchy' classHierarchy 'browse class hierarchy') ('inst vars' browseInstVarRefs 'inst var refs...') ('class vars' browseClassVarRefs 'class var refs...')). ^ aList! ! !CodeHolder methodsFor: 'controls' stamp: 'nk 7/7/2003 11:39' prior: 35095580! optionalButtonPairs "Answer a tuple (formerly pairs) defining buttons, in the format: button label selector to send help message" | aList | aList _ #( ('browse' browseMethodFull 'view this method in a browser') ('senders' browseSendersOfMessages 'browse senders of...') ('implementors' browseMessages 'browse implementors of...') ('versions' browseVersions 'browse versions')), (Preferences decorateBrowserButtons ifTrue: [{#('inheritance' methodHierarchy 'browse method inheritance green: sends to super tan: has override(s) mauve: both of the above pink: is an override but doesn''t call super pinkish tan: has override(s), also is an override but doesn''t call super' )}] ifFalse: [{#('inheritance' methodHierarchy 'browse method inheritance')}]), #( ('hierarchy' classHierarchy 'browse class hierarchy') ('inst vars' browseInstVarRefs 'inst var refs...') ('class vars' browseClassVarRefs 'class var refs...')). ^ aList! ! !CodeHolder methodsFor: 'controls' stamp: 'tk 9/8/2001 22:40'! optionalButtonRow "Answer a row of control buttons" | aRow aButton aLabel | aRow _ AlignmentMorph newRow. aRow setNameTo: 'buttonPane'. aRow beSticky. aRow hResizing: #spaceFill. aRow wrapCentering: #center; cellPositioning: #leftCenter. aRow clipSubmorphs: true. aRow cellInset: 3. Preferences menuButtonInToolPane ifTrue: [aRow addMorphFront: self menuButton]. self optionalButtonPairs do: [:tuple | aButton _ PluggableButtonMorph on: self getState: nil action: tuple second. aButton useRoundedCorners; hResizing: #spaceFill; vResizing: #spaceFill; onColor: Color transparent offColor: Color transparent. aLabel _ Preferences abbreviatedBrowserButtons ifTrue: [self abbreviatedWordingFor: tuple second] ifFalse: [nil]. aButton label: (aLabel ifNil: [tuple first asString]) " font: (StrikeFont familyName: 'Atlanta' size: 9)". tuple size > 2 ifTrue: [aButton setBalloonText: tuple third]. tuple size > 3 ifTrue: [aButton triggerOnMouseDown: tuple fourth]. aRow addMorphBack: aButton]. aRow addMorphBack: self codePaneProvenanceButton. ^ aRow! ! !CodeHolder methodsFor: 'controls' stamp: 'sw 11/13/2001 09:12'! sourceAndDiffsQuintsOnly "Answer a list of quintuplets representing information on the alternative views available in the code pane for the case where the only plausible choices are showing source or either of the two kinds of diffs" ^ #( (source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') (showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version') (prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'prettyDiffs' 'formatted textual source diffed from formatted form of prior version'))! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:36'! defaultDiffsSymbol "Answer the code symbol to use when generically switching to diffing" ^ Preferences diffsWithPrettyPrint ifTrue: [#prettyDiffs] ifFalse: [#showDiffs]! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 09:09'! diffButton "Return a checkbox that lets the user decide whether diffs should be shown or not. Not sent any more but retained against the possibility of existing subclasses outside the base image using it." | outerButton aButton | outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleRegularDiffing; getSelector: #showingRegularDiffs. outerButton addMorphBack: (StringMorph contents: 'diffs') lock. outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'. ^ outerButton ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/20/2001 21:14'! diffFromPriorSourceFor: sourceCode "If there is a prior version of source for the selected method, return a diff, else just return the source code" | prior | ^ (prior _ self priorSourceOrNil) ifNil: [sourceCode] ifNotNil: [TextDiffBuilder buildDisplayPatchFrom: prior to: sourceCode inClass: self selectedClass prettyDiffs: self showingPrettyDiffs]! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 6/8/2001 00:37'! prettyDiffButton "Return a checkbox that lets the user decide whether prettyDiffs should be shown or not" | outerButton aButton | outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #togglePrettyDiffing; getSelector: #showingPrettyDiffs. outerButton addMorphBack: (StringMorph contents: 'prettyDiffs') lock. (self isKindOf: VersionsBrowser) ifTrue: [outerButton setBalloonText: 'If checked, then pretty-printed code differences from the previous version, if any, will be shown.'] ifFalse: [outerButton setBalloonText: 'If checked, then pretty-printed code differences between the file-based method and the in-memory version, if any, will be shown.']. ^ outerButton ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:37'! regularDiffButton "Return a checkbox that lets the user decide whether regular diffs should be shown or not" | outerButton aButton | outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleRegularDiffing; getSelector: #showingRegularDiffs. outerButton addMorphBack: (StringMorph contents: 'diffs') lock. outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'. ^ outerButton ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/18/2001 19:54'! restoreTextualCodingPane "If the receiver is showing tiles, restore the textual coding pane" self showingTiles ifTrue: [contentsSymbol _ #source. self installTextualCodingPane]! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:49'! showDiffs "Answer whether the receiver is showing diffs of source code. The preferred protocol here is #showingRegularDiffs, but this message is still sent by some preexisting buttons so is retained." ^ contentsSymbol == #showDiffs ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:36'! showDiffs: aBoolean "Set whether I'm showing diffs as indicated; use the global preference to determine which kind of diffs to institute." self showingAnyKindOfDiffs ifFalse: [aBoolean ifTrue: [contentsSymbol _ self defaultDiffsSymbol]] ifTrue: [aBoolean ifFalse: [contentsSymbol _ #source]]. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/22/2001 18:25'! showPrettyDiffs: aBoolean "Set whether I'm showing pretty diffs as indicated" self showingPrettyDiffs ifFalse: [aBoolean ifTrue: [contentsSymbol _ #prettyDiffs]] ifTrue: [aBoolean ifFalse: [contentsSymbol _ #source]]. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:50'! showRegularDiffs: aBoolean "Set whether I'm showing regular diffs as indicated" self showingRegularDiffs ifFalse: [aBoolean ifTrue: [contentsSymbol _ #showDiffs]] ifTrue: [aBoolean ifFalse: [contentsSymbol _ #source]]. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:32'! showingAnyKindOfDiffs "Answer whether the receiver is currently set to show any kind of diffs" ^ #(showDiffs prettyDiffs) includes: contentsSymbol! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 09:10'! showingDiffsString "Answer a string representing whether I'm showing diffs. Not sent any more but retained so that prexisting buttons that sent this will not raise errors." ^ (self showingRegularDiffs ifTrue: [''] ifFalse: ['']), 'showDiffs'! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/19/2001 00:07'! showingPrettyDiffs "Answer whether the receiver is showing pretty diffs of source code" ^ contentsSymbol == #prettyDiffs ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/22/2001 16:41'! showingPrettyDiffsString "Answer a string representing whether I'm showing pretty diffs" ^ (self showingPrettyDiffs ifTrue: [''] ifFalse: ['']), 'prettyDiffs'! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:07'! showingRegularDiffs "Answer whether the receiver is showing regular diffs of source code" ^ contentsSymbol == #showDiffs ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:43'! showingRegularDiffsString "Answer a string representing whether I'm showing regular diffs" ^ (self showingRegularDiffs ifTrue: [''] ifFalse: ['']), 'showDiffs'! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/18/2001 23:50'! toggleColorPrint "Toggle whether color-print is in effect in the code pane" self restoreTextualCodingPane. self okToChange ifTrue: [self showingColorPrint ifTrue: [contentsSymbol _ #source] ifFalse: [contentsSymbol _ #colorPrint]. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:30'! toggleDiffing "Toggle whether diffs should be shown in the code pane. If any kind of diffs were being shown, stop showing diffs. If no kind of diffs were being shown, start showing whatever kind of diffs are called for by default." | wasShowingDiffs | self okToChange ifTrue: [wasShowingDiffs _ self showingAnyKindOfDiffs. self restoreTextualCodingPane. self showDiffs: wasShowingDiffs not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/18/2001 19:57'! togglePlainSource "Toggle whether plain source shown in the code pane" | wasShowingPlainSource | self okToChange ifTrue: [wasShowingPlainSource _ self showingPlainSource. self restoreTextualCodingPane. wasShowingPlainSource ifTrue: [self showDocumentation: true] ifFalse: [contentsSymbol _ #source]. self setContentsToForceRefetch. self changed: #contents] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/19/2001 00:02'! togglePrettyDiffing "Toggle whether pretty-diffing should be shown in the code pane" | wasShowingDiffs | self okToChange ifTrue: [wasShowingDiffs _ self showingPrettyDiffs. self restoreTextualCodingPane. self showPrettyDiffs: wasShowingDiffs not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/18/2001 19:54'! togglePrettyPrint "Toggle whether pretty-print is in effectin the code pane" self restoreTextualCodingPane. self okToChange ifTrue: [self showingPrettyPrint ifTrue: [contentsSymbol _ #source] ifFalse: [contentsSymbol _ #prettyPrint]. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:27'! toggleRegularDiffing "Toggle whether regular-diffing should be shown in the code pane" | wasShowingDiffs | self okToChange ifTrue: [wasShowingDiffs _ self showingRegularDiffs. self restoreTextualCodingPane. self showRegularDiffs: wasShowingDiffs not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:24'! wantsDiffFeedback "Answer whether the receiver is showing diffs of source code" ^ self showingAnyKindOfDiffs! ! !CodeHolder methodsFor: 'misc' stamp: 'nk 4/10/2001 07:52'! getSelectorAndSendQuery: querySelector to: queryPerformer "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained as its argument. If no message is currently selected, then obtain a method name from a user type-in" self getSelectorAndSendQuery: querySelector to: queryPerformer with: { }. ! ! !CodeHolder methodsFor: 'misc' stamp: 'nk 4/10/2001 07:53'! getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" | strm array | strm _ WriteStream on: (array _ Array new: queryArgs size + 1). strm nextPut: nil. strm nextPutAll: queryArgs. self selectedMessageName ifNil: [ | selector | selector _ FillInTheBlank request: 'Type selector:' initialAnswer: 'flag:'. ^ selector isEmptyOrNil ifFalse: [ (Symbol hasInterned: selector ifTrue: [ :aSymbol | array at: 1 put: aSymbol. queryPerformer perform: querySelector withArguments: array]) ifFalse: [ self inform: 'no such selector'] ] ]. self selectMessageAndEvaluate: [:selector | array at: 1 put: selector. queryPerformer perform: querySelector withArguments: array ]! ! !CodeHolder methodsFor: 'misc' stamp: 'RAA 5/28/2001 11:42'! isThereAnOverride "Answer whether any subclass of my selected class implements my selected selector" | aName aClass | aName _ self selectedMessageName ifNil: [^ false]. aClass _ self selectedClassOrMetaClass. (Smalltalk allImplementorsOf: aName) do: [ :each | (each actualClass inheritsFrom: aClass) ifTrue: [^ true] ]. ^ false! ! !CodeHolder methodsFor: 'misc' stamp: 'sd 4/19/2003 12:12' prior: 35110116! isThereAnOverride "Answer whether any subclass of my selected class implements my selected selector" | aName aClass | aName _ self selectedMessageName ifNil: [^ false]. aClass _ self selectedClassOrMetaClass. (self systemNavigation allImplementorsOf: aName) do: [:each | (each actualClass inheritsFrom: aClass) ifTrue: [^ true]]. ^ false! ! !CodeHolder methodsFor: 'misc' stamp: 'nk 7/6/2003 07:49' prior: 35110535! isThereAnOverride "Answer whether any subclass of my selected class implements my selected selector" | aName aClass | aName _ self selectedMessageName ifNil: [^ false]. aClass _ self selectedClassOrMetaClass. aClass allSubclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]]. ^ false! ! !CodeHolder methodsFor: 'misc' stamp: 'nk 7/6/2003 07:52'! isThisAnOverride "Answer whether any superclass of my selected class implements my selected selector" | aName aClass | aName _ self selectedMessageName ifNil: [^ false]. aClass _ self selectedClassOrMetaClass. aClass allSuperclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]]. ^ false! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 8/1/2001 11:08'! menuButton "Answer a button that brings up a menu. Useful when adding new features, but at present is between uses" | aButton | aButton _ IconicButton new target: self; borderWidth: 0; labelGraphic: (ScriptingSystem formAtKey: #TinyMenu); color: Color transparent; actWhen: #buttonDown; actionSelector: #offerMenu; yourself. aButton setBalloonText: 'click here to get a menu with further options'. ^ aButton ! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 9/27/2001 01:26'! modelWakeUpIn: aWindow "The window has been activated. Respond to possible changes that may have taken place while it was inactive" self updateListsAndCodeIn: aWindow. self decorateButtons. self refreshAnnotation. super modelWakeUpIn: aWindow! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 11/13/2001 07:42'! okayToAccept "Answer whether it is okay to accept the receiver's input" self showingDocumentation ifTrue: [self inform: 'Sorry, for the moment you can only submit changes here when you are showing source. Later, you will be able to edit the isolated comment here and save it back, but only if YOU implement it!!.'. ^ false]. self showingAnyKindOfDiffs ifFalse: [^ true]. ^ SelectionMenu confirm: 'Caution!! You are "showing diffs" here, so there is a danger that some of the text in the code pane is contaminated by the "diff" display' trueChoice: 'accept anyway -- I''ll take my chances' falseChoice: 'um, let me reconsider' ! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 10/28/2001 00:15'! refreshAnnotation "If the receiver has an annotation pane that does not bear unaccepted edits, refresh it" (self dependents detect: [:m | (m inheritsFromAnyIn: #('PluggableTextView' 'PluggableTextMorph')) and: [m getTextSelector == #annotation]] ifNone: [nil]) ifNotNilDo: [:aPane | aPane hasUnacceptedEdits ifFalse: [aPane update: #annotation]]! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 5/22/2001 16:47'! refusesToAcceptCode "Answer whether receiver, given its current contentsSymbol, could accept code happily if asked to" ^ (#(byteCodes documentation altSyntax tiles) includes: self contentsSymbol)! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 3/19/2001 06:06'! sendQuery: querySelector to: queryPerformer "Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument." | aSelector aString | aSelector _ self selectedMessageName ifNil: [aString _FillInTheBlank request: 'Type selector:' initialAnswer: 'flag:'. ^ aString isEmptyOrNil ifFalse: [(Symbol hasInterned: aString ifTrue: [:aSymbol | queryPerformer perform: querySelector with: aSymbol]) ifFalse: [self inform: 'no such selector']]]. queryPerformer perform: querySelector with: aSelector! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 2/22/2001 06:37'! suggestCategoryToSpawnedBrowser: aBrowser "aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up." aBrowser setOriginalCategoryIndexForCurrentMethod! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 3/20/2001 09:26'! useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer "If incomingSelector is not nil, use it, else obtain a selector from user type-in. Using the determined selector, send the query to the performer provided." | aSelector | incomingSelector ifNotNil: [queryPerformer perform: querySelector with: incomingSelector] ifNil: [aSelector _FillInTheBlank request: 'Type selector:' initialAnswer: 'flag:'. aSelector isEmptyOrNil ifFalse: [(Symbol hasInterned: aSelector ifTrue: [:aSymbol | queryPerformer perform: querySelector with: aSymbol]) ifFalse: [self inform: 'no such selector']]]! ! !CodeHolder methodsFor: 'self-updating' stamp: 'sw 7/31/2002 13:11'! didCodeChangeElsewhere "Determine whether the code for the currently selected method and class has been changed somewhere else." | aClass aSelector aCompiledMethod | currentCompiledMethod ifNil: [^ false]. (aClass _ self selectedClassOrMetaClass) ifNil: [^ false]. (aSelector _ self selectedMessageName) ifNil: [^ false]. aSelector == #Comment ifTrue: [^ currentCompiledMethod ~~ aClass organization commentRemoteStr]. ^ ((aCompiledMethod _ aClass compiledMethodAt: aSelector ifAbsent: [^ false]) ~~ currentCompiledMethod) and: [aCompiledMethod last ~= 0 "either not yet installed" or: [currentCompiledMethod last = 0 "or these methods don't have source pointers"]] ! ! !CodeHolder methodsFor: 'self-updating' stamp: 'sw 2/14/2001 15:34'! updateCodePaneIfNeeded "If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits" self didCodeChangeElsewhere ifTrue: [self hasUnacceptedEdits ifFalse: [self setContentsToForceRefetch. self contentsChanged] ifTrue: [self changed: #codeChangedElsewhere]]! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 23:35'! addContentsTogglesTo: aMenu "Add updating menu toggles governing contents to aMenu." self contentsSymbolQuints do: [:aQuint | aQuint == #- ifTrue: [aMenu addLine] ifFalse: [aMenu addUpdating: aQuint third target: self action: aQuint second. aMenu balloonTextForLastItem: aQuint fifth]]! ! !CodeHolder methodsFor: 'what to show' stamp: 'nk 6/19/2004 16:59' prior: 35116886! addContentsTogglesTo: aMenu "Add updating menu toggles governing contents to aMenu." self contentsSymbolQuints do: [:aQuint | aQuint == #- ifTrue: [aMenu addLine] ifFalse: [Smalltalk isMorphic ifTrue: [aMenu addUpdating: aQuint third target: self action: aQuint second. aMenu balloonTextForLastItem: aQuint fifth] ifFalse: [aMenu add: (('*' match: (self perform: aQuint third)) ifTrue: ['*'] ifFalse: ['']), aQuint fourth target: self selector: #contentsSymbol: argumentList: { aQuint first } ]]]! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:36'! colorPrintString "Answer whether the receiver is showing colorPrint" ^ (self showingColorPrint ifTrue: [''] ifFalse: ['']) , 'colorPrint'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/24/2001 14:14'! offerWhatToShowMenu "Offer a menu governing what to show" | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: 'What to show'. aMenu addStayUpItem. self addContentsTogglesTo: aMenu. aMenu popUpInWorld ! ! !CodeHolder methodsFor: 'what to show' stamp: 'nk 6/19/2004 16:29' prior: 35118182! offerWhatToShowMenu "Offer a menu governing what to show" | aMenu | Smalltalk isMorphic ifTrue: [aMenu := MenuMorph new defaultTarget: self. aMenu addTitle: 'What to show'. aMenu addStayUpItem. self addContentsTogglesTo: aMenu. aMenu popUpInWorld] ifFalse: [aMenu := CustomMenu new. self addContentsTogglesTo: aMenu. aMenu title: 'What to show' translated. aMenu invokeOn: self. self changed: #contents ]! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:36'! prettyPrintString "Answer whether the receiver is showing pretty-print" ^ ((contentsSymbol == #prettyPrint) ifTrue: [''] ifFalse: ['']), 'prettyPrint'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 2/14/2001 15:25'! setContentsToForceRefetch "Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more" contents _ nil! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:26'! showAltSyntax: aBoolean "Set the decompile toggle as indicated" self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#altSyntax])! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 21:13'! showByteCodes: aBoolean "Get into or out of bytecode-showoing mode" self okToChange ifFalse: [^ self changed: #flash]. aBoolean ifTrue: [contentsSymbol _ #byteCodes] ifFalse: [contentsSymbol == #byteCodes ifTrue: [contentsSymbol _ #source]]. self contentsChanged! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:14'! showDecompile: aBoolean "Set the decompile toggle as indicated" self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#decompile])! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:27'! showingAltSyntax "Answer whether the receiver should show alt syntax rather than, say, source code" ^ self contentsSymbol == #altSyntax ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:37'! showingAltSyntaxString "Answer a string characerizing whether altSyntax is showing" ^ (self showingAltSyntax ifTrue: [''] ifFalse: ['']), 'altSyntax'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:05'! showingByteCodes "Answer whether the receiver is showing bytecodes" ^ contentsSymbol == #byteCodes! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 18:28'! showingByteCodesString "Answer whether the receiver is showing bytecodes" ^ (self showingByteCodes ifTrue: [''] ifFalse: ['']), 'byteCodes'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 23:50'! showingColorPrint "Answer whether the receiver is showing color-pretty-print" ^ contentsSymbol == #colorPrint! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:52'! showingDecompile "Answer whether the receiver should show decompile rather than, say, source code" ^ self contentsSymbol == #decompile ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:50'! showingDecompileString "Answer a string characerizing whether decompilation is showing" ^ (self showingDecompile ifTrue: [''] ifFalse: ['']), 'decompile'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:05'! showingDocumentationString "Answer a string characerizing whether documentation is showing" ^ (self showingDocumentation ifTrue: [''] ifFalse: ['']), 'documentation'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 19:43'! showingPlainSource "Answer whether the receiver is showing plain source" ^ contentsSymbol == #source! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 09:31'! showingPlainSourceString "Answer a string telling whether the receiver is showing plain source" ^ (self showingPlainSource ifTrue: [''] ifFalse: ['']), 'source'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:36'! showingPrettyPrint "Answer whether the receiver is showing pretty-print" ^ contentsSymbol == #prettyPrint! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:28'! toggleAltSyntax "Toggle the setting of the showingAltSyntax flag, unless there are unsubmitted edits that the user declines to discard" | wasShowing | self okToChange ifTrue: [wasShowing _ self showingAltSyntax. self restoreTextualCodingPane. self showAltSyntax: wasShowing not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:48'! toggleDecompile "Toggle the setting of the showingDecompile flag, unless there are unsubmitted edits that the user declines to discard" | wasShowing | self okToChange ifTrue: [wasShowing _ self showingDecompile. self restoreTextualCodingPane. self showDecompile: wasShowing not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:15'! toggleShowDocumentation "Toggle the setting of the showingDocumentation flag, unless there are unsubmitted edits that the user declines to discard" | wasShowing | self okToChange ifTrue: [wasShowing _ self showingDocumentation. self restoreTextualCodingPane. self showDocumentation: wasShowing not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:09'! toggleShowingByteCodes "Toggle whether the receiver is showing bytecodes" self restoreTextualCodingPane. self showByteCodes: self showingByteCodes not. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'tiles' stamp: 'sw 7/27/2001 19:01'! addModelItemsToWindowMenu: aMenu "Add model-related item to the window menu" super addModelItemsToWindowMenu: aMenu. Smalltalk isMorphic ifTrue: [aMenu addLine. aMenu add: 'what to show...' target: self action: #offerWhatToShowMenu]! ! !CodeHolder methodsFor: 'tiles' stamp: 'RAA 5/20/2001 10:27'! installTextualCodingPane "Install text into the code pane" | aWindow codePane aPane boundsToUse | (aWindow _ self containingWindow) ifNil: [self error: 'where''s that window?']. codePane _ aWindow findDeepSubmorphThat: [:m | ((m isKindOf: PluggableTextMorph) and: [m getTextSelector == #contents]) or: [m isKindOf: PluggableTileScriptorMorph]] ifAbsent: [self error: 'no code pane']. aPane _ self buildMorphicCodePaneWith: nil. boundsToUse _ (codePane bounds origin- (1@1)) corner: (codePane owner bounds corner " (1@1"). aWindow replacePane: codePane with: aPane. aPane vResizing: #spaceFill; hResizing: #spaceFill; borderWidth: 0. aPane bounds: boundsToUse. aPane owner clipSubmorphs: false. self contentsChanged! ! !CodeHolder methodsFor: 'tiles' stamp: 'sw 8/16/2002 23:39'! installTilesForSelection "Install universal tiles into the code pane." | source aSelector aClass tree syn tileScriptor aWindow codePane | (aWindow _ self containingWindow) ifNil: [self error: 'hamna dirisha']. tileScriptor _ ( (aSelector _ self selectedMessageName) isNil or: [(aClass _ self selectedClassOrMetaClass classThatUnderstands: aSelector) isNil]) ifTrue: [PluggableTileScriptorMorph new] ifFalse: [source _ aClass sourceCodeAt: aSelector. tree _ Compiler new parse: source in: aClass notifying: nil. (syn _ tree asMorphicSyntaxUsing: SyntaxMorph) parsedInClass: aClass. syn inAPluggableScrollPane]. codePane _ aWindow findDeepSubmorphThat: [:m | (m isKindOf: PluggableTextMorph) and: [m getTextSelector == #contents]] ifAbsent: [nil]. codePane ifNotNil: [codePane hideScrollBar]. codePane ifNil: [codePane _ aWindow findDeepSubmorphThat: [:m | m isKindOf: PluggableTileScriptorMorph] ifAbsent: [self error: 'no code pane']]. tileScriptor color: aWindow paneColorToUse; setProperty: #hideUnneededScrollbars toValue: true. aWindow replacePane: codePane with: tileScriptor. currentCompiledMethod _ aClass ifNotNil: [aClass compiledMethodAt: aSelector]. tileScriptor owner clipSubmorphs: true. tileScriptor extent: codePane extent.! ! !CodeHolder methodsFor: 'tiles' prior: 35125586! installTilesForSelection "Install universal tiles into the code pane." | source aSelector aClass tree syn tileScriptor aWindow codePane | (aWindow _ self containingWindow) ifNil: [self error: 'hamna dirisha']. tileScriptor _ ((aSelector _ self selectedMessageName) isNil or: [(aClass _ self selectedClassOrMetaClass whichClassIncludesSelector: aSelector) isNil]) ifTrue: [PluggableTileScriptorMorph new] ifFalse: [source _ aClass sourceCodeAt: aSelector. tree _ Compiler new parse: source in: aClass notifying: nil. (syn _ tree asMorphicSyntaxUsing: SyntaxMorph) parsedInClass: aClass. syn inAPluggableScrollPane]. codePane _ aWindow findDeepSubmorphThat: [:m | (m isKindOf: PluggableTextMorph) and: [m getTextSelector == #contents]] ifAbsent: []. codePane ifNotNil: [codePane hideScrollBar]. codePane ifNil: [codePane _ aWindow findDeepSubmorphThat: [:m | m isKindOf: PluggableTileScriptorMorph] ifAbsent: [self error: 'no code pane']]. tileScriptor color: aWindow paneColorToUse; setProperty: #hideUnneededScrollbars toValue: true. aWindow replacePane: codePane with: tileScriptor. currentCompiledMethod _ aClass ifNotNil: [aClass compiledMethodAt: aSelector]. tileScriptor owner clipSubmorphs: true. tileScriptor extent: codePane extent! ! !CodeHolder methodsFor: 'tiles' stamp: 'nk 4/28/2004 10:14' prior: 35126951! installTilesForSelection "Install universal tiles into the code pane." | source aSelector aClass tree syn tileScriptor aWindow codePane | (aWindow _ self containingWindow) ifNil: [self error: 'hamna dirisha']. tileScriptor _ ((aSelector _ self selectedMessageName) isNil or: [(aClass _ self selectedClassOrMetaClass whichClassIncludesSelector: aSelector) isNil]) ifTrue: [PluggableTileScriptorMorph new] ifFalse: [source _ aClass sourceCodeAt: aSelector. tree _ Compiler new parse: source in: aClass notifying: nil. (syn _ tree asMorphicSyntaxUsing: SyntaxMorph) parsedInClass: aClass. syn inAPluggableScrollPane]. codePane _ aWindow findDeepSubmorphThat: [:m | (m isKindOf: PluggableTextMorph) and: [m getTextSelector == #contents]] ifAbsent: []. codePane ifNotNil: [codePane hideScrollBars]. codePane ifNil: [codePane _ aWindow findDeepSubmorphThat: [:m | m isKindOf: PluggableTileScriptorMorph] ifAbsent: [self error: 'no code pane']]. tileScriptor color: aWindow paneColorToUse; setProperty: #hideUnneededScrollbars toValue: true. aWindow replacePane: codePane with: tileScriptor. currentCompiledMethod _ aClass ifNotNil: [aClass compiledMethodAt: aSelector]. tileScriptor owner clipSubmorphs: true. tileScriptor extent: codePane extent! ! !CodeHolder methodsFor: 'tiles' stamp: 'rhi 1/4/2002 11:15'! showTiles: aBoolean "Set the showingTiles as indicated. The fact that there are initially no senders of this reflects that fact that initially this trait is only directly settable through the UI; later there may be senders, such as if one wanted to set a system up so that all newly-opened browsers showed tiles rather than text." aBoolean ifTrue: [contentsSymbol _ #tiles] ifFalse: [contentsSymbol == #tiles ifTrue: [contentsSymbol _ #source]]. self setContentsToForceRefetch. self changed: #contents! ! !CodeHolder methodsFor: 'tiles' stamp: 'sw 2/3/2001 00:10'! showingTiles "Answer whether the receiver is currently showing tiles" ^ contentsSymbol == #tiles ! ! !CodeHolder methodsFor: 'tiles' stamp: 'sw 5/20/2001 21:12'! showingTilesString "Answer a string characterizing whether tiles are currently showing or not" ^ (self showingTiles ifTrue: [''] ifFalse: ['']), 'tiles'! ! !CodeHolder methodsFor: 'tiles' stamp: 'sw 2/14/2001 15:27'! toggleShowingTiles "Toggle whether tiles should be shown in the code pane" self okToChange ifTrue: [self showingTiles ifTrue: [contentsSymbol _ #source. self setContentsToForceRefetch. self installTextualCodingPane. self contentsChanged] ifFalse: [contentsSymbol _ #tiles. self installTilesForSelection. self changed: #tiles]]! ! !CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 3/7/2001 12:17'! listPaneWithSelector: aSelector "If, among my window's paneMorphs, there is a list pane defined with aSelector as its retriever, answer it, else answer nil" | aWindow | ^ (aWindow _ self containingWindow) ifNotNil: [aWindow paneMorphSatisfying: [:aMorph | (aMorph isKindOf: PluggableListMorph) and: [aMorph getListSelector == aSelector]]]! ! !CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 12/1/2000 20:44'! newSearchPane "Answer a new search pane for the receiver" | aTextMorph | aTextMorph _ PluggableTextMorph on: self text: #lastSearchString accept: #lastSearchString: readSelection: nil menu: nil. aTextMorph setProperty: #alwaysAccept toValue: true. aTextMorph askBeforeDiscardingEdits: false. aTextMorph acceptOnCR: true. aTextMorph setBalloonText: 'Type here and hit ENTER, and all methods whose selectors match what you typed will appear in the list pane below.'. ^ aTextMorph! ! !CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 3/7/2001 12:22'! searchPane "Answer the search pane associated with the receiver in its window, or nil if none. Morphic only" ^ self textPaneWithSelector: #lastSearchString! ! !CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 3/7/2001 12:21'! textPaneWithSelector: aSelector "If, among my window's paneMorphs, there is a text pane defined with aSelector as its retriever, answer it, else answer nil" | aWindow | ^ (aWindow _ self containingWindow) ifNotNil: [aWindow paneMorphSatisfying: [:aMorph | (aMorph isKindOf: PluggableTextMorph) and: [aMorph getTextSelector == aSelector]]]! ! !CodeHolder methodsFor: 'message list' stamp: 'sw 5/20/2001 06:57'! decompiledSourceIntoContents "Obtain a source string by decompiling the method's code, and place that source string into my contents. Get temps from source file" | tempNames class selector method | class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. method _ class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod _ method. tempNames _ (class compilerClass new parse: method getSourceFromFile asString in: class notifying: nil) tempNames. contents _ ((class decompilerClass new withTempNames: tempNames) decompile: selector in: class method: method) decompileString. contents _ contents asText makeSelectorBoldIn: class. ^ contents copy! ! !CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:50' prior: 35132904! decompiledSourceIntoContents "For backwards compatibility." ^self decompiledSourceIntoContentsWithTempNames: (Sensor leftShiftDown not) ! ! !CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:41'! decompiledSourceIntoContentsWithTempNames: showTempNames "Obtain a source string by decompiling the method's code, and place that source string into my contents. Also return the string. Get temps from source file if showTempNames is true." | tempNames class selector method | class := self selectedClassOrMetaClass. selector := self selectedMessageName. "Was method deleted while in another project?" method := class compiledMethodAt: selector ifAbsent: [^ '']. currentCompiledMethod := method. (showTempNames not or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) isNil]]) ifTrue: [ "Emergency or no source file -- decompile without temp names " contents := (class decompilerClass new decompile: selector in: class method: method) decompileString] ifFalse: [tempNames := (class compilerClass new parse: method getSourceFromFile asString in: class notifying: nil) tempNames. contents := ((class decompilerClass new withTempNames: tempNames) decompile: selector in: class method: method) decompileString]. contents := contents asText makeSelectorBoldIn: class. ^ contents copy! ! !CodeHolder methodsFor: 'message list' stamp: 'sw 8/16/2002 23:23'! selectedBytecodes "Answer text to show in a code pane when in showing-byte-codes mode" ^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName ifAbsent: [^ '' asText]) symbolic asText! ! !CodeHolder methodsFor: 'message list' stamp: 'sw 6/4/2001 17:31'! selectedMessage "Answer a copy of the source code for the selected message. This generic version is probably actually never reached, since every subclass probably reimplements and does not send to super. In time, ideally, most, or all, reimplementors would vanish and all would defer instead to a universal version right here. Everything in good time." | class selector method tempNames | contents == nil ifFalse: [^ contents copy]. self showingDecompile ifTrue: [^ self decompiledSourceIntoContents]. class _ self selectedClassOrMetaClass. (class isNil or: [(selector _ self selectedMessageName) isNil]) ifTrue: [^ '']. method _ class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod _ method. (Sensor controlKeyPressed or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) == nil]]) ifTrue: ["Emergency or no source file -- decompile without temp names" contents _ (class decompilerClass new decompile: selector in: class method: method) decompileString. contents _ contents asText makeSelectorBoldIn: class. ^ contents copy]. Sensor leftShiftDown ifTrue: ["Special request to decompile -- get temps from source file" tempNames _ (class compilerClass new parse: method getSourceFromFile asString in: class notifying: nil) tempNames. contents _ ((class decompilerClass new withTempNames: tempNames) decompile: selector in: class method: method) decompileString. contents _ contents asText makeSelectorBoldIn: class. ^ contents copy]. self showComment ifFalse: [contents _ self sourceStringPrettifiedAndDiffed] ifTrue: [contents _ self commentContents]. ^ contents _ contents copy asText makeSelectorBoldIn: class! ! !CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:46' prior: 35135487! selectedMessage "Answer a copy of the source code for the selected message. This generic version is probably actually never reached, since every subclass probably reimplements and does not send to super. In time, ideally, most, or all, reimplementors would vanish and all would defer instead to a universal version right here. Everything in good time." | class selector method | contents ifNotNil: [^ contents copy]. self showingDecompile ifTrue: [^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ]. class _ self selectedClassOrMetaClass. (class isNil or: [(selector _ self selectedMessageName) isNil]) ifTrue: [^ '']. method _ class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod _ method. ^ contents _ (self showComment ifFalse: [self sourceStringPrettifiedAndDiffed] ifTrue: [ self commentContents]) copy asText makeSelectorBoldIn: class! ! !CodeHolder methodsFor: 'message list' stamp: 'sw 7/23/2002 13:05'! sourceStringPrettifiedAndDiffed "Answer a copy of the source code for the selected message, transformed by diffing and pretty-printing exigencies" | class selector sourceString | class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. (class isNil or: [selector isNil]) ifTrue: [^ 'missing']. sourceString _ class ultimateSourceCodeAt: selector ifAbsent: [^ 'error']. self validateMessageSource: sourceString forSelector: selector. (#(prettyPrint colorPrint prettyDiffs altSyntax) includes: contentsSymbol) ifTrue: [sourceString _ class compilerClass new format: sourceString in: class notifying: nil contentsSymbol: contentsSymbol]. self showingAnyKindOfDiffs ifTrue: [sourceString _ self diffFromPriorSourceFor: sourceString]. ^ sourceString! ! !CodeHolder methodsFor: 'message list' stamp: 'sw 8/19/2001 12:57'! validateMessageSource: sourceString forSelector: aSelector "Check whether there is evidence that method source is invalid" | sourcesName | (self selectedClass compilerClass == Object compilerClass and: [(sourceString asString findString: aSelector keywords first ) ~= 1]) ifTrue: [sourcesName _ FileDirectory localNameFor: Smalltalk sourcesName. self inform: 'There may be a problem with your sources file!! The source code for every method should (usually) start with the method selector but this is not the case with this method!! You may proceed with caution but it is recommended that you get a new source file. This can happen if you download the "' , sourcesName , '" file, or the ".changes" file you use, as TEXT. It must be transfered in BINARY mode, even if it looks like a text file, to preserve the CR line ends. Mac users: This may have been caused by Stuffit Expander. To prevent the files above to be converted to Mac line ends when they are expanded, do this: Start the program, then from Preferences... in the File menu, choose the Cross Platform panel, then select "Never" and press OK. Then expand the compressed archive again. (Occasionally, the source code for a method may legitimately start with a non-alphabetic character -- for example, Behavior method #formalHeaderPartsFor:. In such rare cases, you can happily disregard this warning.)'].! ! !CodeHolder methodsFor: 'message list' stamp: 'sd 9/30/2003 14:01' prior: 35139218! validateMessageSource: sourceString forSelector: aSelector "Check whether there is evidence that method source is invalid" | sourcesName | (self selectedClass compilerClass == Object compilerClass and: [(sourceString asString findString: aSelector keywords first ) ~= 1]) ifTrue: [sourcesName _ FileDirectory localNameFor: SmalltalkImage current sourcesName. self inform: 'There may be a problem with your sources file!! The source code for every method should (usually) start with the method selector but this is not the case with this method!! You may proceed with caution but it is recommended that you get a new source file. This can happen if you download the "' , sourcesName , '" file, or the ".changes" file you use, as TEXT. It must be transfered in BINARY mode, even if it looks like a text file, to preserve the CR line ends. Mac users: This may have been caused by Stuffit Expander. To prevent the files above to be converted to Mac line ends when they are expanded, do this: Start the program, then from Preferences... in the File menu, choose the Cross Platform panel, then select "Never" and press OK. Then expand the compressed archive again. (Occasionally, the source code for a method may legitimately start with a non-alphabetic character -- for example, Behavior method #formalHeaderPartsFor:. In such rare cases, you can happily disregard this warning.)'].! ! !CodeHolder methodsFor: 'message list menu' stamp: 'sw 8/5/2002 16:56'! messageListKey: aChar from: view "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." | sel class | aChar == $D ifTrue: [^ self toggleDiffing]. sel _ self selectedMessageName. aChar == $m ifTrue: "These next two put up a type in if no message selected" [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: Smalltalk]. aChar == $n ifTrue: [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: Smalltalk]. "The following require a class selection" (class _ self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel]. aChar == $N ifTrue: [^ self browseClassRefs]. aChar == $i ifTrue: [^ self methodHierarchy]. aChar == $h ifTrue: [^ self classHierarchy]. aChar == $p ifTrue: [^ self browseFullProtocol]. "The following require a method selection" sel ifNotNil: [aChar == $o ifTrue: [^ self fileOutMessage]. aChar == $c ifTrue: [^ self copySelector]. aChar == $v ifTrue: [^ self browseVersions]. aChar == $O ifTrue: [^ self openSingleMessageBrowser]. aChar == $x ifTrue: [^ self removeMessage]. (aChar == $C and: [self canShowMultipleMessageCategories]) ifTrue: [^ self showHomeCategory]]. ^ self arrowKey: aChar from: view! ! !CodeHolder methodsFor: 'message list menu' stamp: 'sd 4/16/2003 09:33' prior: 35142179! messageListKey: aChar from: view "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." | sel class | aChar == $D ifTrue: [^ self toggleDiffing]. sel _ self selectedMessageName. aChar == $m ifTrue: "These next two put up a type in if no message selected" [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation]. aChar == $n ifTrue: [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation]. "The following require a class selection" (class _ self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel]. aChar == $N ifTrue: [^ self browseClassRefs]. aChar == $i ifTrue: [^ self methodHierarchy]. aChar == $h ifTrue: [^ self classHierarchy]. aChar == $p ifTrue: [^ self browseFullProtocol]. "The following require a method selection" sel ifNotNil: [aChar == $o ifTrue: [^ self fileOutMessage]. aChar == $c ifTrue: [^ self copySelector]. aChar == $v ifTrue: [^ self browseVersions]. aChar == $O ifTrue: [^ self openSingleMessageBrowser]. aChar == $x ifTrue: [^ self removeMessage]. (aChar == $C and: [self canShowMultipleMessageCategories]) ifTrue: [^ self showHomeCategory]]. ^ self arrowKey: aChar from: view! ! !CodeHolder methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:19'! canShowMultipleMessageCategories "Answer whether the receiver is capable of showing multiple message categories" ^ false! ! !CodeLoader methodsFor: 'installing' stamp: 'RAA 2/19/2001 08:23'! installProject "Assume that we're loading a single file and it's a project" | aStream | aStream _ sourceFiles first contentStream. aStream ifNil:[^self error:'Project was not loaded']. ProjectLoading openName: nil "<--do we want to cache this locally? Need a name if so" stream: aStream fromDirectory: nil withProjectView: nil. ! ! !CodeLoader methodsFor: 'installing' stamp: 'bf 3/2/2001 16:18'! installSegment: reqEntry "Install the previously loaded segment" | contentStream contents trusted | contentStream _ reqEntry value contentStream. contentStream ifNil:[^self error:'No content to install: ', reqEntry key printString]. trusted _ SecurityManager default positionToSecureContentsOf: contentStream. trusted ifFalse:[(SecurityManager default enterRestrictedMode) ifFalse:[ (contentStream respondsTo: #close) ifTrue:[contentStream close]. ^self error:'Insecure content encountered: ', reqEntry key printString]]. contents _ contentStream ascii upToEnd unzipped. (contentStream respondsTo: #close) ifTrue:[contentStream close]. ^(RWBinaryOrTextStream with: contents) reset fileInObjectAndCode install.! ! !CodeLoader methodsFor: 'installing' stamp: 'sd 1/30/2004 15:16' prior: 35145814! installSegment: reqEntry "Install the previously loaded segment" | contentStream contents trusted | contentStream _ reqEntry value contentStream. contentStream ifNil:[^self error:'No content to install: ', reqEntry key printString]. trusted _ SecurityManager default positionToSecureContentsOf: contentStream. trusted ifFalse:[(SecurityManager default enterRestrictedMode) ifFalse:[ contentStream close. ^self error:'Insecure content encountered: ', reqEntry key printString]]. contents _ contentStream ascii upToEnd unzipped. (contentStream respondsTo: #close) ifTrue:[contentStream close]. ^(RWBinaryOrTextStream with: contents) reset fileInObjectAndCode install.! ! !CodeLoader methodsFor: 'installing' stamp: 'bf 3/2/2001 16:18'! installSourceFile: aStream "Install the previously loaded source file" | contents trusted | aStream ifNil:[^self error:'No content to install']. trusted _ SecurityManager default positionToSecureContentsOf: aStream. trusted ifFalse:[(SecurityManager default enterRestrictedMode) ifFalse:[ (aStream respondsTo: #close) ifTrue:[aStream close]. ^self error:'Insecure content encountered']]. contents _ aStream ascii upToEnd unzipped. (aStream respondsTo: #close) ifTrue:[aStream close]. ^(RWBinaryOrTextStream with: contents) reset fileIn! ! !CodeLoader methodsFor: 'installing' stamp: 'sd 1/30/2004 15:16' prior: 35147371! installSourceFile: aStream "Install the previously loaded source file" | contents trusted | aStream ifNil:[^self error:'No content to install']. trusted _ SecurityManager default positionToSecureContentsOf: aStream. trusted ifFalse:[(SecurityManager default enterRestrictedMode) ifFalse:[ aStream close. ^ self error:'Insecure content encountered']]. contents _ aStream ascii upToEnd unzipped. (aStream respondsTo: #close) ifTrue:[aStream close]. ^(RWBinaryOrTextStream with: contents) reset fileIn! ! !CodeLoader methodsFor: 'private' stamp: 'mir 2/2/2001 14:44'! createRequestFor: name in: aLoader "Create a URL request for the given string, which can be cached locally." | request | request _ HTTPLoader httpRequestClass for: self baseURL , name in: aLoader. aLoader addRequest: request. "fetch from URL" ^request! ! !CodeLoader methodsFor: 'private' stamp: 'avi 4/30/2004 01:40' prior: 19404634! httpRequestClass ^HTTPDownloadRequest! ! !CodeLoader class methodsFor: 'utilities' stamp: 'mir 2/2/2001 14:56'! loadCodeSegment: segmentName | loader | loader _ self new. loader loadSegments: (Array with: segmentName). loader installSegments.! ! !CodeLoader class methodsFor: 'utilities' stamp: 'ar 2/6/2001 19:22'! signFile: fileName renameAs: destFile key: privateKey dsa: dsa "Sign the given file using the private key." | in out | in _ FileStream readOnlyFileNamed: fileName. in binary. out _ FileStream newFileNamed: destFile. out binary. [in atEnd] whileFalse:[out nextPutAll: (in next: 4096)]. in close. out close. FileDirectory splitName: destFile to:[:path :file| SecurityManager default signFile: file directory: (FileDirectory on: path). ]. ! ! !CodeLoader class methodsFor: 'utilities' stamp: 'asm 12/6/2002 08:11' prior: 35149258! signFile: fileName renameAs: destFile key: privateKey dsa: dsa "Sign the given file using the private key." | in out | in _ FileStream readOnlyFileNamed: fileName. in binary. out _ FileStream newFileNamed: destFile. out binary. [in atEnd] whileFalse:[out nextPutAll: (in next: 4096)]. in close. out close. FileDirectory activeDirectoryClass splitName: destFile to:[:path :file| SecurityManager default signFile: file directory: (FileDirectory on: path). ]. ! ! !CodeLoader class methodsFor: 'utilities' stamp: 'ads 7/31/2003 14:00' prior: 19412289! signFilesFrom: sourceNames to: destNames key: privateKey "Sign all the given files using the private key. This will add an 's' to the extension of the file." "| fd oldNames newNames | fd _ FileDirectory default directoryNamed:'unsigned'. oldNames _ fd fileNames. newNames _ oldNames collect:[:name| 'signed', FileDirectory slash, name]. oldNames _ oldNames collect:[:name| 'unsigned', FileDirectory slash, name]. CodeLoader signFilesFrom: oldNames to: newNames key: DOLPrivateKey." | dsa | dsa _ DigitalSignatureAlgorithm new. dsa initRandomNonInteractively. 'Signing files...' displayProgressAt: Sensor cursorPoint from: 1 to: sourceNames size during:[:bar| 1 to: sourceNames size do:[:i| bar value: i. self signFile: (sourceNames at: i) renameAs: (destNames at: i) key: privateKey dsa: dsa]]. ! ! !CodeLoader class methodsFor: 'utilities' stamp: 'ar 2/6/2001 19:17'! verifySignedFileNamed: aFileName "CodeLoader verifySignedFileNamed: 'signed\dummy1.dsq' " | secured signedFileStream | signedFileStream _ FileStream fileNamed: aFileName. secured _ SecurityManager default positionToSecureContentsOf: signedFileStream. signedFileStream close. Transcript show: aFileName , ' verified: '; show: secured printString; cr. ! ! !CodecDemoMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:20'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 1.0 g: 0.806 b: 0.677! ! !CodecDemoMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:20' prior: 19418210! initialize "initialize the state of the receiver" super initialize. "" self codecClassName: 'MuLawCodec'! ! !CodecDemoMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:17' prior: 19417603! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'select codec' translated action: #selectCodec. ! ! !CollapsedMorph methodsFor: 'collapse/expand' stamp: 'sw 4/9/2001 14:23'! uncollapseToHand "Hand the uncollapsedMorph to the user, placing it in her hand, after remembering appropriate state for possible future use" | nakedMorph | nakedMorph _ uncollapsedMorph. uncollapsedMorph _ nil. nakedMorph setProperty: #collapsedPosition toValue: self position. mustNotClose _ false. "so the delete will succeed" self delete. ActiveHand attachMorph: nakedMorph! ! !CollapsedMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:41' prior: 19419589! buildWindowMenu "Answer the menu to be put up in response to the user's clicking on the window-menu control in the window title. Specialized for CollapsedMorphs." | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu add: 'change name...' translated action: #relabel. aMenu addLine. aMenu add: 'send to back' translated action: #sendToBack. aMenu add: 'make next-to-topmost' translated action: #makeSecondTopmost. aMenu addLine. self mustNotClose ifFalse: [aMenu add: 'make unclosable' translated action: #makeUnclosable] ifTrue: [aMenu add: 'make closable' translated action: #makeClosable]. aMenu add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) translated action: #toggleStickiness. ^aMenu! ! !CollapsedMorph methodsFor: 'queries' stamp: 'sw 4/9/2001 12:53'! isMyUncollapsedMorph: aMorph "Answer whether my uncollapsed morph is aMorph" ^ uncollapsedMorph == aMorph! ! !CollapsedMorph methodsFor: 'resize/collapse' stamp: 'sw 6/5/2001 22:55'! wantsExpandBox "Answer whether I'd like an expand box" ^ false! ! !CollapsedMorph class methodsFor: 'as yet unclassified' stamp: 'sw 4/9/2001 14:19'! collapsedMorphOrNilFor: anActualMorph "If there is any instance of the receiver that represents anActualMorph, answer it, else answer nil" self allInstances do: [:cm | (cm isMyUncollapsedMorph: anActualMorph) ifTrue: [^ cm]]. ^ nil! ! !Collection methodsFor: 'accessing' stamp: 'tk 4/9/2001 15:26'! atRandom "Answer a random element of the receiver. Uses a shared random number generator owned by class Collection. If you use this a lot, define your own instance of Random and use #atRandom:. Causes an error if self has no elements." ^ self atRandom: Collection randomForPicking "Examples: #('one' 'or' 'the' 'other') atRandom (1 to: 10) atRandom 'Just pick one of these letters at random' atRandom #(3 7 4 9 21) asSet atRandom (just to show it also works for Sets) "! ! !Collection methodsFor: 'accessing' stamp: 'sd 11/4/2003 22:05' prior: 35154318! atRandom "Answer a random element of the receiver. Uses a shared random number generator owned by class Collection. If you use this a lot, define your own instance of Random and use #atRandom:. Causes an error if self has no elements." ^ self class mutexForPicking critical: [ self atRandom: self class randomForPicking ] "Examples: #('one' 'or' 'the' 'other') atRandom (1 to: 10) atRandom 'Just pick one of these letters at random' atRandom #(3 7 4 9 21) asSet atRandom (just to show it also works for Sets) "! ! !Collection methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 00:17'! raisedTo: arg ^ arg adaptToCollection: self andSend: #raisedTo:! ! !Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 20:30'! asIdentitySkipList "Answer a IdentitySkipList whose elements are the elements of the receiver. The sort order is the default less than or equal." ^ self as: IdentitySkipList! ! !Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 18:47'! asSkipList "Answer a SkipList whose elements are the elements of the receiver. The sort order is the default less than or equal." ^ self as: SkipList! ! !Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 18:46'! asSkipList: aSortBlock "Answer a SkipList whose elements are the elements of the receiver. The sort order is defined by the argument, aSortBlock." | skipList | skipList _ SortedCollection new: self size. skipList sortBlock: aSortBlock. skipList addAll: self. ^ skipList! ! !Collection methodsFor: 'converting' stamp: 'hg 12/26/2001 23:53'! topologicallySortedUsing: aSortBlock "Answer a SortedCollection whose elements are the elements of the receiver, but topologically sorted. The topological order is defined by the argument, aSortBlock." | aSortedCollection | aSortedCollection _ SortedCollection new: self size. aSortedCollection sortBlock: aSortBlock. self do: [:each | aSortedCollection addLast: each]. "avoids sorting" ^ aSortedCollection sortTopologically ! ! !Collection methodsFor: 'copying' stamp: 'al 12/12/2003 14:31'! , aCollection ^self copy addAll: aCollection; yourself! ! !Collection methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement "Answer a new collection with newElement added (as last element if sequenceable)." ^self copyWith: newElement! ! !Collection methodsFor: 'enumerating' stamp: 'gh 9/18/2001 15:59'! noneSatisfy: aBlock "Evaluate aBlock with the elements of the receiver. If aBlock returns false for all elements return true. Otherwise return false" self do: [:item | (aBlock value: item) ifTrue: [^ false]]. ^ true! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! arcCos ^self collect: [:each | each arcCos]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! arcSin ^self collect: [:each | each arcSin]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! arcTan ^self collect: [:each | each arcTan]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! cos ^self collect: [:each | each cos]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! degreeCos ^self collect: [:each | each degreeCos]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'! degreeSin ^self collect: [:each | each degreeSin]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'! exp ^self collect: [:each | each exp]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'! ln ^self collect: [:each | each ln]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:23'! sign ^self collect: [:each | each sign]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:22'! sin ^self collect: [:each | each sin]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:22'! tan ^self collect: [:each | each tan]! ! !Collection methodsFor: 'private' stamp: 'yo 6/29/2004 13:14' prior: 19441276! errorNotKeyed self error: ('Instances of {1} do not respond to keyed accessing messages.' translated format: {self class name}) ! ! !Collection methodsFor: 'testing' stamp: 'jf 12/1/2003 15:37'! ifEmpty: aBlock "Evaluate the block if I'm empty" ^ self isEmpty ifTrue: aBlock! ! !Collection methodsFor: 'testing' stamp: 'jf 12/1/2003 15:39'! ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" ^ self isEmpty ifTrue: emptyBlock ifFalse: notEmptyBlock! ! !Collection methodsFor: 'testing' stamp: 'md 1/30/2004 15:11' prior: 35159270! ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" ^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock valueWithPossibleArgs: {self}]! ! !Collection methodsFor: 'testing' stamp: 'jf 12/1/2003 15:37'! ifNotEmpty: aBlock "Evaluate the block unless I'm empty" ^ self isEmpty ifFalse: aBlock! ! !Collection methodsFor: 'testing' stamp: 'md 1/30/2004 15:08' prior: 35159784! ifNotEmpty: aBlock "Evaluate the block unless I'm empty" ^self isEmpty ifFalse: [aBlock valueWithPossibleArgs: {self}]. ! ! !Collection methodsFor: 'testing' stamp: 'jf 12/1/2003 15:47'! ifNotEmpty: notEmptyBlock ifEmpty: emptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" ^ self isEmpty ifFalse: notEmptyBlock ifTrue: emptyBlock! ! !Collection methodsFor: 'testing' stamp: 'md 1/30/2004 15:11' prior: 35160149! ifNotEmpty: notEmptyBlock ifEmpty: emptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" ^ self isEmpty ifFalse: [notEmptyBlock valueWithPossibleArgs: {self}] ifTrue: emptyBlock! ! !Collection methodsFor: 'testing' stamp: 'dgd 4/4/2004 12:14'! isZero "Answer whether the receiver is zero" ^ false! ! !Collection methodsFor: '*packageinfo-base' stamp: 'ab 9/30/2002 19:26'! gather: aBlock ^ Array streamContents: [:stream | self do: [:ea | stream nextPutAll: (aBlock value: ea)]]! ! !Collection methodsFor: '*packageinfo-base' stamp: 'ab 9/30/2002 19:26' prior: 35160795! gather: aBlock ^ Array streamContents: [:stream | self do: [:ea | stream nextPutAll: (aBlock value: ea)]]! ! !Collection methodsFor: '*packageinfo-base' stamp: 'ab 9/30/2002 19:26' prior: 35161002! gather: aBlock ^ Array streamContents: [:stream | self do: [:ea | stream nextPutAll: (aBlock value: ea)]]! ! !Collection methodsFor: '*connectors-truncation and round-off' stamp: 'nk 12/30/2003 15:47'! roundTo: quantum ^self collect: [ :ea | ea roundTo: quantum ]! ! !Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:07' prior: 19448850! initialize "Set up a Random number generator to be used by atRandom when the user does not feel like creating his own Random generator." RandomForPicking _ Random new. MutexForPicking _ Semaphore forMutualExclusion! ! !Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:08'! mutexForPicking ^ MutexForPicking! ! !Color methodsFor: 'queries' stamp: 'sw 9/27/2001 17:26'! basicType "Answer a symbol representing the inherent type of the receiver" ^ #Color! ! !Color methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'! isOpaque ^true! ! !Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50'! adjustBrightness: brightness "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" ^ Color h: self hue s: self saturation v: (self brightness + brightness min: 1.0 max: 0.005) alpha: self alpha! ! !Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51'! adjustSaturation: saturation brightness: brightness "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" ^ Color h: self hue s: (self saturation + saturation min: 1.0 max: 0.005) v: (self brightness + brightness min: 1.0 max: 0.005) alpha: self alpha! ! !Color methodsFor: 'transformations' stamp: 'nk 3/8/2004 09:43'! atMostAsLuminentAs: aFloat | revisedColor | revisedColor _ self. [revisedColor luminance > aFloat] whileTrue: [revisedColor _ revisedColor slightlyDarker]. ^revisedColor ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! blacker ^ self alphaMixed: 0.8333 with: Color black ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54'! dansDarker "Return a darker shade of the same color. An attempt to do better than the current darker method. (now obsolete, since darker has been changed to do this. -dew)" ^ Color h: self hue s: self saturation v: (self brightness - 0.16 max: 0.0)! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:40'! darker "Answer a darker shade of this color." ^ self adjustBrightness: -0.08! ! !Color methodsFor: 'transformations' stamp: 'dew 3/8/2002 00:13'! duller ^ self adjustSaturation: -0.03 brightness: -0.2! ! !Color methodsFor: 'transformations' stamp: 'dew 1/23/2002 20:19'! lighter "Answer a lighter shade of this color." ^ self adjustSaturation: -0.03 brightness: 0.08! ! !Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29'! muchDarker ^ self alphaMixed: 0.5 with: Color black ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:42'! paler "Answer a paler shade of this color." ^ self adjustSaturation: -0.09 brightness: 0.09 ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! slightlyDarker ^ self adjustBrightness: -0.03 ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! slightlyLighter ^ self adjustSaturation: -0.01 brightness: 0.03! ! !Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25'! slightlyWhiter ^ self alphaMixed: 0.85 with: Color white ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:44'! twiceDarker "Answer a significantly darker shade of this color." ^ self adjustBrightness: -0.15! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:45'! twiceLighter "Answer a significantly lighter shade of this color." ^ self adjustSaturation: -0.06 brightness: 0.15! ! !Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! whiter ^ self alphaMixed: 0.8333 with: Color white ! ! !Color methodsFor: 'other' stamp: 'ar 8/16/2001 12:47'! raisedColor ^ self! ! !Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25'! makeForegroundColor "Make a foreground color contrasting with me" ^self luminance >= 0.5 ifTrue: [Color black] ifFalse: [Color white]! ! !Color methodsFor: 'conversions' stamp: 'ar 5/15/2001 16:12'! pixelValue32 "Note: pixelWord not pixelValue so we include translucency" ^self pixelWordForDepth: 32! ! !Color methodsFor: 'conversions' stamp: 'jm 1/26/2001 15:11'! pixelValueForDepth: d "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue." | rgbBlack val | d = 8 ifTrue: [^ self closestPixelValue8]. "common case" d < 8 ifTrue: [ d = 4 ifTrue: [^ self closestPixelValue4]. d = 2 ifTrue: [^ self closestPixelValue2]. d = 1 ifTrue: [^ self closestPixelValue1]]. rgbBlack _ 1. "closest black that is not transparent in RGB" d = 16 ifTrue: [ "five bits per component; top bits ignored" val _ (((rgb bitShift: -15) bitAnd: 16r7C00) bitOr: ((rgb bitShift: -10) bitAnd: 16r03E0)) bitOr: ((rgb bitShift: -5) bitAnd: 16r001F). ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]]. d = 32 ifTrue: [ "eight bits per component; top 8 bits set to all ones (opaque alpha)" val _ LargePositiveInteger new: 4. val at: 3 put: ((rgb bitShift: -22) bitAnd: 16rFF). val at: 2 put: ((rgb bitShift: -12) bitAnd: 16rFF). val at: 1 put: ((rgb bitShift: -2) bitAnd: 16rFF). val = 0 ifTrue: [val at: 1 put: 1]. "closest non-transparent black" val at: 4 put: 16rFF. "opaque alpha" ^ val]. d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" val _ (((rgb bitShift: -18) bitAnd: 16r0F00) bitOr: ((rgb bitShift: -12) bitAnd: 16r00F0)) bitOr: ((rgb bitShift: -6) bitAnd: 16r000F). ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]]. d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" val _ (((rgb bitShift: -21) bitAnd: 16r01C0) bitOr: ((rgb bitShift: -14) bitAnd: 16r0038)) bitOr: ((rgb bitShift: -7) bitAnd: 16r0007). ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]]. self error: 'unknown pixel depth: ', d printString ! ! !Color methodsFor: 'Morphic menu' stamp: 'dgd 10/17/2003 12:10' prior: 19485797! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" aMenu add: 'change color...' translated target: self selector: #changeColorIn:event: argument: aMorph! ! !Color class methodsFor: 'instance creation' stamp: 'sw 2/26/2002 10:46'! colorFrom: parm "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" | aColor firstParm | (parm isKindOf: Color) ifTrue: [^ parm]. (parm isKindOf: Symbol) ifTrue: [^ self perform: parm]. ((parm isKindOf: SequenceableCollection) and: [parm size > 0]) ifTrue: [firstParm _ parm first. (firstParm isKindOf: Number) ifTrue: [^ self fromRgbTriplet: parm]. aColor _ self colorFrom: firstParm. parm doWithIndex: [:sym :ind | ind > 1 ifTrue: [aColor _ aColor perform: sym]]. ^ aColor]. ^ parm " Color colorFrom: #(blue darker) Color colorFrom: Color blue darker Color colorFrom: #blue Color colorFrom: #(0.0 0.0 1.0) "! ! !Color class methodsFor: 'instance creation' stamp: 'tk 8/15/2001 11:03'! colorFromPixelValue: p depth: d "Convert a pixel value for the given display depth into a color." "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." | r g b alpha | d = 8 ifTrue: [^ IndexedColors at: (p bitAnd: 16rFF) + 1]. d = 4 ifTrue: [^ IndexedColors at: (p bitAnd: 16r0F) + 1]. d = 2 ifTrue: [^ IndexedColors at: (p bitAnd: 16r03) + 1]. d = 1 ifTrue: [^ IndexedColors at: (p bitAnd: 16r01) + 1]. (d = 16) | (d = 15) ifTrue: [ "five bits per component" r _ (p bitShift: -10) bitAnd: 16r1F. g _ (p bitShift: -5) bitAnd: 16r1F. b _ p bitAnd: 16r1F. (r = 0 and: [g = 0]) ifTrue: [ b = 0 ifTrue: [^Color transparent]. b = 1 ifTrue: [^Color black]]. ^ Color r: r g: g b: b range: 31]. d = 32 ifTrue: [ "eight bits per component; 8 bits of alpha" r _ (p bitShift: -16) bitAnd: 16rFF. g _ (p bitShift: -8) bitAnd: 16rFF. b _ p bitAnd: 16rFF. alpha _ p bitShift: -24. alpha = 0 ifTrue: [^Color transparent]. (r = 0 and: [g = 0 and: [b = 0]]) ifTrue: [^Color transparent]. alpha < 255 ifTrue: [^ (Color r: r g: g b: b range: 255) alpha: (alpha asFloat / 255.0)] ifFalse: [^ (Color r: r g: g b: b range: 255)]]. d = 12 ifTrue: [ "four bits per component" r _ (p bitShift: -8) bitAnd: 16rF. g _ (p bitShift: -4) bitAnd: 16rF. b _ p bitAnd: 16rF. ^ Color r: r g: g b: b range: 15]. d = 9 ifTrue: [ "three bits per component" r _ (p bitShift: -6) bitAnd: 16r7. g _ (p bitShift: -3) bitAnd: 16r7. b _ p bitAnd: 16r7. ^ Color r: r g: g b: b range: 7]. self error: 'unknown pixel depth: ', d printString ! ! !Color class methodsFor: 'instance creation' stamp: 'dew 3/19/2002 23:49'! h: h s: s v: v alpha: alpha ^ (self h: h s: s v: v) alpha: alpha! ! !ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:03'! at: index ^(super at: index) asColorOfDepth: 32! ! !ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:04'! at: index put: aColor ^super at: index put: (aColor pixelWordForDepth: 32).! ! !ColorArray methodsFor: 'converting' stamp: 'ar 3/3/2001 20:06'! asColorArray ^self! ! !ColorArray methodsFor: 'converting' stamp: 'RAA 3/8/2001 06:24'! bytesPerElement ^4! ! !ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45'! colors: colorList "Set my color palette to the given collection." | colorArray colorCount newColors | colorList ifNil: [ colors _ cachedDepth _ cachedColormap _ nil. ^ self]. colorArray _ colorList asArray. colorCount _ colorArray size. newColors _ Array new: (1 bitShift: self depth). 1 to: newColors size do: [:i | i <= colorCount ifTrue: [newColors at: i put: (colorArray at: i)] ifFalse: [newColors at: i put: Color transparent]]. colors _ newColors. cachedDepth _ nil. cachedColormap _ nil. ! ! !ColorForm methodsFor: 'displaying' stamp: 'ar 5/14/2001 23:32'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm aDisplayMedium copyBits: self boundingBox from: self at: aDisplayPoint + self offset clippingBox: clipRectangle rule: rule fillColor: aForm map: (self colormapIfNeededFor: aDisplayMedium). ! ! !ColorForm methodsFor: 'displaying' stamp: 'ar 12/14/2001 18:14'! maskingMap "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." | maskingMap | maskingMap _ Bitmap new: (1 bitShift: depth) withAll: 16rFFFFFFFF. 1 to: colors size do:[:i| (colors at: i) isTransparent ifTrue:[maskingMap at: i put: 0]. ]. colors size+1 to: maskingMap size do:[:i| maskingMap at: i put: 0]. ^maskingMap! ! !ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/17/2001 15:44'! colormapIfNeededForDepth: destDepth "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." | newMap | colors == nil ifTrue: [ "use the standard colormap" ^ Color colorMapIfNeededFrom: self depth to: destDepth]. (destDepth = cachedDepth and:[cachedColormap isColormap not]) ifTrue: [^ cachedColormap]. newMap _ Bitmap new: colors size. 1 to: colors size do: [:i | newMap at: i put: ((colors at: i) pixelValueForDepth: destDepth)]. cachedDepth _ destDepth. ^ cachedColormap _ newMap. ! ! !ColorForm methodsFor: 'copying' stamp: 'di 11/12/2001 15:37'! blankCopyOf: aRectangle scaledBy: scale | newForm | newForm _ super blankCopyOf: aRectangle scaledBy: scale. colors ifNotNil: [newForm colors: colors copy]. ^ newForm! ! !ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44'! ensureColorArrayExists "Return my color palette." colors ifNil: [ self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. ! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 20:07'! hibernate "Make myself take up less space. See comment in Form>hibernate." super hibernate. self clearColormapCache. colors ifNotNil:[colors _ colors asColorArray].! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:46'! readAttributesFrom: aBinaryStream super readAttributesFrom: aBinaryStream. colors _ ColorArray new: (2 raisedTo: depth). 1 to: colors size do: [:idx | colors basicAt: idx put: (aBinaryStream nextLittleEndianNumber: 4). ]. ! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 20:07'! unhibernate colors ifNotNil:[colors _ colors asArray]. ^super unhibernate. ! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:42'! writeAttributesOn: file | colorArray | super writeAttributesOn: file. colorArray _ self colors asColorArray. 1 to: (2 raisedTo: depth) do: [:idx | file nextLittleEndianNumber: 4 put: (colorArray basicAt: idx). ] ! ! !ColorForm methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:44'! colormapIfNeededFor: destForm | newMap color pv | (self hasNonStandardPalette or:[destForm hasNonStandardPalette]) ifFalse:[ ^self colormapIfNeededForDepth: destForm depth. ]. colors == nil ifTrue: [ "use the standard colormap" ^ super colormapIfNeededFor: destForm]. (destForm depth = cachedDepth and:[cachedColormap isColormap]) ifTrue: [^ cachedColormap]. newMap _ WordArray new: (1 bitShift: self depth). 1 to: colors size do: [:i | color _ colors at: i. pv _ destForm pixelValueFor: color. (pv = 0 and:[color isTransparent not]) ifTrue:[pv _ 1]. newMap at: i put: pv]. cachedDepth _ destForm depth. ^cachedColormap _ ColorMap shifts: nil masks: nil colors: newMap.! ! !ColorForm methodsFor: 'testing' stamp: 'ar 5/27/2001 16:34'! isColorForm ^true! ! !ColorForm methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'! isTranslucent "Answer whether this form may be translucent" ^true! ! !ColorForm class methodsFor: 'as yet unclassified' stamp: 'nk 4/17/2004 19:44' prior: 19538090! mappingWhiteToTransparentFrom: aFormOrCursor "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." | f map | aFormOrCursor depth <= 8 ifFalse: [ ^ self error: 'argument depth must be 8-bits per pixel or less']. (aFormOrCursor isColorForm) ifTrue: [ f _ aFormOrCursor deepCopy. map _ aFormOrCursor colors. ] ifFalse: [ f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. f copyBits: aFormOrCursor boundingBox from: aFormOrCursor at: 0@0 clippingBox: aFormOrCursor boundingBox rule: Form over fillColor: nil. map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. map _ map collect: [:c | c = Color white ifTrue: [Color transparent] ifFalse: [c]]. f colors: map. ^ f ! ! !ColorMap methodsFor: 'pixel mapping' stamp: 'ar 5/15/2001 16:12'! mapPixel: pixelValue "Perform a forward pixel mapping operation" | pv | (shifts == nil and:[masks == nil]) ifFalse:[ pv _ (((pixelValue bitAnd: self redMask) bitShift: self redShift) bitOr: ((pixelValue bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pixelValue bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pixelValue bitAnd: self alphaMask) bitShift: self alphaShift)). ] ifTrue:[pv _ pixelValue]. colors ifNotNil:[pv _ colors at: pv]. "Need to check for translucency else Form>>paint goes gaga" pv = 0 ifTrue:[pixelValue = 0 ifFalse:[pv _ 1]]. ^pv! ! !ColorMap methodsFor: 'pixel mapping' stamp: 'ar 5/15/2001 16:12'! pixelMap: pixelValue "Perform a reverse pixel mapping operation" | pv | colors == nil ifTrue:[pv _ pixelValue] ifFalse:[pv _ colors at: pixelValue]. (shifts == nil and:[masks == nil]) ifFalse:[pv _ (((pv bitAnd: self redMask) bitShift: self redShift) bitOr: ((pv bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pv bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pv bitAnd: self alphaMask) bitShift: self alphaShift))]. "Need to check for translucency else Form>>paint goes gaga" pv = 0 ifTrue:[pixelValue = 0 ifFalse:[pv _ 1]]. ^pv! ! !ColorMap methodsFor: 'comparing' stamp: 'tk 7/5/2001 21:59'! = aColorMap "Return true if the receiver is equal to aColorMap" self species == aColorMap species ifFalse:[^false]. self isIndexed == aColorMap isIndexed ifFalse:[^false]. ^self colors = aColorMap colors and:[ self shifts = aColorMap shifts and:[ self masks = aColorMap masks]]! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/4/2001 15:59'! masks: maskArray shifts: shiftArray ^self shifts: shiftArray masks: maskArray colors: nil.! ! !ColorMappingCanvas methodsFor: 'drawing-polygons' stamp: 'mir 9/12/2001 14:24'! drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc "Draw the given polygon." ^myCanvas drawPolygon: vertices color: aColor borderWidth: bw borderColor: (self mapColor: bc)! ! !ColorMappingCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:28'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used." myCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: (self mapColor: c)! ! !ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:14'! on: aCanvas myCanvas _ aCanvas.! ! !ColorMappingCanvas methodsFor: 'testing' stamp: 'ar 8/8/2001 14:16'! isShadowDrawing ^myCanvas isShadowDrawing! ! !ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle." ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: rule.! ! !ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'! mapColor: aColor ^aColor! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 8/25/2001 20:44'! locationIndicator | loc | ^self valueOfProperty: #locationIndicator ifAbsent:[ loc _ EllipseMorph new. loc color: Color transparent; borderWidth: 1; borderColor: Color red; extent: 6@6. self setProperty: #locationIndicator toValue: loc. self addMorphFront: loc. loc]! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 8/25/2001 20:51'! originalColor: colorOrSymbol "Set the receiver's original color. It is at this point that a command is launched to represent the action of the picker, in support of Undo." originalColor _ (colorOrSymbol isKindOf: Color) ifTrue: [colorOrSymbol] ifFalse: [Color lightGreen]. originalForm fill: RevertBox fillColor: originalColor. selectedColor _ originalColor. self locationIndicator center: self topLeft + (self positionOfColor: originalColor).! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'gm 2/22/2003 13:12' prior: 35180946! originalColor: colorOrSymbol "Set the receiver's original color. It is at this point that a command is launched to represent the action of the picker, in support of Undo." originalColor := (colorOrSymbol isColor) ifTrue: [colorOrSymbol] ifFalse: [Color lightGreen]. originalForm fill: RevertBox fillColor: originalColor. selectedColor := originalColor. self locationIndicator center: self topLeft + (self positionOfColor: originalColor)! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'aoy 2/15/2003 21:24' prior: 19559531! target: anObject target := anObject. selectedColor := (target respondsTo: #color) ifTrue: [target color] ifFalse: [Color white]! ! !ColorPickerMorph methodsFor: 'event handling' stamp: 'RAA 2/19/2001 13:16'! inhibitDragging ^self hasProperty: #noDraggingThisPicker! ! !ColorPickerMorph methodsFor: 'event handling' stamp: 'RAA 2/19/2001 13:17'! mouseDown: evt | localPt | localPt _ evt cursorPoint - self topLeft. self deleteAllBalloons. clickedTranslucency _ TransparentBox containsPoint: localPt. self inhibitDragging ifFalse: [ (DragBox containsPoint: localPt) ifTrue: [^ evt hand grabMorph: self]. ]. (RevertBox containsPoint: localPt) ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor]. self inhibitDragging ifFalse: [self comeToFront]. sourceHand _ evt hand. self startStepping. ! ! !ColorPickerMorph methodsFor: 'initialization' stamp: 'ar 9/4/2001 13:26'! initialize "Initialize the receiver. Obey the modalColorPickers preference when deciding how to configure myself. This is not quite satisfactory -- we'd like to have explicit calls tell us things like whether whether to be modal, whether to allow transparency, but for the moment, in grand Morphic fashion, this is rather inflexibly all housed right here" super initialize. self clipSubmorphs: true. self buildChartForm. selectedColor _ Color white. sourceHand _ nil. deleteOnMouseUp _ false. clickedTranslucency _ false. updateContinuously _ true. selector _ nil. target _ nil! ! !ColorPickerMorph methodsFor: 'initialization' stamp: 'RAA 2/19/2001 13:18'! initializeForPropertiesPanel "Initialize the receiver. If beModal is true, it will be a modal color picker, else not" isModal _ false. self removeAllMorphs. self setProperty: #noDraggingThisPicker toValue: true. self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'restore original color'). self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'shows selected color'). self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'adjust translucency'). self buildChartForm. selectedColor ifNil: [selectedColor _ Color white]. sourceHand _ nil. deleteOnMouseUp _ false. updateContinuously _ true. ! ! !ColorPickerMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:17' prior: 19566670! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. deleteOnMouseUp ifTrue: [aCustomMenu add: 'stay up' translated action: #toggleDeleteOnMouseUp] ifFalse: [aCustomMenu add: 'do not stay up' translated action: #toggleDeleteOnMouseUp]. updateContinuously ifTrue: [aCustomMenu add: 'update only at end' translated action: #toggleUpdateContinuously] ifFalse: [aCustomMenu add: 'update continuously' translated action: #toggleUpdateContinuously]. ! ! !ColorPickerMorph methodsFor: 'menu' stamp: 'tk 2/21/2001 17:54'! pickUpColorFor: aMorph "Show the eyedropper cursor, and modally track the mouse through a mouse-down and mouse-up cycle" | aHand localPt | aHand _ aMorph ifNil: [self activeHand] ifNotNil: [aMorph activeHand]. aHand ifNil: [aHand _ self currentHand]. self addToWorld: aHand world near: (aMorph ifNil: [aHand world]) fullBounds. self owner ifNil: [^ self]. aHand showTemporaryCursor: (ScriptingSystem formAtKey: #Eyedropper) hotSpotOffset: 6 negated @ 4 negated. "<<<< the form was changed a bit??" self updateContinuously: false. [Sensor anyButtonPressed] whileFalse: [self trackColorUnderMouse]. self deleteAllBalloons. localPt _ Sensor cursorPoint - self topLeft. self inhibitDragging ifFalse: [ (DragBox containsPoint: localPt) ifTrue: ["Click or drag the drag-dot means to anchor as a modeless picker" ^ self anchorAndRunModeless: aHand]. ]. (clickedTranslucency _ TransparentBox containsPoint: localPt) ifTrue: [selectedColor _ originalColor]. self updateContinuously: true. [Sensor anyButtonPressed] whileTrue: [self updateTargetColorWith: self indicateColorUnderMouse]. aHand newMouseFocus: nil; showTemporaryCursor: nil; flushEvents. self delete. ! ! !ColorPickerMorph methodsFor: 'other' stamp: 'dgd 8/26/2003 21:44' prior: 19570025! delete "The moment of departure has come. If the receiver has an affiliated command, finalize it and have the system remember it. In any case, delete the receiver" self rememberCommand: (Command new cmdWording: 'color change' translated; undoTarget: target selector: selector arguments: (self argumentsWith: originalColor); redoTarget: target selector: selector arguments: (self argumentsWith: selectedColor)). super delete! ! !ColorPickerMorph methodsFor: 'private' stamp: 'ar 7/19/2003 20:40' prior: 19561530! argumentsWith: aColor "Return an argument array appropriate to this action selector" | nArgs | nArgs _ selector ifNil:[0] ifNotNil:[selector numArgs]. nArgs = 0 ifTrue:[^#()]. nArgs = 1 ifTrue:[^ {aColor}]. nArgs = 2 ifTrue:[^ {aColor. sourceHand}]. nArgs = 3 ifTrue:[^ {aColor. argument. sourceHand}]. ! ! !ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:59' prior: 19561995! modalBalloonHelpAtPoint: cursorPoint self flag: #arNote. "Throw this away. There needs to be another way." self submorphsDo: [:m | m wantsBalloon ifTrue: [(m valueOfProperty: #balloon) isNil ifTrue: [(m containsPoint: cursorPoint) ifTrue: [m showBalloon: m balloonText]] ifFalse: [(m containsPoint: cursorPoint) ifFalse: [m deleteBalloon]]]]! ! !ColorPickerMorph methodsFor: 'private' stamp: 'ar 8/25/2001 20:43'! pickColorAt: aGlobalPoint | alpha selfRelativePoint pickedColor | clickedTranslucency ifNil: [clickedTranslucency _ false]. selfRelativePoint _ (self globalPointToLocal: aGlobalPoint) - self topLeft. (FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self]. (RevertBox containsPoint: selfRelativePoint) ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor]. "check for transparent color and update using appropriate feedback color " (TransparentBox containsPoint: selfRelativePoint) ifTrue: [clickedTranslucency ifFalse: [^ self]. "Can't wander into translucency control" alpha _ (selfRelativePoint x - TransparentBox left - 10) asFloat / (TransparentBox width - 20) min: 1.0 max: 0.0. "(alpha roundTo: 0.01) printString , ' ' displayAt: 0@0." " -- debug" self updateColor: (selectedColor alpha: alpha) feedbackColor: (selectedColor alpha: alpha). ^ self]. "pick up color, either inside or outside this world" clickedTranslucency ifTrue: [^ self]. "Can't wander out of translucency control" self locationIndicator visible: false. self refreshWorld. pickedColor _ Display colorAt: aGlobalPoint. self locationIndicator visible: true. self refreshWorld. self updateColor: ( (selectedColor isColor and: [selectedColor isTranslucentColor]) ifTrue: [pickedColor alpha: selectedColor alpha] ifFalse: [pickedColor] ) feedbackColor: pickedColor! ! !ColorPickerMorph methodsFor: 'private' stamp: 'ar 9/4/2001 13:27'! positionOfColor: aColor "Compute the position of the given color in the color chart form" | rgbRect x y h s v | rgbRect _ (0@0 extent: originalForm boundingBox extent) insetBy: (1@10 corner: 11@1). h _ aColor hue. s _ aColor saturation. v _ aColor brightness. h = 0.0 ifTrue:["gray" ^(rgbRect right + 6) @ (rgbRect height * (1.0 - v) + rgbRect top)]. x _ (h + 22 \\ 360 / 360.0 * rgbRect width) rounded. y _ 0.5. s < 1.0 ifTrue:[y _ y - (1.0 - s * 0.5)]. v < 1.0 ifTrue:[y _ y + (1.0 - v * 0.5)]. y _ (y * rgbRect height) rounded. ^x@y + (1@10)! ! !ColorPickerMorph methodsFor: 'private' stamp: 'ar 8/25/2001 20:50'! updateColor: aColor feedbackColor: feedbackColor "Set my selected color to the given color if it is different. Give user feedback. Inform the target of the change if the target and selector are not nil." selectedColor = aColor ifTrue: [^ self]. "do nothing if color doesn't change" self updateAlpha: aColor alpha. originalForm fill: FeedbackBox fillColor: feedbackColor. self form: originalForm. selectedColor _ aColor. updateContinuously ifTrue: [self updateTargetColor]. self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).! ! !ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:41' prior: 19565884! updateTargetColor | nArgs | (target notNil and: [selector notNil]) ifTrue: [self updateSelectorDisplay. nArgs := selector numArgs. nArgs = 1 ifTrue: [^target perform: selector with: selectedColor]. nArgs = 2 ifTrue: [^target perform: selector with: selectedColor with: sourceHand]. nArgs = 3 ifTrue: [^target perform: selector with: selectedColor with: argument with: sourceHand]]! ! !ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:41' prior: 19566348! updateTargetColorWith: aColor "Update the target so that it reflects aColor as the color choice" (target notNil and: [selector notNil]) ifTrue: [self updateSelectorDisplay. ^target perform: selector withArguments: (self argumentsWith: aColor)]! ! !ColorPickerMorph commentStamp: 'kfr 10/27/2003 16:16' prior: 0! A gui for setting color and transparency. Behaviour can be changed with the Preference modalColorPickers.! !ColorSeerTile methodsFor: 'code generation' stamp: 'dgd 2/22/2003 14:25' prior: 19575372! storeCodeOn: aStream indent: tabCount "We have a hidden arg. Output two keywords with interspersed arguments." | parts | parts := operatorOrExpression keywords. "color:sees:" ^aStream nextPutAll: (parts first); space; nextPutAll: colorSwatch color printString; space; nextPutAll: (parts second)! ! !ColorSeerTile methodsFor: 'initialization' stamp: 'sw 10/10/2001 21:23'! initialize | m1 m2 desiredW wording | super initialize. self removeAllMorphs. "get rid of the parts of a regular Color tile" type _ #operator. operatorOrExpression _ #color:sees:. wording _ (Vocabulary eToyVocabulary methodInterfaceAt: operatorOrExpression ifAbsent: []) elementWording. m1 _ StringMorph contents: wording font: ScriptingSystem fontForTiles. m2 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0 b: 0). desiredW _ m1 width + 6. self extent: (desiredW max: self basicWidth) @ self class defaultH. m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 5). m2 position: (bounds center x - (m2 width // 2) + 3) @ (bounds top + 8). self addMorph: m1; addMorphFront: m2. colorSwatch _ m2. ! ! !ColorSeerTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45' prior: 35192117! initialize "initialize the state of the receiver" | m1 m2 desiredW wording | super initialize. "" self removeAllMorphs. "get rid of the parts of a regular Color tile" type _ #operator. operatorOrExpression _ #color:sees:. wording _ (Vocabulary eToyVocabulary methodInterfaceAt: operatorOrExpression ifAbsent: []) elementWording. m1 _ StringMorph contents: wording font: ScriptingSystem fontForTiles. m2 _ Morph new extent: 12 @ 8; color: (Color r: 0.8 g: 0 b: 0). desiredW _ m1 width + 6. self extent: (desiredW max: self basicWidth) @ self class defaultH. m1 position: bounds center x - (m1 width // 2) @ (bounds top + 5). m2 position: bounds center x - (m2 width // 2) + 3 @ (bounds top + 8). self addMorph: m1; addMorphFront: m2. colorSwatch _ m2! ! !ColorSeerTile methodsFor: 'initialization' stamp: 'bf 10/8/2001 14:59'! updateWordingToMatchVocabulary "The current vocabulary has changed; change the wording on my face, if appropriate" | aMethodInterface | aMethodInterface _ self currentVocabulary methodInterfaceAt: operatorOrExpression ifAbsent: [Vocabulary eToyVocabulary methodInterfaceAt: operatorOrExpression ifAbsent: [^ self]]. self labelMorph contents: aMethodInterface wording. self setBalloonText: aMethodInterface documentation.! ! !ColorSwatch methodsFor: 'setting' stamp: 'sw 3/23/2001 12:12'! setTargetColor: aColor "Set the target color as indicated" putSelector ifNotNil: [self color: aColor. contents _ aColor. target perform: self putSelector withArguments: (Array with: argument with: aColor)] ! ! !ColorSwatch methodsFor: 'target access' stamp: 'sw 3/23/2001 12:13'! readFromTarget "Obtain a value from the target and set it into my lastValue" | v | ((target == nil) or: [getSelector == nil]) ifTrue: [^ contents]. v _ target perform: getSelector with: argument. lastValue _ v. ^ v ! ! !ColorSwatch methodsFor: 'target access' stamp: 'dgd 2/22/2003 13:32' prior: 35194606! readFromTarget "Obtain a value from the target and set it into my lastValue" | v | (target isNil or: [getSelector isNil]) ifTrue: [^contents]. v := target perform: getSelector with: argument. lastValue := v. ^v! ! !ColorTileMorph methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:27'! resultType "Answer the result type of the receiver" ^ #Color! ! !ColorTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44' prior: 19577440! initialize "initialize the state of the receiver" super initialize. "" type _ #literal. self addColorSwatch! ! !ColorType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'! defaultArgumentTile "Answer a tile to represent the type" ^ Color blue newTileMorphRepresentative! ! !ColorType methodsFor: 'tiles' stamp: 'sw 9/25/2001 21:08'! updatingTileForTarget: aTarget partName: partName getter: getter setter: setter "Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter" | readout | readout _ UpdatingRectangleMorph new. readout getSelector: getter; target: aTarget; borderWidth: 1; extent: 22@22. (setter isNil or: [#(unused none nil) includes: setter]) ifFalse: [readout putSelector: setter]. ^ readout ! ! !ColorType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:28'! initialValueForASlotFor: aPlayer "Answer the value to give initially to a newly created slot of the given type in the given player" ^ Color random! ! !ColorType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:23'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #Color.! ! !ColorType methodsFor: 'color' stamp: 'sw 9/27/2001 17:21'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(1.0 0 0.065) ! ! !CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 18:57'! add: unicode | dict elem | codes ifNil: [codes _ Array with: unicode. combined _ unicode. ^ true]. dict _ Compositions at: combined ifAbsent: [^ false]. elem _ dict at: unicode ifAbsent: [^ false]. codes _ codes copyWith: unicode. combined _ elem. ^ true. ! ! !CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 1/1/2003 10:42'! base ^ Unicode value: codes first. ! ! !CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 21:43'! combined ^ Unicode value: combined. ! ! !CombinedChar class methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 19:21'! isDiacriticals: unicode ^ Diacriticals includes: unicode. ! ! !CombinedChar class methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 19:09'! parseCompositionMappingFrom: stream " self halt. self parseCompositionMapping " | line fieldEnd point fieldStart compositions toNumber diacritical result | toNumber _ [:quad | ('16r', quad) asNumber]. Compositions _ IdentityDictionary new: 2048. Decompositions _ IdentityDictionary new: 2048. Diacriticals _ IdentitySet new: 2048. [(line _ stream upTo: Character cr) size > 0] whileTrue: [ fieldEnd _ line indexOf: $; startingAt: 1. point _ ('16r', (line copyFrom: 1 to: fieldEnd - 1)) asNumber. 2 to: 6 do: [:i | fieldStart _ fieldEnd + 1. fieldEnd _ line indexOf: $; startingAt: fieldStart. ]. compositions _ line copyFrom: fieldStart to: fieldEnd - 1. (compositions size > 0 and: [compositions first ~= $<]) ifTrue: [ compositions _ compositions substrings collect: toNumber. compositions size > 1 ifTrue: [ diacritical _ compositions first. Diacriticals add: diacritical. result _ compositions second. (Decompositions includesKey: point) ifTrue: [ self error: 'should not happen'. ] ifFalse: [ Decompositions at: point put: (Array with: diacritical with: result). ]. (Compositions includesKey: diacritical) ifTrue: [ (Compositions at: diacritical) at: result put: point. ] ifFalse: [ Compositions at: diacritical put: (IdentityDictionary new at: result put: point; yourself). ]. ]. ]. ]. ! ! !Command methodsFor: 'copying' stamp: 'tk 2/25/2001 17:53'! veryDeepFixupWith: deepCopier | old | "ALL inst vars were weakly copied. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. 1 to: self class instSize do: [:ii | old _ self instVarAt: ii. self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])]. ! ! !Command methodsFor: 'copying' stamp: 'tk 2/25/2001 17:53'! veryDeepInner: deepCopier "ALL fields are weakly copied!! Can't duplicate an object by duplicating a Command that involves it. See DeepCopier." super veryDeepInner: deepCopier. "just keep old pointers to all fields" parameters _ parameters.! ]style[(25 108 10 103)f1b,f1,f1LDeepCopier Comment;,f1! ! !Command methodsFor: 'private' stamp: 'dgd 8/26/2003 21:43' prior: 19590565! cmdWording "Answer the wording to be used to refer to the command in a menu" ^ cmdWording ifNil: ['last command' translated]! ! !CommandHistory methodsFor: 'called by programmer' stamp: 'aoy 2/15/2003 21:14' prior: 19598632! purgeAllCommandsSuchThat: cmdBlock "Remove a bunch of commands, as in [:cmd | cmd undoTarget == zort]" Preferences useUndo ifFalse: [^self]. history := history reject: cmdBlock. lastCommand := history isEmpty ifTrue: [nil] ifFalse: [history last] ! ! !CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25' prior: 19600082! redoNextCommand "If there is a way to 'redo' (move FORWARD) in the undo/redo history tape, do it." | anIndex | lastCommand ifNil: [^ Beeper beep]. lastCommand phase == #undone ifFalse: [anIndex _ history indexOf: lastCommand. (anIndex < history size) ifTrue: [lastCommand _ history at: anIndex + 1] ifFalse: [^ Beeper beep]]. lastCommand redoCommand. lastCommand phase: #done ! ! !CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25' prior: 19600571! undoLastCommand "Undo the last command, i.e. move backward in the recent-commands tape, if possible." | aPhase anIndex | lastCommand ifNil: [^ Beeper beep]. (aPhase _ lastCommand phase) == #done ifFalse: [aPhase == #undone ifTrue: [anIndex _ history indexOf: lastCommand. anIndex > 1 ifTrue: [lastCommand _ history at: anIndex - 1]]]. lastCommand undoCommand. lastCommand phase: #undone "Command undoLastCommand" ! ! !CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25' prior: 19601101! undoOrRedoCommand "This gives a feature comparable to standard Mac undo/redo. If the undo/redo action taken was a simple do or a redo, then undo it. But if the last undo/redo action taken was an undo, then redo it." "Command undoOrRedoCommand" | aPhase | lastCommand ifNil: [^ Beeper beep]. (aPhase _ lastCommand phase) == #done ifTrue: [lastCommand undoCommand. lastCommand phase: #undone] ifFalse: [aPhase == #undone ifTrue: [lastCommand redoCommand. lastCommand phase: #done]]! ! !CommandHistory methodsFor: 'called from the ui' stamp: 'sw 3/28/2001 10:03'! undoTo "Not yet functional, and not yet sent. Allow the user to choose a point somewhere in the undo/redo tape, and undo his way to there. Applicable only if infiniteUndo is set. " | anIndex commandList aMenu reply | (anIndex _ self historyIndexOfLastCommand) == 0 ifTrue: [^ self beep]. commandList _ history copyFrom: ((anIndex - 10) max: 1) to: ((anIndex + 10) min: history size). aMenu _ SelectionMenu labels: (commandList collect: [:cmd | cmd cmdWording truncateWithElipsisTo: 20]) selections: commandList. reply _ aMenu startUpWithCaption: 'undo or redo to...'. reply ifNotNil: [self inform: #deferred] "ActiveWorld commandHistory undoTo" ! ! !CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25' prior: 35202124! undoTo "Not yet functional, and not yet sent. Allow the user to choose a point somewhere in the undo/redo tape, and undo his way to there. Applicable only if infiniteUndo is set. " | anIndex commandList aMenu reply | (anIndex _ self historyIndexOfLastCommand) == 0 ifTrue: [^ Beeper beep]. commandList _ history copyFrom: ((anIndex - 10) max: 1) to: ((anIndex + 10) min: history size). aMenu _ SelectionMenu labels: (commandList collect: [:cmd | cmd cmdWording truncateWithElipsisTo: 20]) selections: commandList. reply _ aMenu startUpWithCaption: 'undo or redo to...'. reply ifNotNil: [self inform: #deferred] "ActiveWorld commandHistory undoTo" ! ! !CommandHistory methodsFor: 'menu' stamp: 'sw 3/28/2001 09:50'! redoMenuWording "Answer the wording to be used in a menu offering the current Redo command" | nextCommand | ((nextCommand _ self nextCommand) == nil or: [Preferences useUndo not]) ifTrue: [^ 'can''t redo']. ^ String streamContents: [:aStream | aStream nextPutAll: 'redo "'. aStream nextPutAll: (nextCommand cmdWording truncateWithElipsisTo: 20). aStream nextPut: $". lastCommand phase == #done ifFalse: [aStream nextPutAll: ' (z)']]! ! !CommandHistory methodsFor: 'menu' stamp: 'dgd 2/22/2003 14:40' prior: 35203624! redoMenuWording "Answer the wording to be used in a menu offering the current Redo command" | nextCommand | ((nextCommand := self nextCommand) isNil or: [Preferences useUndo not]) ifTrue: [^'can''t redo']. ^String streamContents: [:aStream | aStream nextPutAll: 'redo "'. aStream nextPutAll: (nextCommand cmdWording truncateWithElipsisTo: 20). aStream nextPut: $". lastCommand phase == #done ifFalse: [aStream nextPutAll: ' (z)']]! ! !CommandHistory methodsFor: 'menu' stamp: 'sw 3/26/2001 23:13'! undoMenuWording "Answer the wording to be used in an 'undo' menu item" (((lastCommand == nil or: [Preferences useUndo not]) or: [Preferences infiniteUndo not and: [lastCommand phase == #undone]]) or: [self nextCommandToUndo == nil]) ifTrue: [^ 'can''t undo']. ^ String streamContents: [:aStream | aStream nextPutAll: 'undo "'. aStream nextPutAll: (self nextCommandToUndo cmdWording truncateWithElipsisTo: 20). aStream nextPut: $". lastCommand phase == #done ifTrue: [aStream nextPutAll: ' (z)']]! ! !CommandHistory methodsFor: 'menu' stamp: 'dgd 2/22/2003 14:40' prior: 35204691! undoMenuWording "Answer the wording to be used in an 'undo' menu item" (((lastCommand isNil or: [Preferences useUndo not]) or: [Preferences infiniteUndo not and: [lastCommand phase == #undone]]) or: [self nextCommandToUndo isNil]) ifTrue: [^'can''t undo']. ^String streamContents: [:aStream | aStream nextPutAll: 'undo "'. aStream nextPutAll: (self nextCommandToUndo cmdWording truncateWithElipsisTo: 20). aStream nextPut: $". lastCommand phase == #done ifTrue: [aStream nextPutAll: ' (z)']]! ! !CommandHistory methodsFor: 'menu' stamp: 'sw 3/28/2001 09:52'! undoOrRedoMenuWording "Answer the wording to be used in a menu item offering undo/redo (i.e., the form used when the #infiniteUndo preference is false)" | pre | lastCommand ifNil: [^ 'can''t undo']. pre _ lastCommand phase == #done ifTrue: ['undo'] ifFalse: ['redo']. ^ pre, ' "', (lastCommand cmdWording truncateWithElipsisTo: 20), '" (z)'! ! !CommandHistory methodsFor: 'menu' stamp: 'dgd 8/26/2003 21:42' prior: 35205896! undoOrRedoMenuWording "Answer the wording to be used in a menu item offering undo/redo (i.e., the form used when the #infiniteUndo preference is false)" | pre | lastCommand ifNil: [^ 'can''t undo' translated]. pre _ lastCommand phase == #done ifTrue: ['undo' translated] ifFalse: ['redo' translated]. ^ pre, ' "', (lastCommand cmdWording truncateWithElipsisTo: 20), '" (z)'! ! !CommandHistory class methodsFor: 'system startup' stamp: 'tk 5/16/2002 13:52'! forgetAllGrabCommandsFrom: starter "Forget all the commands that might be held on to in the properties dicitonary of various morphs for various reasons." | object | object _ starter. [ [0 == object] whileFalse: [ object isMorph ifTrue: [object removeProperty: #undoGrabCommand]. object _ object nextObject]. ] ifError: [:err :rcvr | "object is obsolete" self forgetAllGrabCommandsFrom: object nextObject]. "CommandHistory forgetAllGrabCommandsFrom: true someObject" ! ! !CommandHistory class methodsFor: 'system startup' stamp: 'tk 5/16/2002 13:38'! resetAllHistory "Reset all command histories, and make all morphs that might be holding on to undo-grab-commands forget them" self allInstancesDo: [:c | c resetCommandHistory]. self forgetAllGrabCommandsFrom: self someObject. "CommandHistory resetAllHistory" ! ! !CommandLineLauncherExample methodsFor: 'running' stamp: 'sd 3/28/2003 16:24' prior: 19603667! startUp | className | className _ self parameterAt: 'class'. Browser newOnClass: (Smalltalk at: className asSymbol ifAbsent: [Object])! ! !CommentedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:37'! isCommented ^true! ! !CommentedEvent methodsFor: 'printing' stamp: 'rw 7/1/2003 11:37'! printEventKindOn: aStream aStream nextPutAll: 'Commented'! ! !CommentedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'! changeKind ^#Commented! ! !CommentedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:20'! supportedKinds ^Array with: self classKind! ! !CompiledMethod methodsFor: 'accessing' stamp: 'rw 5/12/2003 11:12'! defaultSelector "Invent and answer an appropriate message selector (a Symbol) for me, that is, one that will parse with the correct number of arguments." | aStream | aStream _ WriteStream on: (String new: 16). aStream nextPutAll: 'DoIt'. 1 to: self numArgs do: [:i | aStream nextPutAll: 'with:']. ^aStream contents asSymbol! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ls 7/5/2003 13:50'! flag "Answer the user-level flag bit" ^( (self header bitShift: -29) bitAnd: 1) = 1 ifTrue: [ true ] ifFalse: [ false ] ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'nk 3/15/2004 11:29'! methodReference | who | who _ self who. who = #(unknown unknown) ifTrue: [ ^nil ]. ^MethodReference new setStandardClass: who first methodSymbol: who second. ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ls 6/22/2000 14:35' prior: 19616910! primitive "Answer the primitive index associated with the receiver. Zero indicates that this is not a primitive method. We currently allow 10 bits of primitive index, but they are in two places for backward compatibility. The time to unpack is negligible, since the reconstituted full index is stored in the method cache." | primBits | primBits _ self header bitAnd: 16r100001FF. ^ (primBits bitAnd: 16r1FF) + (primBits bitShift: -19) ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ajh 11/17/2001 14:30'! trailer | end trailer | end _ self endPC. trailer _ ByteArray new: self size - end. end + 1 to: self size do: [:i | trailer at: i - end put: (self at: i)]. ^ trailer! ! !CompiledMethod methodsFor: 'comparing' stamp: 'ar 8/16/2001 13:24'! = method | myLits otherLits | "Answer whether the receiver implements the same code as the argument, method." (method isKindOf: CompiledMethod) ifFalse: [^false]. self size = method size ifFalse: [^false]. self header = method header ifFalse: [^false]. self initialPC to: self endPC do: [:i | (self at: i) = (method at: i) ifFalse: [^false]]. (myLits _ self literals) = (otherLits _ method literals) ifFalse: [myLits size = otherLits size ifFalse: [^ false]. "Dont bother checking FFI and named primitives" (#(117 120) includes: self primitive) ifTrue: [^ true]. myLits with: otherLits do: [:lit1 :lit2 | lit1 = lit2 ifFalse: [(lit1 isVariableBinding) ifTrue: ["Associations match if value is equal, since associations used for super may have key = nil or name of class." lit1 value == lit2 value ifFalse: [^ false]] ifFalse: [(lit1 isMemberOf: Float) ifTrue: ["Floats match if values are close, due to roundoff error." (lit1 closeTo: lit2) ifFalse: [^ false]] ifFalse: ["any other discrepancy is a failure" ^ false]]]]]. ^ true! ! !CompiledMethod methodsFor: 'testing' stamp: 'sw 5/3/2001 15:06'! hasReportableSlip "Answer whether the receiver contains anything that should be brought to the attention of the author when filing out. Customize the lists here to suit your preferences. If slips do not get reported in spite of your best efforts here, make certain that the Preference 'checkForSlips' is set to true." | assoc | #(doOnlyOnce: halt halt: hottest printDirectlyToDisplay toRemove personal urgent) do: [:aLit | (self hasLiteral: aLit) ifTrue: [^ true]]. #(Transcript AA BB CC DD EE) do: [:aSymbol | (assoc _ (Smalltalk associationAt: aSymbol ifAbsent: [nil])) ifNotNil: [(self hasLiteral: assoc) ifTrue: [^ true]]]. ^ false! ! !CompiledMethod methodsFor: 'testing' stamp: 'md 11/21/2003 12:15'! isCompiledMethod ^ true! ! !CompiledMethod methodsFor: 'printing' stamp: 'sw 7/29/2002 02:24'! dateMethodLastSubmitted "Answer a Date object indicating when a method was last submitted. If there is no date stamp, return nil" "(CompiledMethod compiledMethodAt: #dateMethodLastSubmitted) dateMethodLastSubmitted" | aStamp tokens | aStamp _ self timeStamp. tokens _ aStamp findBetweenSubStrs: ' '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" ^ tokens size > 1 ifTrue: [[tokens second asDate] ifError: [nil]] ifFalse: [nil]! ! !CompiledMethod methodsFor: 'printing' stamp: 'ajh 2/9/2003 14:17'! longPrintOn: aStream "List of all the byte codes in a method with a short description of each" self longPrintOn: aStream indent: 0! ! !CompiledMethod methodsFor: 'printing' stamp: 'ajh 2/9/2003 14:17' prior: 35212593! longPrintOn: aStream "List of all the byte codes in a method with a short description of each" self longPrintOn: aStream indent: 0! ! !CompiledMethod methodsFor: 'printing' stamp: 'ar 6/28/2003 00:08'! longPrintOn: aStream indent: tabs "List of all the byte codes in a method with a short description of each" self isQuick ifTrue: [self isReturnSpecial ifTrue: [^ aStream tab: tabs; nextPutAll: 'Quick return ' , (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255)]. ^ aStream nextPutAll: 'Quick return field ' , self returnField printString , ' (0-based)']. self primitive = 0 ifFalse: [ aStream tab: tabs. self printPrimitiveOn: aStream. ]. (InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream. ! ! !CompiledMethod methodsFor: 'printing' stamp: 'ajh 2/9/2003 14:20' prior: 35213023! longPrintOn: aStream indent: tabs "List of all the byte codes in a method with a short description of each" self isQuick ifTrue: [self isReturnSpecial ifTrue: [^ aStream tabs: tabs; nextPutAll: 'Quick return ' , (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255)]. ^ aStream nextPutAll: 'Quick return field ' , self returnField printString , ' (0-based)']. self primitive = 0 ifFalse: [ aStream tabs: tabs. self printPrimitiveOn: aStream. ]. (InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream. ! ! !CompiledMethod methodsFor: 'printing' stamp: 'ar 6/28/2003 00:08' prior: 35213675! longPrintOn: aStream indent: tabs "List of all the byte codes in a method with a short description of each" self isQuick ifTrue: [self isReturnSpecial ifTrue: [^ aStream tab: tabs; nextPutAll: 'Quick return ' , (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255)]. ^ aStream nextPutAll: 'Quick return field ' , self returnField printString , ' (0-based)']. self primitive = 0 ifFalse: [ aStream tab: tabs. self printPrimitiveOn: aStream. ]. (InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream. ! ! !CompiledMethod methodsFor: 'printing' stamp: 'ajh 6/27/2003 22:21' prior: 19623134! symbolic "Answer a String that contains a list of all the byte codes in a method with a short description of each." | aStream | aStream _ WriteStream on: (String new: 1000). self longPrintOn: aStream. ^aStream contents! ! !CompiledMethod methodsFor: 'printing' stamp: 'ajh 3/20/2001 11:41' prior: 35214982! symbolic "Answer a String that contains a list of all the byte codes in a method with a short description of each." | aStream | aStream _ WriteStream on: (String new: 1000). self longPrintOn: aStream. ^aStream contents! ! !CompiledMethod methodsFor: 'printing' stamp: 'sw 7/29/2002 02:21'! timeStamp "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available." "(CompiledMethod compiledMethodAt: #timeStamp) timeStamp" | position file preamble stamp tokens tokenCount | self fileIndex == 0 ifTrue: [^ String new]. "no source pointer for this method" position _ self filePosition. file _ SourceFiles at: self fileIndex. file ifNil: [^ String new]. "sources file not available" "file does not exist happens in secure mode" file _ [file readOnlyCopy] on: FileDoesNotExistException do:[:ex| nil]. file ifNil: [^ String new]. file position: (0 max: position - 150). "Skip back to before the preamble" [file position < (position - 1)] "then pick it up from the front" whileTrue: [preamble _ file nextChunk]. stamp _ String new. tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [Scanner new scanTokens: preamble] ifFalse: [Array new "ie cant be back ref"]. (((tokenCount _ tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:]) ifTrue: [(tokens at: tokenCount - 3) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokenCount - 2]]. ((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:]) ifTrue: [(tokens at: tokenCount - 1) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokenCount]]. file close. ^ stamp ! ! !CompiledMethod methodsFor: 'printing' stamp: 'sd 4/17/2003 20:45' prior: 19623737! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." | sel | SystemNavigation new allBehaviorsDo: [:class | (sel _ class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^Array with: class with: sel]]. ^ Array with: #unknown with: #unknown ! ! !CompiledMethod methodsFor: 'printing' stamp: 'dvf 8/23/2003 11:50' prior: 35217240! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." | sel | self systemNavigation allBehaviorsDo: [:class | (sel := class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^Array with: class with: sel]]. ^Array with: #unknown with: #unknown! ! !CompiledMethod methodsFor: 'literals' stamp: 'ajh 2/9/2003 13:15'! headerDescription "Answer a description containing the information about the form of the receiver and the form of the context needed to run the receiver." | s | s _ '' writeStream. self header printOn: s. s cr; nextPutAll: '"primitive: '. self primitive printOn: s. s cr; nextPutAll: ' numArgs: '. self numArgs printOn: s. s cr; nextPutAll: ' numTemps: '. self numTemps printOn: s. s cr; nextPutAll: ' numLiterals: '. self numLiterals printOn: s. s cr; nextPutAll: ' frameSize: '. self frameSize printOn: s. s cr; nextPutAll: ' isClosureCompiled: '. self isClosureCompiled printOn: s. s nextPut: $"; cr. ^ s contents! ! !CompiledMethod methodsFor: 'literals' stamp: 'ar 8/16/2001 13:24'! literalStrings | lits litStrs | lits _ self literals. litStrs _ OrderedCollection new: lits size * 3. self literals do: [:lit | (lit isVariableBinding) ifTrue: [litStrs addLast: lit key] ifFalse: [(lit isMemberOf: Symbol) ifTrue: [litStrs addAll: lit keywords] ifFalse: [litStrs addLast: lit printString]]]. ^ litStrs! ! !CompiledMethod methodsFor: 'source code management' stamp: 'di 1/7/2004 15:32' prior: 19632214! copyWithTempNames: tempNames | tempStr compressed | tempStr _ String streamContents: [:strm | tempNames do: [:n | strm nextPutAll: n; space]]. compressed := self qCompress: tempStr firstTry: true. compressed ifNil: ["failure case (tempStr too big) will just decompile with tNN names" ^ self copyWithTrailerBytes: #(0 0 0 0)]. ^ self copyWithTrailerBytes: compressed! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 09:45'! holdsTempNames "Are tempNames stored in trailer bytes" | flagByte | flagByte _ self last. (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]]) ifTrue: [^ false]. "No source pointer & no temp names" flagByte < 252 ifTrue: [^ true]. "temp names compressed" ^ false "Source pointer" ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'RAA 5/29/2001 08:49'! putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock "Store the source code for the receiver on an external file. If no sources are available, i.e., SourceFile is nil, then store temp names for decompilation at the end of the method. If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, in each case, storing a 4-byte source code pointer at the method end." | file remoteString st80str | (SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue: [^ self become: (self copyWithTempNames: methodNode tempNames)]. Smalltalk assureStartupStampLogged. file setToEnd. preambleBlock value: file. "Write the preamble" (methodNode isKindOf: DialectMethodNode) ifTrue: ["This source was parsed from an alternate syntax. We must convert to ST80 before logging it." st80str _ (DialectStream dialect: #ST80 contents: [:strm | methodNode printOn: strm]) asString. remoteString _ RemoteString newString: st80str onFileNumber: fileIndex toFile: file] ifFalse: [remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file]. file nextChunkPut: ' '. InMidstOfFileinNotification signal ifFalse: [file flush]. self checkOKToAdd: sourceStr size at: remoteString position. self setSourcePosition: remoteString position inFile: fileIndex! ! !CompiledMethod methodsFor: 'source code management' stamp: 'NS 1/16/2004 15:39' prior: 35220166! putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock "Store the source code for the receiver on an external file. If no sources are available, i.e., SourceFile is nil, then store temp names for decompilation at the end of the method. If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, in each case, storing a 4-byte source code pointer at the method end." | file remoteString st80str | (SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue: [^ self become: (self copyWithTempNames: methodNode tempNames)]. SmalltalkImage current assureStartupStampLogged. file setToEnd. preambleBlock value: file. "Write the preamble" (methodNode isKindOf: DialectMethodNode) ifTrue: ["This source was parsed from an alternate syntax. We must convert to ST80 before logging it." st80str _ (DialectStream dialect: #ST80 contents: [:strm | methodNode printOn: strm]) asString. remoteString _ RemoteString newString: st80str onFileNumber: fileIndex toFile: file] ifFalse: [remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file]. file nextChunkPut: ' '. InMidstOfFileinNotification signal ifFalse: [file flush]. self checkOKToAdd: sourceStr size at: remoteString position. self setSourcePosition: remoteString position inFile: fileIndex! ! !CompiledMethod methodsFor: 'source code management' stamp: 'di 1/7/2004 15:32'! qCompress: str firstTry: firstTry "A very simple text compression routine designed for method temp names. Most common 12 chars get values 0-11 packed in one 4-bit nibble; others get values 12-15 (2 bits) * 16 plus next nibble. Last char of str must be a space so it may be dropped without consequence if output ends on odd nibble. Normal call is with firstTry == true." | charTable odd ix oddNibble names shorterStr maybe | charTable _ "Character encoding table must match qDecompress:" ' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. ^ ByteArray streamContents: [:strm | odd _ true. "Flag for odd or even nibble out" oddNibble _ nil. str do: [:char | ix _ (charTable indexOf: char) - 1. (ix <= 12 ifTrue: [Array with: ix] ifFalse: [Array with: ix//16+12 with: ix\\16]) do: [:nibble | (odd _ odd not) ifTrue: [strm nextPut: oddNibble*16 + nibble] ifFalse: [oddNibble _ nibble]]]. strm position > 251 ifTrue: ["Only values 1...251 are available for the flag byte that signals compressed temps. See the logic in endPC." "Before giving up completely, we attempt to encode most of the temps, but with the last few shortened to tNN-style names." firstTry ifFalse: [^ nil "already tried --give up now"]. names _ str findTokens: ' '. names size < 8 ifTrue: [^ nil "weird case -- give up now"]. 4 to: names size//2 by: 4 do: [:i | shorterStr _ String streamContents: [:s | 1 to: names size - i do: [:j | s nextPutAll: (names at: j); space]. 1 to: i do: [:j | s nextPutAll: 't' , j printString; space]]. (maybe _ self qCompress: shorterStr firstTry: false) ifNotNil: [^ maybe]]. ^ nil]. strm nextPut: strm position] " | m s | m _ CompiledMethod new. s _ 'charTable odd ix oddNibble '. ^ Array with: s size with: (m qCompress: s) size with: (m qDecompress: (m qCompress: s)) " ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'yo 3/16/2004 12:48' prior: 35223120! qCompress: string firstTry: firstTry "A very simple text compression routine designed for method temp names. Most common 12 chars get values 0-11 packed in one 4-bit nibble; others get values 12-15 (2 bits) * 16 plus next nibble. Last char of str must be a space so it may be dropped without consequence if output ends on odd nibble. Normal call is with firstTry == true." | charTable odd ix oddNibble names shorterStr maybe str temps | str _ string isOctetString ifTrue: [string] ifFalse: [temps _ string findTokens: ' '. String streamContents: [:stream | 1 to: temps size do: [:index | stream nextPut: $t. stream nextPutAll: index asString. stream space]]]. charTable _ "Character encoding table must match qDecompress:" ' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. ^ ByteArray streamContents: [:strm | odd _ true. "Flag for odd or even nibble out" oddNibble _ nil. str do: [:char | ix _ (charTable indexOf: char) - 1. (ix <= 12 ifTrue: [Array with: ix] ifFalse: [Array with: ix//16+12 with: ix\\16]) do: [:nibble | (odd _ odd not) ifTrue: [strm nextPut: oddNibble*16 + nibble] ifFalse: [oddNibble _ nibble]]]. strm position > 251 ifTrue: ["Only values 1...251 are available for the flag byte that signals compressed temps. See the logic in endPC." "Before giving up completely, we attempt to encode most of the temps, but with the last few shortened to tNN-style names." firstTry ifFalse: [^ nil "already tried --give up now"]. names _ str findTokens: ' '. names size < 8 ifTrue: [^ nil "weird case -- give up now"]. 4 to: names size//2 by: 4 do: [:i | shorterStr _ String streamContents: [:s | 1 to: names size - i do: [:j | s nextPutAll: (names at: j); space]. 1 to: i do: [:j | s nextPutAll: 't' , j printString; space]]. (maybe _ self qCompress: shorterStr firstTry: false) ifNotNil: [^ maybe]]. ^ nil]. strm nextPut: strm position] " | m s | m _ CompiledMethod new. s _ 'charTable odd ix oddNibble '. ^ Array with: s size with: (m qCompress: s) size with: (m qDecompress: (m qCompress: s)) " ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 8/13/2002 18:19'! sourceClass "Get my receiver class (method class) from the preamble of my source. Return nil if not found." ^ [(Compiler evaluate: (self sourceFileStream backChunk "blank"; backChunk "preamble")) theClass] on: Error do: [nil]! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 8/13/2002 18:18'! sourceFileStream "Answer the sources file stream with position set at the beginning of my source string" | pos | (pos _ self filePosition) = 0 ifTrue: [^ nil]. ^ (RemoteString newFileNumber: self fileIndex position: pos) fileStream! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 8/13/2002 18:28'! sourceSelector "Answer my selector extracted from my source. If no source answer nil" | sourceString | sourceString _ self getSourceFromFile ifNil: [^ nil]. ^ Compiler parserClass new parseSelector: sourceString! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 00:29' prior: 19639919! tempNames | byteCount bytes | self holdsTempNames ifFalse: [ ^ (1 to: self numTemps) collect: [:i | 't', i printString] ]. byteCount _ self at: self size. byteCount = 0 ifTrue: [^ Array new]. bytes _ (ByteArray new: byteCount) replaceFrom: 1 to: byteCount with: self startingAt: self size - byteCount. ^ (self qDecompress: bytes) findTokens: ' '! ! !CompiledMethod methodsFor: 'file in/out' stamp: 'RAA 8/21/2001 23:10'! zapSourcePointer "clobber the source pointer since it will be wrong" 0 to: 3 do: [ :i | self at: self size - i put: 0]. ! ! !CompiledMethod methodsFor: 'evaluating' stamp: 'ajh 1/28/2003 12:33' prior: 19641553! valueWithReceiver: aReceiver arguments: anArray ^ aReceiver withArgs: anArray executeMethod: self! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/3/2003 21:18'! blockNode BlockNodeCache key == self ifTrue: [^ BlockNodeCache value]. ^ self blockNodeIn: nil! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 5/28/2003 01:10'! blockNodeIn: homeMethodNode "Return the block node for self" homeMethodNode ifNil: [ ^ self decompilerClass new decompileBlock: self]. homeMethodNode ir compiledMethod. "generate method" homeMethodNode nodesDo: [:node | (node isBlock and: [node scope isInlined not and: [node ir compiledMethod = self]]) ifTrue: [ BlockNodeCache _ self -> node. ^ node] ]. self errorNodeNotFound! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 19:45'! decompile "Return the decompiled parse tree that represents self" ^ self decompileClass: nil selector: nil! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 19:44'! decompileClass: aClass selector: selector "Return the decompiled parse tree that represents self" ^ self decompilerClass new decompile: selector in: aClass method: self! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ar 6/28/2003 00:05'! decompilerClass ^Decompiler ! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 13:11'! isClosureCompiled "Return true if this method was compiled with the new closure compiler, Parser2 (compiled while Preference compileBlocksAsClosures was true). Return false if it was compiled with the old compiler." ^ self header < 0! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 13:11' prior: 35230383! isClosureCompiled "Return true if this method was compiled with the new closure compiler, Parser2 (compiled while Preference compileBlocksAsClosures was true). Return false if it was compiled with the old compiler." ^ self header < 0! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 00:22'! methodNode "Return the parse tree that represents self" ^ self methodNodeDecompileClass: nil selector: nil! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 3/3/2003 12:02'! methodNodeDecompileClass: aClass selector: selector "Return the parse tree that represents self" | source | ^ (source _ self getSourceFromFile) ifNil: [self decompileClass: aClass selector: selector] ifNotNil: [self parserClass new parse: source class: (self sourceClass ifNil: [aClass])]! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 12/13/2003 18:30' prior: 35231210! methodNodeDecompileClass: aClass selector: selector "Return the parse tree that represents self" | source | ^ (source _ self getSourceFromFile) ifNil: [self decompileClass: aClass selector: selector] ifNotNil: [self parserClass new parse: source class: (aClass ifNil: [self sourceClass])]! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'nk 2/20/2004 15:59'! methodNodeFormattedAndDecorated: decorate "Return the parse tree that represents self" ^ self methodNodeFormattedDecompileClass: nil selector: nil decorate: decorate! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'nk 2/20/2004 15:58'! methodNodeFormattedDecompileClass: aClass selector: selector decorate: decorated "Return the parse tree that represents self, using pretty-printed source text if possible." | source sClass node | source := self getSourceFromFile. sClass _ aClass ifNil: [self sourceClass]. source ifNil: [ ^self decompileClass: sClass selector: selector]. source _ sClass compilerClass new format: source in: sClass notifying: nil decorated: decorated. node _ sClass parserClass new parse: source class: sClass. node sourceText: source. ^node! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ar 6/28/2003 00:05'! parserClass ^Parser! ! !CompiledMethod methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 09:22'! hasBreakpoint ^BreakpointManager methodHasBreakpoint: self! ! !CompiledMethod methodsFor: 'user interface' stamp: 'ajh 2/3/2003 19:18'! inspectorClass ^ CompiledMethodInspector! ! !CompiledMethod commentStamp: 'ls 7/5/2003 13:48' prior: 0! My instances are methods suitable for interpretation by the virtual machine. This is the only class in the system whose instances intermix both indexable pointer fields and indexable integer fields. The current format of a CompiledMethod is as follows: header (4 bytes) literals (4 bytes each) bytecodes (variable) trailer (variable) The header is a 30-bit integer with the following format: (index 0) 9 bits: main part of primitive number (#primitive) (index 9) 8 bits: number of literals (#numLiterals) (index 17) 1 bit: whether a large frame size is needed (#frameSize) (index 18) 6 bits: number of temporary variables (#numTemps) (index 24) 4 bits: number of arguments to the method (#numArgs) (index 28) 1 bit: high-bit of primitive number (#primitive) (index 29) 1 bit: flag bit, ignored by the VM (#flag) The trailer has two variant formats. In the first variant, the last byte is at least 252 and the last four bytes represent a source pointer into one of the sources files (see #sourcePointer). In the second variant, the last byte is less than 252, and the last several bytes are a compressed version of the names of the method's temporary variables. The number of bytes used for this purpose is the value of the last byte in the method. ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 2/3/2003 21:16' prior: 19642162! initialize "CompiledMethod initialize" "Initialize class variables specifying the size of the temporary frame needed to run instances of me." SmallFrame _ 16. "Context range for temps+stack" LargeFrame _ 56. self classPool at: #BlockNodeCache ifAbsentPut: [nil->nil].! ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 7/18/2001 02:04'! smallFrameSize ^ SmallFrame! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'ls 7/5/2003 13:49'! newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." | largeBit primBits method flagBit | nTemps > 64 ifTrue: [^ self error: 'Cannot compile -- too many temporary variables']. largeBit _ (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. "For now the high bit of the primitive no. is in a high bit of the header" primBits _ (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19). flagBit := flag ifTrue: [ 1 ] ifFalse: [ 0 ]. method _ self newMethod: numberOfBytes + trailer size header: (nArgs bitShift: 24) + (nTemps bitShift: 18) + (largeBit bitShift: 17) + (nLits bitShift: 9) + primBits + (flagBit bitShift: 29). "Copy the source code trailer to the end" 1 to: trailer size do: [:i | method at: method size - trailer size + i put: (trailer at: i)]. ^ method! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'ajh 3/9/2003 15:09'! primitive: primNum numArgs: numArgs numTemps: numTemps stackSize: stackSize literals: literals bytecodes: bytecodes trailer: trailerBytes "Create method with given attributes. numTemps includes numArgs. stackSize does not include numTemps." | compiledMethod | compiledMethod _ self newBytes: bytecodes size trailerBytes: trailerBytes nArgs: numArgs nTemps: numTemps nStack: stackSize nLits: literals size primitive: primNum. (WriteStream with: compiledMethod) position: compiledMethod initialPC - 1; nextPutAll: bytecodes. literals withIndexDo: [:obj :i | compiledMethod literalAt: i put: obj]. ^ compiledMethod! ! !CompiledMethodInspector methodsFor: 'accessing' stamp: 'ajh 1/18/2003 13:47'! fieldList | keys | keys _ OrderedCollection new. keys add: 'self'. keys add: 'all bytecodes'. keys add: 'header'. 1 to: object numLiterals do: [ :i | keys add: 'literal', i printString ]. object initialPC to: object size do: [ :i | keys add: i printString ]. ^ keys asArray ! ! !CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2003 00:17'! contentsIsString "Hacked so contents empty when deselected" ^ #(0 2 3) includes: selectionIndex! ! !CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 1/18/2003 13:56'! selection | bytecodeIndex | selectionIndex = 0 ifTrue: [^ '']. selectionIndex = 1 ifTrue: [^ object ]. selectionIndex = 2 ifTrue: [^ object symbolic]. selectionIndex = 3 ifTrue: [^ object headerDescription]. selectionIndex <= (object numLiterals + 3) ifTrue: [ ^ object objectAt: selectionIndex - 2 ]. bytecodeIndex _ selectionIndex - object numLiterals - 3. ^ object at: object initialPC + bytecodeIndex - 1! ! !CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2001 11:56'! selectionUnmodifiable "Answer if the current selected variable is unmodifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" ^ true! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'md 4/16/2003 15:26'! returnPlusOne: anInteger ^anInteger + 1.! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'md 4/16/2003 15:25'! returnTrue ^true! ! !CompiledMethodTest methodsFor: 'testing - testing' stamp: 'md 4/16/2003 15:32'! testIsQuick | method | method := self class compiledMethodAt: #returnTrue. self assert: (method isQuick). method := self class compiledMethodAt: #returnPlusOne:. self deny: (method isQuick). ! ! !CompiledMethodTest methodsFor: 'testing - evaluating' stamp: 'md 4/16/2003 15:30'! testValueWithReceiverArguments | method value | method := self class compiledMethodAt: #returnTrue. value := method valueWithReceiver: nil arguments: #(). self assert: (value = true). method := self class compiledMethodAt: #returnPlusOne:. value := method valueWithReceiver: nil arguments: #(1). self assert: (value = 2). ! ! !CompiledMethodTest commentStamp: '' prior: 0! This is the unit test for the class CompiledMethod. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:03'! method: aCompiledMethod method _ aCompiledMethod! ! !CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:04'! node: aMethodNode node _ aMethodNode! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:03'! method ^ method! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! node ^ node! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! selector ^ self node selector! ! !CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! generateMethodFromNode: aMethodNode trailer: bytes ^ self method: (aMethodNode generate: bytes) node: aMethodNode.! ! !CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! method: aCompiledMethod node: aMethodNode ^ self new method: aCompiledMethod; node: aMethodNode.! ! !Compiler methodsFor: 'error handling' stamp: 'LC 1/6/2002 13:53' prior: 19647558! notify: aString at: location "Refer to the comment in Object|notify:." requestor == nil ifTrue: [^SyntaxErrorNotification inClass: class withCode: (sourceStream contents copyReplaceFrom: location to: location - 1 with: aString) doitFlag: false] ifFalse: [^requestor notify: aString at: location in: sourceStream]! ! !Compiler methodsFor: 'public access' stamp: 'vb 8/13/2001 23:11'! compileNoPattern: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock "Similar to #compile:in:notifying:ifFail:, but the compiled code is expected to be a do-it expression, with no message pattern." self from: textOrStream class: aClass context: aContext notifying: aRequestor. ^self translate: sourceStream noPattern: true ifFail: failBlock! ! !Compiler methodsFor: 'public access' stamp: 'sd 1/19/2004 20:58'! evaluate: aString in: aContext to: aReceiver "evaluate aString in the given context, and return the result. 2/2/96 sw" | result | result _ self evaluate: aString in: aContext to: aReceiver notifying: nil ifFail: [^ #failedDoit]. ^ result! ! !Compiler methodsFor: 'public access' stamp: 'RAA 5/28/2001 17:09'! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock "Compiles the sourceStream into a parse tree, then generates code into a method. This method is then installed in the receiver's class so that it can be invoked. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is invoked from here as DoIt or (in the case of evaluation in aContext) DoItIn:. The method is subsequently removed from the class, but this will not get done if the invocation causes an error which is terminated. Such garbage can be removed by executing: Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: #DoItIn:]." | methodNode method value | class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. self from: textOrStream class: class context: aContext notifying: aRequestor. methodNode _ self translate: sourceStream noPattern: true ifFail: [^failBlock value]. method _ methodNode generate: #(0 0 0 0). self interactive ifTrue: [method _ method copyWithTempNames: methodNode tempNames]. context == nil ifTrue: [class addSelector: #DoIt withMethod: method. value _ receiver DoIt. InMidstOfFileinNotification signal ifFalse: [ class removeSelectorSimply: #DoIt. ]. ^value] ifFalse: [class addSelector: #DoItIn: withMethod: method. value _ receiver DoItIn: context. InMidstOfFileinNotification signal ifFalse: [ class removeSelectorSimply: #DoItIn:. ]. ^value]! ! !Compiler methodsFor: 'public access' stamp: 'NS 1/19/2004 09:05' prior: 35241860! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock ^ self evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: false.! ! !Compiler methodsFor: 'public access' stamp: 'NS 1/19/2004 10:00'! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag "Compiles the sourceStream into a parse tree, then generates code into a method. This method is then installed in the receiver's class so that it can be invoked. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is invoked from here as DoIt or (in the case of evaluation in aContext) DoItIn:. The method is subsequently removed from the class, but this will not get done if the invocation causes an error which is terminated. Such garbage can be removed by executing: Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: #DoItIn:]." | methodNode method value selector | class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. self from: textOrStream class: class context: aContext notifying: aRequestor. methodNode _ self translate: sourceStream noPattern: true ifFail: [^failBlock value]. method _ methodNode generate: #(0 0 0 0). self interactive ifTrue: [method _ method copyWithTempNames: methodNode tempNames]. selector _ context isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:]. SystemChangeNotifier uniqueInstance doSilently: [class addSelector: selector withMethod: method]. value _ context isNil ifTrue: [receiver DoIt] ifFalse: [receiver DoItIn: context]. InMidstOfFileinNotification signal ifFalse: [SystemChangeNotifier uniqueInstance doSilently: [class removeSelectorSimply: selector]]. logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. ^ value.! ! !Compiler methodsFor: 'public access' stamp: 'NS 1/28/2004 11:19' prior: 35244036! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag "Compiles the sourceStream into a parse tree, then generates code into a method. This method is then installed in the receiver's class so that it can be invoked. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is invoked from here as DoIt or (in the case of evaluation in aContext) DoItIn:. The method is subsequently removed from the class, but this will not get done if the invocation causes an error which is terminated. Such garbage can be removed by executing: Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: #DoItIn:]." | methodNode method value selector | class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. self from: textOrStream class: class context: aContext notifying: aRequestor. methodNode _ self translate: sourceStream noPattern: true ifFail: [^failBlock value]. method _ methodNode generate: #(0 0 0 0). self interactive ifTrue: [method _ method copyWithTempNames: methodNode tempNames]. selector _ context isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:]. class addSelectorSilently: selector withMethod: method. value _ context isNil ifTrue: [receiver DoIt] ifFalse: [receiver DoItIn: context]. InMidstOfFileinNotification signal ifFalse: [class basicRemoveSelector: selector]. logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. ^ value.! ! !Compiler methodsFor: 'public access' stamp: 'sw 5/20/2001 10:01'! format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol "Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely. If aBoolean is true, then decorate the resulting text with color and hypertext actions" | aNode | self from: textOrStream class: aClass context: nil notifying: aRequestor. aNode _ self format: sourceStream noPattern: false ifFail: [^ nil]. aSymbol == #colorPrint ifTrue: [^ aNode asColorizedSmalltalk80Text]. aSymbol == #altSyntax "Alan's current explorations for alternate syntax - 2000/2001" ifTrue: [^ aNode asAltSyntaxText]. ^ aNode decompileString! ! !Compiler methodsFor: 'public access' stamp: 'ajh 9/14/2002 18:47' prior: 19651410! parse: textOrStream in: aClass notifying: req dialect: useDialect "Compile the argument, textOrStream, with respect to the class, aClass, and answer the MethodNode that is the root of the resulting parse tree. Notify the argument, req, if an error occurs. The failBlock is defaulted to an empty block." self from: textOrStream class: aClass context: nil notifying: req. ^ ((useDialect and: [RequestAlternateSyntaxSetting signal]) ifTrue: [self dialectParserClass] ifFalse: [self parserClass]) new parse: sourceStream class: class noPattern: false context: context notifying: requestor ifFail: []! ! !Compiler methodsFor: 'private' stamp: 'ajh 9/19/2002 02:19'! cacheDoItNode: boolean cacheDoItNode _ boolean! ! !Compiler methodsFor: 'private' stamp: 'ar 6/28/2003 00:05'! dialectParserClass ^DialectParser! ! !Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:44' prior: 19652280! format: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ self parserClass new parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^ failBlock value]. ^ tree! ! !Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:44'! parserClass ^ parserClass! ! !Compiler methodsFor: 'private' stamp: 'ajh 9/19/2002 02:20'! parserClass: aParserClass parserClass _ aParserClass. cacheDoItNode _ true. ! ! !Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:45' prior: 19652900! translate: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ self parserClass new parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^ failBlock value]. ^ tree! ! !Compiler class methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:39'! new ^ super new parserClass: self parserClass! ! !Compiler class methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:42'! old ^ self new parserClass: Parser! ! !Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 10:07' prior: 19653425! evaluate: textOrString "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object, and the invocation is not logged." ^self evaluate: textOrString for: nil logged: false! ! !Compiler class methodsFor: 'evaluating' stamp: 'NS 1/16/2004 15:41' prior: 19654126! evaluate: textOrString for: anObject notifying: aController logged: logFlag "Compile and execute the argument, textOrString with respect to the class of anObject. If a compilation error occurs, notify aController. If both compilation and execution are successful then, if logFlag is true, log (write) the text onto a system changes file so that it can be replayed if necessary." | val | val _ self new evaluate: textOrString in: nil to: anObject notifying: aController ifFail: [^nil]. logFlag ifTrue: [Smalltalk logChange: textOrString]. ^val! ! !Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 09:50' prior: 35251402! evaluate: textOrString for: anObject notifying: aController logged: logFlag "Compile and execute the argument, textOrString with respect to the class of anObject. If a compilation error occurs, notify aController. If both compilation and execution are successful then, if logFlag is true, log (write) the text onto a system changes file so that it can be replayed if necessary." ^ self new evaluate: textOrString in: nil to: anObject notifying: aController ifFail: [^nil] logged: logFlag.! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:13'! colors ^colors ifNil:[colors _ self computeColors].! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! style ^style! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! style: newStyle style == newStyle ifTrue:[^self]. style _ newStyle. self releaseCachedState.! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:14'! widthForRounding ^0! ! !ComplexBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! trackColorFrom: aMorph baseColor ifNil:[self color: aMorph raisedColor].! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 8/26/2001 19:31'! drawLineFrom: startPoint to: stopPoint on: aCanvas "Here we're using the balloon engine since this is much faster than BitBlt w/ brushes." | delta length dir cos sin tfm w h w1 w2 h1 h2 fill | width isPoint ifTrue:[w _ width x. h _ width y] ifFalse:[w _ h _ width]. w1 _ w // 2. w2 _ w - w1. h1 _ h // 2. h2 _ h - h1. "Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint" delta _ stopPoint - startPoint. length _ delta r. length > 1.0e-10 ifTrue:[dir _ delta / length] ifFalse:[dir _ 1@0]. cos _ dir dotProduct: (1@0). sin _ dir crossProduct: (1@0). tfm _ (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos. "Install the start point offset" tfm offset: startPoint. "Now get the fill style appropriate for the given direction" fill _ self fillStyleForDirection: dir. "And draw..." aCanvas asBalloonCanvas transformBy: tfm during:[:cc| cc drawPolygon: { (0-w1) @ (0-h1). "top left" (length + w2) @ (0-h1). "top right" (length + w2) @ (h2). "bottom right" (0-w1) @ (h2). "bottom left" } fillStyle: fill. ]. ! ! !ComplexBorder methodsFor: 'drawing' stamp: 'aoy 2/17/2003 01:08' prior: 35253286! drawLineFrom: startPoint to: stopPoint on: aCanvas "Here we're using the balloon engine since this is much faster than BitBlt w/ brushes." | delta length dir cos sin tfm w h w1 w2 h1 h2 fill | width isPoint ifTrue: [w := width x. h := width y] ifFalse: [w := h := width]. w1 := w // 2. w2 := w - w1. h1 := h // 2. h2 := h - h1. "Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint" delta := stopPoint - startPoint. length := delta r. dir := length > 1.0e-10 ifTrue: [delta / length] ifFalse: [ 1 @ 0]. cos := dir dotProduct: 1 @ 0. sin := dir crossProduct: 1 @ 0. tfm := (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos. "Install the start point offset" tfm offset: startPoint. "Now get the fill style appropriate for the given direction" fill := self fillStyleForDirection: dir. "And draw..." aCanvas asBalloonCanvas transformBy: tfm during: [:cc | cc drawPolygon: { (0 - w1) @ (0 - h1). "top left" (length + w2) @ (0 - h1). "top right" (length + w2) @ h2. "bottom right" (0 - w1) @ h2 "bottom left"} fillStyle: fill]! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 11/26/2001 15:10'! drawPolyPatchFrom: startPoint to: stopPoint on: aCanvas usingEnds: endsArray | cos sin tfm fill dir fsOrigin fsDirection points x y | dir _ (stopPoint - startPoint) normalized. "Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint" cos _ dir dotProduct: (1@0). sin _ dir crossProduct: (1@0). "Now get the fill style appropriate for the given direction" fill _ self fillStyleForDirection: dir. false ifTrue:[ "Transform the fill appropriately" fill _ fill clone. "Note: Code below is inlined from tfm transformPoint:/transformDirection:" x _ fill origin x. y _ fill origin y. fsOrigin _ ((x * cos) + (y * sin) + startPoint x) @ ((y * cos) - (x * sin) + startPoint y). x _ fill direction x. y _ fill direction y. fsDirection _ ((x * cos) + (y * sin)) @ ((y * cos) - (x * sin)). fill origin: fsOrigin; direction: fsDirection rounded; "NOTE: This is a bug in the balloon engine!!!!!!" normal: nil. aCanvas asBalloonCanvas drawPolygon: endsArray fillStyle: fill. ] ifFalse:[ "Transform the points rather than the fills" tfm _ (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos. "Install the start point offset" tfm offset: startPoint. points _ endsArray collect:[:pt| tfm invertPoint: pt]. aCanvas asBalloonCanvas transformBy: tfm during:[:cc| cc drawPolygon: points fillStyle: fill. ]. ].! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 9/4/2001 19:51'! framePolygon2: vertices on: aCanvas | dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3 cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends | balloon _ aCanvas asBalloonCanvas. balloon == aCanvas ifFalse:[balloon deferred: true]. ends _ Array new: 4. w _ width * 0.5. pointA _ nil. 1 to: vertices size do:[:i| p1 _ vertices atWrap: i. p2 _ vertices atWrap: i+1. p3 _ vertices atWrap: i+2. p4 _ vertices atWrap: i+3. dir1 _ p2 - p1. dir2 _ p3 - p2. dir3 _ p4 - p3. i = 1 ifTrue:[ "Compute the merge points of p1->p2 with p2->p3" cross1 _ dir2 crossProduct: dir1. nrm1 _ dir1 normalized. nrm1 _ (nrm1 y * w) @ (0 - nrm1 x * w). nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross1 < 0 ifTrue:[nrm1 _ nrm1 negated. nrm2 _ nrm2 negated]. point1 _ (p1 x + nrm1 x) @ (p1 y + nrm1 y). point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). pointA _ self intersectFrom: point1 with: dir1 to: point2 with: dir2. point1 _ (p1 x - nrm1 x) @ (p1 y - nrm1 y). point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). pointB _ self intersectFrom: point1 with: dir1 to: point2 with: dir2. pointB ifNotNil:[ (pointB x - p2 x) abs + (pointB y - p2 y) abs > (4*w) ifTrue:[pointA _ pointB _ nil]. ]. ]. "Compute the merge points of p2->p3 with p3->p4" cross2 _ dir3 crossProduct: dir2. nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). nrm3 _ dir3 normalized. nrm3 _ (nrm3 y * w) @ (0 - nrm3 x * w). cross2 < 0 ifTrue:[nrm2 _ nrm2 negated. nrm3 _ nrm3 negated]. point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). point3 _ (p3 x + nrm3 x) @ (p3 y + nrm3 y). pointC _ self intersectFrom: point2 with: dir2 to: point3 with: dir3. point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). point3 _ (p3 x - nrm3 x) @ (p3 y - nrm3 y). pointD _ self intersectFrom: point2 with: dir2 to: point3 with: dir3. pointD ifNotNil:[ (pointD x - p3 x) abs + (pointD y - p3 y) abs > (4*w) ifTrue:[pointC _ pointD _ nil]. ]. cross1 * cross2 < 0.0 ifTrue:[ point1 _ pointA. pointA _ pointB. pointB _ point1. cross1 _ 0.0 - cross1]. ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointD; at: 4 put: pointC. pointA ifNil:["degenerate and slow" nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross1 < 0 ifTrue:[nrm2 _ nrm2 negated]. point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). ends at: 1 put: point2]. pointB ifNil:["degenerate and slow" nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross1 < 0 ifTrue:[nrm2 _ nrm2 negated]. point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). ends at: 2 put: point2]. pointC ifNil:["degenerate and slow" nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross2 < 0 ifTrue:[nrm2 _ nrm2 negated]. point2 _ (p3 x + nrm2 x) @ (p3 y + nrm2 y). ends at: 4 put: point2]. pointD ifNil:["degenerate and slow" nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross2 < 0 ifTrue:[nrm2 _ nrm2 negated]. point2 _ (p3 x - nrm2 x) @ (p3 y - nrm2 y). ends at: 3 put: point2]. self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends. pointA _ pointC. pointB _ pointD. cross1 _ cross2. ]. balloon == aCanvas ifFalse:[balloon flush].! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 9/4/2001 19:50'! framePolygon: vertices on: aCanvas | dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3 cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends pointE pointF | balloon _ aCanvas asBalloonCanvas. balloon == aCanvas ifFalse:[balloon deferred: true]. ends _ Array new: 6. w _ width * 0.5. pointA _ nil. 1 to: vertices size do:[:i| p1 _ vertices atWrap: i. p2 _ vertices atWrap: i+1. p3 _ vertices atWrap: i+2. p4 _ vertices atWrap: i+3. dir1 _ p2 - p1. dir2 _ p3 - p2. dir3 _ p4 - p3. (i = 1 | true) ifTrue:[ "Compute the merge points of p1->p2 with p2->p3" cross1 _ dir2 crossProduct: dir1. nrm1 _ dir1 normalized. nrm1 _ (nrm1 y * w) @ (0 - nrm1 x * w). nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross1 < 0 ifTrue:[nrm1 _ nrm1 negated. nrm2 _ nrm2 negated]. point1 _ (p1 x + nrm1 x) @ (p1 y + nrm1 y). point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). pointA _ self intersectFrom: point1 with: dir1 to: point2 with: dir2. point1 _ (p1 x - nrm1 x) @ (p1 y - nrm1 y). point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). pointB _ point1 + dir1 + point2 * 0.5. pointB _ p2 + ((pointB - p2) normalized * w). pointC _ point2. ]. "Compute the merge points of p2->p3 with p3->p4" cross2 _ dir3 crossProduct: dir2. nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). nrm3 _ dir3 normalized. nrm3 _ (nrm3 y * w) @ (0 - nrm3 x * w). cross2 < 0 ifTrue:[nrm2 _ nrm2 negated. nrm3 _ nrm3 negated]. point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). point3 _ (p3 x + nrm3 x) @ (p3 y + nrm3 y). pointD _ self intersectFrom: point2 with: dir2 to: point3 with: dir3. point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). point3 _ (p3 x - nrm3 x) @ (p3 y - nrm3 y). pointF _ point2 + dir2. pointE _ pointF + point3 * 0.5. pointE _ p3 + ((pointE - p3) normalized * w). cross1 * cross2 < 0.0 ifTrue:[ ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointC; at: 4 put: pointD; at: 5 put: pointE; at: 6 put: pointF. ] ifFalse:[ ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointC; at: 4 put: pointF; at: 5 put: pointE; at: 6 put: pointD. ]. self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends. pointA _ pointD. pointB _ pointE. pointC _ pointF. cross1 _ cross2. ]. balloon == aCanvas ifFalse:[balloon flush].! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 8/26/2001 19:01'! frameRectangle: aRectangle on: aCanvas "Note: This uses BitBlt since it's roughly a factor of two faster for rectangles" | w h r | self colors ifNil:[^super frameRectangle: aRectangle on: aCanvas]. w _ self width. w isPoint ifTrue:[h _ w y. w _ w x] ifFalse:[h _ w]. 1 to: h do:[:i| "top/bottom" r _ (aRectangle topLeft + (i-1)) extent: (aRectangle width - (i-1*2))@1. "top" aCanvas fillRectangle: r color: (colors at: i). r _ (aRectangle bottomLeft + (i @ (0-i))) extent: (aRectangle width - (i-1*2) - 1)@1. "bottom" aCanvas fillRectangle: r color: (colors at: colors size - i + 1). ]. 1 to: w do:[:i| "left/right" r _ (aRectangle topLeft + (i-1)) extent: 1@(aRectangle height - (i-1*2)). "left" aCanvas fillRectangle: r color: (colors at: i). r _ aRectangle topRight + ((0-i)@i) extent: 1@(aRectangle height - (i-1*2) - 1). "right" aCanvas fillRectangle: r color: (colors at: colors size - i + 1). ].! ! !ComplexBorder methodsFor: 'initialize' stamp: 'ar 11/26/2001 14:43'! releaseCachedState colors _ nil. lineStyles _ nil.! ! !ComplexBorder methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! isComplex ^true! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:15'! colorsForDirection: direction "Return an array of colors describing the receiver in the given direction" | colorArray dT cc | cc _ self colors. (direction x * direction y) <= 0 ifTrue:[ "within up->right or down->left transition; no color blend needed" (direction x > 0 or:[direction y < 0]) ifTrue:["up->right" colorArray _ cc copyFrom: 1 to: width. ] ifFalse:["down->left" "colors are stored in reverse direction when following a line" colorArray _ (cc copyFrom: width+1 to: cc size) reversed. ]. ] ifFalse:[ "right->down or left->up transition; need color blend" colorArray _ Array new: width. dT _ direction x asFloat / (direction x + direction y). (direction x > 0 or:[direction y >= 0]) ifTrue:["top-right" 1 to: width do:[:i| colorArray at: i put: ((cc at: i) mixed: dT with: (cc at: cc size - i + 1))] ] ifFalse:["bottom-left" 1 to: width do:[:i| colorArray at: i put: ((cc at: cc size - i + 1) mixed: dT with: (cc at: i))] ]. ]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:02' prior: 35264146! colorsForDirection: direction "Return an array of colors describing the receiver in the given direction" | colorArray dT cc | cc := self colors. direction x * direction y <= 0 ifTrue: ["within up->right or down->left transition; no color blend needed" colorArray := (direction x > 0 or: [direction y < 0]) ifTrue: ["up->right" cc copyFrom: 1 to: width] ifFalse: ["down->left" "colors are stored in reverse direction when following a line" (cc copyFrom: width + 1 to: cc size) reversed]] ifFalse: ["right->down or left->up transition; need color blend" colorArray := Array new: width. dT := direction x asFloat / (direction x + direction y). (direction x > 0 or: [direction y >= 0]) ifTrue: ["top-right" 1 to: width do: [:i | colorArray at: i put: ((cc at: i) mixed: dT with: (cc at: cc size - i + 1))]] ifFalse: ["bottom-left" 1 to: width do: [:i | colorArray at: i put: ((cc at: cc size - i + 1) mixed: dT with: (cc at: i))]]]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:16'! computeAltFramedColors | base light dark w hw colorArray param | base _ self color asColor. light _ Color white. dark _ Color black. w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w _ w asInteger. w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}]. colorArray _ Array new: w. hw _ w // 2. "brighten" 0 to: hw-1 do:[:i| param _ 0.5 + (i asFloat / hw * 0.5). colorArray at: i+1 put: (base mixed: param with: dark). "brighten" colorArray at: w-i put: (base mixed: param with: light). "darken" ]. w odd ifTrue:[colorArray at: hw+1 put: base]. ^colorArray, colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:16'! computeAltInsetColors | base light dark w colorArray param hw | base _ self color asColor. light _ Color white. dark _ Color black. w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w _ w asInteger. colorArray _ Array new: w*2. hw _ 0.5 / w. 0 to: w-1 do:[:i| false ifTrue:[param _ 0.5 + (hw * i)] ifFalse:[param _ 0.5 + (hw * (w-i))]. colorArray at: i+1 put: (base mixed: param with: dark). "darken" colorArray at: colorArray size - i put: (base mixed: param with: light). "brighten" ]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:03' prior: 35267131! computeAltInsetColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | param := false ifTrue: ["whats this ???!! false ifTrue:[]" 0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: dark). "darken" colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:16'! computeAltRaisedColors | base light dark w colorArray param hw | base _ self color asColor. light _ Color white. dark _ Color black. w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w _ w asInteger. colorArray _ Array new: w*2. hw _ 0.5 / w. 0 to: w-1 do:[:i| false ifTrue:[param _ 0.5 + (hw * i)] ifFalse:[param _ 0.5 + (hw * (w-i))]. colorArray at: i+1 put: (base mixed: param with: light). "brighten" colorArray at: colorArray size - i put: (base mixed: param with: dark). "darken" ]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:05' prior: 35268492! computeAltRaisedColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | "again !! false ifTrue:[] ?!!" param := false ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: light). "brighten" colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 11/26/2001 15:00'! computeColors width = 0 ifTrue:[^colors _ #()]. style == #complexFramed ifTrue:[^self computeFramedColors]. style == #complexAltFramed ifTrue:[^self computeAltFramedColors]. style == #complexRaised ifTrue:[^self computeRaisedColors]. style == #complexAltRaised ifTrue:[^self computeAltRaisedColors]. style == #complexInset ifTrue:[^self computeInsetColors]. style == #complexAltInset ifTrue:[^self computeAltInsetColors]. self error:'Unknown border style: ', style printString.! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:35'! computeFramedColors | base light dark w hw colorArray param | base _ self color asColor. light _ Color white. dark _ Color black. w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w _ w asInteger. w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}]. colorArray _ Array new: w. hw _ w // 2. "brighten" 0 to: hw-1 do:[:i| param _ 0.5 + (i asFloat / hw * 0.5). colorArray at: i+1 put: (base mixed: param with: light). "brighten" colorArray at: w-i put: (base mixed: param with: dark). "darken" ]. w odd ifTrue:[colorArray at: hw+1 put: base]. ^colorArray, colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:16'! computeInsetColors | base light dark w colorArray param hw | base _ self color asColor. light _ Color white. dark _ Color black. w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w _ w asInteger. colorArray _ Array new: w*2. hw _ 0.5 / w. 0 to: w-1 do:[:i| true ifTrue:[param _ 0.5 + (hw * i)] ifFalse:[param _ 0.5 + (hw * (w-i))]. colorArray at: i+1 put: (base mixed: param with: dark). "darken" colorArray at: colorArray size - i put: (base mixed: param with: light). "brighten" ]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:06' prior: 35271090! computeInsetColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | param := true ifTrue: [ 0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: dark). "darken" colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:16'! computeRaisedColors | base light dark w colorArray param hw | base _ self color asColor. light _ Color white. dark _ Color black. w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w _ w asInteger. colorArray _ Array new: w*2. hw _ 0.5 / w. 0 to: w-1 do:[:i| true ifTrue:[param _ 0.5 + (hw * i)] ifFalse:[param _ 0.5 + (hw * (w-i))]. colorArray at: i+1 put: (base mixed: param with: light). "brighten" colorArray at: colorArray size - i put: (base mixed: param with: dark). "darken" ]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:07' prior: 35272390! computeRaisedColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | param := true ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: light). "brighten" colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 9/4/2001 19:51'! fillStyleForDirection: direction "Fill the given form describing the receiver's look at a particular direction" | index fill dir | index _ direction degrees truncated // 10 + 1. lineStyles ifNotNil:[ fill _ lineStyles at: index. fill ifNotNil:[^fill]. ]. dir _ Point r: 1.0 degrees: index - 1 * 10 + 5. fill _ GradientFillStyle colors: (self colorsForDirection: dir). fill direction: 0 @ width asPoint y; radial: false. fill origin: ((width asPoint x // 2) @ (width asPoint y // 2)) negated. fill pixelRamp: (fill computePixelRampOfSize: 16). fill isTranslucent. "precompute" lineStyles ifNil:[lineStyles _ Array new: 37]. lineStyles at: index put: fill. ^fill! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/26/2001 23:39'! intersectFrom: startPt with: startDir to: endPt with: endDir "Compute the intersection of two lines. Return nil if either * the intersection does not exist, or * the intersection is 'before' startPt, or * the intersection is 'after' endPt " | det deltaPt alpha beta | det _ (startDir x * endDir y) - (startDir y * endDir x). det = 0.0 ifTrue:[^nil]. "There's no solution for it" deltaPt _ endPt - startPt. alpha _ (deltaPt x * endDir y) - (deltaPt y * endDir x). beta _ (deltaPt x * startDir y) - (deltaPt y * startDir x). alpha _ alpha / det. beta _ beta / det. alpha < 0 ifTrue:[^nil]. beta > 1.0 ifTrue:[^nil]. "And compute intersection" ^(startPt x + (alpha * startDir x)) @ (startPt y + (alpha * startDir y))! ! !ComplexBorder commentStamp: 'kfr 10/27/2003 10:18' prior: 0! see BorderedMorph. poly _ polygon250 baseColor _ Color blue twiceLighter. border _ (ComplexBorder framed: 10) baseColor: poly color. border frameRectangle: ((100@100 extent: 200@200) insetBy: -5) on: Display getCanvas. baseColor _ Color red twiceLighter. border _ (ComplexBorder framed: 10) baseColor: baseColor. border drawPolygon: {100@100. 300@100. 300@300. 100@300} on: Display getCanvas. border drawPolyPatchFrom: 100@200 via: 100@100 via: 200@100 to: 200@200 on: Display getCanvas. border drawPolyPatchFrom: 100@100 via: 200@100 via: 200@200 to: 100@200 on: Display getCanvas. border drawPolyPatchFrom: 200@100 via: 200@200 via: 100@200 to: 100@100 on: Display getCanvas. border drawPolyPatchFrom: 200@200 via: 100@200 via: 100@100 to: 200@100 on: Display getCanvas. border _ (ComplexBorder raised: 10) baseColor: poly color. border drawPolygon: poly getVertices on: Display getCanvas 360 / 16.0 22.5 points _ (0 to: 15) collect:[:i| (Point r: 100 degrees: i*22.5) + 200]. Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor. border drawPolygon: points on: Display getCanvas. -1 to: points size + 1 do:[:i| border drawPolyPatchFrom: (points atWrap: i) via: (points atWrap: i+1) via: (points atWrap: i+2) to: (points atWrap: i+3) on: Display getCanvas. ]. Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor. 0 to: 36 do:[:i| border drawLineFrom: (Point r: 100 degrees: i*10) + 200 to: (Point r: 100 degrees: i+1*10) + 200 on: Display getCanvas. ]. drawPolygon: Point r: 1.0 degrees: 10 MessageTally spyOn:[ Display deferUpdates: true. t1 _ [1 to: 1000 do:[:i| border drawLineFrom: (100@100) to: (300@100) on: Display getCanvas. border drawLineFrom: (300@100) to: (300@300) on: Display getCanvas. border drawLineFrom: (300@300) to: (100@300) on: Display getCanvas. border drawLineFrom: (100@300) to: (100@100) on: Display getCanvas]] timeToRun. Display deferUpdates: false. ]. MessageTally spyOn:[ Display deferUpdates: true. t2 _ [1 to: 1000 do:[:i| border drawLine2From: (100@100) to: (300@100) on: Display getCanvas. border drawLine2From: (300@100) to: (300@300) on: Display getCanvas. border drawLine2From: (300@300) to: (100@300) on: Display getCanvas. border drawLine2From: (100@300) to: (100@100) on: Display getCanvas]] timeToRun. Display deferUpdates: false. ]. ! !ComplexBorder class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:22'! style: aSymbol ^self new style: aSymbol! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'ar 3/2/2001 20:31'! addProgressDecoration: extraParam | f m | targetMorph ifNil:[^self]. (extraParam isKindOf: Form) ifTrue:[ targetMorph submorphsDo:[:mm| (mm isKindOf: SketchMorph) ifTrue:[mm delete]]. f _ Form extent: extraParam extent depth: extraParam depth. extraParam displayOn: f. m _ SketchMorph withForm: f. m align: m fullBounds leftCenter with: targetMorph fullBounds leftCenter + (2@0). targetMorph addMorph: m. ^self]. (extraParam isMemberOf: String) ifTrue:[ targetMorph submorphsDo:[:mm| (mm isKindOf: StringMorph) ifTrue:[mm delete]]. m _ StringMorph contents: extraParam. m align: m fullBounds bottomCenter + (0@8) with: targetMorph bounds bottomCenter. targetMorph addMorph: m. ^self].! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'gm 2/22/2003 14:46' prior: 35277784! addProgressDecoration: extraParam | f m | targetMorph ifNil: [^self]. (extraParam isForm) ifTrue: [targetMorph submorphsDo: [:mm | (mm isKindOf: SketchMorph) ifTrue: [mm delete]]. f := Form extent: extraParam extent depth: extraParam depth. extraParam displayOn: f. m := SketchMorph withForm: f. m align: m fullBounds leftCenter with: targetMorph fullBounds leftCenter + (2 @ 0). targetMorph addMorph: m. ^self]. (extraParam isMemberOf: String) ifTrue: [targetMorph submorphsDo: [:mm | (mm isKindOf: StringMorph) ifTrue: [mm delete]]. m := StringMorph contents: extraParam. m align: m fullBounds bottomCenter + (0 @ 8) with: targetMorph bounds bottomCenter. targetMorph addMorph: m. ^self]! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 19656054! backgroundWorldDisplay | f | self flag: #bob. "really need a better way to do this" "World displayWorldSafely." "ugliness to try to track down a possible error" [World displayWorld] ifError: [ :a :b | stageCompleted _ 999. f _ FileDirectory default fileNamed: 'bob.errors'. f nextPutAll: a printString,' ',b printString; cr; cr. f nextPutAll: 'worlds equal ',(formerWorld == World) printString; cr; cr. f nextPutAll: thisContext longStack; cr; cr. f nextPutAll: formerProcess suspendedContext longStack; cr; cr. f close. Beeper beep. ]. ! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'ar 7/8/2001 17:05'! forkProgressWatcher | killTarget | [ [stageCompleted < 999 and: [formerProject == Project current and: [formerWorld == World and: [translucentMorph world notNil and: [formerProcess suspendedContext notNil and: [Project uiProcess == formerProcess]]]]]] whileTrue: [ translucentMorph setProperty: #revealTimes toValue: {(Time millisecondClockValue - start max: 1). (estimate * newRatio max: 1)}. translucentMorph changed. translucentMorph owner addMorphInLayer: translucentMorph. (Time millisecondClockValue - WorldState lastCycleTime) abs > 500 ifTrue: [ self backgroundWorldDisplay ]. (Delay forMilliseconds: 100) wait. ]. translucentMorph removeProperty: #revealTimes. self loadingHistoryAt: 'total' add: (Time millisecondClockValue - start max: 1). killTarget _ targetMorph ifNotNil: [ targetMorph valueOfProperty: #deleteOnProgressCompletion ]. formerWorld == World ifTrue: [ translucentMorph delete. killTarget ifNotNil: [killTarget delete]. ] ifFalse: [ translucentMorph privateDeleteWithAbsolutelyNoSideEffects. killTarget ifNotNil: [killTarget privateDeleteWithAbsolutelyNoSideEffects]. ]. ] forkAt: Processor lowIOPriority.! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'ar 3/2/2001 20:25'! withProgressDo: aBlock | safetyFactor totals trialRect delta stageCompletedString | Smalltalk isMorphic ifFalse: [^aBlock value]. formerProject _ Project current. formerWorld _ World. formerProcess _ Processor activeProcess. targetMorph ifNil: [targetMorph _ ProgressTargetRequestNotification signal]. targetMorph ifNil: [ trialRect _ Rectangle center: Sensor cursorPoint extent: 80@80. delta _ trialRect amountToTranslateWithin: formerWorld bounds. trialRect _ trialRect translateBy: delta. translucentMorph _ TranslucentProgessMorph new opaqueBackgroundColor: Color white; bounds: trialRect; openInWorld: formerWorld. ] ifNotNil: [ translucentMorph _ TranslucentProgessMorph new setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1; bounds: targetMorph boundsInWorld; openInWorld: targetMorph world. ]. stageCompleted _ 0. safetyFactor _ 1.1. "better to guess high than low" translucentMorph setProperty: #progressStageNumber toValue: 1. totals _ self loadingHistoryDataForKey: 'total'. newRatio _ 1.0. estimate _ totals size < 2 ifTrue: [ 15000 "be a pessimist" ] ifFalse: [ (totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor. ]. start _ Time millisecondClockValue. self forkProgressWatcher. [ aBlock on: ProgressInitiationException do: [ :ex | ex sendNotificationsTo: [ :min :max :curr | "ignore this as it is inaccurate" ]. ]. ] on: ProgressNotification do: [ :note | note extraParam ifNotNil:[self addProgressDecoration: note extraParam]. stageCompletedString _ (note messageText findTokens: ' ') first. stageCompleted _ (stageCompletedString copyUpTo: $:) asNumber. cumulativeStageTime _ Time millisecondClockValue - start max: 1. prevData _ self loadingHistoryDataForKey: stageCompletedString. prevData isEmpty ifFalse: [ newRatio _ (cumulativeStageTime / (prevData average max: 1)) asFloat. ]. self loadingHistoryAt: stageCompletedString add: cumulativeStageTime. translucentMorph setProperty: #progressStageNumber toValue: stageCompleted + 1. note resume. ]. stageCompleted _ 999. "we may or may not get here" ! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'mir 1/5/2004 11:45' prior: 35281446! withProgressDo: aBlock | safetyFactor totals trialRect delta stageCompletedString targetOwner | Smalltalk isMorphic ifFalse: [^aBlock value]. formerProject _ Project current. formerWorld _ World. formerProcess _ Processor activeProcess. targetMorph ifNil: [ targetMorph _ ProgressTargetRequestNotification signal. targetOwner := targetMorph owner]. targetMorph ifNil: [ trialRect _ Rectangle center: Sensor cursorPoint extent: 80@80. delta _ trialRect amountToTranslateWithin: formerWorld bounds. trialRect _ trialRect translateBy: delta. translucentMorph _ TranslucentProgessMorph new opaqueBackgroundColor: Color white; bounds: trialRect; openInWorld: formerWorld. ] ifNotNil: [ translucentMorph _ TranslucentProgessMorph new setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1; bounds: targetMorph boundsInWorld; openInWorld: targetMorph world. ]. stageCompleted _ 0. safetyFactor _ 1.1. "better to guess high than low" translucentMorph setProperty: #progressStageNumber toValue: 1. translucentMorph hide. targetOwner ifNotNil: [targetOwner hide]. totals _ self loadingHistoryDataForKey: 'total'. newRatio _ 1.0. estimate _ totals size < 2 ifTrue: [ 15000 "be a pessimist" ] ifFalse: [ (totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor. ]. start _ Time millisecondClockValue. self forkProgressWatcher. [ aBlock on: ProgressInitiationException do: [ :ex | ex sendNotificationsTo: [ :min :max :curr | "ignore this as it is inaccurate" ]. ]. ] on: ProgressNotification do: [ :note | translucentMorph show. targetOwner ifNotNil: [targetOwner show]. note extraParam ifNotNil:[self addProgressDecoration: note extraParam]. stageCompletedString _ (note messageText findTokens: ' ') first. stageCompleted _ (stageCompletedString copyUpTo: $:) asNumber. cumulativeStageTime _ Time millisecondClockValue - start max: 1. prevData _ self loadingHistoryDataForKey: stageCompletedString. prevData isEmpty ifFalse: [ newRatio _ (cumulativeStageTime / (prevData average max: 1)) asFloat. ]. self loadingHistoryAt: stageCompletedString add: cumulativeStageTime. translucentMorph setProperty: #progressStageNumber toValue: stageCompleted + 1. note resume. ]. stageCompleted _ 999. "we may or may not get here" ! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'mir 3/9/2004 16:27' prior: 35283745! withProgressDo: aBlock | safetyFactor totals trialRect delta stageCompletedString targetOwner | Smalltalk isMorphic ifFalse: [^aBlock value]. formerProject _ Project current. formerWorld _ World. formerProcess _ Processor activeProcess. targetMorph ifNil: [targetMorph _ ProgressTargetRequestNotification signal]. targetMorph ifNil: [ trialRect _ Rectangle center: Sensor cursorPoint extent: 80@80. delta _ trialRect amountToTranslateWithin: formerWorld bounds. trialRect _ trialRect translateBy: delta. translucentMorph _ TranslucentProgessMorph new opaqueBackgroundColor: Color white; bounds: trialRect; openInWorld: formerWorld. ] ifNotNil: [ targetOwner := targetMorph owner. translucentMorph _ TranslucentProgessMorph new setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1; bounds: targetMorph boundsInWorld; openInWorld: targetMorph world. ]. stageCompleted _ 0. safetyFactor _ 1.1. "better to guess high than low" translucentMorph setProperty: #progressStageNumber toValue: 1. translucentMorph hide. targetOwner ifNotNil: [targetOwner hide]. totals _ self loadingHistoryDataForKey: 'total'. newRatio _ 1.0. estimate _ totals size < 2 ifTrue: [ 15000 "be a pessimist" ] ifFalse: [ (totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor. ]. start _ Time millisecondClockValue. self forkProgressWatcher. [ aBlock on: ProgressInitiationException do: [ :ex | ex sendNotificationsTo: [ :min :max :curr | "ignore this as it is inaccurate" ]. ]. ] on: ProgressNotification do: [ :note | translucentMorph show. targetOwner ifNotNil: [targetOwner show]. note extraParam ifNotNil:[self addProgressDecoration: note extraParam]. stageCompletedString _ (note messageText findTokens: ' ') first. stageCompleted _ (stageCompletedString copyUpTo: $:) asNumber. cumulativeStageTime _ Time millisecondClockValue - start max: 1. prevData _ self loadingHistoryDataForKey: stageCompletedString. prevData isEmpty ifFalse: [ newRatio _ (cumulativeStageTime / (prevData average max: 1)) asFloat. ]. self loadingHistoryAt: stageCompletedString add: cumulativeStageTime. translucentMorph setProperty: #progressStageNumber toValue: stageCompleted + 1. note resume. ]. stageCompleted _ 999. "we may or may not get here" ! ! !ComplexProgressIndicator class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25' prior: 19661273! historyReport " ComplexProgressIndicator historyReport " | answer data | History ifNil: [^Beeper beep]. answer _ String streamContents: [ :strm | (History keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :k | strm nextPutAll: k printString; cr. data _ History at: k. (data keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :dataKey | strm tab; nextPutAll: dataKey printString,' ', (data at: dataKey) asArray printString; cr. ]. strm cr. ]. ]. StringHolder new contents: answer contents; openLabel: 'Progress History'! ! !Component methodsFor: 'variables' stamp: 'gm 3/2/2003 18:35' prior: 19664378! addVariableNamed: varName "Adjust name if necessary and add it" | otherNames i partName | otherNames := self class allInstVarNames. i := nil. [partName := i isNil ifTrue: [varName] ifFalse: [varName , i printString]. otherNames includes: partName] whileTrue: [i := i isNil ifTrue: [1] ifFalse: [i + 1]]. self class addInstVarName: partName. "Now compile read method and write-with-change method" self class compile: (String streamContents: [:s | s nextPutAll: partName; cr; tab; nextPutAll: '^' , partName]) classified: 'view access' notifying: nil. self class compile: (String streamContents: [:s | s nextPutAll: partName , 'Set: newValue'; cr; tab; nextPutAll: partName , ' _ newValue.'; cr; tab; nextPutAll: 'self changed: #' , partName , '.'; cr; tab; nextPutAll: '^ true' "for components that expect a boolean for accept"]) classified: 'view access' notifying: nil. ^Array with: partName asSymbol with: (partName , 'Set:') asSymbol! ! !ComponentLayout methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:17' prior: 19673053! addCustomMenuItems: menu hand: aHandMorph super addCustomMenuItems: menu hand: aHandMorph. menu addLine. menu add: 'inspect model in morphic' translated action: #inspectModelInMorphic! ! !ComponentLayout methodsFor: 'model' stamp: 'dgd 2/21/2003 23:06' prior: 19673508! createCustomModel "Create a model object for this world if it does not yet have one. The default model for an EditView is a Component." model isNil ifFalse: [^self]. "already has a model" model := Component newSubclass new! ! !ComponentLayout methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 19:06' prior: 19673314! allKnownNames ^super allKnownNames , (self submorphs collect: [:m | m knownName] thenSelect: [:m | m notNil])! ! !ComponentLikeModel methodsFor: 'naming' stamp: 'dgd 2/21/2003 23:01' prior: 19674728! choosePartName "When I am renamed, get a slot, make default methods, move any existing methods." | old | (self pasteUpMorph model isKindOf: Component) ifTrue: [self knownName ifNil: [^self nameMeIn: self pasteUpMorph] ifNotNil: [^self renameMe]]. old := slotName. super choosePartName. slotName ifNil: [^self]. "user chose bad slot name" self model: self world model slotName: slotName. old isNil ifTrue: [self compilePropagationMethods] ifFalse: [self copySlotMethodsFrom: old] "old ones not erased!!"! ! !ComponentLikeModel methodsFor: 'submorphs-add/remove' stamp: 'gm 2/22/2003 13:14' prior: 19675876! delete "Delete the receiver. Possibly put up confirming dialog. Abort if user changes mind" (model isKindOf: Component) ifTrue: [^self deleteComponent]. (model isMorphicModel) ifFalse: [^super delete]. slotName ifNotNil: [(PopUpMenu confirm: 'Shall I remove the slot ' , slotName , ' along with all associated methods?') ifTrue: [(model class selectors select: [:s | s beginsWith: slotName]) do: [:s | model class removeSelector: s]. (model class instVarNames includes: slotName) ifTrue: [model class removeInstVarName: slotName]] ifFalse: [(PopUpMenu confirm: '...but should I at least dismiss this morph? [choose no to leave everything unchanged]') ifFalse: [^self]]]. super delete! ! !CompositionScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 02:06'! composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength done stopCondition | "Set up margins" leftMargin _ lineRectangle left. leftSide ifTrue: [leftMargin _ leftMargin + (firstLine ifTrue: [textStyle firstIndent] ifFalse: [textStyle restIndent])]. destX _ spaceX _ leftMargin. rightMargin _ lineRectangle right. rightSide ifTrue: [rightMargin _ rightMargin - textStyle rightIndent]. lastIndex _ startIndex. "scanning sets last index" destY _ lineRectangle top. lineHeight _ baseline _ 0. "Will be increased by setFont" self setStopConditions. "also sets font" runLength _ text runLengthFor: startIndex. runStopIndex _ (lastIndex _ startIndex) + (runLength - 1). line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) rectangle: lineRectangle. spaceCount _ 0. self handleIndentation. leftMargin _ destX. line leftMargin: leftMargin. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [^ line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! ! !CompositionScanner methodsFor: 'scanning' stamp: 'hmm 7/20/2000 18:24'! composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength done stopCondition | destX _ spaceX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex. destY _ 0. rightMargin _ aParagraph rightMarginForComposition. leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose']. lastIndex _ startIndex. "scanning sets last index" lineHeight _ textStyle lineGrid. "may be increased by setFont:..." baseline _ textStyle baseline. self setStopConditions. "also sets font" self handleIndentation. runLength _ text runLengthFor: startIndex. runStopIndex _ (lastIndex _ startIndex) + (runLength - 1). line _ TextLineInterval start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0. spaceCount _ 0. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [^line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'RAA 5/4/2001 13:52'! columnBreak "Answer true. Set up values for the text line interval currently being composed." line stop: lastIndex. spaceX _ destX. line paddingWidth: rightMargin - spaceX. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 12/17/2001 02:13'! placeEmbeddedObject: anchoredMorph | descent | "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. (super placeEmbeddedObject: anchoredMorph) ifFalse: ["It doesn't fit" "But if it's the first character then leave it here" lastIndex < line first ifFalse:[ line stop: lastIndex-1. ^ false]]. descent _ lineHeight - baseline. lineHeight _ lineHeight max: anchoredMorph height. baseline _ lineHeight - descent. line stop: lastIndex. ^ true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'RAA 5/7/2001 10:12'! setFont super setFont. stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #space. wantsColumnBreaks == true ifTrue: [ stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak. ]. ! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:59'! tab "Advance destination x according to tab settings in the paragraph's textStyle. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." destX _ textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. destX > rightMargin ifTrue: [^self crossedX]. lastIndex _ lastIndex + 1. ^false ! ! !CompoundTextConverter methodsFor: 'conversion' stamp: 'yo 8/18/2003 17:50'! emitSequenceToResetStateIfNeededOn: aStream Latin1 emitSequenceToResetStateIfNeededOn: aStream forState: state. ! ! !CompoundTextConverter methodsFor: 'conversion' stamp: 'yo 8/13/2003 11:34'! nextFromStream: aStream | character character2 size leadingChar offset result | aStream isBinary ifTrue: [^ aStream basicNext]. character _ aStream basicNext. character ifNil: [^ nil]. character == Character escape ifTrue: [ self parseShiftSeqFromStream: aStream. character _ aStream basicNext. character ifNil: [^ nil]]. character asciiValue < 128 ifTrue: [ size _ state g0Size. leadingChar _ state g0Leading. offset _ 16r21. ] ifFalse: [ size _state g1Size. leadingChar _ state g1Leading. offset _ 16rA1. ]. size = 1 ifTrue: [ leadingChar = 0 ifTrue: [^ character] ifFalse: [^ MultiCharacter leadingChar: leadingChar code: character asciiValue] ]. size = 2 ifTrue: [ character2 _ aStream basicNext. character2 ifNil: [self errorMalformedInput]. character _ character asciiValue - offset. character2 _ character2 asciiValue - offset. result _ MultiCharacter leadingChar: leadingChar code: character * 94 + character2. ^ self toUnicode: result ]. self error: 'unsupported encoding'. ! ! !CompoundTextConverter methodsFor: 'conversion' stamp: 'yo 8/18/2003 17:52'! nextPut: aCharacter toStream: aStream | ascii leadingChar | aStream isBinary ifTrue: [ aCharacter class == Character ifTrue: [ ^ aStream basicNextPut: aCharacter. ]. aCharacter class == MultiCharacter ifTrue: [ "this shouldn't happen?" ^ aStream nextInt32Put: aCharacter value. ]. ]. aCharacter isUnicode ifTrue: [ ascii _ (JISX0208 charFromUnicode: aCharacter asUnicode) charCode. leadingChar _ JISX0208 leadingChar. ] ifFalse: [ ascii _ aCharacter charCode. leadingChar _ aCharacter leadingChar. ]. self nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar. ! ! !CompoundTextConverter methodsFor: 'private' stamp: 'yo 11/4/2002 14:36'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar | charset | charset _ EncodedCharSet charsetAt: leadingChar. charset ifNotNil: [ charset nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state. ] ifNil: [ "..." ]. ! ! !CompoundTextConverter methodsFor: 'private' stamp: 'yo 11/4/2002 14:47'! parseShiftSeqFromStream: aStream | c set target id | c _ aStream basicNext. c = $$ ifTrue: [ set _ #multibyte. c _ aStream basicNext. c = $( ifTrue: [target _ 1]. c = $) ifTrue: [target _ 2]. target ifNil: [target _ 1. id _ c] ifNotNil: [id _ aStream basicNext]. ] ifFalse: [ c = $( ifTrue: [target _ 1. set _ #nintyfour]. c = $) ifTrue: [target _ 2. set _ #nintyfour]. c = $- ifTrue: [target _ 2. set _ #nintysix]. "target = nil ifTrue: [self errorMalformedInput]." id _ aStream basicNext. ]. (set = #multibyte and: [id = $B]) ifTrue: [ state charSize: 2. target = 1 ifTrue: [ state g0Size: 2. state g0Leading: 1. ] ifFalse: [ state g1Size: 2. state g1Leading: 1. ]. ^ self ]. (set = #nintyfour and: [id = $B or: [id = $J]]) ifTrue: [ state charSize: 1. state g0Size: 1. state g0Leading: 0. ^ self ]. (set = #nintysix and: [id = $A]) ifTrue: [ state charSize: 1. state g1Size: 1. state g1Leading: 0. ^ self ]. "self errorUnsupported." ! ! !CompoundTextConverter methodsFor: 'private' stamp: 'yo 11/4/2002 12:33'! restoreStateOf: aStream with: aConverterState state _ aConverterState copy. aStream position: state streamPosition. ! ! !CompoundTextConverter methodsFor: 'private' stamp: 'yo 11/4/2002 13:52'! saveStateOf: aStream | inst | inst _ state clone. inst streamPosition: aStream position. ^ inst. ! ! !CompoundTextConverter methodsFor: 'private' stamp: 'yo 8/4/2003 12:02'! toUnicode: aChar ^ MultiCharacter leadingChar: UnicodeJapanese leadingChar code: aChar asUnicode. ! ! !CompoundTextConverter methodsFor: 'accessing' stamp: 'yo 8/23/2002 22:39'! accepts: aSymbol ^ acceptingEncodings includes: aSymbol. ! ! !CompoundTextConverter methodsFor: 'accessing' stamp: 'yo 9/16/2002 21:41'! currentCharSize ^ state charSize. ! ! !CompoundTextConverter methodsFor: 'initialize-release' stamp: 'yo 8/13/2003 11:45'! initialize state _ CompoundTextConverterState g0Size: 1 g1Size: 1 g0Leading: 0 g1Leading: 0 charSize: 1 streamPosition: 0. acceptingEncodings _ #(ascii iso88591 jisx0208 gb2312 ksc5601 ksx1001 ) copy. ! ! !CompoundTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 8/19/2002 16:47'! errorMalformedInput ^ self error: 'malformed input'. ! ! !CompoundTextConverter methodsFor: 'as yet unclassified' stamp: 'yo 8/19/2002 16:48'! errorUnsupported ^ self error: 'unsupported encoding'. ! ! !CompoundTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 10/24/2002 14:16'! encodingNames ^ #('iso-2022-jp' 'x-ctext') copy ! ! !CompoundTextConverter class methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 22:56'! new ^ (super new) initialize; yourself. ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:30'! charSize ^ charSize ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'! charSize: s charSize _ s. ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:29'! g0Leading ^ g0Leading ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'! g0Leading: l g0Leading _ l. ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:29'! g0Size ^ g0Size ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'! g0Size: s g0Size _ s. ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 14:37'! g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos g0Size _ g0. g1Size _ g1. g0Leading _ g0l. g1Leading _ g1l. charSize _ cSize. streamPosition _ pos. ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:30'! g1Leading ^ g1Leading ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'! g1Leading: l g1Leading _ l. ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:29'! g1Size ^ g1Size ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:41'! g1Size: s g1Size _ s. ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 11/4/2002 12:31'! printOn: aStream aStream nextPut: $(; nextPutAll: g0Size printString; space; nextPutAll: g1Size printString; space; nextPutAll: g0Leading printString; space; nextPutAll: g1Leading printString; space; nextPutAll: charSize printString; space; nextPutAll: streamPosition printString. aStream nextPut: $). ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 8/23/2002 21:30'! streamPosition ^ streamPosition ! ! !CompoundTextConverterState methodsFor: 'as yet unclassified' stamp: 'yo 9/16/2002 20:40'! streamPosition: pos streamPosition _ pos. ! ! !CompoundTextConverterState class methodsFor: 'as yet unclassified' stamp: 'yo 8/19/2002 17:04'! g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos ^ (self new) g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos ; yourself. ! ! !CompoundTileMorph methodsFor: 'dropping/grabbing' stamp: 'sw 12/13/2001 16:42'! wantsDroppedMorph: aMorph event: evt "Removing this method entirely would be okay someday" ^ false " ^ (aMorph isKindOf: TileMorph) or: [(aMorph isKindOf: ScriptEditorMorph) or: [(aMorph isKindOf: CompoundTileMorph) or: [aMorph isKindOf: CommandTilesMorph]]]" ! ! !CompoundTileMorph methodsFor: 'e-toy support' stamp: 'ar 2/7/2001 17:57'! isTileEditor "Yes I am" ^true! ! !CompoundTileMorph methodsFor: 'event handling' stamp: 'tk 2/28/2001 21:22'! handlesMouseDown: evt ^true! ! !CompoundTileMorph methodsFor: 'event handling' stamp: 'tk 2/28/2001 21:25'! mouseDown: evt "Pretend we picked up the tile and then put it down for a trial positioning." "The essence of ScriptEditor mouseEnter:" | ed ss guyToTake | " self isPartsDonor ifTrue:[ dup _ self duplicate. evt hand attachMorph: dup. dup position: evt position. ^self]. submorphs isEmpty never true ifTrue: [^ self]. " (ed _ self enclosingEditor) ifNil: [^evt hand grabMorph: self]. guyToTake _ self. owner class == TilePadMorph ifTrue: ["picking me out of another phrase" (ss _ submorphs first) class == TilePadMorph ifTrue: [ss _ ss submorphs first]. guyToTake _ ss veryDeepCopy]. evt hand grabMorph: guyToTake. ed startStepping. ed mouseEnterDragging: evt. ed setProperty: #justPickedUpPhrase toValue: true. ! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:21'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:21'! defaultColor "answer the default color/fill style for the receiver" ^ Color orange muchLighter! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'sw 1/16/2002 20:03'! initialize | r | super initialize. self color: Color orange muchLighter. self borderWidth: 1. self layoutInset: 2. self listDirection: #topToBottom. self hResizing: #spaceFill; vResizing: #shrinkWrap; cellInset: (0 @ 1); minCellSize: (200@14). r _ AlignmentMorph newRow color: color; layoutInset: 0. r setProperty: #demandsBoolean toValue: true. r addMorphBack: (Morph new color: color; extent: 2@5). "spacer" r addMorphBack: (StringMorph new contents: 'Test'). r addMorphBack: (Morph new color: color; extent: 5@5). "spacer" r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0; layoutInset: 1). testPart color: Color transparent. testPart hResizing: #spaceFill. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 30@5). "spacer" r addMorphBack: (StringMorph new contents: 'Yes'). r addMorphBack: (Morph new color: color; extent: 5@5). "spacer" r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). yesPart hResizing: #spaceFill. yesPart color: Color transparent. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 35@5). "spacer" r addMorphBack: (StringMorph new contents: 'No'). r addMorphBack: (Morph new color: color; extent: 5@5). "spacer" r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). noPart hResizing: #spaceFill. noPart color: Color transparent. self addMorphBack: r. self bounds: self fullBounds! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:22' prior: 35306971! initialize "initialize the state of the receiver" | r | super initialize. "" self layoutInset: 2. self listDirection: #topToBottom. self hResizing: #spaceFill; vResizing: #shrinkWrap; cellInset: 0 @ 1; minCellSize: 200 @ 14. r _ AlignmentMorph newRow color: color; layoutInset: 0. r setProperty: #demandsBoolean toValue: true. r addMorphBack: (Morph new color: color; extent: 2 @ 5). "spacer" r addMorphBack: (StringMorph new contents: 'Test'). r addMorphBack: (Morph new color: color; extent: 5 @ 5). "spacer" r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0; layoutInset: 1). testPart color: Color transparent. testPart hResizing: #spaceFill. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 30 @ 5). "spacer" r addMorphBack: (StringMorph new contents: 'Yes'). r addMorphBack: (Morph new color: color; extent: 5 @ 5). "spacer" r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). yesPart hResizing: #spaceFill. yesPart color: Color transparent. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 35 @ 5). "spacer" r addMorphBack: (StringMorph new contents: 'No'). r addMorphBack: (Morph new color: color; extent: 5 @ 5). "spacer" r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). noPart hResizing: #spaceFill. noPart color: Color transparent. self addMorphBack: r. self bounds: self fullBounds! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 10/8/2003 18:51' prior: 35308646! initialize "initialize the state of the receiver" | r | super initialize. "" self layoutInset: 2. self listDirection: #topToBottom. self hResizing: #spaceFill; vResizing: #shrinkWrap; cellInset: 0 @ 1; minCellSize: 200 @ 14. r _ AlignmentMorph newRow color: color; layoutInset: 0. r setProperty: #demandsBoolean toValue: true. r addMorphBack: (Morph new color: color; extent: 2 @ 5). "spacer" r addMorphBack: (StringMorph new contents: 'Test' translated). r addMorphBack: (Morph new color: color; extent: 5 @ 5). "spacer" r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0; layoutInset: 1). testPart color: Color transparent. testPart hResizing: #spaceFill. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 30 @ 5). "spacer" r addMorphBack: (StringMorph new contents: 'Yes' translated). r addMorphBack: (Morph new color: color; extent: 5 @ 5). "spacer" r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). yesPart hResizing: #spaceFill. yesPart color: Color transparent. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 35 @ 5). "spacer" r addMorphBack: (StringMorph new contents: 'No' translated). r addMorphBack: (Morph new color: color; extent: 5 @ 5). "spacer" r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). noPart hResizing: #spaceFill. noPart color: Color transparent. self addMorphBack: r. self bounds: self fullBounds! ! !CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'ar 2/6/2001 22:07'! recompileScript "Pertains only when the test is outside a script?!!" ! ! !CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 9/27/2001 17:27'! resultType "Answer the result type of the receiver" ^ #Command! ! !CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'tk 2/15/2001 16:36'! tileRows "Answer a list of tile rows, in this case just one though it's compound" ^ Array with: (Array with: self veryDeepCopy)! ! !CompoundTileMorph methodsFor: 'testing' stamp: 'yo 11/4/2002 20:33'! isTileScriptingElement ^ true ! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/1/2003 22:36'! binary self error: 'Compressed source files are ascii to the user (though binary underneath)'! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/1/2003 22:36'! close self flush. segmentFile close! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 17:54'! openOn: aFile "Open the receiver." segmentFile _ aFile. segmentFile binary. segmentFile size > 0 ifTrue: [self readHeaderInfo. "If file exists, then read the parameters"] ifFalse: [self segmentSize: 20000 maxSize: 34000000. "Otherwise write default values"]! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 10:13'! openReadOnly segmentFile openReadOnly! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/5/2003 22:41'! readHeaderInfo | valid a b | segmentFile position: 0. segmentSize _ segmentFile nextNumber: 4. nSegments _ segmentFile nextNumber: 4. endOfFile _ segmentFile nextNumber: 4. segmentFile size < (nSegments+1 + 3 * 4) ifTrue: "Check for reasonable segment info" [self error: 'This file is not in valid compressed source format']. segmentTable _ (1 to: nSegments+1) collect: [:x | segmentFile nextNumber: 4]. segmentTable first ~= self firstSegmentLoc ifTrue: [self error: 'This file is not in valid compressed source format']. valid _ true. 1 to: nSegments do: "Check that segment offsets are ascending" [:i | a _ segmentTable at: i. b _ segmentTable at: i+1. (a = 0 and: [b ~= 0]) ifTrue: [valid _ false]. (a ~= 0 and: [b ~= 0]) ifTrue: [b <= a ifTrue: [valid _ false]]]. valid ifFalse: [self error: 'This file is not in valid compressed source format']. dirty _ false. self position: 0.! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 10:09'! readOnlyCopy ^ self class on: segmentFile readOnlyCopy! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/2/2003 23:07'! test "FileDirectory default deleteFileNamed: 'test.stc'. (CompressedSourceStream on: (FileStream newFileNamed: 'test.stc')) fileOutChanges" "FileDirectory default deleteFileNamed: 'test2.stc'. ((CompressedSourceStream on: (FileStream newFileNamed: 'test2.stc')) segmentSize: 100 nSegments: 1000) fileOutChanges" "FileDirectory default deleteFileNamed: 'test3.st'. (FileStream newFileNamed: 'test3.st') fileOutChanges" "(CompressedSourceStream on: (FileStream oldFileNamed: 'test.stc')) contentsOfEntireFile" ! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/3/2003 00:41'! atEnd position >= readLimit ifFalse: [^ false]. "more in segment" ^ self position >= endOfFile "more in file"! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 22:48'! contentsOfEntireFile | contents | self position: 0. contents _ self next: self size. self close. ^ contents! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 19:50'! flush dirty ifTrue: ["Write buffer, compressed, to file, and also write the segment offset and eof" self writeSegment].! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/20/2003 12:03'! next position >= readLimit ifTrue: [^ (self next: 1) at: 1] ifFalse: [^ collection at: (position _ position + 1)]! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 11:45'! next: n | str | n <= (readLimit - position) ifTrue: ["All characters are available in buffer" str _ collection copyFrom: position + 1 to: position + n. position _ position + n. ^ str]. "Read limit could be segment boundary or real end of file" (readLimit + self segmentOffset) = endOfFile ifTrue: ["Real end of file -- just return what's available" ^ self next: readLimit - position]. "Read rest of segment. Then (after positioning) read what remains" str _ self next: readLimit - position. self position: self position. ^ str , (self next: n - str size) ! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 11:27'! nextPut: char "Slow, but we don't often write, and then not a lot" self nextPutAll: char asString. ^ char! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 12:06'! nextPutAll: str | n nInSeg | n _ str size. n <= (writeLimit - position) ifTrue: ["All characters fit in buffer" collection replaceFrom: position + 1 to: position + n with: str. dirty _ true. position _ position + n. readLimit _ readLimit max: position. endOfFile _ endOfFile max: self position. ^ str]. "Write what fits in segment. Then (after positioning) write what remains" nInSeg _ writeLimit - position. nInSeg = 0 ifTrue: [self position: self position. self nextPutAll: str] ifFalse: [self nextPutAll: (str first: nInSeg). self position: self position. self nextPutAll: (str allButFirst: nInSeg)] ! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 09:27'! position ^ position + self segmentOffset! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 22:24'! position: newPosition | compressedBuffer newSegmentIndex | newPosition > endOfFile ifTrue: [self error: 'Attempt to position beyond the end of file']. newSegmentIndex _ (newPosition // segmentSize) + 1. newSegmentIndex ~= segmentIndex ifTrue: [self flush. segmentIndex _ newSegmentIndex. newSegmentIndex > nSegments ifTrue: [self error: 'file size limit exceeded']. segmentFile position: (segmentTable at: segmentIndex). (segmentTable at: segmentIndex+1) = 0 ifTrue: [newPosition ~= endOfFile ifTrue: [self error: 'Internal logic error']. collection size = segmentSize ifFalse: [self error: 'Internal logic error']. "just leave garbage beyond end of file"] ifFalse: [compressedBuffer _ segmentFile next: ((segmentTable at: segmentIndex+1) - (segmentTable at: segmentIndex)). collection _ (GZipReadStream on: compressedBuffer) upToEnd asString]. readLimit _ collection size min: endOfFile - self segmentOffset]. position _ newPosition \\ segmentSize. ! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 11:41'! size ^ endOfFile ifNil: [0]! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/20/2003 12:45'! fileID "Only needed for OSProcess stuff" ^ segmentFile fileID ! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/2/2003 09:35'! firstSegmentLoc "First segment follows 3 header words and segment table" ^ (3 + nSegments+1) * 4! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/2/2003 09:24'! segmentOffset ^ segmentIndex - 1 * segmentSize! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/5/2003 22:41'! segmentSize: segSize maxSize: maxSize "Note that this method can be called after the initial open, provided that no writing has yet taken place. This is how to override the default segmentation." self size = 0 ifFalse: [self error: 'Cannot set parameters after the first write']. segmentFile position: 0. segmentFile nextNumber: 4 put: (segmentSize _ segSize). segmentFile nextNumber: 4 put: (nSegments _ maxSize // segSize + 2). segmentFile nextNumber: 4 put: (endOfFile _ 0). segmentTable _ Array new: nSegments+1 withAll: 0. segmentTable at: 1 put: self firstSegmentLoc. "Loc of first segment, always." segmentTable do: [:i | segmentFile nextNumber: 4 put: i]. segmentIndex _ 1. collection _ String new: segmentSize. writeLimit _ segmentSize. readLimit _ 0. position _ 0. endOfFile _ 0. self writeSegment. ! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/5/2003 22:42'! writeSegment "The current segment must be the last in the file." | compressedSegment | segmentFile position: (segmentTable at: segmentIndex). compressedSegment _ ByteArray streamContents: [:strm | (GZipWriteStream on: strm) nextPutAll: collection asByteArray; close]. segmentFile nextPutAll: compressedSegment. segmentTable at: segmentIndex + 1 put: segmentFile position. segmentFile position: 2 * 4. segmentFile nextNumber: 4 put: endOfFile. segmentFile position: (segmentIndex + 3) * 4. segmentFile nextNumber: 4 put: (segmentTable at: segmentIndex + 1). dirty _ false! ! !CompressedSourceStream commentStamp: 'di 11/3/2003 17:58' prior: 0! I implement a file format that compresses segment by segment to allow incremental writing and browsing. Note that the file can only be written at the end. Structure: segmentFile The actual compressed file. segmentSize This is the quantum of compression. The virtual file is sliced up into segments of this size. nSegments The maximum number of segments to which this file can be grown. endOfFile The user's endOfFile pointer. segmentTable When a file is open, this table holds the physical file positions of the compressed segments. segmentIndex Index of the most recently accessed segment. Inherited from ReadWriteStream... collection The segment buffer, uncompressed position This is the position *local* to the current segment buffer readLimit ReadLimit for the current buffer writeLimit WriteLimit for the current buffer Great care must be exercised to distinguish between the position relative to the segment buffer and the full file position (and, or course, the segment file position ;-). The implementation defaults to a buffer size of 20k, and a max file size of 34MB (conveniently chosen to be greater than the current 33MB limit of source code pointers). The format of the file is as follows: segmentSize 4 bytes nSegments 4 bytes endOfFile 4 bytes segmentTable 4 bytes * (nSegments+1) beginning of first compressed segment It is possible to override the default allocation by sending the message #segmentSize:nSegments: immediately after opening a new file for writing, as follows: bigFile _ (CompressedSourceStream on: (FileStream newFileNamed: 'biggy.stc')) segmentSize: 50000 maxSize: 200000000 The difference between segment table entries reveals the size of each compressed segment. When a file is being written, it may lack the final segment, but any flush, position:, or close will force a dirty segment to be written.! !CompressedSourceStream class methodsFor: 'as yet unclassified' stamp: 'di 11/1/2003 22:58'! on: aFile ^ self basicNew openOn: aFile! ! !ConnectionClosed commentStamp: 'mir 5/12/2003 18:12' prior: 0! Signals a prematurely closed connection. ! !ConnectionQueue methodsFor: 'private' stamp: 'mir 5/15/2003 18:27' prior: 19724582! listenLoop "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." | newConnection | socket _ Socket newTCP. "We'll accept four simultanous connections at the same time" socket listenOn: portNumber backlogSize: 4. "If the listener is not valid then the we cannot use the BSD style accept() mechanism." socket isValid ifFalse: [^self oldStyleListenLoop]. [true] whileTrue: [ socket isValid ifFalse: [ "socket has stopped listening for some reason" socket destroy. (Delay forMilliseconds: 10) wait. ^self listenLoop ]. [newConnection _ socket waitForAcceptFor: 10] on: ConnectionTimedOut do: [:ex | newConnection _ nil]. newConnection ifNotNil: [accessSema critical: [connections addLast: newConnection]]. self pruneStaleConnections]. ! ! !ConnectionQueue methodsFor: 'private' stamp: 'mir 5/15/2003 18:28' prior: 19726259! oldStyleListenLoop "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." [true] whileTrue: [ ((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [ "try to create a new socket for listening" socket _ Socket createIfFail: [nil]]. socket == nil ifTrue: [(Delay forMilliseconds: 100) wait] ifFalse: [ socket isUnconnected ifTrue: [socket listenOn: portNumber]. [socket waitForConnectionFor: 10] on: ConnectionTimedOut do: [:ex | socket isConnected ifTrue: [ "connection established" accessSema critical: [connections addLast: socket]. socket _ nil] ifFalse: [ socket isWaitingForConnection ifFalse: [socket destroy. socket _ nil]]]]. "broken socket; start over" self pruneStaleConnections]. ! ! !ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'! host ^ host! ! !ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:39'! host: addressOrHostName port: portNumber host _ addressOrHostName. port _ portNumber! ! !ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'! port ^ port! ! !ConnectionRefused commentStamp: 'mir 5/12/2003 18:14' prior: 0! Signals that a connection to the specified host and port was refused. host host which refused the connection port prot to which the connection was refused ! !ConnectionRefused class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:39'! host: addressOrHostName port: portNumber ^ self new host: addressOrHostName port: portNumber! ! !ConnectionTimedOut commentStamp: 'mir 5/12/2003 18:14' prior: 0! Signals that a connection attempt timed out. ! !ContextPart methodsFor: 'accessing' stamp: 'ajh 2/9/2003 00:21'! methodNode | selector methodClass | selector _ self receiver class selectorAtMethod: self method setClass: [:mclass | methodClass _ mclass]. ^ self method methodNodeDecompileClass: methodClass selector: selector! ! !ContextPart methodsFor: 'accessing' stamp: 'nk 2/20/2004 16:50'! methodNodeFormattedAndDecorated: decorate "Answer a method node made from pretty-printed (and colorized, if decorate is true) source text." | selector methodClass | selector _ self receiver class selectorAtMethod: self method setClass: [:mclass | methodClass _ mclass]. ^ self method methodNodeFormattedDecompileClass: methodClass selector: selector decorate: decorate! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'hmm 7/30/2001 20:40'! jump: distance if: condition "Simulate the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." | bool | bool _ self pop. (bool == true or: [bool == false]) ifFalse: [ ^self send: #mustBeBoolean to: bool with: #() super: false]. (bool eqv: condition) ifTrue: [self jump: distance]! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 7/6/2003 20:38' prior: 35328071! jump: distance if: condition "Simulate the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." | bool | bool _ self pop. (bool == true or: [bool == false]) ifFalse: [ ^self send: #mustBeBooleanIn: to: bool with: {self} super: false]. (bool eqv: condition) ifTrue: [self jump: distance]! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:35' prior: 19731397! methodReturnConstant: value "Simulate the action of a 'return constant' bytecode whose value is the argument, value. This corresponds to a source expression like '^0'." ^ self return: value from: self home! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:34' prior: 19731666! methodReturnReceiver "Simulate the action of a 'return receiver' bytecode. This corresponds to the source expression '^self'." ^ self return: self receiver from: self home! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:34' prior: 19731900! methodReturnTop "Simulate the action of a 'return top of stack' bytecode. This corresponds to source expressions like '^something'." ^ self return: self pop from: self home! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 23:17'! return: value from: aContext "Return value to aContext's sender. If aContext is not self then do remote return by calling return: from self and resuming until the return is complete. This is done so unwind blocks will be executed in context of self's thread (not thisContext thread which is simulating it)." | topContext here error ctxt | self == aContext ifTrue: [ "Do local return" topContext _ self sender. self singleRelease. topContext ifNotNil: [topContext push: value]. ^ topContext ]. "Activate a remote #return: context" topContext _ self activateReturn: aContext value: value. "Insert ensure: and on:do: under aContext that will halt when reached" here _ thisContext. error _ false. ctxt _ aContext insertSender: (ContextPart contextOn: UnhandledError do: [:ex | error ifTrue: [ex pass] ifFalse: [error _ true. topContext _ thisContext. here jump]]). ctxt _ ctxt insertSender: (ContextPart contextEnsure: [error ifFalse: [topContext _ thisContext. here jump]]). "Execute remote return" topContext jumpTop. "do not add return value when jumping to it" "'here jump' resumes here" topContext push: nil. "since we jump out of the topContext in the blocks above before pushing a block return value" "If no unhandled error was raised, remove ensure: context and step down to sender" error ifFalse: [ topContext _ topContext stepToCallee. topContext == ctxt ifTrue: [^ topContext stepToCallee]. "pop ensure: & return" "topContext must be ContextPart>>#return:, step until it returns" ctxt _ topContext. [ctxt isDead] whileFalse: [topContext _ topContext step]. ]. ^ topContext! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 3/5/2004 03:44' prior: 35329877! return: value from: aSender "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" | newTop ctxt | aSender isDead ifTrue: [ ^ self send: #cannotReturn: to: self with: {value} super: false]. newTop _ aSender sender. ctxt _ self findNextUnwindContextUpTo: newTop. ctxt ifNotNil: [ ^ self send: #aboutToReturn:through: to: self with: {value. ctxt} super: false]. self releaseTo: newTop. newTop ifNotNil: [newTop push: value]. ^ newTop ! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'hmm 7/17/2001 20:52'! send: selector super: superFlag numArgs: numArgs "Simulate the action of bytecodes that send a message with selector, selector. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method. The arguments of the message are found in the top numArgs locations on the stack and the receiver just below them." | receiver arguments answer | arguments _ Array new: numArgs. numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop]. receiver _ self pop. selector == #doPrimitive:method:receiver:args: ifTrue: [answer _ receiver doPrimitive: (arguments at: 1) method: (arguments at: 2) receiver: (arguments at: 3) args: (arguments at: 4). self push: answer. ^self]. QuickStep == self ifTrue: [ QuickStep _ nil. ^self quickSend: selector to: receiver with: arguments super: superFlag]. ^self send: selector to: receiver with: arguments super: superFlag! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 9/25/2001 00:12'! contextStack "Answer an Array of the contexts on the receiver's sender chain." ^self stackOfSize: 100000! ! !ContextPart methodsFor: 'debugger access' stamp: 'sw 7/19/2002 13:04'! errorReportOn: strm "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: Smalltalk platformName asString; nextPutAll: ' - '; nextPutAll: Smalltalk vmVersion asString; cr. strm nextPutAll: 'Image: '; nextPutAll: Smalltalk version asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'; cr. strm cr. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." cnt _ 0. startPos _ strm position. aContext _ self. [aContext == nil] whileFalse: [[(cnt _ cnt + 1) < 5] whileTrue: [aContext printDetails: strm. "variable values" strm cr. aContext _ aContext sender]. strm cr; nextPutAll: '--- The full stack ---'; cr. aContext _ self. cnt _ 0. [aContext == nil] whileFalse: [cnt _ cnt + 1. cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. strm print: aContext; cr. "just class>>selector" strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext _ aContext sender]]! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 8/4/2003 13:20' prior: 35333454! errorReportOn: strm "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: Smalltalk platformName asString; nextPutAll: ' - '; nextPutAll: Smalltalk vmVersion asString; cr. strm nextPutAll: 'Image: '; nextPutAll: Smalltalk version asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'; cr. strm cr. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." cnt _ 0. startPos _ strm position. aContext _ self. [aContext notNil and: [(cnt _ cnt + 1) < 5]] whileTrue: [aContext printDetails: strm. "variable values" strm cr. aContext _ aContext sender]. strm cr; nextPutAll: '--- The full stack ---'; cr. aContext _ self. cnt _ 0. [aContext == nil] whileFalse: [cnt _ cnt + 1. cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. strm print: aContext; cr. "just class>>selector" strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext _ aContext sender]. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'md 10/28/2003 10:34' prior: 35335093! errorReportOn: strm "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: Smalltalk platformName asString; nextPutAll: ' - '; nextPutAll: Smalltalk vmVersion asString; cr. strm nextPutAll: 'Image: '; nextPutAll: SystemVersion current version asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'; cr. strm cr. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." cnt _ 0. startPos _ strm position. aContext _ self. [aContext notNil and: [(cnt _ cnt + 1) < 5]] whileTrue: [aContext printDetails: strm. "variable values" strm cr. aContext _ aContext sender]. strm cr; nextPutAll: '--- The full stack ---'; cr. aContext _ self. cnt _ 0. [aContext == nil] whileFalse: [cnt _ cnt + 1. cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. strm print: aContext; cr. "just class>>selector" strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext _ aContext sender]. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'md 12/12/2003 17:13' prior: 35336715! errorReportOn: strm "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: SmalltalkImage current platformName asString; nextPutAll: ' - '; nextPutAll: SmalltalkImage current asString; cr. strm nextPutAll: 'Image: '; nextPutAll: SystemVersion current version asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'; cr. strm cr. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." cnt _ 0. startPos _ strm position. aContext _ self. [aContext notNil and: [(cnt _ cnt + 1) < 5]] whileTrue: [aContext printDetails: strm. "variable values" strm cr. aContext _ aContext sender]. strm cr; nextPutAll: '--- The full stack ---'; cr. aContext _ self. cnt _ 0. [aContext == nil] whileFalse: [cnt _ cnt + 1. cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. strm print: aContext; cr. "just class>>selector" strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext _ aContext sender]. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'sw 3/4/2004 00:27' prior: 35338350! errorReportOn: strm "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: SmalltalkImage current platformName asString; nextPutAll: ' - '; nextPutAll: SmalltalkImage current asString; cr. strm nextPutAll: 'Image: '; nextPutAll: SystemVersion current version asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'; cr. strm cr. SecurityManager default printStateOn: strm. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." cnt _ 0. startPos _ strm position. aContext _ self. [aContext notNil and: [(cnt _ cnt + 1) < 5]] whileTrue: [aContext printDetails: strm. "variable values" strm cr. aContext _ aContext sender]. strm cr; nextPutAll: '--- The full stack ---'; cr. aContext _ self. cnt _ 0. [aContext == nil] whileFalse: [cnt _ cnt + 1. cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. strm print: aContext; cr. "just class>>selector" strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext _ aContext sender]. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 9/7/2002 21:15'! methodSelector "Answer the selector of the method that created the receiver." ^self receiver class selectorAtMethod: self method setClass: [:ignored]! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 1/24/2003 00:03' prior: 19738034! singleRelease "Remove information from the receiver in order to break circularities." stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]]. sender _ nil. pc _ nil. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 2/9/2003 12:25' prior: 19739954! tempNames "Answer an OrderedCollection of the names of the receiver's temporary variables, which are strings." ^ self methodNode tempNames! ! !ContextPart methodsFor: 'debugger access' stamp: 'tk 10/19/2001 10:20'! tempsAndValuesLimitedTo: sizeLimit indent: indent "Return a string of the temporary variabls and their current values" | aStream | aStream _ WriteStream on: (String new: 100). self tempNames doWithIndex: [:title :index | indent timesRepeat: [aStream tab]. aStream nextPutAll: title; nextPut: $:; space; tab. aStream nextPutAll: ((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)). aStream cr]. ^aStream contents! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 01:41'! jump "Abandon thisContext thread and execute self instead. You probably should save thisContext's sender before calling this so you can jump back to it." thisContext privSender: self. ^ nil! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 3/25/2004 00:07' prior: 35343009! jump "Abandon thisContext and resume self instead (using the same current process). You may want to save thisContext's sender before calling this so you can jump back to it. Self MUST BE a top context (ie. a suspended context or a abandoned context that was jumped out of). A top context already has its return value on its stack (see Interpreter>>primitiveSuspend and other suspending primitives). thisContext's sender is converted to a top context (by pushing a nil return value on its stack) so it can be jump back to." | top | "Make abandoned context a top context (has return value (nil)) so it can be jumped back to" thisContext sender push: nil. "Pop self return value then return it to self (since we jump to self by returning to it)" stackp = 0 ifTrue: [self stepToSendOrReturn]. stackp = 0 ifTrue: [self push: nil]. "must be quick return self/constant" top _ self pop. thisContext privSender: self. ^ top! ! !ContextPart methodsFor: 'controlling' stamp: 'hmm 7/17/2001 20:57'! quickSend: selector to: receiver with: arguments super: superFlag "Send the given selector with arguments in an environment which closely resembles the non-simulating environment, with an interjected unwind-protected block to catch nonlocal returns. Attention: don't get lost!!" | oldSender contextToReturnTo result lookupClass | contextToReturnTo _ self. lookupClass _ superFlag ifTrue: [(self method literalAt: self method numLiterals) value superclass] ifFalse: [receiver class]. [oldSender _ thisContext sender swapSender: self. result _ receiver perform: selector withArguments: arguments inSuperclass: lookupClass. thisContext sender swapSender: oldSender] ifCurtailed: [ contextToReturnTo _ thisContext sender receiver. "The block context returning nonlocally" contextToReturnTo jump: -1. "skip to front of return bytecode causing this unwind" contextToReturnTo nextByte = 16r7C ifTrue: [ "If it was a returnTop, push the value to be returned. Otherwise the value is implicit in the bytecode" contextToReturnTo push: (thisContext sender tempAt: 1)]. thisContext swapSender: thisContext home sender. "Make this block return to the method's sender" contextToReturnTo]. contextToReturnTo push: result. ^contextToReturnTo! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 2/1/2003 12:39'! restart "Roll back thisContext to self and resume from beginning. Execute unwind blocks when rolling back. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: nil to: self]. self privRefresh. [ ctxt _ thisContext findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. thisContext terminateTo: ctxt sender. unwindBlock value. ]. thisContext terminateTo: self. self jumpTop. ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32' prior: 35345634! restart "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: nil to: self]. self privRefresh. ctxt _ thisContext. [ ctxt _ ctxt findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. unwindBlock ifNotNil: [ ctxt tempAt: 1 put: nil. thisContext terminateTo: ctxt. unwindBlock value]. ]. thisContext terminateTo: self. self jump. ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 6/27/2003 22:17'! resume "Roll back thisContext to self and resume. Execute unwind blocks when rolling back. ASSUMES self is a sender of thisContext" self resume: nil! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 6/27/2003 22:16'! resume: value "Roll back thisContext to self and resume with value as result of last send. Execute unwind blocks when rolling back. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: value to: self]. [ ctxt _ thisContext findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. thisContext terminateTo: ctxt sender. unwindBlock value. ]. thisContext terminateTo: self. ^ value ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32' prior: 35347036! resume: value "Unwind thisContext to self and resume with value as result of last send. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: value to: self]. ctxt _ thisContext. [ ctxt _ ctxt findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. unwindBlock ifNotNil: [ ctxt tempAt: 1 put: nil. thisContext terminateTo: ctxt. unwindBlock value]. ]. thisContext terminateTo: self. ^ value ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/21/2003 19:27'! return "Unwind until my sender is on top" self return: self receiver! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 2/1/2003 12:38'! return: value "Roll back thisContext to self and return value to self's sender. Execute any unwind blocks on the way. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | (sender isNil or: [sender isDead]) ifTrue: [self cannotReturn: value to: sender]. [ ctxt _ thisContext findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. thisContext terminateTo: ctxt sender. unwindBlock value. ]. thisContext terminateTo: self sender. ^ value! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 3/5/2004 02:37' prior: 35348362! return: value "Roll back thisContext to self and return value to self's sender. Execute any unwind blocks on the way. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | (sender isNil or: [sender isDead]) ifTrue: [self cannotReturn: value to: sender]. [ ctxt _ thisContext findNextUnwindContextUpTo: self sender. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. thisContext terminateTo: ctxt sender. unwindBlock value. ]. thisContext terminateTo: self sender. ^ value! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:27' prior: 35348948! return: value "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext" sender ifNil: [self cannotReturn: value to: sender]. sender resume: value! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 15:30' prior: 19742282! return: value to: sendr "Simulate the return of value to sendr." self releaseTo: sendr. sendr ifNil: [^ nil]. ^ sendr push: value! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 3/5/2004 02:00'! runUntilErrorOrReturnFrom: aSender "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." | error ctxt here topContext | here _ thisContext. "Insert ensure and exception handler contexts under aSender" error _ nil. ctxt _ aSender insertSender: (ContextPart contextOn: UnhandledError do: [:ex | error ifNil: [ error _ ex exception. topContext _ thisContext. ex resumeUnchecked: here jump] ifNotNil: [ex pass] ]). ctxt _ ctxt insertSender: (ContextPart contextEnsure: [error ifNil: [ topContext _ thisContext. here jump] ]). self jumpTop. "Control jumps to self" "Control resumes here once above ensure block or exception handler is executed" topContext push: nil. "top context needs return value" error ifNil: [ "No error was raised, remove ensure context and step down to sender" topContext _ topContext stepToCallee. "pop ensure block context" topContext == ctxt ifTrue: [^ {topContext stepToCallee. nil}]. "pop ensure context & return" "ensure block must have been executed as a result of remote returning past it, so topContext must be ContextPart>>#return:" topContext method == ContextPart theReturnMethod ifFalse: [ topContext halt: 'Error in control assumptions'. ^ {topContext.nil}]. "Allow remote return to complete by running until the home context returns" ^ topContext runUntilErrorOrReturnFrom: topContext receiver ] ifNotNil: [ "Error was raised, remove inserted above contexts then return signaler context" aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" ^ {topContext. error} ]. ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:20' prior: 35350080! runUntilErrorOrReturnFrom: aSender "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." | error ctxt here topContext | here _ thisContext. "Insert ensure and exception handler contexts under aSender" error _ nil. ctxt _ aSender insertSender: (ContextPart contextOn: UnhandledError do: [:ex | error ifNil: [ error _ ex exception. topContext _ thisContext. ex resumeUnchecked: here jump] ifNotNil: [ex pass] ]). ctxt _ ctxt insertSender: (ContextPart contextEnsure: [error ifNil: [ topContext _ thisContext. here jump] ]). self jump. "Control jumps to self" "Control resumes here once above ensure block or exception handler is executed" ^ error ifNil: [ "No error was raised, remove ensure context by stepping until popped" [ctxt isDead] whileFalse: [topContext _ topContext stepToCallee]. {topContext. nil} ] ifNotNil: [ "Error was raised, remove inserted above contexts then return signaler context" aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" {topContext. error} ]. ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 00:56' prior: 19743558! terminate "Make myself unresumable." sender _ nil. pc _ nil. ! ! !ContextPart methodsFor: 'controlling' stamp: 'ar 3/6/2001 14:26'! terminateTo: previousContext "Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender." | currentContext sendingContext | (self hasSender: previousContext) ifTrue: [ currentContext _ sender. [currentContext == previousContext] whileFalse: [ sendingContext _ currentContext sender. currentContext terminate. currentContext _ sendingContext]]. sender _ previousContext! ! !ContextPart methodsFor: 'printing' stamp: 'tk 10/19/2001 11:24'! printDetails: strm "Put my class>>selector and arguments and temporaries on the stream. Protect against errors during printing." | str | self printOn: strm. strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. str _ [self tempsAndValuesLimitedTo: 80 indent: 2] ifError: [:err :rcvr | '<>']. strm nextPutAll: str. strm peekLast == Character cr ifFalse: [strm cr].! ! !ContextPart methodsFor: 'printing' stamp: 'ajh 3/17/2003 09:25' prior: 19744328! printOn: aStream | selector class mclass | self method == nil ifTrue: [^ super printOn: aStream]. selector _ (class _ self receiver class) selectorAtMethod: self method setClass: [:c | mclass _ c]. selector == #? ifTrue: [aStream nextPut: $?; print: self method who. ^self]. aStream nextPutAll: class name. mclass == class ifFalse: [aStream nextPut: $(. aStream nextPutAll: mclass name. aStream nextPut: $)]. aStream nextPutAll: '>>'. aStream nextPutAll: selector. selector = #doesNotUnderstand: ifTrue: [ aStream space. (self tempAt: 1) selector printOn: aStream. ]. ! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:43'! completeCallee: aContext "Simulate the execution of bytecodes until a return to the receiver." | ctxt current ctxt1 | ctxt _ aContext. [ctxt == current or: [ctxt hasSender: self]] whileTrue: [current _ ctxt. ctxt1 _ ctxt quickStep. ctxt1 ifNil: [self halt]. ctxt _ ctxt1]. ^self stepToSendOrReturn! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/15/2001 20:58'! quickStep "If the next instruction is a send, just perform it. Otherwise, do a normal step." self willReallySend ifTrue: [QuickStep _ self]. ^self step! ! !ContextPart methodsFor: 'system simulation' stamp: 'ajh 1/24/2003 22:54'! stepToCallee "Step to callee or sender" | ctxt | ctxt _ self. [(ctxt _ ctxt step) == self] whileTrue. ^ ctxt! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:48'! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | ctxt | [self willReallySend | self willReturn | self willStore] whileFalse: [ ctxt _ self step. ctxt == self ifFalse: [self halt. "Caused by mustBeBoolean handling" ^ctxt]]! ! !ContextPart methodsFor: 'system simulation' stamp: 'ajh 7/6/2003 17:59' prior: 35357246! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | ctxt | [self willReallySend or: [self willReturn or: [self willStore or: [self willJumpIfTrue or: [self willJumpIfFalse]]]]] whileFalse: [ ctxt _ self step. ctxt == self ifFalse: [self halt. "Caused by mustBeBoolean handling" ^ctxt]]! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:48' prior: 35357700! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | ctxt | [self willReallySend | self willReturn | self willStore] whileFalse: [ ctxt _ self step. ctxt == self ifFalse: [self halt. "Caused by mustBeBoolean handling" ^ctxt]]! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/24/2003 16:17'! activateReturn: aContext value: value "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender" | meth | meth _ aContext class lookupSelector: #return:. meth primitive = 0 ifFalse: [^ self error: '#return: must not be a primitive']. ^ self activateMethod: meth withArgs: {value} receiver: aContext class: aContext class! ! !ContextPart methodsFor: 'private' stamp: 'ajh 5/20/2004 16:27' prior: 35358645! activateReturn: aContext value: value "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender" ^ self activateMethod: ContextPart theReturnMethod withArgs: {value} receiver: aContext class: aContext class! ! !ContextPart methodsFor: 'private' stamp: 'ajh 6/29/2003 15:32'! cannotReturn: result to: homeContext "The receiver tried to return result to homeContext that no longer exists." ^ BlockCannotReturn new result: result; deadHome: homeContext; signal! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/27/2003 21:18'! copyTo: aContext blocks: dict "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home." | copy | self == aContext ifTrue: [^ nil]. copy _ self copy. dict at: self ifPresent: [:blocks | blocks do: [:b | b privHome: copy]]. self sender ifNotNil: [ copy privSender: (self sender copyTo: aContext blocks: dict)]. ^ copy! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/24/2003 00:50'! cut: aContext "Cut aContext and its senders from my sender chain" | ctxt callee | ctxt _ self. [ctxt == aContext] whileFalse: [ callee _ ctxt. ctxt _ ctxt sender. ctxt ifNil: [aContext ifNotNil: [self error: 'aContext not a sender']]. ]. callee privSender: nil. ! ! !ContextPart methodsFor: 'private' stamp: 'hg 10/2/2001 20:44'! doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message." | value | "Simulation guard" "If successful, push result and return resuming context, else ^ PrimitiveFailToken" (primitiveIndex = 19) ifTrue:[ Debugger openContext: self label:'Code simulation error' contents: nil]. (primitiveIndex = 80 and: [receiver isKindOf: ContextPart]) ifTrue: [^self push: ((BlockContext newForMethod: receiver home method) home: receiver home startpc: pc + 2 nargs: (arguments at: 1))]. (primitiveIndex = 81 and: [receiver isMemberOf: BlockContext]) ifTrue: [^receiver pushArgs: arguments from: self]. primitiveIndex = 83 "afr 9/11/1998 19:50" ifTrue: [^ self send: arguments first to: receiver with: arguments allButFirst super: false]. primitiveIndex = 84 "afr 9/11/1998 19:50" ifTrue: [^ self send: arguments first to: receiver with: (arguments at: 2) super: false]. arguments size > 6 ifTrue: [^ PrimitiveFailToken]. primitiveIndex = 117 ifTrue:[value _ self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] ifFalse:[value _ receiver tryPrimitive: primitiveIndex withArgs: arguments]. value == PrimitiveFailToken ifTrue: [^ PrimitiveFailToken] ifFalse: [^ self push: value]! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/24/2003 23:17'! insertSender: aContext "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." | ctxt | ctxt _ aContext bottom. ctxt privSender: self sender. self privSender: aContext. ^ ctxt! ! !ContextPart methodsFor: 'private' stamp: 'ajh 7/21/2003 09:59' prior: 35362264! insertSender: aContext "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." | ctxt | ctxt _ aContext bottomContext. ctxt privSender: self sender. self privSender: aContext. ^ ctxt! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/23/2003 22:35'! privSender: aContext sender _ aContext! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 01:30'! canHandleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then return true, otherwise forward this message to the next handler context. If none left, return false (see nil>>canHandleSignal:)" ^ (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) or: [self nextHandlerContext canHandleSignal: exception]. ! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 19:27'! findNextHandlerContextStarting "Return the next handler marked context, returning nil if there is none. Search starts with self and proceeds up to nil." | ctx | ctx _ self. [ctx isHandlerContext ifTrue:[^ctx]. (ctx _ ctx sender) == nil ] whileFalse. ^nil! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/23/2000 16:37'! findNextUnwindContextUpTo: aContext "Return the next unwind marked above the receiver, returning nil if there is none. Search proceeds up to but not including aContext." | ctx | ctx _ self. [(ctx _ ctx sender) == nil or: [ctx == aContext]] whileFalse: [ ctx isUnwindContext ifTrue: [^ctx]]. ^nil! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 6/27/2003 20:47'! handleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then execute my handle block (second arg), otherwise forward this message to the next handler context. If none left, execute exception's defaultAction (see nil>>handleSignal:)." | val | (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) ifFalse: [ ^ self nextHandlerContext handleSignal: exception]. exception privHandlerContext: self contextTag. self tempAt: 3 put: false. "disable self while executing handle block" val _ [(self tempAt: 2) valueWithPossibleArgs: {exception}] ensure: [self tempAt: 3 put: true]. self return: val. "return from self if not otherwise directed in handle block" ! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 21:29'! isHandlerContext ^false! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 15:45'! isUnwindContext ^false! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 00:20'! nextHandlerContext ^ self sender findNextHandlerContextStarting! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 21:39'! unwindTo: aContext | ctx returnValue unwindBlock | ctx := self. [(ctx _ ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [ unwindBlock := ctx tempAt: 1. unwindBlock == nil ifFalse: [returnValue := unwindBlock value]]. ^returnValue! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 1/21/2003 17:59' prior: 35365419! unwindTo: aContext | ctx unwindBlock | ctx := self. [(ctx _ ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [ unwindBlock := ctx tempAt: 1. unwindBlock == nil ifFalse: [ ctx tempAt: 1 put: nil. unwindBlock value] ]. ! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 12:35'! blockHome ^ self! ! !ContextPart methodsFor: 'query' stamp: 'ajh 7/21/2003 09:59'! bottomContext "Return the last context (the first context invoked) in my sender chain" ^ self findContextSuchThat: [:c | c sender isNil]! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 18:35'! copyStack ^ self copyTo: nil! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 21:20'! copyTo: aContext "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home. It is best to use BlockClosures instead. They only hold a ContextTag, which will work for all copies of the original home context." ^ self copyTo: aContext blocks: IdentityDictionary new! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:12'! findContextSuchThat: testBlock "Search self and my sender chain for first one that satisfies testBlock. Return nil if none satisfy" | ctxt | ctxt _ self. [ctxt isNil] whileFalse: [ (testBlock value: ctxt) ifTrue: [^ ctxt]. ctxt _ ctxt sender. ]. ^ nil! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 19:42'! hasContext: aContext "Answer whether aContext is me or one of my senders" ^ (self findContextSuchThat: [:c | c == aContext]) notNil! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:04'! isDead "Has self finished" ^ pc isNil! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 22:28'! secondFromBottom "Return the second from bottom of my sender chain" self sender ifNil: [^ nil]. ^ self findContextSuchThat: [:c | c sender sender isNil]! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'! contextEnsure: block "Create an #ensure: context that is ready to return from executing its receiver" | ctxt chain | ctxt _ thisContext. [chain _ thisContext sender cut: ctxt. ctxt jump] ensure: block. "jump above will resume here without unwinding chain" ^ chain! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'! contextOn: exceptionClass do: block "Create an #on:do: context that is ready to return from executing its receiver" | ctxt chain | ctxt _ thisContext. [chain _ thisContext sender cut: ctxt. ctxt jump] on: exceptionClass do: block. "jump above will resume here without unwinding chain" ^ chain! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 3/5/2004 20:50'! theReturnMethod | meth | meth _ self lookupSelector: #return:. meth primitive = 0 ifFalse: [^ self error: '#return: must not be a primitive']. ^ meth! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 5/20/2004 16:25' prior: 35368780! theReturnMethod | meth | meth _ self lookupSelector: #return:. meth primitive = 0 ifFalse: [^ self error: 'expected #return: to not be a primitive']. ^ meth! ! !ContextVariablesInspector methodsFor: 'accessing' stamp: 'ajh 1/31/2003 15:45'! inspect: anObject "Initialize the receiver so that it is inspecting anObject. There is no current selection." self initialize. object _ anObject. selectionIndex _ 0. contents _ ''! ! !ControlManager methodsFor: 'accessing' stamp: 'sw 5/4/2001 23:20'! controllersSatisfying: aBlock "Return a list of scheduled controllers satisfying aBlock" ^ (scheduledControllers ifNil: [^ #()]) select: [:aController | (aBlock value: aController) == true]! ! !ControlManager methodsFor: 'scheduling' stamp: 'ajh 12/31/2001 15:15'! spawnNewProcess self activeController: self screenController! ! !CornerRounder methodsFor: 'all' stamp: 'ar 1/5/2002 17:26'! saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: cornerList | offset corner mask form corners rect | underBits _ Array new: 4. corners _ bounds corners. cornerList do:[:i| mask _ cornerMasks at: i. corner _ corners at: i. i = 1 ifTrue: [offset _ 0@0]. i = 2 ifTrue: [offset _ 0@mask height negated]. i = 3 ifTrue: [offset _ mask extent negated]. i = 4 ifTrue: [offset _ mask width negated@0]. rect _ corner + offset extent: mask extent. (aCanvas isVisible: rect) ifTrue:[ form _ aCanvas contentsOfArea: rect. form copyBits: form boundingBox from: mask at: 0@0 clippingBox: form boundingBox rule: Form and fillColor: nil map: (Bitmap with: 16rFFFFFFFF with: 0). underBits at: i put: form]]. ! ! !CornerRounder methodsFor: 'all' stamp: 'ar 1/5/2002 17:22'! tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: cornerList "This variant has a cornerList argument, to allow some corners to be rounded and others not" | offset corner saveBits fourColors mask outBits shadowColor corners | shadowColor _ aCanvas shadowColor. aCanvas shadowColor: nil. "for tweaking it's essential" w > 0 ifTrue:[ fourColors _ shadowColor ifNil:[aMorph borderStyle colorsAtCorners] ifNotNil:[Array new: 4 withAll: shadowColor]]. mask _ Form extent: cornerMasks first extent depth: aCanvas depth. corners _ bounds corners. cornerList do:[:i| corner _ corners at: i. saveBits _ underBits at: i. saveBits ifNotNil:[ i = 1 ifTrue: [offset _ 0@0]. i = 2 ifTrue: [offset _ 0@saveBits height negated]. i = 3 ifTrue: [offset _ saveBits extent negated]. i = 4 ifTrue: [offset _ saveBits width negated@0]. "Mask out corner area (painting saveBits won't clear if transparent)." mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF). outBits _ aCanvas contentsOfArea: (corner + offset extent: mask extent). mask displayOn: outBits at: 0@0 rule: Form and. "Paint back corner bits." saveBits displayOn: outBits at: 0@0 rule: Form paint. "Paint back corner bits." aCanvas drawImage: outBits at: corner + offset. w > 0 ifTrue:[ "Paint over with border if any" aCanvas stencil: (cornerOverlays at: i) at: corner + offset color: (fourColors at: i)]]]. aCanvas shadowColor: shadowColor. "restore shadow color" ! ! !CornerRounder methodsFor: 'all' stamp: 'kfr 8/4/2003 23:28' prior: 35370750! tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: cornerList "This variant has a cornerList argument, to allow some corners to be rounded and others not" | offset corner saveBits fourColors mask outBits shadowColor corners | shadowColor _ aCanvas shadowColor. aCanvas shadowColor: nil. "for tweaking it's essential" w > 0 ifTrue:[ fourColors _ shadowColor ifNil:[aMorph borderStyle colorsAtCorners] ifNotNil:[Array new: 4 withAll: Color transparent]]. mask _ Form extent: cornerMasks first extent depth: aCanvas depth. corners _ bounds corners. cornerList do:[:i| corner _ corners at: i. saveBits _ underBits at: i. saveBits ifNotNil:[ i = 1 ifTrue: [offset _ 0@0]. i = 2 ifTrue: [offset _ 0@saveBits height negated]. i = 3 ifTrue: [offset _ saveBits extent negated]. i = 4 ifTrue: [offset _ saveBits width negated@0]. "Mask out corner area (painting saveBits won't clear if transparent)." mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF). outBits _ aCanvas contentsOfArea: (corner + offset extent: mask extent). mask displayOn: outBits at: 0@0 rule: Form and. "Paint back corner bits." saveBits displayOn: outBits at: 0@0 rule: Form paint. "Paint back corner bits." aCanvas drawImage: outBits at: corner + offset. w > 0 ifTrue:[ aCanvas stencil: (cornerOverlays at: i) at: corner + offset color: (fourColors at: i)]]]. aCanvas shadowColor: shadowColor. "restore shadow color" ! ! !CornerRounder class methodsFor: 'all' stamp: 'ar 1/5/2002 17:24'! roundCornersOf: aMorph on: aCanvas in: bounds displayBlock: displayBlock borderWidth: w corners: aList | rounder | rounder _ CR0. w = 1 ifTrue: [rounder _ CR1]. w = 2 ifTrue: [rounder _ CR2]. rounder _ rounder copy. rounder saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: aList. displayBlock value. rounder tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: aList! ! !CrLfFileStream commentStamp: 'ls 11/10/2002 13:32' prior: 0! I am the same as a regular file stream, except that when I am in text mode, I will automatically convert line endings between the underlying platform's convention, and Squeak's convention of carriage-return only. The goal is that Squeak text files can be treated as OS text files, and vice versa. In binary mode, I behave identically to a StandardFileStream. To enable CrLfFileStream as the default file stream class for an entire image, modify FileStream class concreteStream . There are two caveats on programming with CrLfFileStream. First, the choice of text mode versus binary mode affects which characters are visible in Squeak, and no longer just affects whether those characters are returned as Character's or as Integer's. Thus the choice of mode needs to be made very carefully, and must be based on intent instead of convenience of representation. The methods asString, asByteArray, asCharacter, and asInteger can be used to convert between character and integer representations. (Arguably, file streams should accept either strings or characters in nextPut: and nextPutAll:, but that is not the case right now.) Second, arithmetic on positions no longer works, because one character that Squeak sees (carriage return) could map to two characters in the underlying file (carriage return plus line feed, on MS Windows and MS DOS). Comparison between positions still works. (This caveat could perhaps be fixed by maintaining a map between Squeak positions and positions in the underlying file, but it is complicated. Consider, for example, updates to the middle of the file. Also, consider that text files are rarely updated in the middle of the file, and that general random access to a text file is rarely very useful. If general random access with specific file counts is desired, then the file is starting to sound like a binary file instead of a text file.) ! ]style[(448 31 1371 6 32)f1,f1LFileStream class concreteStream;,f1,f1i,f1! !CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'sw 5/4/2001 23:22'! showSharedFlaps "Answer whether shared flaps are currently showing (true) or suppressed (false). The CurrentProjectRefactoring circumlocution is in service of making it possible for shared flaps to appear on the edges of an interior subworld, I believe." ^ self xxxCurrent showSharedFlaps! ! !CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'sw 8/11/2001 23:13'! suppressFlapsString "Answer a string characterizing whether flaps are suppressed at the moment or not" ^ self currentFlapsSuppressed ifFalse: ['show shared tabs (F)'] ifTrue: ['show shared tabs (F)']! ! !CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'dgd 8/31/2003 18:06' prior: 35377024! suppressFlapsString "Answer a string characterizing whether flaps are suppressed at the moment or not" ^ (self currentFlapsSuppressed ifTrue: [''] ifFalse: ['']), 'show shared tabs (F)' translated! ! !Cursor methodsFor: 'updating' stamp: 'ls 6/17/2002 12:00'! changed: aParameter "overriden to reinstall the cursor if it is the active cursor, in case the appearance has changed. (Is this used anywhere? Do cursors really change in place these days?)" self == CurrentCursor ifTrue: [self beCursor]. super changed: aParameter! ! !Cursor methodsFor: 'displaying' stamp: 'ls 6/17/2002 11:56'! show "Make the hardware's mouse cursor look like the receiver" Sensor currentCursor: self! ! !Cursor commentStamp: '' prior: 0! I am a Form that is a possible appearance for a mouse cursor. My size is always 16x16, ever since the original implementation on the Alto. There are many examples available in the "current cursor" category of class methods. For example, "Cursor normal" and "Cursor wait". For example: Cursor wait show ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:57'! initBottomLeft BottomLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1111111111111111 2r1111111111111111) offset: 0@-16). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:57'! initBottomRight BottomRightCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r1111111111111111 2r1111111111111111) offset: -16@-16). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 21:02' prior: 19826070! initCrossHair CrossHairCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0111111111111100 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000000000000 2r0) offset: -7@-7). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'di 7/30/2001 10:32'! initMenu MenuCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111100000 2r1000000000100000 2r1010011000100000 2r1000000000100000 2r1101001101100000 2r1111111111100000 2r1000000000100000 2r1011001010100000 2r1000000000100000 2r1010110010100000 2r1000000000100000 2r1010010100100000 2r1000000000100000 2r1111111111100000 0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 21:10' prior: 19827701! initMove MoveCursor _ Cursor extent: 16@16 fromArray: #( 2r1111111111111100 2r1111111111111100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1111111111111100 2r1111111111111100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1111111111111100 2r1111111111111100 0) offset: 0@0. ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 22:55' prior: 19830005! initRead ReadCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000000000000000 2r0001000000001000 2r0010100000010100 2r0100000000100000 2r1111101111100000 2r1000010000100000 2r1000010000100000 2r1011010110100000 2r0111101111000000 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:57'! initResizeLeft ResizeLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000001010000000 2r0000001010000000 2r0000001010000000 2r0000101010010000 2r0001101010011000 2r0011101010011100 2r0111111011111110 2r0011101010011100 2r0001101010011000 2r0000101010010000 2r0000001010000000 2r0000001010000000 2r0000001010000000 2r0000001010000000 2r0000000000000000 ) offset: -7@-7 ) withMask ! ! !Cursor class methodsFor: 'class initialization' stamp: 'dew 2/14/2004 01:24' prior: 35381453! initResizeLeft ResizeLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000001001000000 2r0000001001000000 2r0000001001000000 2r0000101001010000 2r0001101001011000 2r0011101001011100 2r0111111001111110 2r0011101001011100 2r0001101001011000 2r0000101001010000 2r0000001001000000 2r0000001001000000 2r0000001001000000 2r0000001001000000 2r0000000000000000 ) offset: -7@-7 ) withMask ! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:59'! initResizeTop ResizeTopCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000000100000000 2r0000001110000000 2r0000011111000000 2r0000111111100000 2r0000000100000000 2r0111111111111110 2r0000000000000000 2r0111111111111110 2r0000000100000000 2r0000000100000000 2r0000111111100000 2r0000011111000000 2r0000001110000000 2r0000000100000000 2r0000000000000000) offset: -7@-7) withMask! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 4/3/2004 11:46' prior: 35382516! initResizeTop "Cursor initResizeTop" ResizeTopCursor _ (Cursor extent: 16@16 fromArray: #( 2r000000100000000 2r000001110000000 2r000011111000000 2r000111111100000 2r000000100000000 2r111111111111100 2r000000000000000 2r000000000000000 2r111111111111100 2r000000100000000 2r000111111100000 2r000011111000000 2r000001110000000 2r000000100000000 2r000000000000000) offset: -7@-7) withMask! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:59'! initResizeTopLeft ResizeTopLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0111110000010000 2r0111100000100000 2r0111000001000100 2r0110100010001000 2r0100010100010000 2r0000001000100000 2r0000010001000000 2r0000100010000000 2r0001000100100010 2r0010001000010110 2r0000010000001110 2r0000100000011110 2r0000000000111110 2r0000000000000000 2r0000000000000000) offset: -7@-7) withMask! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:00'! initResizeTopRight ResizeTopRightCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000100000111110 2r0000010000011110 2r0010001000001110 2r0001000100010110 2r0000100010100010 2r0000010001000000 2r0000001000100000 2r0000000100010000 2r0100010010001000 2r0110100001000100 2r0111000000100000 2r0111100000010000 2r0111110000000000 2r0000000000000000 2r0000000000000000) offset: -7@-7) withMask.! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:01'! initTopLeft TopLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:02'! initTopRight TopRightCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011) offset: -16@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 21:27' prior: 19831397! initWait WaitCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111100 2r1000000000000100 2r0100000000001000 2r0010000000010000 2r0001110011100000 2r0000111111000000 2r0000011110000000 2r0000011110000000 2r0000100101000000 2r0001000100100000 2r0010000110010000 2r0100001111001000 2r1000111111110100 2r1111111111111100 0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 22:52' prior: 19831877! initWrite WriteCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000011000 2r0000000000111100 2r0000000001001000 2r0000000010010000 2r0000000100100000 2r0000001001000100 2r0000010010000100 2r0000100100001100 2r0001001000010000 2r0010010000010000 2r0111100000001000 2r0101000011111000 2r1110000110000000 2r0111111100000000 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:04' prior: 19832849! initialize "Create all the standard cursors..." self initOrigin. self initRightArrow. self initMenu. self initCorner. self initRead. self initWrite. self initWait. BlankCursor _ Cursor new. self initXeq. self initSquare. self initNormalWithMask. self initCrossHair. self initMarker. self initUp. self initDown. self initMove. self initBottomLeft. self initBottomRight. self initResizeLeft. self initResizeTop. self initResizeTopLeft. self initResizeTopRight. self initTopLeft. self initTopRight. self makeCursorsWithMask. "Cursor initialize" ! ! !Cursor class methodsFor: 'instance creation' stamp: 'ar 8/16/2001 15:52'! resizeForEdge: aSymbol "Cursor resizeForEdge: #top" "Cursor resizeForEdge: #bottomLeft" ^self perform: ('resize', aSymbol first asString asUppercase, (aSymbol copyFrom: 2 to: aSymbol size)) asSymbol.! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13' prior: 19835080! bottomLeft "Cursor bottomLeft showWhile: [Sensor waitButton]" ^BottomLeftCursor ! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13' prior: 19835585! bottomRight "Cursor bottomRight showWhile: [Sensor waitButton]" ^BottomRightCursor ! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:48'! resizeBottom "Cursor resizeBottom showWhile: [Sensor waitButton]" ^self resizeTop! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:46'! resizeBottomLeft "Cursor resizeBottomLeft showWhile: [Sensor waitButton]" ^self resizeTopRight! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! resizeBottomRight "Cursor resizeBottomRight showWhile: [Sensor waitButton]" ^self resizeTopLeft! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:50'! resizeLeft "Cursor resizeLeft showWhile: [Sensor waitButton]" ^(Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000001010000000 2r0000001010000000 2r0000001010000000 2r0000101010010000 2r0001101010011000 2r0011101010011100 2r0111111011111110 2r0011101010011100 2r0001101010011000 2r0000101010010000 2r0000001010000000 2r0000001010000000 2r0000001010000000 2r0000001010000000 2r0000000000000000 ) offset: -7@-7 ) withMask ! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 18:58' prior: 35388418! resizeLeft "Cursor resizeLeft showWhile: [Sensor waitButton]" ^ResizeLeftCursor! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! resizeRight "Cursor resizeRight showWhile: [Sensor waitButton]" ^self resizeLeft! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:49'! resizeTop "Cursor resizeTop showWhile: [Sensor waitButton]" ^(Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000000100000000 2r0000001110000000 2r0000011111000000 2r0000111111100000 2r0000000100000000 2r0111111111111110 2r0000000000000000 2r0111111111111110 2r0000000100000000 2r0000000100000000 2r0000111111100000 2r0000011111000000 2r0000001110000000 2r0000000100000000 2r0000000000000000) offset: -7@-7) withMask! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:19' prior: 35389280! resizeTop "Cursor resizeTop showWhile: [Sensor waitButton]" ^ResizeTopCursor! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 15:58'! resizeTopLeft "Cursor resizeTopLeft showWhile: [Sensor waitButton]" ^ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0111110000010000 2r0111100000100000 2r0111000001000100 2r0110100010001000 2r0100010100010000 2r0000001000100000 2r0000010001000000 2r0000100010000000 2r0001000100100010 2r0010001000010110 2r0000010000001110 2r0000100000011110 2r0000000000111110 2r0000000000000000 2r0000000000000000) offset: -7@-7) withMask! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00' prior: 35389981! resizeTopLeft "Cursor resizeTopLeft showWhile: [Sensor waitButton]" ^ ResizeTopLeftCursor! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 16:00'! resizeTopRight "Cursor resizeTopRight showWhile: [Sensor waitButton]" ^ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000100000111110 2r0000010000011110 2r0010001000001110 2r0001000100010110 2r0000100010100010 2r0000010001000000 2r0000001000100000 2r0000000100010000 2r0100010010001000 2r0110100001000100 2r0111000000100000 2r0111100000010000 2r0111110000000000 2r0000000000000000 2r0000000000000000) offset: -7@-7) withMask.! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00' prior: 35390704! resizeTopRight "Cursor resizeTopRight showWhile: [Sensor waitButton]" ^ResizeTopRightCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:01' prior: 19837773! topLeft "Cursor topLeft showWhile: [Sensor waitButton]" ^ TopLeftCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:02' prior: 19838270! topRight "Cursor topRight showWhile: [Sensor waitButton]" ^ TopRightCursor! ! !Cursor class methodsFor: 'constants' stamp: 'ar 9/26/2001 22:37'! webLink "Return a cursor that can be used for emphasizing web links" "Cursor webLink showWhile: [Sensor waitButton]" ^WebLinkCursor ifNil:[ WebLinkCursor _ (CursorWithMask extent: 16@16 fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 ) offset: -5@0) setMaskForm: (Form extent: 16@16 fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [:bits | bits bitShift: 16]) offset: 0@0)].! ! !CursorWithMask commentStamp: '' prior: 0! A Cursor which additionally has a 16x16 transparency bitmap called a "mask". See the comment of beCursorWithMask: for details on how the mask is treated.! ]style[(97 17 40)f3,f3LCursor beCursorWithMask:;,f3! !CurveMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'! initializeToStandAlone super initializeToStandAlone. self beSmoothCurve. ! ! !CurveMorph class methodsFor: 'instance creation' stamp: 'tk 11/14/2001 17:47'! arrowPrototype | aa | aa _ PolygonMorph vertices: (Array with: 5@40 with: 5@8 with: 35@8 with: 35@40) color: Color black borderWidth: 2 borderColor: Color black. aa beSmoothCurve; makeOpen; makeForwardArrow. "is already open" aa dashedBorder: {10. 10. Color red}. "A dash spec is a 3- or 5-element array with { length of normal border color. length of alternate border color. alternate border color}" aa computeBounds. ^ aa! ! !CurveMorph class methodsFor: 'parts bin' stamp: 'tk 11/16/2001 12:17'! descriptionForPartsBin ^ self partName: 'Curve' categories: #('Graphics' ' Basic 1 ') documentation: 'A smooth wiggly curve, or a curved solid. Shift-click to get handles and move the points.'! ! !CurveMorph class methodsFor: 'parts bin' stamp: 'tk 11/16/2001 12:17'! supplementaryPartsDescriptions ^ {DescriptionForPartsBin formalName: 'Curvy Arrow' categoryList: #(' Basic 1 ' 'Graphics') documentation: 'A curved line with an arrowhead. Shift-click to get handles and move the points.' globalReceiverSymbol: #CurveMorph nativitySelector: #arrowPrototype} ! ! !CurveMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:15'! initialize self registerInFlapsRegistry. ! ! !CurveMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:16'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(CurveMorph authoringPrototype 'Curve' 'A curve') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(CurveMorph authoringPrototype 'Curve' 'A curve') forFlapNamed: 'Supplies'.]! ! !CurveMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:33'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !CustomMenu methodsFor: 'initialize-release' stamp: 'sumim 2/10/2002 01:26'! initialize labels _ OrderedCollection new. selections _ OrderedCollection new. dividers _ OrderedCollection new. lastDivider _ 0. targets _ OrderedCollection new. arguments _ OrderedCollection new ! ! !CustomMenu methodsFor: 'construction' stamp: 'sw 2/27/2001 07:52'! addList: listOfTuplesAndDashes "Add a menu item to the receiver for each tuple in the given list of the form ( ). Add a line for each dash (-) in the list. The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc." listOfTuplesAndDashes do: [:aTuple | aTuple == #- ifTrue: [self addLine] ifFalse: [self add: aTuple first action: aTuple second]] "CustomMenu new addList: #( ('apples' buyApples) ('oranges' buyOranges) - ('milk' buyMilk)); startUp" ! ! !CustomMenu methodsFor: 'construction' stamp: 'sw 8/12/2002 17:14'! addStayUpItem "For compatibility with MenuMorph. Here it is a no-op"! ! !CustomMenu methodsFor: 'construction' stamp: 'nk 11/25/2003 10:00'! addTranslatedList: listOfTuplesAndDashes "Add a menu item to the receiver for each tuple in the given list of the form ( ). Add a line for each dash (-) in the list. The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc. The first element will be translated." listOfTuplesAndDashes do: [:aTuple | aTuple == #- ifTrue: [self addLine] ifFalse: [self add: aTuple first translated action: aTuple second]] "CustomMenu new addTranslatedList: #( ('apples' buyApples) ('oranges' buyOranges) - ('milk' buyMilk)); startUp" ! ! !CustomMenu methodsFor: 'construction' stamp: 'yo 8/28/2002 22:34' prior: 19848662! labels: labelList lines: linesArray selections: selectionsArray "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." "Labels can be either a sting with embedded crs, or a collection of strings." | labelArray | labelList isString ifTrue: [labelArray _ labelList findTokens: String cr] ifFalse: [labelArray _ labelList]. 1 to: labelArray size do: [:i | self add: (labelArray at: i) action: (selectionsArray at: i). (linesArray includes: i) ifTrue: [self addLine]]. ! ! !CustomMenu methodsFor: 'invocation' stamp: 'sw 2/17/2002 04:48'! invokeOn: targetObject "Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected. If the chosen selector has arguments, obtain them from my arguments" ^ self invokeOn: targetObject orSendTo: nil! ! !CustomMenu methodsFor: 'invocation' stamp: 'sw 11/16/2002 23:45'! invokeOn: targetObject orSendTo: anObject "Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected. If the chosen selector has arguments, obtain appropriately. If the recipient does not respond to the resulting message, send it to the alternate object provided" | aSelector anIndex recipient | ^ (aSelector _ self startUp) ifNotNil: [anIndex _ self selection. recipient _ ((targets _ self targets) isEmptyOrNil or: [anIndex > targets size]) ifTrue: [targetObject] ifFalse: [targets at: anIndex]. aSelector numArgs == 0 ifTrue: [recipient perform: aSelector orSendTo: anObject] ifFalse: [recipient perform: aSelector withArguments: (self arguments at: anIndex)]]! ! !CustomMenu methodsFor: 'compatibility' stamp: 'ads 2/20/2003 08:59'! add: aString subMenu: aMenu target: target selector: aSymbol argumentList: argList "Create a sub-menu with the given label. This isn't really a sub-menu the way Morphic does it; it'll just pop up another menu." self add: aString target: aMenu selector: #invokeOn: argumentList: argList asArray.! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:23'! add: aString target: target selector: aSymbol argument: arg "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." self add: aString target: target selector: aSymbol argumentList: (Array with: arg)! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:18'! add: aString target: target selector: aSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument." self add: aString action: aSymbol. targets addLast: target. arguments addLast: argList asArray ! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:21'! addService: aService for: serviceUser "Append a menu item with the given service. If the item is selected, it will perform the given service." self add: aService label target: aService selector: aService requestSelector argument: serviceUser ! ! !CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:19' prior: 35399857! addService: aService for: serviceUser "Append a menu item with the given service. If the item is selected, it will perform the given service." aService addServiceFor: serviceUser toMenu: self.! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:19'! addServices2: services for: served extraLines: linesArray services withIndexDo: [:service :i | self add: service label target: service selector: service requestSelector argument: (service getArgumentsFrom: served). (linesArray includes: i) | service useLineAfter ifTrue: [self addLine] ]! ! !CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:02' prior: 35400464! addServices2: services for: served extraLines: linesArray services withIndexDo: [:service :i | service addServiceFor: served toMenu: self. (linesArray includes: i) ifTrue: [self addLine] ]! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:20'! addServices: services for: served extraLines: linesArray services withIndexDo: [:service :i | self addService: service for: served. (linesArray includes: i) | service useLineAfter ifTrue: [self addLine]]! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sw 2/16/2002 00:57'! arguments "Answer my arguments, initializing them to an empty collection if they're found to be nil." ^ arguments ifNil: [arguments _ OrderedCollection new]! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sw 2/16/2002 00:57'! targets "Answer my targets, initializing them to an empty collection if found to be nil" ^ targets ifNil: [targets _ OrderedCollection new]! ! !DSCPostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:53' prior: 19888430! fullDraw: aMorph (morphLevel = 0 and: [aMorph pagesHandledAutomatically not]) ifTrue: [pages _ pages + 1. target print: '%%Page: 1 1'; cr]. super fullDraw: aMorph. morphLevel = 0 ifTrue: [ self writeTrailer: pages. ]! ! !DSCPostscriptCanvas methodsFor: 'initialization' stamp: 'RAA 2/22/2001 07:47'! writePSIdentifierRotated: rotateFlag | morphExtent pageExtent scaledBox | target print:'%!!PS-Adobe-2.0'; cr; print:'%%Pages: (atend)'; cr. "Define initialScale so that the morph will fit the page rotated or not" savedMorphExtent _ morphExtent _ rotateFlag ifTrue: [psBounds extent transposed] ifFalse: [psBounds extent]. pageExtent _ self defaultImageableArea extent asFloatPoint. initialScale _ (printSpecs isNil or: [printSpecs scaleToFitPage]) ifTrue: [ pageExtent x/morphExtent x min: pageExtent y/morphExtent y ] ifFalse: [ 1.0 ]. target print:'% initialScale: '; write:initialScale; cr. scaledBox _ self pageBBox rounded. target print: '%%BoundingBox: '; write: scaledBox rounded; cr. rotateFlag ifTrue: [ target print: '90 rotate'; cr; write: self defaultMargin * initialScale; space; write: (self defaultMargin + scaledBox height * initialScale) negated; print: ' translate'; cr ] ifFalse: [ target write: self defaultMargin * initialScale; space; write: (self defaultMargin * initialScale); print: ' translate'; cr ]. target print: '%%EndComments'; cr. ! ! !DSCPostscriptCanvas methodsFor: 'initialization' stamp: 'nk 1/2/2004 15:36' prior: 35402228! writePSIdentifierRotated: rotateFlag | morphExtent pageExtent | target print: '%!!PS-Adobe-2.0'; cr; print: '%%Pages: (atend)'; cr; print: '%%DocumentFonts: (atend)'; cr. "Define initialScale so that the morph will fit the page rotated or not" savedMorphExtent := morphExtent := rotateFlag ifTrue: [psBounds extent transposed] ifFalse: [psBounds extent]. pageExtent := self defaultImageableArea extent asFloatPoint. initialScale := (printSpecs isNil or: [printSpecs scaleToFitPage]) ifTrue: [pageExtent x / morphExtent x min: pageExtent y / morphExtent y] ifFalse: [1.0]. target print: '%%BoundingBox: '; write: self defaultImageableArea; cr. target print: '%%Title: '; print: self topLevelMorph externalName; cr. target print: '%%Creator: '; print: Utilities authorName; cr. target print: '%%CreationDate: '; print: Date today asString; space; print: Time now asString; cr. target print: '%%Orientation: '; print: (rotateFlag ifTrue: ['Landscape'] ifFalse: ['Portrait']); cr. target print: '%%EndComments'; cr. ! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/2/2004 16:53'! endGStateForMorph: aMorph "position the morph on the page " morphLevel == (topLevelMorph pagesHandledAutomatically ifTrue: [2] ifFalse: [1]) ifTrue: [ target showpage; print: 'grestore'; cr ]! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'tk 12/12/2001 15:51'! fullDrawBookMorph: aBookMorph " draw all the pages in a book morph, but only if it is the top-level morph " | currentPage | morphLevel = 1 ifFalse: [^ super fullDrawBookMorph: aBookMorph]. "Unfortunately, the printable 'pages' of a StackMorph are the cards, but for a BookMorph, they are the pages. Separate the cases here." currentPage _ 0. (aBookMorph isKindOf: StackMorph) ifTrue: [ aBookMorph cards do: [:aCard | aBookMorph goToCard: aCard. "cause card-specific morphs to be installed" currentPage _ currentPage + 1. target print: '%%Page: '; write: currentPage; space; write: currentPage; cr. self drawPage: aBookMorph currentPage]] ifFalse: [ aBookMorph pages do: [:aPage | currentPage _ currentPage + 1. target print: '%%Page: '; write: currentPage; space; write: currentPage; cr. self drawPage: aPage]]. target print: '%%EOF'; cr. ! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/2/2004 16:18' prior: 35404905! fullDrawBookMorph: aBookMorph " draw all the pages in a book morph, but only if it is the top-level morph " morphLevel = 1 ifFalse: [^ super fullDrawBookMorph: aBookMorph]. "Unfortunately, the printable 'pages' of a StackMorph are the cards, but for a BookMorph, they are the pages. Separate the cases here." (aBookMorph isKindOf: StackMorph) ifTrue: [ aBookMorph cards do: [:aCard | aBookMorph goToCard: aCard. "cause card-specific morphs to be installed" pages _ pages + 1. target print: '%%Page: '; write: pages; space; write: pages; cr. self drawPage: aBookMorph pages]] ifFalse: [ aBookMorph pages do: [:aPage | pages _ pages + 1. target print: '%%Page: '; write: pages; space; write: pages; cr. self drawPage: aPage]]. morphLevel = 0 ifTrue: [ self writeTrailer: pages ]. ! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 6/10/2004 13:19' prior: 35405891! fullDrawBookMorph: aBookMorph " draw all the pages in a book morph, but only if it is the top-level morph " morphLevel = 1 ifFalse: [^ super fullDrawBookMorph: aBookMorph]. "Unfortunately, the printable 'pages' of a StackMorph are the cards, but for a BookMorph, they are the pages. Separate the cases here." (aBookMorph isKindOf: StackMorph) ifTrue: [ aBookMorph cards do: [:aCard | aBookMorph goToCard: aCard. "cause card-specific morphs to be installed" pages _ pages + 1. target print: '%%Page: '; write: pages; space; write: pages; cr. self drawPage: aBookMorph currentPage]] ifFalse: [ aBookMorph pages do: [:aPage | pages _ pages + 1. target print: '%%Page: '; write: pages; space; write: pages; cr. self drawPage: aPage]]. morphLevel = 0 ifTrue: [ self writeTrailer: pages ]. ! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/1/2004 18:21' prior: 19889710! setupGStateForMorph: aMorph "position the morph on the page " morphLevel == (topLevelMorph pagesHandledAutomatically ifTrue: [2] ifFalse: [1]) ifTrue: [ self writePageSetupFor: aMorph ]! ! !DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'aoy 2/15/2003 21:46' prior: 19889000! pageBBox | pageSize offset bbox trueExtent | trueExtent := EPSCanvas bobsPostScriptHacks ifTrue: [savedMorphExtent "this one has been rotated"] ifFalse: [psBounds extent]. pageSize := self defaultImageableArea. offset := ((pageSize extent - trueExtent) / 2 max: 0 @ 0) + self defaultMargin. bbox := offset extent: psBounds extent. ^bbox! ! !DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 19:56' prior: 35408048! pageBBox | pageSize offset bbox trueExtent | trueExtent := savedMorphExtent * initialScale. "this one has been rotated" pageSize := self defaultPageSize. offset := pageSize extent - trueExtent / 2 max: 0 @ 0. bbox := offset extent: trueExtent. ^ bbox! ! !DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'nk 12/30/2003 17:22' prior: 19889452! pageOffset ^self pageBBox origin. ! ! !DSCPostscriptCanvasToDisk methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:41'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset ^self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: nil ! ! !DSCPostscriptCanvasToDisk methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:41'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil self reset. psBounds _ offset extent: aMorph bounds extent. topLevelMorph _ aMorph. self writeHeaderRotated: rotateFlag. self fullDrawMorph: aMorph. ^self close ! ! !DSCPostscriptCanvasToDisk methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 17:39' prior: 35409227! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil self reset. psBounds := offset extent: aMorph bounds extent. topLevelMorph := aMorph. self writeHeaderRotated: rotateFlag. self fullDrawMorph: aMorph. ^ self close! ! !DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:40'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil | newFileName stream | ^[ (self new morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset) close ] on: PickAFileToWriteNotification do: [ :ex | newFileName _ FillInTheBlank request: 'Name of file to write:' initialAnswer: 'xxx',Time millisecondClockValue printString,'.eps'. newFileName isEmptyOrNil ifFalse: [ stream _ FileStream fileNamed: newFileName. stream ifNotNil: [ex resume: stream]. ]. ]. ! ! !DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 16:58' prior: 35409943! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil | newFileName stream | ^[ (self new morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset) close ] on: PickAFileToWriteNotification do: [ :ex | newFileName _ FillInTheBlank request: 'Name of file to write:' translated initialAnswer: 'xxx',Time millisecondClockValue printString, self defaultExtension. newFileName isEmptyOrNil ifFalse: [ stream _ FileStream fileNamed: newFileName. stream ifNotNil: [ex resume: stream]. ]. ]. ! ! !DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:43'! morphAsPostscript: aMorph rotated: rotateFlag specs: specsOrNil ^ self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: self baseOffset specs: specsOrNil ! ! !DSCPostscriptCanvasToDisk class methodsFor: 'testing' stamp: 'RAA 2/22/2001 07:41'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset ^self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: nil ! ! !DamageRecorder methodsFor: 'recording' stamp: 'di 11/17/2001 14:19'! recordInvalidRect: newRect "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle." | mergeRect a | totalRepaint ifTrue: [^ self]. "planning full repaint; don't bother collecting damage" invalidRects do: [:rect | ((a _ (rect intersect: newRect) area) > 40 and: ["Avoid combining a vertical and horizontal rects. Can make a big diff and we only test when likely." a > (newRect area // 4) or: [a > (rect area // 4)]]) ifTrue: ["merge rectangle in place (see note below) if there is significant overlap" rect setOrigin: (rect origin min: newRect origin) truncated corner: (rect corner max: newRect corner) truncated. ^ self]]. invalidRects size >= 15 ifTrue: ["if there are too many separate areas, merge them all" mergeRect _ Rectangle merging: invalidRects. self reset. invalidRects addLast: mergeRect]. "add the given rectangle to the damage list" "Note: We make a deep copy of all rectangles added to the damage list, since rectangles in this list may be extended in place." invalidRects addLast: (newRect topLeft truncated corner: newRect bottomRight truncated). ! ! !DamageRecorder methodsFor: 'testing' stamp: 'dgd 2/22/2003 14:43' prior: 19895198! updateIsNeeded "Return true if the display needs to be updated." ^totalRepaint or: [invalidRects notEmpty]! ! !DataStream methodsFor: 'other' stamp: 'nk 3/12/2004 21:56'! contents ^byteStream contents! ! !DataStream methodsFor: 'other' stamp: 'tk 3/5/2002 09:51'! nextAndClose "Speedy way to grab one object. Only use when we are inside an object binary file. Do not use for the start of a SmartRefStream mixed code-and-object file." | obj | obj _ self next. self close. ^ obj! ! !DataStream methodsFor: 'other' stamp: 'ar 2/24/2001 22:45'! project ^nil! ! !DataStream class methodsFor: 'as yet unclassified' stamp: 'tk 3/7/2001 17:57'! initialize "TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats. nextPut: writes these IDs to the data stream. NOTE: Changing these type ID numbers will invalidate all extant data stream files. Adding new ones is OK. Classes named here have special formats in the file. If such a class has a subclass, it will use type 9 and write correctly. It will just be slow. (Later write the class name in the special format, then subclasses can use the type also.) See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:" "DataStream initialize" | refTypes t | refTypes _ OrderedCollection new. t _ TypeMap _ Dictionary new: 80. "sparse for fast hashing" t at: UndefinedObject put: 1. refTypes add: 0. t at: True put: 2. refTypes add: 0. t at: False put: 3. refTypes add: 0. t at: SmallInteger put: 4. refTypes add: 0. t at: String put: 5. refTypes add: 1. t at: Symbol put: 6. refTypes add: 1. t at: ByteArray put: 7. refTypes add: 1. t at: Array put: 8. refTypes add: 1. "(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)" refTypes add: 1. "(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)" refTypes add: 0. t at: Bitmap put: 11. refTypes add: 1. t at: Metaclass put: 12. refTypes add: 0. "Type ID 13 is used for HyperSqueak User classes that must be reconstructed." refTypes add: 1. t at: Float put: 14. refTypes add: 1. t at: Rectangle put: 15. refTypes add: 1. "Allow compact Rects." "type ID 16 is an instance with short header. See beginInstance:size:" refTypes add: 1. t at: String put: 17. refTypes add: 1. "new String format, 1 or 4 bytes of length" t at: WordArray put: 18. refTypes add: 1. "bitmap-like" t at: WordArrayForSegment put: 19. refTypes add: 1. "bitmap-like" t at: SoundBuffer put: 20. refTypes add: 1. "And all other word arrays, both 16-bit and 32-bit. See methods in ArrayedCollection. Overridden in SoundBuffer." t at: CompiledMethod put: 21. refTypes add: 1. "special creation method" "t at: put: 22. refTypes add: 0." ReferenceStream refTypes: refTypes. "save it" "For all classes that are like WordArrays, store them the way ColorArray is stored. As bits, and able to change endianness." Smalltalk do: [:cls | cls isInMemory ifTrue: [ cls isBehavior ifTrue: [ cls isPointers not & cls isVariable & cls isWords ifTrue: [ (t includesKey: cls) ifFalse: [t at: cls put: 20]]]]].! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:36'! addExtraItemsToMenu: aMenu forSlotSymbol: slotSym "If the receiver has extra menu items to add to the slot menu, here is its chance to do it"! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:38'! addUserSlotItemsTo: aMenu slotSymbol: slotSym "Optionally add items to the menu that pertain to a user-defined slot of the given symbol" ! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/6/2002 11:32'! addWatcherItemsToMenu: aMenu forGetter: aGetter "Add watcher items to the menu if appropriate, provided the getter is not an odd-ball one for which a watcher makes no sense" (#(colorSees copy newClone getNewClone color:sees: touchesA: overlaps:) includes: aGetter) ifFalse: [aMenu add: 'simple watcher' selector: #tearOffWatcherFor: argument: aGetter]! ! !DataType methodsFor: 'tiles' stamp: 'dgd 9/6/2003 20:29' prior: 35416982! addWatcherItemsToMenu: aMenu forGetter: aGetter "Add watcher items to the menu if appropriate, provided the getter is not an odd-ball one for which a watcher makes no sense" (#(colorSees copy newClone getNewClone color:sees: touchesA: overlaps:) includes: aGetter) ifFalse: [aMenu add: 'simple watcher' translated selector: #tearOffWatcherFor: argument: aGetter]! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 02:29'! affordsCoercionToBoolean "Answer true if a tile of this data type, when dropped into a pane that demands a boolean, could plausibly be expanded into a comparison (of the form frog < toad or frog = toad) to provide a boolean expression" ^ true! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 02:53'! comparatorForSampleBoolean "Answer the comparator to use in tile coercions involving the receiver; normally, the equality comparator is used but NumberType overrides" ^ #=! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 13:15'! defaultArgumentTile "Answer a tile to represent the type" ^ 'arg' newTileMorphRepresentative typeColor: self typeColor! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:37'! newReadoutTile "Answer a tile that can serve as a readout for data of this type" ^ StringReadoutTile new typeColor: Color lightGray lighter! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/25/2001 21:18'! updatingTileForTarget: aTarget partName: partName getter: getter setter: setter "Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter" | aTile displayer actualSetter | actualSetter _ setter ifNotNil: [(#(none nil unused) includes: setter) ifTrue: [nil] ifFalse: [setter]]. aTile _ self newReadoutTile. displayer _ UpdatingStringMorph new getSelector: getter; target: aTarget; growable: true; minimumWidth: 24; putSelector: actualSetter. "Note that when typeSymbol = #number, the #target: call above will have dealt with floatPrecision details" self setFormatForDisplayer: displayer. aTile addMorphBack: displayer. (actualSetter notNil and: [self wantsArrowsOnTiles]) ifTrue: [aTile addArrows]. getter numArgs == 0 ifTrue: [aTile setLiteralInitially: (aTarget perform: getter)]. ^ aTile ! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:33'! wantsArrowsOnTiles "Answer whether this data type wants up/down arrows on tiles representing its values" ^ true! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/26/2001 03:11'! wantsAssignmentTileVariants "Answer whether an assignment tile for a variable of this type should show variants to increase-by, decrease-by, multiply-by. NumberType says yes, the rest of us say no" ^ false! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/26/2001 03:18'! wantsSuffixArrow "Answer whether a tile showing data of this type would like to have a suffix arrow" ^ false! ! !DataType methodsFor: 'initial value' stamp: 'sw 9/26/2001 12:00'! initialValueForASlotFor: aPlayer "Answer the value to give initially to a newly created slot of the given type in the given player" ^ 'no value'! ! !DataType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:32'! setFormatForDisplayer: aDisplayer "Set up the displayer to have the right format characteristics" aDisplayer useDefaultFormat. aDisplayer growable: true ! ! !DataType methodsFor: 'color' stamp: 'sw 9/27/2001 17:32'! subduedColorFromTriplet: anRGBTriplet "Answer a subdued color derived from the rgb-triplet to use as a tile color. Don't pay too much attention to this whole branch, for it relates to an aspect whose use is basically in abeyance" ^ (Color fromRgbTriplet: anRGBTriplet) mixed: ScriptingSystem colorFudge with: ScriptingSystem uniformTileInteriorColor! ! !DataType methodsFor: 'queries' stamp: 'sw 9/27/2001 03:25'! representsAType "Answer whether this vocabulary represents an end-user-sensible data type" ^ (self class == DataType) not "i.e. subclasses yes, myself no"! ! !DataType commentStamp: 'sw 8/22/2002 15:01' prior: 0! A Vocabulary representing typed data.! !Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:07'! mmddyyyy "Answer the receiver rendered in standard U.S.A format mm/dd/yyyy. Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example February 1 1996 is 2/1/96" ^ self printFormat: #(2 1 3 $/ 1 1)! ! !Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:06'! printFormat: formatArray "Answer a String describing the receiver using the argument formatArray." | aStream | aStream _ WriteStream on: (String new: 16). self printOn: aStream format: formatArray. ^ aStream contents! ! !Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'! printOn: aStream self printOn: aStream format: #(1 2 3 $ 3 1 )! ! !Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:05'! printOn: aStream format: formatArray "Print a description of the receiver on aStream using the format denoted the argument, formatArray: #(item item item sep monthfmt yearfmt twoDigits) items: 1=day 2=month 3=year will appear in the order given, separated by sep which is eaither an ascii code or character. monthFmt: 1=09 2=Sep 3=September yearFmt: 1=1996 2=96 digits: (missing or)1=9 2=09. See the examples in printOn: and mmddyy" | gregorian twoDigits element monthFormat | gregorian _ self dayMonthYearDo: [ :d :m :y | {d. m. y} ]. twoDigits _ formatArray size > 6 and: [(formatArray at: 7) > 1]. 1 to: 3 do: [ :i | element := formatArray at: i. element = 1 ifTrue: [twoDigits ifTrue: [aStream nextPutAll: (gregorian first asString padded: #left to: 2 with: $0)] ifFalse: [gregorian first printOn: aStream]]. element = 2 ifTrue: [monthFormat := formatArray at: 5. monthFormat = 1 ifTrue: [twoDigits ifTrue: [aStream nextPutAll: (gregorian middle asString padded: #left to: 2 with: $0)] ifFalse: [gregorian middle printOn: aStream]]. monthFormat = 2 ifTrue: [aStream nextPutAll: ((Month nameOfMonth: gregorian middle) copyFrom: 1 to: 3)]. monthFormat = 3 ifTrue: [aStream nextPutAll: (Month nameOfMonth: gregorian middle)]]. element = 3 ifTrue: [(formatArray at: 6) = 1 ifTrue: [gregorian last printOn: aStream] ifFalse: [aStream nextPutAll: ((gregorian last \\ 100) asString padded: #left to: 2 with: $0)]]. i < 3 ifTrue: [(formatArray at: 4) ~= 0 ifTrue: [aStream nextPut: (formatArray at: 4) asCharacter]]] ! ! !Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'! storeOn: aStream aStream print: self printString; nextPutAll: ' asDate'! ! !Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:04'! yyyymmdd "Format the date in ISO 8601 standard like '2002-10-22'." ^ self printFormat: #(3 2 1 $- 1 1 2)! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:09'! addDays: dayCount ^ (self asDateAndTime + (dayCount days)) asDate! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:08'! asSeconds "Answer the seconds since the Squeak epoch: 1 January 1901" ^ start asSeconds! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:08'! leap "Answer whether the receiver's year is a leap year." ^ start isLeapYear ifTrue: [1] ifFalse: [0].! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 1/16/2004 14:30'! previous: dayName "Answer the previous date whose weekday name is dayName." | days | days _ 7 + self weekdayIndex - (self class dayOfWeek: dayName) \\ 7. days = 0 ifTrue: [ days _ 7 ]. ^ self subtractDays: days ! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:09'! subtractDate: aDate "Answer the number of days between self and aDate" ^ (self start - aDate asDateAndTime) days! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:05'! subtractDays: dayCount ^ (self asDateAndTime - (dayCount days)) asDate! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 12:04'! weekday "Answer the name of the day of the week on which the receiver falls." ^ self dayOfWeekName! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 12:04'! weekdayIndex "Sunday=1, ... , Saturday=7" ^ self dayOfWeek! ! !Date methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:10'! asDate ^ self! ! !Date methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:10'! dayMonthYearDo: aBlock "Supply integers for day, month and year to aBlock and return the result" ^ start dayMonthYearDo: aBlock! ! !Date methodsFor: 'squeak protocol' stamp: 'avi 2/21/2004 18:12'! month ^ self asMonth! ! !Date methodsFor: 'squeak protocol' stamp: 'avi 2/29/2004 13:10'! monthIndex ^ super month! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:36'! asGregorian "Return an array of integers #(dd mm yyyy)" ^ self deprecated: 'Use #dayMonthYearDo:'; dayMonthYearDo: [ :d :m :y | { d. m. y } ] ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:32'! asJulianDayNumber ^ self deprecated: 'Use #julianDayNumber'; julianDayNumber! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:36'! day: dayInteger year: yearInteger ^ self deprecated: 'Obsolete' ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:39'! daylightSavingsInEffect "Return true if DST is observed at or after 2am on this day" self deprecated: 'Deprecated'. self dayMonthYearDo: [ :day :month :year | (month < 4 or: [month > 10]) ifTrue: [^ false]. "False November through March" (month > 4 and: [month < 10]) ifTrue: [^ true]. "True May through September" month = 4 ifTrue: ["It's April -- true on first Sunday or later" day >= 7 ifTrue: [^ true]. "Must be after" ^ day > (self weekdayIndex \\ 7)] ifFalse: ["It's October -- false on last Sunday or later". day <= 24 ifTrue: [^ true]. "Must be before" ^ day <= (24 + (self weekdayIndex \\ 7))]]! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:39'! daylightSavingsInEffectAtStandardHour: hour "Return true if DST is observed at this very hour (standard time)" "Note: this *should* be the kernel method, and daylightSavingsInEffect should simply be self daylightSavingsInEffectAtHour: 3" self deprecated: 'Deprecated'. self daylightSavingsInEffect ifTrue: [^ (self addDays: -1) daylightSavingsInEffect or: [hour >= 2]] ifFalse: [^ (self addDays: -1) daylightSavingsInEffect and: [hour < 1]]! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:37'! firstDayOfMonthIndex: monthIndex ^ self deprecated: 'Obsolete' ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:41'! julianDayNumber: anInteger "Set the number of days elapsed since midnight GMT on January 1st, 4713 B.C." self deprecated: 'Obsolete'. ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:34'! mmddyy "Please use mmddyyyy instead, so dates in 2000 will be unambiguous" ^ self deprecated: 'Use #mmddyyyy'; printFormat: #(2 1 3 $/ 1 2) ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:46'! uniqueDateStringBetween: aStart and: anEnd "Return a String, with just enough information to distinguish it from other dates in the range." "later, be more sophisticated" self deprecated: 'Deprecated'. aStart year + 1 >= anEnd year ifFalse: [^ self printFormat: #(1 2 3 $ 3 1)]. "full" aStart week next >= anEnd week ifFalse: [^ self printFormat: #(2 1 9 $ 3 1)]. "May 6" ^ self weekday ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:31'! week ^ self deprecated: 'Use #asWeek'; asWeek! ! !Date commentStamp: '' prior: 0! Instances of Date are Timespans with duration of 1 day. Their default creation assumes a start of midnight in the local time zone.! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 21:48'! dateAndTimeNow "Answer an Array whose with Date today and Time now." ^ self timeClass dateAndTimeNow! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:00' prior: 35429415! dateAndTimeNow "Answer an Array whose with Date today and Time now." ^ Time dateAndTimeNow! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:35'! dayOfWeek: dayName ^ Week indexOfDay: dayName! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:59'! daysInMonth: monthName forYear: yearInteger ^ Month daysInMonth: monthName forYear: yearInteger. ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:53'! daysInYear: yearInteger ^ Year daysInYear: yearInteger.! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 1/16/2004 14:35'! firstWeekdayOfMonth: month year: year "Answer the weekday index of the first day in in the ." ^ (self newDay: 1 month: month year: year) weekdayIndex ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'! fromDays: dayCount "Days since 1 January 1901" ^ self julianDayNumber: dayCount + SqueakEpoch! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:02'! fromSeconds: seconds "Answer an instance of me which is 'seconds' seconds after January 1, 1901." ^ self fromDays: ((Duration seconds: seconds) days)! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:39'! indexOfMonth: aMonthName ^ Month indexOfMonth: aMonthName. ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:56'! leapYear: yearInteger ^ Year leapYear: yearInteger! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:37'! nameOfDay: dayIndex ^ Week nameOfDay: dayIndex ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:40'! nameOfMonth: anIndex ^ Month nameOfMonth: anIndex. ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:02'! newDay: day month: month year: year ^ self year: year month: month day: day! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'! newDay: dayCount year: yearInteger ^ self year: yearInteger day: dayCount! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'! today ^ self current! ! !Date class methodsFor: 'deprecated' stamp: 'brp 8/4/2003 22:13'! absoluteDaysToYear: gregorianYear self deprecated: 'Deprecated'! ! !Date class methodsFor: 'deprecated' stamp: 'brp 8/4/2003 22:14'! fromJulianDayNumber: aJulianDayNumber self deprecated: 'Deprecated'; julianDayNumber: aJulianDayNumber! ! !Date class methodsFor: 'deprecated' stamp: 'brp 8/4/2003 22:15'! yearAndDaysFromDays: days into: aTwoArgBlock self deprecated: 'Deprecated'! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:03'! fromString: aString "Answer an instance of created from a string with format dd.mm.yyyy." ^ self readFrom: aString readStream. ! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 18:25'! julianDayNumber: aJulianDayNumber ^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber)! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 09:21'! readFrom: aStream "Read a Date from the stream in any of the forms: (5 April 1982; 5-APR-82) (April 5, 1982) (4/5/82) (5APR82)" | day month year | aStream peek isDigit ifTrue: [day := Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. aStream peek isLetter ifTrue: ["number/name... or 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]. day := Integer readFrom: aStream]] ifFalse: ["number/number..." month := Month nameOfMonth: day. day := Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. year := Integer readFrom: aStream. year < 10 ifTrue: [year := 2000 + year] ifFalse: [ year < 1900 ifTrue: [ year := 1900 + year]]. ^ self year: year month: month day: day! ! !Date class methodsFor: 'squeak protocol' stamp: 'BP 3/23/2001 12:36'! starting: aDateAndTime ^super starting: (aDateAndTime midnight) duration: (Duration days: 1) ! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 18:09'! tomorrow ^ self today next! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 22:03'! year: year day: dayOfYear ^ self starting: (DateAndTime year: year day: dayOfYear) ! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 22:02'! year: year month: month day: day ^ self starting: (DateAndTime year: year month: month day: day) ! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 18:09'! yesterday ^ self today previous! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 7/9/2005 08:45'! + operand "operand conforms to protocol Duration" | ticks | ticks _ self ticks + (operand asDuration ticks) . ^ self class basicNew ticks: ticks offset: self offset; yourself. ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 1/9/2004 05:39'! - operand "operand conforms to protocol DateAndTime or protocol Duration" ^ (operand respondsTo: #asDateAndTime) ifTrue: [ | lticks rticks | lticks _ self asLocal ticks. rticks _ operand asDateAndTime asLocal ticks. Duration seconds: (SecondsInDay *(lticks first - rticks first)) + (lticks second - rticks second) nanoSeconds: (lticks third - rticks third) ] ifFalse: [ self + (operand negated) ]. ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 15:49'! < comparand "comparand conforms to protocol DataAndTime" | lticks rticks | lticks _ self asUTC ticks. rticks _ comparand asDateAndTime asUTC ticks. ^ (lticks first < rticks first) ifTrue: [ true ] ifFalse: [ (lticks first > rticks first) ifTrue: [ false ] ifFalse: [ (lticks second < rticks second ) ifTrue: [ true ] ifFalse: [ (lticks second > rticks second) ifTrue: [ false ] ifFalse: [ lticks third < rticks third ]]]] ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 09:09' prior: 35435349! < comparand "comparand conforms to protocol DateAndTime, or can be converted into something that conforms." | lticks rticks comparandAsDateAndTime | comparandAsDateAndTime := comparand asDateAndTime. offset = comparandAsDateAndTime offset ifTrue: [lticks := self ticks. rticks := comparandAsDateAndTime ticks] ifFalse: [lticks := self asUTC ticks. rticks := comparandAsDateAndTime asUTC ticks]. ^ lticks first < rticks first or: [lticks first > rticks first ifTrue: [false] ifFalse: [lticks second < rticks second or: [lticks second > rticks second ifTrue: [false] ifFalse: [lticks third < rticks third]]]] ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 15:49'! = comparand "comparand conforms to protocol DateAndTime" ^ self == comparand ifTrue: [true] ifFalse: [ [self asUTC ticks = comparand asDateAndTime asUTC ticks ] on: MessageNotUnderstood do: [false] ].! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 08:49' prior: 35436688! = comparand "comparand conforms to protocol DateAndTime, or can be converted into something that conforms." | comparandAsDateAndTime | self == comparand ifTrue: [^ true]. [comparandAsDateAndTime := comparand asDateAndTime] on: MessageNotUnderstood do: [^ false]. ^ self offset = comparandAsDateAndTime offset ifTrue: [self ticks = comparandAsDateAndTime ticks] ifFalse: [self asUTC ticks = comparandAsDateAndTime asUTC ticks] ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 13:11'! asLocal ^ (self offset = self class localOffset) ifTrue: [self] ifFalse: [self utcOffset: self class localOffset] ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 13:12'! asUTC ^ self utcOffset: 0! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:03'! dayOfMonth "Answer which day of the month is represented by the receiver." ^ self dayMonthYearDo: [ :d :m :y | d ]! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/24/2003 12:25'! dayOfWeek "Sunday=1, ... , Saturday=7" ^ (jdn + 1 rem: 7) + 1! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 10:34'! dayOfWeekAbbreviation ^ self dayOfWeekName copyFrom: 1 to: 3! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:28'! dayOfWeekName ^ Week nameOfDay: self dayOfWeek ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'! dayOfYear ^ jdn - (Year year: self year) start julianDayNumber + 1 ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 15:49'! hash ^ self asUTC ticks hash ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'! hour ^ self hour24 ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 11:21'! hour12 "Answer an between 1 and 12, inclusive, representing the hour of the day in the 12-hour clock of the local time of the receiver." | h | h _ (self hour24 abs + 1). ^ h > 12 ifTrue: [h - 12] ifFalse: [h]. ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 18:46' prior: 35438805! hour12 "Answer an between 1 and 12, inclusive, representing the hour of the day in the 12-hour clock of the local time of the receiver." ^ self hour24 - 1 \\ 12 + 1! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'! hour24 ^ (Duration seconds: seconds) hours ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'! isLeapYear ^ Year isLeapYear: self year. ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/24/2003 11:03'! meridianAbbreviation ^ self asTime meridianAbbreviation! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'! minute ^ (Duration seconds: seconds) minutes ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:05'! month ^ self dayMonthYearDo: [ :d :m :y | m ].! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'! monthAbbreviation ^ self monthName copyFrom: 1 to: 3 ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'! monthName ^ Month nameOfMonth: self month ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'! offset ^ offset ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:09'! offset: anOffset "Answer a equivalent to the receiver but with its local time being offset from UTC by offset." ^ self class basicNew ticks: self ticks offset: anOffset asDuration; yourself ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:31'! second ^ (Duration seconds: seconds) seconds ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 9/4/2003 06:42'! timeZoneAbbreviation ^ self class localTimeZone abbreviation ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 9/4/2003 06:42'! timeZoneName ^ self class localTimeZone name ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:05'! year ^ self dayMonthYearDo: [ :d :m :y | y ]! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 23:56'! asDate ^ Date starting: self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 23:56' prior: 35441207! asDate ^ Date starting: self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:46'! asDateAndTime ^ self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'! asDuration "Answer the duration since midnight" ^ Duration seconds: seconds nanoSeconds: nanos ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'! asMonth ^ Month starting: self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:45'! asNanoSeconds "Answer the number of nanoseconds since midnight" ^ self asDuration asNanoSeconds ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:00'! asTime ^ Time seconds: seconds nanoSeconds: nanos! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 22:37' prior: 35442024! asTime ^ self timeClass seconds: seconds nanoSeconds: nanos! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:00' prior: 35442170! asTime ^ Time seconds: seconds nanoSeconds: nanos! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:02'! asTimeStamp ^ self as: TimeStamp! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:02' prior: 35442456! asTimeStamp ^ self as: TimeStamp! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'! asWeek ^ Week starting: self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'! asYear ^ Year starting: self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:47'! dayMonthYearDo: aBlock "Evaluation the block with three arguments: day month, year." | l n i j dd mm yyyy | l := jdn + 68569. n := 4 * l // 146097. l := l - (146097 * n + 3 // 4). i := 4000 * (l + 1) // 1461001. l := l - (1461 * i // 4) + 31. j := 80 * l // 2447. dd := l - (2447 * j // 80). l := j // 11. mm := j + 2 - (12 * l). yyyy := 100 * (n - 49) + i + l. ^ aBlock value: dd value: mm value: yyyy.! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:49'! duration ^ Duration zero ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:49'! julianDayNumber ^ jdn ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:49'! middleOf: aDuration "Return a Timespan where the receiver is the middle of the Duration" | duration | duration _ aDuration asDuration. ^ Timespan starting: (self - (duration / 2)) duration: duration. ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:48'! midnight "Answer a DateAndTime starting at midnight local time" ^ self dayMonthYearDo: [ :d :m :y | self class year: y month: m day: d ]! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:50'! nanoSecond ^ nanos ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:49'! noon "Answer a DateAndTime starting at noon" ^ self dayMonthYearDo: [ :d :m :y | self class year: y month: m day: d hour: 12 minute: 0 second: 0 ]! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:03'! printHMSOn: aStream "Print just hh:mm:ss" aStream nextPutAll: (self hour asString padded: #left to: 2 with: $0); nextPut: $:; nextPutAll: (self minute asString padded: #left to: 2 with: $0); nextPut: $:; nextPutAll: (self second asString padded: #left to: 2 with: $0). ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 13:23'! printOn: aStream "Print as per ISO 8601 sections 5.3.3 and 5.4.1. -YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z " | year month day | self dayMonthYearDo: [ :d :m :y | year _ y. month _ m. day _ d ]. aStream nextPut: (year negative ifTrue: [$-] ifFalse: [ Character space ]); nextPutAll: (year abs asString padded: #left to: 4 with: $0); nextPut: $-; nextPutAll: (month asString padded: #left to: 2 with: $0); nextPut: $-; nextPutAll: (day asString padded: #left to: 2 with: $0); nextPut: $T; nextPutAll: (self hour asString padded: #left to: 2 with: $0); nextPut: $:; nextPutAll: (self minute asString padded: #left to: 2 with: $0); nextPut: $:; nextPutAll: (self second asString padded: #left to: 2 with: $0). self nanoSecond ~= 0 ifTrue: [ | z ps | ps _ self nanoSecond printString padded: #left to: 9 with: $0. z _ ps findLast: [ :c | c asciiValue > $0 asciiValue ]. ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]. aStream nextPut: (offset positive ifTrue: [$+] ifFalse: [$-]); nextPutAll: (offset hours abs asString padded: #left to: 2 with: $0); nextPut: $:; nextPutAll: (offset minutes abs asString padded: #left to: 2 with: $0). offset seconds = 0 ifFalse: [ aStream nextPut: $:; nextPutAll: (offset seconds abs truncated asString) ].! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:38' prior: 35444868! printOn: aStream "Print as per ISO 8601 sections 5.3.3 and 5.4.1. Prints either: 'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)" ^self printOn: aStream withLeadingSpace: false ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:37'! printOn: aStream withLeadingSpace: printLeadingSpaceToo "Print as per ISO 8601 sections 5.3.3 and 5.4.1. If printLeadingSpaceToo is false, prints either: 'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years) If printLeadingSpaceToo is true, prints either: ' YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years) " self printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo. aStream nextPut: $T. self printHMSOn: aStream. self nanoSecond ~= 0 ifTrue: [ | z ps | ps := self nanoSecond printString padded: #left to: 9 with: $0. z := ps findLast: [ :c | c asciiValue > $0 asciiValue ]. ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]. aStream nextPut: (offset positive ifTrue: [$+] ifFalse: [$-]); nextPutAll: (offset hours abs asString padded: #left to: 2 with: $0); nextPut: $:; nextPutAll: (offset minutes abs asString padded: #left to: 2 with: $0). offset seconds = 0 ifFalse: [ aStream nextPut: $:; nextPutAll: (offset seconds abs truncated asString) ]. ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:29'! printYMDOn: aStream "Print just YYYY-MM-DD part. If the year is negative, prints out '-YYYY-MM-DD'." ^self printYMDOn: aStream withLeadingSpace: false. ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:29'! printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo "Print just the year, month, and day on aStream. If printLeadingSpaceToo is true, then print as: ' YYYY-MM-DD' (if the year is positive) or '-YYYY-MM-DD' (if the year is negative) otherwise print as: 'YYYY-MM-DD' or '-YYYY-MM-DD' " | year month day | self dayMonthYearDo: [ :d :m :y | year := y. month := m. day := d ]. year negative ifTrue: [ aStream nextPut: $- ] ifFalse: [ printLeadingSpaceToo ifTrue: [ aStream space ]]. aStream nextPutAll: (year abs asString padded: #left to: 4 with: $0); nextPut: $-; nextPutAll: (month asString padded: #left to: 2 with: $0); nextPut: $-; nextPutAll: (day asString padded: #left to: 2 with: $0) ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:50'! to: anEnd "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" ^ Timespan starting: self ending: (anEnd asDateAndTime). ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:57'! to: anEnd by: aDuration "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" ^ (Schedule starting: self ending: (anEnd asDateAndTime)) schedule: (Array with: aDuration asDuration); yourself. ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 16:01'! to: anEnd by: aDuration do: aBlock "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" ^ (self to: anEnd by: aDuration) scheduleDo: aBlock ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:37'! utcOffset: anOffset "Answer a equivalent to the receiver but offset from UTC by anOffset" | equiv | equiv _ self + (anOffset asDuration - self offset). ^ equiv ticks: (equiv ticks) offset: anOffset asDuration; yourself ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 21:03'! asSeconds "Return the number of seconds since the Squeak epoch" ^ (self - (self class epoch)) asSeconds ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 17:53'! day ^ self dayOfYear! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:48'! daysInMonth "Answer the number of days in the month represented by the receiver." ^ self asMonth daysInMonth ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:48'! daysInYear "Answer the number of days in the year represented by the receiver." ^ self asYear daysInYear ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 15:44'! daysLeftInYear "Answer the number of days in the year after the date of the receiver." ^ self daysInYear - self dayOfYear ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 15:44'! firstDayOfMonth ^ self asMonth start day! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 18:30'! hours ^ self hour! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 1/7/2004 15:45'! minutes ^ self minute! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:50'! monthIndex ^ self month ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 18:31'! seconds ^ self second! ! !DateAndTime methodsFor: 'private' stamp: 'brp 8/23/2003 15:45'! ticks "Private - answer an array with our instance variables. Assumed to be UTC " ^ Array with: jdn with: seconds with: nanos .! ! !DateAndTime methodsFor: 'private' stamp: 'brp 1/14/2004 09:08'! ticks: ticks offset: utcOffset "ticks is {julianDayNumber. secondCount. nanoSeconds}" | normalize | normalize _ [ :i :base | | tick quo rem | tick _ ticks at: i. quo _ tick abs // base. rem _ tick abs \\ base. (tick negative and: [rem ~= 0]) ifTrue: [ quo _ (quo+1) negated. rem _ base - rem ]. ticks at: (i-1) put: ((ticks at: i-1) + quo). ticks at: i put: rem ]. normalize value: 3 value: NanosInSecond. normalize value: 2 value: SecondsInDay. jdn _ ticks first. seconds _ ticks second. nanos _ ticks third. offset _ utcOffset. ! ! !DateAndTime methodsFor: 'private' stamp: 'nk 3/30/2004 09:38' prior: 35451532! ticks: ticks offset: utcOffset "ticks is {julianDayNumber. secondCount. nanoSeconds}" | normalize | normalize := [ :i :base | | tick div quo rem | tick := ticks at: i. div := tick digitDiv: base neg: tick negative. quo := div first normalize. rem := div second normalize. rem < 0 ifTrue: [ quo := quo - 1. rem := base + rem ]. ticks at: (i-1) put: ((ticks at: i-1) + quo). ticks at: i put: rem ]. normalize value: 3 value: NanosInSecond. normalize value: 2 value: SecondsInDay. jdn _ ticks first. seconds _ ticks second. nanos := ticks third. offset := utcOffset. ! ! !DateAndTime commentStamp: 'brp 5/13/2003 08:07' prior: 0! I represent a point in UTC time as defined by ISO 8601. I have zero duration. My implementation uses three SmallIntegers and a Duration: jdn - julian day number. seconds - number of seconds since midnight. nanos - the number of nanoseconds since the second. offset - duration from UTC. The nanosecond attribute is almost always zero but it defined for full ISO compliance and is suitable for timestamping. ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:32'! clockPrecision "One nanosecond precision" ^ Duration nanoSeconds: 1 ! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 9/25/2003 10:59'! now | ticks millis | LastTickSemaphore critical: [millis _ self millisecondClockValue - FirstMilliSecondValue. ticks _ (self totalSeconds * NanosInSecond) + (millis * NanosInMillisecond). LastTick _ (LastTick >= ticks ifTrue: [LastTick + 1] ifFalse: [ticks]). ^ self basicNew ticks: (Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: 0 nanoSeconds: LastTick) ticks offset: self localOffset; yourself] ! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 19:03' prior: 35453499! now ^ self basicNew ticks: (Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: self totalSeconds nanoSeconds: 0) ticks offset: self localOffset; yourself ! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 7/27/2003 15:25'! year: year day: dayOfYear hour: hour minute: minute second: second ^ self year: year day: dayOfYear hour: hour minute: minute second: second offset: self localOffset. ! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 7/27/2003 15:28'! year: year day: dayOfYear hour: hour minute: minute second: second offset: offset "Return a DataAndTime" | y d | y _ self year: year month: 1 day: 1 hour: hour minute: minute second: second nanoSecond: 0 offset: offset. d _ Duration days: (dayOfYear - 1). ^ y + d! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:00'! year: year month: month day: day hour: hour minute: minute second: second "Return a DateAndTime" ^ self year: year month: month day: day hour: hour minute: minute second: second offset: self localOffset ! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:36'! year: year month: month day: day hour: hour minute: minute second: second offset: offset ^ self year: year month: month day: day hour: hour minute: minute second: second nanoSecond: 0 offset: offset ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:36'! current ^ self now ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 16:12'! date: aDate time: aTime ^ self year: aDate year day: aDate dayOfYear hour: aTime hour minute: aTime minute second: aTime second ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp` 8/24/2003 19:11'! epoch "Answer a DateAndTime representing the Squeak epoch: 1 January 1901" ^ self julianDayNumber: SqueakEpoch ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:36'! fromString: aString ^ self readFrom: (ReadStream on: aString) ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 21:08'! julianDayNumber: aJulianDayNumber ^ self basicNew ticks: aJulianDayNumber days ticks offset: self localOffset; yourself ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/4/2003 06:40'! localOffset "Answer the duration we are offset from UTC" ^ self localTimeZone offset ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/4/2003 06:39'! localTimeZone "Answer the local time zone" ^ LocalTimeZone ifNil: [ LocalTimeZone _ TimeZone default ] ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/4/2003 06:40'! localTimeZone: aTimeZone "Set the local time zone" LocalTimeZone _ aTimeZone ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'nk 3/30/2004 09:53' prior: 35456914! localTimeZone: aTimeZone "Set the local time zone" " DateAndTime localTimeZone: (TimeZone offset: 0 hours name: 'Universal Time' abbreviation: 'UTC'). DateAndTime localTimeZone: (TimeZone offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST'). " LocalTimeZone := aTimeZone ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:09'! midnight ^ self now midnight ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:57'! new "Answer a DateAndTime representing the Squeak epoch: 1 January 1901" ^ self epoch ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:09'! noon ^ self now noon! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:58'! readFrom: aStream | bc year month day hour minute second nanos offset buffer ch | aStream peek = $- ifTrue: [ aStream next. bc _ -1] ifFalse: [bc _ 1]. year _ (aStream upTo: $-) asInteger * bc. month _ (aStream upTo: $-) asInteger. day _ (aStream upTo: $T) asInteger. hour _ (aStream upTo: $:) asInteger. buffer _ '00:'. ch _ nil. minute _ WriteStream on: buffer. [ aStream atEnd | (ch = $:) | (ch = $+) | (ch = $-) ] whileFalse: [ ch _ minute nextPut: aStream next. ]. (ch isNil or: [ch isDigit]) ifTrue: [ ch _ $: ]. minute _ ((ReadStream on: buffer) upTo: ch) asInteger. buffer _ '00.'. second _ WriteStream on: buffer. [ aStream atEnd | (ch = $.) | (ch = $+) | (ch = $-) ] whileFalse: [ ch _ second nextPut: aStream next. ]. (ch isNil or: [ch isDigit]) ifTrue: [ ch _ $. ]. second _ ((ReadStream on: buffer) upTo: ch) asInteger. buffer _ '00000000+'. nanos _ WriteStream on: buffer. [ aStream atEnd | (ch = $+) | (ch = $-) ] whileFalse: [ ch _ nanos nextPut: aStream next. ]. (ch isNil or: [ch isDigit]) ifTrue: [ ch _ $+ ]. nanos _ ((ReadStream on: buffer) upTo: ch) asInteger. aStream atEnd ifTrue: [ offset _ self localOffset ] ifFalse: [offset _ Duration fromString: (ch asString, '0:', aStream upToEnd). (offset = self localOffset) ifTrue: [ offset _ self localOffset ]]. ^ self year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanos offset: offset. " '-1199-01-05T20:33:14.321-05:00' asDateAndTime ' 2002-05-16T17:20:45.00000001+01:01' asDateAndTime ' 2002-05-16T17:20:45.00000001' asDateAndTime ' 2002-05-16T17:20' asDateAndTime ' 2002-05-16T17:20:45' asDateAndTime ' 2002-05-16T17:20:45+01:57' asDateAndTime ' 2002-05-16T17:20:45-02:34' asDateAndTime ' 2002-05-16T17:20:45+00:00' asDateAndTime ' 1997-04-26T01:02:03+01:02:3' asDateAndTime " ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:09'! today ^ self midnight ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 12:19'! tomorrow ^ self today asDate next asDateAndTime! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:53'! year: year day: dayOfYear "Return a DateAndTime" ^ self year: year day: dayOfYear hour: 0 minute: 0 second: 0! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:54'! year: year month: month day: day "Return a DateAndTime, midnight local time" ^ self year: year month: month day: day hour: 0 minute: 0! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:54'! year: year month: month day: day hour: hour minute: minute "Return a DateAndTime" ^ self year: year month: month day: day hour: hour minute: minute second: 0! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 1/7/2004 15:39'! year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanoCount offset: offset "Return a DateAndTime" | monthIndex p q r s julianDayNumber since | monthIndex _ month isInteger ifTrue: [month] ifFalse: [Month indexOfMonth: month]. p _ (monthIndex - 14) quo: 12. q _ year + 4800 + p. r _ monthIndex - 2 - (12 * p). s _ (year + 4900 + p) quo: 100. julianDayNumber _ ( (1461 * q) quo: 4 ) + ( (367 * r) quo: 12 ) - ( (3 * s) quo: 4 ) + ( day - 32075 ). since _ Duration days: julianDayNumber hours: hour minutes: minute seconds: second nanoSeconds: nanoCount. ^ self basicNew ticks: since ticks offset: offset; yourself.! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 12:19'! yesterday ^ self today asDate previous asDateAndTime ! ! !DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp` 8/24/2003 19:09'! fromSeconds: seconds "Answer a DateAndTime since the Squeak epoch: 1 January 1901" | since | since _ Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: seconds. ^ self basicNew ticks: since ticks offset: self localOffset; yourself. ! ! !DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:00'! millisecondClockValue ^ Time millisecondClockValue! ! !DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:00' prior: 35462143! millisecondClockValue ^ Time millisecondClockValue! ! !DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:01'! totalSeconds ^ Time totalSeconds! ! !DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:01' prior: 35462425! totalSeconds ^ Time totalSeconds! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! testAsDate self assert: aDateAndTime asDate = 'January 1, 1901' asDate. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:31'! testAsDateAndTime self assert: aDateAndTime asDateAndTime = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:34'! testAsDuration self assert: aDateAndTime asDuration = 0 asDuration ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:06'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime utcOffset: aDateAndTime class localOffset) ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:27'! testAsMonth self assert: aDateAndTime asMonth = (Month month: 'January' year: 1901). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:59'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = 0 asDuration asNanoSeconds ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:01'! testAsSeconds self assert: aDateAndTime asSeconds = 0 asDuration asSeconds ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:32'! testAsTime self assert: aDateAndTime asTime = Time midnight. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:51'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = TimeStamp new. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:07'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:43'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '12-31-1900' asDate). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:43'! testAsYear self assert: aDateAndTime asYear = (Year starting: '01-01-1901' asDate). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'! testCurrent self deny: aDateAndTime = (DateAndTime current). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:46'! testDateTime self assert: aDateAndTime = (DateAndTime date: '01-01-1901' asDate time: '00:00:00' asTime) ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! testDay self assert: aDateAndTime day = DateAndTime new day ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:08'! testDayMonthYearDo |iterations| iterations := 0. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | iterations := iterations + 1]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 1901. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 1. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 15:45'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 1. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:47'! testDayOfWeek self assert: aDateAndTime dayOfWeek = 3. self assert: aDateAndTime dayOfWeekAbbreviation = 'Tue'. self assert: aDateAndTime dayOfWeekName = 'Tuesday'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! testDayOfYear self assert: aDateAndTime dayOfYear = 1. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testDaysInMonth self assert: aDateAndTime daysInMonth = 31. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testDaysInYear self assert: aDateAndTime daysInYear = 365. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 364. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:24'! testDuration self assert: aDateAndTime duration = 0 asDuration. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:25'! testEpoch self assert: aDateAndTime = '1901-01-01T00:00:00+00:00'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:44'! testFirstDayOfMonth self assert: aDateAndTime firstDayOfMonth = 1 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:25'! testFromSeconds self assert: aDateAndTime = (DateAndTime fromSeconds: 0). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:26'! testFromString self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00'). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testHash self assert: aDateAndTime hash = DateAndTime new hash. self assert: aDateAndTime hash = 199296261 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:59'! testHour self assert: aDateAndTime hour = aDateAndTime hour24. self assert: aDateAndTime hour = 0. self assert: aDateAndTime hour = aDateAndTime hours ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:57'! testHour12 self assert: aDateAndTime hour12 = DateAndTime new hour12. self assert: aDateAndTime hour12 = 1 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:21' prior: 35468021! testHour12 self assert: aDateAndTime hour12 = DateAndTime new hour12. self assert: aDateAndTime hour12 = 12 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testIsLeapYear self deny: aDateAndTime isLeapYear ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:18'! testJulianDayNumber self assert: aDateAndTime = (DateAndTime julianDayNumber: 2415386). self assert: aDateAndTime julianDayNumber = 2415386.! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:20'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:40'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'AM'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:37'! testMiddleOf self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) = (Timespan starting: '12-31-1900' asDate duration: 2 days). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:39'! testMidnight self assert: aDateAndTime midnight = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:03'! testMinus self assert: aDateAndTime - aDateAndTime = '0:00:00:00' asDuration. self assert: aDateAndTime - '0:00:00:00' asDuration = aDateAndTime. self assert: aDateAndTime - aDuration = (DateAndTime year: 1900 month: 12 day: 30 hour: 21 minute: 56 second: 55 nanoSecond: 999999995 offset: 0 hours ). " I believe this Failure is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:35'! testMinute self assert: aDateAndTime minute = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:41'! testMinutes self assert: aDateAndTime minutes = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:46'! testMonth self assert: aDateAndTime month = 1. self assert: aDateAndTime monthAbbreviation = 'Jan'. self assert: aDateAndTime monthName = 'January'. self assert: aDateAndTime monthIndex = 1.! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:47'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:27'! testNew self assert: aDateAndTime = (DateAndTime new). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:49'! testNoon self assert: aDateAndTime noon = '1901-01-01T12:00:00+00:00'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'! testNow self deny: aDateAndTime = (DateAndTime now). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:41'! testOffset self assert: aDateAndTime offset = '0:00:00:00' asDuration. self assert: (aDateAndTime offset: '0:12:00:00') = '1901-01-01T00:00:00+12:00'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 11:03'! testPlus self assert: aDateAndTime + '0:00:00:00' = aDateAndTime. self assert: aDateAndTime + 0 = aDateAndTime. self assert: aDateAndTime + aDuration = (DateAndTime year: 1901 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:37'! testPrintOn |cs rw | cs _ ReadStream on: ' 1901-01-01T00:00:00+00:00'. rw _ ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs _ ReadStream on: 'a TimeZone(ETZ)'. rw _ ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'nk 3/12/2004 10:16' prior: 35471797! testPrintOn | cs rw | cs := ReadStream on: '1901-01-01T00:00:00+00:00'. rw := ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs := ReadStream on: 'a TimeZone(ETZ)'. rw := ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:22'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:22'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:25'! testTicks self assert: aDateAndTime ticks = (DateAndTime julianDayNumber: 2415386) ticks. self assert: aDateAndTime ticks = #(2415386 0 0)! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:31'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2415386 0 0) offset: DateAndTime localOffset). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:42'! testTo self assert: (aDateAndTime to: aDateAndTime) = (DateAndTime new to: DateAndTime new) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:43'! testToBy self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days) = (DateAndTime new to: DateAndTime new + 10 days by: 5 days ) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:53'! testToByDo "self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days do: []) = " "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:35'! testToday self deny: aDateAndTime = (DateAndTime today). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:45'! testTommorrow self assert: (DateAndTime today + 24 hours) = (DateAndTime tomorrow). self deny: aDateAndTime = (DateAndTime tomorrow). "MessageNotUnderstood: Date class>>starting:"! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:58'! testUtcOffset self assert: (aDateAndTime utcOffset: '0:12:00:00') = '1901-01-01T12:00:00+12:00'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 21:00'! testYear self assert: aDateAndTime year = 1901. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:30'! testYearDay self assert: aDateAndTime = (DateAndTime year: 1901 day: 1). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! testYearDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1901 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! testYearMonthDay self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! testYearMonthDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:23'! testYearMonthDayHourMinuteSecondNanosSecondOffset self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset:0 hours ). self assert: ((DateAndTime year: 1 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset: 0 hours ) + (Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) ) = (DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"" I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:47'! testYesterday self deny: aDateAndTime = (DateAndTime yesterday). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:12'! testtimeZone self assert: aDateAndTime timeZoneName = 'Grenwich Mean Time'. self assert: aDateAndTime timeZoneAbbreviation = 'GMT' ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26' prior: 35476508! testtimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 10:58'! setUp localTimeZoneToRestore := DateAndTime localTimeZone. aDateAndTime := DateAndTime localTimeZone: TimeZone default; epoch. aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'Epoch Test Time Zone' abbreviation: 'ETZ'. aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! !DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 11:04'! tearDown DateAndTime localTimeZone: localTimeZoneToRestore. "wish I could remove the time zones I added earlier, tut there is no method for that" ! ! !DateAndTimeEpochTest commentStamp: 'tlk 1/6/2004 18:27' prior: 0! I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. The other Chronology sunit test cases are: DateTestCase DateAndTimeLeapTestCase, DurationTestCase, ScheduleTestCase TimeStampTestCase TimespanDoTestCase, TimespanDoSpanAYearTestCase, TimespanTestCase, YearMonthWeekTestCase. These tests attempt to exercise all public and private methods. Except, they do not explicitly depreciated methods. tlk My fixtures are: aDateAndTime = January 01, 1901 midnight (the start of the Squeak epoch) with localTimeZone = Grenwhich Meridian (local offset = 0 hours) aDuration = 1 day, 2 hours, 3, minutes, 4 seconds and 5 nano seconds. aTimeZone = 'Epoch Test Time Zone', 'ETZ' , offset: 12 hours, 15 minutes. ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:00'! testAsDate self assert: aDateAndTime asDate = 'February 29, 2004' asDate. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:55'! testAsDuration self assert: aDateAndTime asDuration = aDuration ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:00'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime utcOffset: aDateAndTime class localOffset) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:24'! testAsMonth self assert: aDateAndTime asMonth = (Month month: 'February' year: 2004). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:59'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = aDuration asNanoSeconds. self assert: aDateAndTime asNanoSeconds = 48780000000000 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:05'! testAsSeconds self assert: aDuration asSeconds = 48780. self assert: aDateAndTime asSeconds = 3255507180 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:26'! testAsTime self assert: aDateAndTime asTime = (Time hour: 13 minute: 33 second: 0) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:31'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = ((TimeStamp readFrom: '2-29-2004 1:33 pm' readStream) offset: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:59'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:30'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '02-29-2004' asDate). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:36'! testAsYear self assert: aDateAndTime asYear = (Year starting: '02-29-2004' asDate). self deny: aDateAndTime asYear = (Year starting: '01-01-2004' asDate) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:23'! testDay self assert: aDateAndTime day = 60. self deny: aDateAndTime day = 29 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:16'! testDayMonthYearDo self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 2004. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 2. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 29. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:17'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 29. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:34'! testDayOfWeek self assert: aDateAndTime dayOfWeek = 1. self assert: aDateAndTime dayOfWeekAbbreviation = 'Sun'. self assert: aDateAndTime dayOfWeekName = 'Sunday'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:59'! testDayOfYear self assert: aDateAndTime dayOfYear = 60. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testDaysInMonth self assert: aDateAndTime daysInMonth = 29. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testDaysInYear self assert: aDateAndTime daysInYear = 366. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 306. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:38'! testFirstDayOfMonth self deny: aDateAndTime firstDayOfMonth = 1. self assert: aDateAndTime firstDayOfMonth = 32 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 10:43'! testFromString self assert: aDateAndTime = (DateAndTime fromString: ' 2004-02-29T13:33:00+02:00'). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testHash self assert: aDateAndTime hash = 29855404 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 10:48'! testHour self assert: aDateAndTime hour = aDateAndTime hour24. self assert: aDateAndTime hour = 13. self assert: aDateAndTime hour = aDateAndTime hours ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:57'! testHour12 self assert: aDateAndTime hour12 = 2. self deny: aDateAndTime hour12 = 1 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:19' prior: 35482723! testHour12 self assert: aDateAndTime hour12 = 1. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:35'! testIsLeapYear self assert: aDateAndTime isLeapYear ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:42'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'PM'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:12'! testMiddleOf self assert: (aDateAndTime middleOf: aDuration) = (Timespan starting: (DateAndTime year: 2004 month: 2 day: 29 hour: 6 minute: 46 second: 30 offset: 2 hours) duration: (Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 )) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:57'! testMidnight self assert: aDateAndTime midnight = '2004-02-29T00:00:00+00:00'. self deny: aDateAndTime midnight = '2004-02-29T00:00:00+02:00' ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:00'! testMinute self assert: aDateAndTime minute = 33 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:44'! testMinutes self assert: aDateAndTime minutes = 33 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:02'! testMonth self assert: aDateAndTime month = 2. self assert: aDateAndTime monthAbbreviation = 'Feb'. self assert: aDateAndTime monthName = 'February'. self assert: aDateAndTime monthIndex = 2.! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:03'! testNoon self assert: aDateAndTime noon = '2004-02-29T12:00:00+00:00'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:07'! testOffset self assert: aDateAndTime offset = '0:02:00:00' asDuration. self assert: (aDateAndTime offset: '0:12:00:00') = '2004-02-29T13:33:00+12:00'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:42'! testPrintOn |cs rw | cs _ ReadStream on: ' 2004-02-29T13:33:00+02:00'. rw _ ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs _ ReadStream on: 'a TimeZone(GMT)'. rw _ ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:27' prior: 35485142! testPrintOn | cs rw | cs := ReadStream on: '2004-02-29T13:33:00+02:00'. rw := ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs := ReadStream on: 'a TimeZone(UTC)'. rw := ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:12'! testTicks self assert: aDateAndTime ticks = ((DateAndTime julianDayNumber: 2453065) + 48780 seconds) ticks. self assert: aDateAndTime ticks = #(2453065 48780 0)! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:52'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2453065 48780 0) offset: DateAndTime localOffset). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:51'! testUtcOffset self assert: (aDateAndTime utcOffset: '0:02:00:00') = '2004-02-29T13:33:00+02:00'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:17'! testYear self assert: aDateAndTime year = 2004. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:21'! testYearDayHourMinuteSecond self assert: aDateAndTime = ((DateAndTime year: 2004 day: 60 hour: 13 minute: 33 second: 0) offset: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:23'! testYearMonthDayHourMinuteSecond self assert: aDateAndTime = ((DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0) offset: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testtimeZone self assert: aDateAndTime timeZoneName = 'Grenwich Mean Time'. self assert: aDateAndTime timeZoneAbbreviation = 'GMT' ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26' prior: 35487405! testtimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeLeapTest methodsFor: 'running' stamp: 'tlk 1/2/2004 21:54'! setUp localTimeZoneToRestore := DateAndTime localTimeZone. "so how do I set local time zone?" aDateAndTime := (DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0 offset: 2 hours). aTimeZone := TimeZone default. aDuration := Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 ! ! !DateAndTimeLeapTest methodsFor: 'running' stamp: 'nk 3/12/2004 11:00' prior: 35487841! setUp localTimeZoneToRestore := DateAndTime localTimeZone. DateAndTime localTimeZone: TimeZone default. aDateAndTime := (DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0 offset: 2 hours). aTimeZone := TimeZone default. aDuration := Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 ! ! !DateAndTimeLeapTest methodsFor: 'running' stamp: 'tlk 1/2/2004 21:30'! tearDown DateAndTime localTimeZone: localTimeZoneToRestore. "wish I could remove the time zones I added earlier, tut there is no method for that" ! ! !DateAndTimeLeapTest commentStamp: 'tlk 1/6/2004 17:54' prior: 0! I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. tlk. My fixtures are: aDateAndTime = February 29, 2004 1:33 PM with offset: 2 hours aDuration = 15 days, 14 hours, 13 minutes, 12 seconds and 11 nano seconds. aTimeZone = Grenwhich Meridian (local offset = 0 hours) ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 17:00'! testArithmeticAcrossDateBoundary | t1 t2 | t1 _ '2004-01-07T11:55:00+00:00' asDateAndTime. t2 _ t1 - ( (42900+1) seconds). self assert: t2 = ('2004-01-06T23:59:59+00:00' asDateAndTime) ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 15:37'! testInstanceCreation | t | t _ DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. self assert: (t julianDayNumber = 1721427); assert: (t offset = 6 hours); assert: (t hour = 2); assert: (t minute = 3); assert: (t second = 4); assert: (t nanoSecond = 5). ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 09:47'! testMonotonicity | t1 t2 t3 t4 | t1 _ DateAndTime now. t2 _ DateAndTime now. t3 _ DateAndTime now. t4 _ DateAndTime now. self assert: ( t1 < t2); assert: ( t2 < t3); assert: ( t3 < t4). ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'nk 3/12/2004 11:06' prior: 35489992! testMonotonicity | t1 t2 t3 t4 | t1 := DateAndTime now. t2 := DateAndTime now. (Delay forMilliseconds: 1000) wait. t3 := DateAndTime now. t4 := DateAndTime now. self assert: ( t1 <= t2); assert: ( t2 < t3); assert: ( t3 <= t4). ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 15:43'! testSmalltalk80Accessors | t | t _ DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. self assert: (t hours = t hours); assert: (t minutes = t minute); assert: (t seconds = t second). ! ! !DateAndTimeTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 09:25'! classToBeTested ^ DateAndTime ! ! !DateAndTimeTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 09:25'! selectorsToBeIgnored | private | private := #( #printOn: ). ^ super selectorsToBeIgnored, private ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 16:07'! testAccessing self assert: date day = 153; assert: date julianDayNumber = 2441836; assert: date leap = 0; assert: date monthIndex = 6; assert: date monthName = #June; assert: date weekday = #Saturday; assert: date weekdayIndex = 7; assert: date year = 1973. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:10'! testArithmetic | d | d := date addDays: 32. "4 July 1973" self assert: d year = 1973; assert: d monthIndex = 7; assert: d dayOfMonth = 4. self assert: (d subtractDate: date) = 32; assert: (date subtractDate: d) = -32. self assert: (d subtractDays: 32) = date. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:54'! testComparing | d1 d2 d3 | d1 := self dateClass newDay: 2 month: #June year: 1973. d2 := self dateClass newDay: 97 year: 2003. "7 April 2003" d3 := self dateClass newDay: 250 year: 1865. "7 September 1865" self assert: date = d1; assert: date = date copy; assert: date hash = d1 hash. self assert: date < d2; deny: date < d3. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:15'! testConverting self assert: date asDate = date; assert: '2 June 1973' asDate = date; assert: date asSeconds = 2285280000. date dayMonthYearDo: [ :d :m :y | self assert: d = 2; assert: m = 6; assert: y = 1973 ].! ! !DateTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:47'! testFromDays | epoch d0 d1 d2 | epoch := self dateClass newDay: 1 year: 1901. d0 := self dateClass fromDays: 0. "1 January 1901" self assert: d0 = epoch. d1 := self dateClass fromDays: 26450. "2 June 1973" self assert: d1 = date. d2 := self dateClass fromDays: -100000. "18 March 1627" self assert: d2 julianDayNumber = 2315386. self assert: aDate = (Date fromDays: 37642). self assert: aDate = (Date fromDays: 103*365 + 22 + 25 "leap days") . ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:17'! testFromSeconds | d | d := self dateClass fromSeconds: 2285280000. self assert: d = date. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 16:37'! testGeneralInquiries | shuffled indices names now | shuffled := #(#January #February #March #April #May #June #July #August #September #October #November #December) shuffled. indices := shuffled collect: [ :m | self dateClass indexOfMonth: m ]. names := indices collect: [ :i | self dateClass nameOfMonth: i ]. self assert: names = shuffled. shuffled := #(#Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday) shuffled. indices := shuffled collect: [ :m | self dateClass dayOfWeek: m ]. names := indices collect: [ :i | self dateClass nameOfDay: i ]. self assert: names = shuffled. now := self dateClass dateAndTimeNow. self assert: now size = 2; assert: now first = self dateClass today. self assert: (self dateClass firstWeekdayOfMonth: #June year: 1973) = 6. self assert: (self dateClass leapYear: 1973) = 0; assert: (self dateClass leapYear: 1972) = 1; assert: (self dateClass daysInYear: 1973) = 365; assert: (self dateClass daysInYear: 1972) = 366; assert: (self dateClass daysInMonth: #February forYear: 1973) = 28; assert: (self dateClass daysInMonth: #February forYear: 1972) = 29. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:17'! testInitialization self should: [ self dateClass initialize. true ]. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:18'! testInquiries self assert: date dayOfMonth = 2; assert: date dayOfYear = 153; assert: date daysInMonth = 30; assert: date daysInYear = 365; assert: date daysLeftInYear = (365 - 153); assert: date firstDayOfMonth = 152. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:05'! testNew | epoch | epoch := self dateClass newDay: 1 year: 1901. self assert: (self dateClass new = epoch).! ! !DateTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 16:33'! testPreviousNext | n p pt ps | n := date next. p := date previous. self assert: n year = 1973; assert: n dayOfYear = 154; assert: p year = 1973; assert: p dayOfYear = 152. pt := date previous: #Thursday. "31 May 1973" self assert: pt year = 1973; assert: pt dayOfYear = 151. ps := date previous: #Saturday. " 26 May 1973" self assert: ps year = 1973; assert: ps dayOfYear = (153-7). ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:21'! testPrinting self assert: date mmddyyyy = '6/2/1973'; assert: date yyyymmdd = '1973-06-02'; assert: (date printFormat: #(3 1 2 $!! 2 1 1)) = '1973!!2!!Jun'. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:23'! testReadFrom | s1 s2 s3 s4 s5 | s1 := '2 June 1973'. s2 := '2-JUN-73'. s3 := 'June 2, 1973'. s4 := '6/2/73'. s5 := '2JUN73'. self assert: date = (self dateClass readFrom: s1 readStream); assert: date = (self dateClass readFrom: s2 readStream); assert: date = (self dateClass readFrom: s3 readStream); assert: date = (self dateClass readFrom: s4 readStream); assert: date = (self dateClass readFrom: s5 readStream).! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:05'! testStoring self assert: date storeString = '''2 June 1973'' asDate'; assert: date = ('2 June 1973' asDate). ! ! !DateTest methodsFor: 'Private' stamp: 'brp 8/24/2003 00:10'! dateClass ^ Date! ! !DateTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:01'! classToBeTested ^ self dateClass! ! !DateTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 14:05'! selectorsToBeIgnored | deprecated private special | deprecated := #( #fromJulianDayNumber: #uniqueDateStringBetween:and: #daylightSavingsInEffectAtStandardHour: #daylightSavingsInEffect #asGregorian #asJulianDayNumber #day:year: #firstDayOfMonthIndex: #mmddyy #absoluteDaysToYear: #yearAndDaysFromDays:into: #week #month ). private := #( #julianDayNumber: ). special := #( #< #= #new #next #previous #printOn: #printOn:format: #storeOn: #fromString: ). ^ super selectorsToBeIgnored, deprecated, private, special! ! !DateTest methodsFor: 'Running' stamp: 'brp 1/21/2004 18:46'! setUp date := self dateClass newDay: 153 year: 1973. "2 June 1973" aDate := Date readFrom: '01-23-2004' readStream. aTime := Time readFrom: '12:34:56 pm' readStream! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testAddDays self assert: (aDate addDays: 00) yyyymmdd = '2004-01-23'. self assert: (aDate addDays: 30) yyyymmdd = '2004-02-22'. self assert: (aDate addDays: 60) yyyymmdd = '2004-03-23'. self assert: (aDate addDays: 90) yyyymmdd = '2004-04-22'. self assert: (aDate addDays:120) yyyymmdd = '2004-05-22'! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testAsDate self assert: (aDate asDate) = aDate ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testAsSeconds self assert: (aDate asSeconds) = 3252268800. self assert: (aDate asSeconds) = ((103*365*24*60*60) + (22+25"leap days"*24*60*60)) . self assert: aDate = (Date fromSeconds: 3252268800).! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDateAndTimeNow "Not a great test: could falsely fail if midnight come in between the two executions and doesnt catch time errors" self assert: Date dateAndTimeNow first = Date today ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDayMonthYearDo self assert: (aDate dayMonthYearDo: [:day :month :year | day asString , month asString, year asString]) = '2312004' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDaysInMonthForYear self assert: (Date daysInMonth: 'February' forYear: 2008) = 29. self assert: (Date daysInMonth: 'February' forYear: 2000) = 29. self assert: (Date daysInMonth: 'February' forYear: 2100) = 28. self assert: (Date daysInMonth: 'July' forYear: 2100) = 31. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDaysInYear self assert: (Date daysInYear: 2008) = 366. self assert: (Date daysInYear: 2000) = 366. self assert: (Date daysInYear: 2100) = 365 ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDuration self assert: aDate duration = 24 hours! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testEqual self assert: aDate = (Date readFrom: (ReadStream on: 'January 23, 2004')).! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testFirstWeekdayOfMonthYear self assert: (Date firstWeekdayOfMonth: 'January' year: 2004) = 5. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testIndexOfMonth self assert: (Date indexOfMonth: 'January') = 1. self assert: (Date indexOfMonth: 'December') = 12. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testJulianDayNumber self assert: aDate = (Date julianDayNumber: ((4713+2004)*365 +1323) ). ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testLeap self assert: aDate leap = 1. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testLeapNot self assert: (aDate addDays: 365) leap = 0 ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testLessThan self assert: aDate < (Date readFrom: (ReadStream on: '01-24-2004')).! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testMmddyyyy self assert: aDate mmddyyyy = '1/23/2004'! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testNameOfMonth self assert: (Date nameOfMonth: 5) = 'May'. self assert: (Date nameOfMonth: 8) = 'August' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testNewDayMonthYear self assert: aDate = (Date newDay: 23 month: 1 year: 2004) ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testNewDayYear self assert: aDate = (Date newDay: 23 year: 2004) ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPreviousFriday self assert: (aDate previous: 'Friday') yyyymmdd = '2004-01-16' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPreviousThursday self assert: (aDate previous: 'Thursday') yyyymmdd = '2004-01-22' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPrintFormat self assert: (aDate printFormat: #(1 2 3 $? 2 2)) = '23?Jan?04'! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPrintOn | cs rw | cs := ReadStream on: '23 January 2004'. rw := ReadWriteStream on: ''. aDate printOn: rw. self assert: rw contents = cs contents! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPrintOnFormat | cs rw | cs := ReadStream on: '04*Jan*23'. rw := ReadWriteStream on: ''. aDate printOn: rw format: #(3 2 1 $* 2 2). self assert: rw contents = cs contents! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testStarting self assert: aDate = (Date starting: (DateAndTime fromString: '2004-01-23T12:12')). ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testStoreOn | cs rw | cs := ReadStream on: '''23 January 2004'' asDate'. rw := ReadWriteStream on: ''. aDate storeOn: rw. self assert: rw contents = cs contents! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testSubtractDate self assert: (aDate subtractDate:(aDate addDays: 30)) = -30. self assert: (aDate subtractDate:(aDate subtractDays: 00)) = 0. self assert: (aDate subtractDate:(aDate subtractDays: 30)) = 30. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testSubtractDays self assert: (aDate subtractDays: 00) yyyymmdd = '2004-01-23'. self assert: (aDate subtractDays: 30) yyyymmdd = '2003-12-24'. self assert: (aDate subtractDays: 60) yyyymmdd = '2003-11-24' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testTomorrow "Not a great test: could falsely fail if midnight come in between the two executions and doesnt catch many errors" self assert: Date tomorrow > Date today ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testWeekday self assert: aDate weekday = 'Friday'. self assert: aDate weekdayIndex = 6. self assert: (Date dayOfWeek: aDate weekday ) =6. self assert: (Date nameOfDay: 6 ) = 'Friday' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testYesterday "Not a great test: doesnt catch many errors" self assert: Date yesterday < Date today ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testYyyymmdd self assert: aDate yyyymmdd = '2004-01-23'! ! !DateTest commentStamp: 'brp 7/26/2003 16:58' prior: 0! This is the unit test for the class Date. ! !Debugger methodsFor: 'initialize' stamp: 'sw 1/16/2002 20:03'! buildMVCNotifierButtonView | aView bHeight priorButton buttonView | aView _ View new model: self. bHeight _ self notifierButtonHeight. aView window: (0@0 extent: 350@bHeight). priorButton _ nil. self preDebugButtonQuads do: [:aSpec | buttonView _ PluggableButtonView on: self getState: nil action: aSpec second. buttonView label: aSpec first; insideColor: (Color perform: aSpec third) muchLighter lighter; borderWidthLeft: 1 right: 1 top: 0 bottom: 0; window: (0@0 extent: 117@bHeight). priorButton ifNil: [aView addSubView: buttonView] ifNotNil: [aView addSubView: buttonView toRightOf: priorButton]. priorButton _ buttonView]. ^ aView! ! !Debugger methodsFor: 'initialize' stamp: 'hmm 7/30/2001 17:25'! buildMVCOptionalButtonsButtonsView | aView bHeight offset aButtonView wid pairs windowWidth previousView | aView _ View new model: self. bHeight _ self optionalButtonHeight. windowWidth _ 150. aView window: (0@0 extent: windowWidth@bHeight). offset _ 0. pairs _ self optionalButtonPairs. previousView _ nil. pairs do: [:pair | aButtonView _ PluggableButtonView on: self getState: nil action: pair second. pair second = pairs last second ifTrue: [wid _ windowWidth - offset] ifFalse: [aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0. wid _ windowWidth // (pairs size)]. aButtonView label: pair first asParagraph; insideColor: Color red muchLighter lighter; window: (offset@0 extent: wid@bHeight). offset _ offset + wid. pair second = pairs first second ifTrue: [aView addSubView: aButtonView] ifFalse: [aView addSubView: aButtonView toRightOf: previousView]. previousView _ aButtonView]. ^ aView! ! !Debugger methodsFor: 'initialize' stamp: 'ar 8/16/2001 11:27'! buttonRowForPreDebugWindow: aDebugWindow | aRow aButton | aRow _ AlignmentMorph newRow hResizing: #spaceFill. aRow beSticky. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer. self preDebugButtonQuads do: [:quad | aButton _ SimpleButtonMorph new target: aDebugWindow. aButton color: Color transparent; borderWidth: 1. aButton actionSelector: quad second. aButton label: quad first. aButton submorphs first color: (Color colorFrom: quad third). aButton setBalloonText: quad fourth. Preferences alternativeWindowLook ifTrue:[aButton borderWidth: 2; borderColor: #raised]. aRow addMorphBack: aButton. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer]. ^ aRow! ! !Debugger methodsFor: 'initialize' stamp: 'nk 2/12/2003 22:56' prior: 35505649! buttonRowForPreDebugWindow: aDebugWindow | aRow aButton quads | aRow _ AlignmentMorph newRow hResizing: #spaceFill. aRow beSticky. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer. quads _ OrderedCollection withAll: self preDebugButtonQuads. (self interruptedContext selector == #doesNotUnderstand:) ifTrue: [ quads add: { 'Create'. #createMethod. #magenta. 'create the missing method' } ]. quads do: [:quad | aButton _ SimpleButtonMorph new target: aDebugWindow. aButton color: Color transparent; borderWidth: 1. aButton actionSelector: quad second. aButton label: quad first. aButton submorphs first color: (Color colorFrom: quad third). aButton setBalloonText: quad fourth. Preferences alternativeWindowLook ifTrue:[aButton borderWidth: 2; borderColor: #raised]. aRow addMorphBack: aButton. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer]. ^ aRow! ! !Debugger methodsFor: 'initialize' stamp: 'sw 8/21/2002 18:40'! customButtonRow "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'customButtonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" | aRow aButton aLabel | aRow _ AlignmentMorph newRow beSticky. aRow setNameTo: 'customButtonPane'. aRow clipSubmorphs: true. aButton _ SimpleButtonMorph new target: self. aButton color: Color lightRed; borderWidth: 1; borderColor: Color red darker. aRow addTransparentSpacerOfSize: (5@0). self customButtonSpecs do: [:tuple | aButton _ PluggableButtonMorph on: self getState: nil action: tuple second. aButton hResizing: #spaceFill; vResizing: #spaceFill; useRoundedCorners; onColor: Color transparent offColor: Color transparent. (#(proceed restart send doStep stepIntoBlock fullStack where) includes: tuple second) ifTrue: [aButton askBeforeChanging: true]. aLabel _ Preferences abbreviatedBrowserButtons ifTrue: [self abbreviatedWordingFor: tuple second] ifFalse: [nil]. aButton label: (aLabel ifNil: [tuple first asString]). tuple size > 2 ifTrue: [aButton setBalloonText: tuple third]. Preferences alternativeWindowLook ifTrue:[aButton borderWidth: 2; borderColor: #raised]. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0)]. ^ aRow! ! !Debugger methodsFor: 'initialize' stamp: 'sw 8/21/2002 18:41'! customButtonSpecs "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." | list | list _ #(('Proceed' proceed 'close the debugger and proceed.') ('Restart' restart 'reset this context to its start.') ('Send' send 'step into message sends') ('Step' doStep 'step over message sends') ('Through' stepIntoBlock 'step into a block') ('Full Stack' fullStack 'show full stack') ('Where' where 'select current pc range')). Preferences restartAlsoProceeds ifTrue: [list _ list collect: [:each | each second == #restart ifTrue: [each copy at: 3 put: 'proceed from the beginning of this context.'; yourself] ifFalse: [each]]]. ^ list! ! !Debugger methodsFor: 'initialize' stamp: 'ab 2/25/2004 18:59' prior: 35508934! customButtonSpecs "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." | list | list _ #(('Proceed' proceed 'close the debugger and proceed.') ('Restart' restart 'reset this context to its start.') ('Into' send 'step Into message sends') ('Over' doStep 'step Over message sends') ('Through' stepIntoBlock 'step into a block') ('Full Stack' fullStack 'show full stack') ('Where' where 'select current pc range')). Preferences restartAlsoProceeds ifTrue: [list _ list collect: [:each | each second == #restart ifTrue: [each copy at: 3 put: 'proceed from the beginning of this context.'; yourself] ifFalse: [each]]]. ^ list! ! !Debugger methodsFor: 'initialize' stamp: 'ajh 7/20/2003 23:41'! errorWasInUIProcess: boolean errorWasInUIProcess _ boolean! ! !Debugger methodsFor: 'initialize' stamp: 'tk 5/9/2003 11:20'! initialExtent "Make the full debugger longer!!" dependents size < 9 ifTrue: [^ super initialExtent]. "Pre debug window" RealEstateAgent standardWindowExtent y < 400 "a tiny screen" ifTrue: [^ super initialExtent]. ^ 600@700 ! ! !Debugger methodsFor: 'initialize' stamp: 'sw 10/29/2001 20:01'! openFullMorphicLabel: aLabelString "Open a full morphic debugger with the given label" | window aListMorph oldContextStackIndex | oldContextStackIndex _ contextStackIndex. self expandStack. "Sets contextStackIndex to zero." window _ (SystemWindow labelled: aLabelString) model: self. aListMorph _ PluggableListMorph on: self list: #contextStackList selected: #contextStackIndex changeSelected: #toggleContextStackIndex: menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (0@0 corner: 1@0.3). self addLowerPanesTo: window at: (0@0.3 corner: 1@0.7) with: nil. window addMorph: ( PluggableListMorph new doubleClickSelector: #inspectSelection; on: self receiverInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) frame: (0@0.7 corner: 0.2@1). window addMorph: (PluggableTextMorph on: self receiverInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0.2@0.7 corner: 0.5@1). window addMorph: ( PluggableListMorph new doubleClickSelector: #inspectSelection; on: self contextVariablesInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) frame: (0.5@0.7 corner: 0.7@1). window addMorph: (PluggableTextMorph on: self contextVariablesInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0.7@0.7 corner: 1@1). window openInWorld. self toggleContextStackIndex: oldContextStackIndex. ^ window ! ! !Debugger methodsFor: 'initialize' stamp: 'tk 5/9/2003 11:07' prior: 35511029! openFullMorphicLabel: aLabelString "Open a full morphic debugger with the given label" | window aListMorph oldContextStackIndex | oldContextStackIndex _ contextStackIndex. self expandStack. "Sets contextStackIndex to zero." window _ (SystemWindow labelled: aLabelString) model: self. aListMorph _ PluggableListMorph on: self list: #contextStackList selected: #contextStackIndex changeSelected: #toggleContextStackIndex: menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (0@0 corner: 1@0.25). self addLowerPanesTo: window at: (0@0.25 corner: 1@0.8) with: nil. window addMorph: ( PluggableListMorph new doubleClickSelector: #inspectSelection; on: self receiverInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) frame: (0@0.8 corner: 0.2@1). window addMorph: (PluggableTextMorph on: self receiverInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0.2@0.8 corner: 0.5@1). window addMorph: ( PluggableListMorph new doubleClickSelector: #inspectSelection; on: self contextVariablesInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) frame: (0.5@0.8 corner: 0.7@1). window addMorph: (PluggableTextMorph on: self contextVariablesInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0.7@0.8 corner: 1@1). window openInWorld. self toggleContextStackIndex: oldContextStackIndex. ^ window ! ! !Debugger methodsFor: 'initialize' stamp: 'di 10/28/2001 10:59'! openNotifierContents: msgString label: label "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." | msg topView p | Sensor flushKeyboard. savedCursor _ Sensor currentCursor. Sensor currentCursor: Cursor normal. (label beginsWith: 'Space is low') ifTrue: [msg _ self lowSpaceChoices, (msgString ifNil: [''])] ifFalse: [msg _ msgString]. isolationHead ifNotNil: ["We have already revoked the isolation layer -- now jump to the parent project." msg _ self isolationRecoveryAdvice, msgString. failedProject _ Project current. isolationHead parent enterForEmergencyRecovery]. Smalltalk isMorphic ifTrue: [ self buildMorphicNotifierLabelled: label message: msg. errorWasInUIProcess _ CurrentProjectRefactoring newProcessIfUI: interruptedProcess. ^self ]. Display fullScreen. topView _ self buildMVCNotifierViewLabel: label message: thisContext sender sender shortStack minSize: 350@((14 * 5) + 16 + self optionalButtonHeight). ScheduledControllers activeController ifNil: [p _ Display boundingBox center] ifNotNil: [p _ ScheduledControllers activeController view displayBox center]. topView controller openNoTerminateDisplayAt: (p max: (200@60)). ^ topView! ! !Debugger methodsFor: 'initialize' stamp: 'sw 8/23/2002 00:23'! optionalButtonPairs "Actually, return triples. In mvc (until someone deals with this) only the custom debugger-specific buttons are shown, but in morphic, the standard code-tool buttons are provided in addition to the custom buttons" ^ Smalltalk isMorphic ifFalse: [self customButtonSpecs] ifTrue: [super optionalButtonPairs]! ! !Debugger methodsFor: 'initialize' stamp: 'sw 12/14/2001 01:29'! optionalButtonRow "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'buttonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" | aRow aButton aLabel | aRow _ AlignmentMorph newRow beSticky. aRow setNameTo: 'buttonPane'. aRow clipSubmorphs: true. aButton _ SimpleButtonMorph new target: self. aButton color: Color lightRed; borderWidth: 1; borderColor: Color red darker. aRow addTransparentSpacerOfSize: (5@0). self optionalButtonPairs do: [:tuple | aButton _ PluggableButtonMorph on: self getState: nil action: tuple second. aButton hResizing: #spaceFill; vResizing: #spaceFill; useRoundedCorners; onColor: Color transparent offColor: Color transparent. (#(proceed restart send doStep stepIntoBlock fullStack where) includes: tuple second) ifTrue: [aButton askBeforeChanging: true]. aLabel _ Preferences abbreviatedBrowserButtons ifTrue: [self abbreviatedWordingFor: tuple second] ifFalse: [nil]. aButton label: (aLabel ifNil: [tuple first asString]). tuple size > 2 ifTrue: [aButton setBalloonText: tuple third]. Preferences alternativeWindowLook ifTrue:[aButton borderWidth: 2; borderColor: #raised]. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0)]. ^ aRow! ! !Debugger methodsFor: 'initialize' stamp: 'mir 11/10/2003 15:13' prior: 19961891! preDebugButtonQuads ^Preferences eToyFriendly ifTrue: [ #(('Store log' storeLog blue 'write a log of the encountered problem' ) ('Abandon' abandon black 'abandon this execution by closing this window') ('Debug' debug red 'bring up a debugger'))] ifFalse: [ #(('Proceed' proceed blue 'continue execution' ) ('Abandon' abandon black 'abandon this execution by closing this window') ('Debug' debug red 'bring up a debugger'))] ! ! !Debugger methodsFor: 'initialize' stamp: 'ajh 7/6/2003 17:10' prior: 19962821! windowIsClosing "My window is being closed; clean up. Restart the low space watcher." interruptedProcess == nil ifTrue: [^ self]. [interruptedProcess terminate] on: Error do: []. interruptedProcess _ nil. interruptedController _ nil. contextStack _ nil. contextStackTop _ nil. receiverInspector _ nil. contextVariablesInspector _ nil. Smalltalk installLowSpaceWatcher. "restart low space handler" ! ! !Debugger methodsFor: 'initialize' stamp: 'ajh 3/5/2004 21:31' prior: 35518799! windowIsClosing "My window is being closed; clean up. Restart the low space watcher." interruptedProcess == nil ifTrue: [^ self]. interruptedProcess terminate. interruptedProcess _ nil. interruptedController _ nil. contextStack _ nil. contextStackTop _ nil. receiverInspector _ nil. contextVariablesInspector _ nil. Smalltalk installLowSpaceWatcher. "restart low space handler" ! ! !Debugger methodsFor: 'accessing' stamp: 'sw 5/23/2001 13:37'! contents: aText notifying: aController "The retrieved information has changed and its source must now be updated. In this case, the retrieved information is the method of the selected context." | selector classOfMethod category method priorMethod parseNode | contextStackIndex = 0 ifTrue: [^ false]. (self selectedContext isKindOf: MethodContext) ifFalse: [(self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: self selectedContext home] ifFalse: [^ false]]. classOfMethod _ self selectedClass. category _ self selectedMessageCategoryName. Cursor execute showWhile: [method _ classOfMethod compile: aText notifying: aController trailer: #(0 0 0 0) ifFail: [^ false] elseSetSelectorAndNode: [:sel :methodNode | selector _ sel. selector == self selectedMessageName ifFalse: [self inform: 'can''t change selector'. ^ false]. priorMethod _ (classOfMethod includesSelector: selector) ifTrue: [classOfMethod compiledMethodAt: selector] ifFalse: [nil]. sourceMap _ methodNode sourceMap. tempNames _ methodNode tempNames. parseNode _ methodNode]. method cacheTempNames: tempNames]. category isNil ifFalse: "Skip this for DoIts" [method putSource: aText fromParseNode: parseNode class: classOfMethod category: category inFile: 2 priorMethod: priorMethod. classOfMethod organization classify: selector under: category]. contents _ aText copy. self selectedContext restartWith: method. contextVariablesInspector object: nil. self resetContext: self selectedContext. ^true! ! !Debugger methodsFor: 'accessing' stamp: 'ajh 3/21/2003 00:44' prior: 35519751! contents: aText notifying: aController "The retrieved information has changed and its source must now be updated. In this case, the retrieved information is the method of the selected context." | selector classOfMethod category h ctxt | contextStackIndex = 0 ifTrue: [^ false]. self selectedContext isExecutingBlock ifTrue: [ h _ self selectedContext finalBlockHome. h ifNil: [self inform: 'Method not found for block, can''t edit'. ^ false]. (self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: h] ifFalse: [^ false] ]. classOfMethod _ self selectedClass. category _ self selectedMessageCategoryName. selector _ Compiler parserClass new parseSelector: aText. selector == self selectedMessageName ifFalse: [self inform: 'can''t change selector'. ^ false]. selector _ classOfMethod compile: aText classified: category notifying: aController. selector ifNil: [^ false]. "compile cancelled" contents _ aText. ctxt _ self selectedContext. interruptedProcess popTo: ctxt; restartTopWith: (classOfMethod compiledMethodAt: selector); stepToSendOrReturn. contextVariablesInspector object: nil. theMethodNode _ ctxt methodNode. sourceMap _ theMethodNode sourceMap. tempNames _ theMethodNode tempNames. self resetContext: ctxt. ^true! ! !Debugger methodsFor: 'accessing' stamp: 'nk 2/20/2004 16:00' prior: 35521467! contents: aText notifying: aController "The retrieved information has changed and its source must now be updated. In this case, the retrieved information is the method of the selected context." | selector classOfMethod category h ctxt | contextStackIndex = 0 ifTrue: [^ false]. self selectedContext isExecutingBlock ifTrue: [h := self selectedContext finalBlockHome. h ifNil: [self inform: 'Method not found for block, can''t edit'. ^ false]. (self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: h] ifFalse: [^ false]]. classOfMethod := self selectedClass. category := self selectedMessageCategoryName. selector := self selectedClass parserClass new parseSelector: aText. selector == self selectedMessageName ifFalse: [self inform: 'can''t change selector'. ^ false]. selector := classOfMethod compile: aText classified: category notifying: aController. selector ifNil: [^ false]. "compile cancelled" contents := aText. ctxt := self selectedContext. interruptedProcess popTo: ctxt; restartTopWith: (classOfMethod compiledMethodAt: selector); stepToSendOrReturn. contextVariablesInspector object: nil. theMethodNode := Preferences browseWithPrettyPrint ifTrue: [ ctxt methodNodeFormattedAndDecorated: Preferences colorWhenPrettyPrinting ] ifFalse: [ ctxt methodNode]. sourceMap := theMethodNode sourceMap. tempNames := theMethodNode tempNames. self resetContext: ctxt. ^ true! ! !Debugger methodsFor: 'accessing' stamp: 'ajh 3/5/2004 01:20' prior: 35522907! contents: aText notifying: aController "The retrieved information has changed and its source must now be updated. In this case, the retrieved information is the method of the selected context." | selector classOfMethod category h ctxt | contextStackIndex = 0 ifTrue: [^ false]. self selectedContext isExecutingBlock ifTrue: [h := self selectedContext finalBlockHome. h ifNil: [self inform: 'Method not found for block, can''t edit'. ^ false]. (self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: h] ifFalse: [^ false]]. classOfMethod := self selectedClass. category := self selectedMessageCategoryName. selector := self selectedClass parserClass new parseSelector: aText. selector == self selectedMessageName ifFalse: [self inform: 'can''t change selector'. ^ false]. selector := classOfMethod compile: aText classified: category notifying: aController. selector ifNil: [^ false]. "compile cancelled" contents := aText. ctxt := interruptedProcess popTo: self selectedContext. ctxt == self selectedContext ifFalse: [ self inform: 'Method saved, but current context unchanged because of unwind error. Click OK to see error'. ] ifTrue: [ interruptedProcess restartTopWith: (classOfMethod compiledMethodAt: selector); stepToSendOrReturn. contextVariablesInspector object: nil. theMethodNode := Preferences browseWithPrettyPrint ifTrue: [ctxt methodNodeFormattedAndDecorated: Preferences colorWhenPrettyPrinting] ifFalse: [ctxt methodNode]. sourceMap := theMethodNode sourceMap. tempNames := theMethodNode tempNames. ]. self resetContext: ctxt. ^ true! ! !Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'! labelString ^labelString! ! !Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'! labelString: aString labelString _ aString. self changed: #relabel! ! !Debugger methodsFor: 'notifier menu' stamp: 'jcg 3/7/2003 01:47' prior: 19966830! debug "Open a full DebuggerView." | topView | topView _ self topView. topView model: nil. "so close won't release me." Smalltalk isMorphic ifTrue: [self breakDependents. topView delete. ^ self openFullMorphicLabel: topView label]. topView controller controlTerminate. topView deEmphasize; erase. "a few hacks to get the scroll selection artifacts out when we got here by clicking in the list" topView subViewWantingControl ifNotNil: [ topView subViewWantingControl controller controlTerminate ]. topView controller status: #closed. self openFullNoSuspendLabel: topView label. topView controller closeAndUnscheduleNoErase. Processor terminateActive. ! ! !Debugger methodsFor: 'notifier menu' stamp: 'mir 3/5/2004 19:26'! storeLog | logFileName | logFileName := Preferences debugLogTimestamp ifTrue: ['SqueakDebug-' , Time totalSeconds printString , '.log'] ifFalse: ['SqueakDebug.log']. Smalltalk logError: labelString printString inContext: contextStackTop to: logFileName ! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'ajh 9/25/2001 00:14' prior: 19968257! fullyExpandStack "Expand the stack to include all of it, rather than the first four or five contexts." self okToChange ifFalse: [^ self]. self newStack: contextStackTop contextStack. self changed: #contextStackList! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'ajh 3/19/2003 13:40' prior: 19968708! selectedMessage "Answer the source code of the currently selected context." contents _ theMethodNode sourceText. Preferences browseWithPrettyPrint ifTrue: [ contents _ self selectedClass compilerClass new format: contents in: self selectedClass notifying: nil decorated: Preferences colorWhenPrettyPrinting]. ^ contents _ contents asText makeSelectorBold! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'nk 2/20/2004 15:55' prior: 35528013! selectedMessage "Answer the source code of the currently selected context." contents := theMethodNode sourceText. ^ contents := contents asText makeSelectorBold! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'ajh 9/7/2002 21:15' prior: 19969254! selectedMessageName "Answer the message selector of the currently selected context." ^self selectedContext methodSelector! ! !Debugger methodsFor: 'context stack menu' stamp: 'sd 3/4/2004 20:39'! askForCategoryIn: aClass default: aString | categories index category | categories := OrderedCollection with: 'new ...'. categories addAll: (aClass allMethodCategoriesIntegratedThrough: Object). index := PopUpMenu withCaption: 'Please provide a good category for the new method!!' translated chooseFrom: categories. index = 0 ifTrue: [^ aString]. category := index = 1 ifTrue: [FillInTheBlank request: 'Enter category name:'] ifFalse: [categories at: index]. ^ category isEmpty ifTrue: [^ aString] ifFalse: [category]! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 9/14/2001 00:26'! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." | class selector | class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. VersionsBrowser browseVersionsOf: (class compiledMethodAt: selector) class: self selectedClass theNonMetaClass meta: class isMeta category: self selectedMessageCategoryName selector: selector! ! !Debugger methodsFor: 'context stack menu' stamp: 'hg 10/2/2001 20:22'! buildMorphicNotifierLabelled: label message: messageString | notifyPane window contentTop extentToUse | self expandStack. window _ (PreDebugWindow labelled: label) model: self. contentTop _ 0.2. extentToUse _ 450 @ 156. "nice and wide to show plenty of the error msg" window addMorph: (self buttonRowForPreDebugWindow: window) frame: (0@0 corner: 1 @ contentTop). Preferences eToyFriendly | messageString notNil ifFalse: [notifyPane _ PluggableListMorph on: self list: #contextStackList selected: #contextStackIndex changeSelected: #debugAt: menu: nil keystroke: nil] ifTrue: [notifyPane _ PluggableTextMorph on: self text: nil accept: nil readSelection: nil menu: #debugProceedMenu:. notifyPane editString: (self preDebugNotifierContentsFrom: messageString); askBeforeDiscardingEdits: false]. window addMorph: notifyPane frame: (0@contentTop corner: 1@1). "window deleteCloseBox. chickened out by commenting the above line out, sw 8/14/2000 12:54" window setBalloonTextForCloseBox. ^ window openInWorldExtent: extentToUse! ! !Debugger methodsFor: 'context stack menu' stamp: 'hg 9/29/2001 20:24'! contextStackMenu: aMenu shifted: shifted "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" ^ shifted ifFalse: [aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) step through (T) send (e) where (w) peel to first like this senders of... (n) implementors of... (m) inheritance (i) versions (v) inst var refs... inst var defs... class var refs... class variables class refs (N) browse full (b) file out mail out bug report more...' lines: #(8 12 14 17 20) selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull fileOutMessage mailOutBugReport shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method (O) implementors of sent messages change sets with this method inspect instances inspect subinstances revert to previous version remove from current change set revert & remove from changes more...' lines: #(5 7 10) selections: #(classHierarchy browseClass openSingleMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ads 2/17/2003 10:15' prior: 35531223! contextStackMenu: aMenu shifted: shifted "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" ^ shifted ifFalse: [self selectedContext selector = #doesNotUnderstand: ifTrue: [aMenu add: 'implement in...' subMenu: (self populateImplementInMenu: (Smalltalk isMorphic ifTrue: [MenuMorph new defaultTarget: self] ifFalse: [CustomMenu new])) target: nil selector: nil argumentList: #(nil)]. aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) step through (T) send (e) where (w) peel to first like this senders of... (n) implementors of... (m) inheritance (i) versions (v) inst var refs... inst var defs... class var refs... class variables class refs (N) browse full (b) file out mail out bug report more...' lines: #(8 12 14 17 20) selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull fileOutMessage mailOutBugReport shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method (O) implementors of sent messages change sets with this method inspect instances inspect subinstances revert to previous version remove from current change set revert & remove from changes more...' lines: #(5 7 10) selections: #(classHierarchy browseClass openSingleMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Debugger methodsFor: 'context stack menu' stamp: 'emm 5/30/2002 10:14' prior: 35532731! contextStackMenu: aMenu shifted: shifted "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" ^ shifted ifFalse: [aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) step through (T) send (e) where (w) peel to first like this toggle break on entry senders of... (n) implementors of... (m) inheritance (i) versions (v) inst var refs... inst var defs... class var refs... class variables class refs (N) browse full (b) file out mail out bug report more...' lines: #(8 9 13 15 18 21) selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst toggleBreakOnEntry browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull fileOutMessage mailOutBugReport shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method (O) implementors of sent messages change sets with this method inspect instances inspect subinstances revert to previous version remove from current change set revert & remove from changes more...' lines: #(5 7 10) selections: #(classHierarchy browseClass openSingleMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Debugger methodsFor: 'context stack menu' stamp: 'gk 4/26/2004 14:09' prior: 35534545! contextStackMenu: aMenu shifted: shifted "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" ^ shifted ifFalse: [self selectedContext selector = #doesNotUnderstand: ifTrue: [aMenu add: 'implement in...' subMenu: (self populateImplementInMenu: (Smalltalk isMorphic ifTrue: [MenuMorph new defaultTarget: self] ifFalse: [CustomMenu new])) target: nil selector: nil argumentList: #(nil)]. aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) step through (T) send (e) where (w) peel to first like this toggle break on entry senders of... (n) implementors of... (m) inheritance (i) versions (v) inst var refs... inst var defs... class var refs... class variables class refs (N) browse full (b) file out mail out bug report more...' lines: #(8 9 13 15 18 21) selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst toggleBreakOnEntry browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull fileOutMessage mailOutBugReport shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method (O) implementors of sent messages change sets with this method inspect instances inspect subinstances revert to previous version remove from current change set revert & remove from changes more...' lines: #(5 7 10) selections: #(classHierarchy browseClass openSingleMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/30/2001 20:49'! doStep "Send the selected message in the accessed method, and regain control after the invoked method returns." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. externalInterrupt ifFalse: [contextStackTop push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" currentContext _ self selectedContext. self contextStackIndex > 1 ifTrue: [newContext _ currentContext completeCallee: contextStackTop. self resetContext: newContext] ifFalse: [newContext _ currentContext stepToSendOrReturn. newContext == currentContext ifTrue: [newContext _ currentContext quickStep]. newContext == currentContext ifTrue: [ currentContext stepToSendOrReturn. self changed: #contentsSelection. self updateInspectors] ifFalse: [ externalInterrupt ifFalse: [newContext push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" newContext stepToSendOrReturn. self resetContext: newContext]]! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 13:35' prior: 35537934! doStep "Send the selected message in the accessed method, and regain control after the invoked method returns." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. currentContext _ self selectedContext. interruptedProcess completeStep: currentContext. newContext _ interruptedProcess stepToSendOrReturn. self contextStackIndex > 1 ifTrue: [self resetContext: newContext] ifFalse: [newContext == currentContext ifTrue: [ self changed: #contentsSelection. self updateInspectors] ifFalse: [ self resetContext: newContext]]! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 7/6/2003 21:06' prior: 35539087! doStep "Send the selected message in the accessed method, and regain control after the invoked method returns." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. currentContext _ self selectedContext. newContext _ interruptedProcess completeStep: currentContext. newContext == currentContext ifTrue: [ newContext _ interruptedProcess stepToSendOrReturn]. self contextStackIndex > 1 ifTrue: [self resetContext: newContext] ifFalse: [newContext == currentContext ifTrue: [self changed: #contentsSelection. self updateInspectors] ifFalse: [self resetContext: newContext]]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ads 7/21/2003 16:00'! implement: aMessage inClass: aClass aClass compile: aMessage createStubMethod. self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector). self resetContext: self selectedContext. self contextStackIndex: 1 oldContextWas: nil ! ! !Debugger methodsFor: 'context stack menu' stamp: 'sd 3/4/2004 20:39' prior: 35540510! implement: aMessage inClass: aClass | category | category := self askForCategoryIn: aClass default: 'as yet unclassified'. aClass compile: aMessage createStubMethod classified: category. self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector). self resetContext: self selectedContext. self contextStackIndex: 1 oldContextWas: nil ! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 10/16/2001 19:00'! mailOutBugReport "Compose a useful bug report showing the state of the process as well as vital image statistics as suggested by Chris Norton - 'Squeak could pre-fill the bug form with lots of vital, but oft-repeated, information like what is the image version, last update number, VM version, platform, available RAM, author...' and address it to the list with the appropriate subject prefix." | messageStrm | (Smalltalk includesKey: #Celeste) ifFalse: [^ self inform: 'no mail reader present']. Cursor write showWhile: ["Prepare the message" messageStrm _ WriteStream on: (String new: 1500). messageStrm nextPutAll: 'From: '; nextPutAll: Celeste userName; cr; nextPutAll: 'To: squeak-dev@lists.squeakfoundation.org'; cr; nextPutAll: 'Subject: '; nextPutAll: '[BUG]'; nextPutAll: self interruptedContext printString; cr;cr; nextPutAll: 'here insert explanation of what you were doing, suspect changes you''ve made and so forth.';cr;cr. self interruptedContext errorReportOn: messageStrm. CelesteComposition openForCeleste: Celeste current initialText: messageStrm contents]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'dvf 5/11/2002 00:51' prior: 35541295! mailOutBugReport "Compose a useful bug report showing the state of the process as well as vital image statistics as suggested by Chris Norton - 'Squeak could pre-fill the bug form with lots of vital, but oft-repeated, information like what is the image version, last update number, VM version, platform, available RAM, author...' and address it to the list with the appropriate subject prefix." | messageStrm | MailSender default ifNil: [^self]. Cursor write showWhile: ["Prepare the message" messageStrm _ WriteStream on: (String new: 1500). messageStrm nextPutAll: 'From: '; nextPutAll: MailSender userName; cr; nextPutAll: 'To: squeak-dev@lists.squeakfoundation.org'; cr; nextPutAll: 'Subject: '; nextPutAll: '[BUG]'; nextPutAll: self interruptedContext printString; cr;cr; nextPutAll: 'here insert explanation of what you were doing, suspect changes you''ve made and so forth.';cr;cr. self interruptedContext errorReportOn: messageStrm. MailSender sendMessage: (MailMessage from: messageStrm contents)]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 3/16/2001 17:20'! messageListMenu: aMenu shifted: shifted "The context-stack menu takes the place of the message-list menu in the debugger, so pass it on" ^ self contextStackMenu: aMenu shifted: shifted! ! !Debugger methodsFor: 'context stack menu' stamp: 'nb 6/17/2003 12:25' prior: 19978710! peelToFirst "Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!" | upperGuy meth second | contextStackIndex = 0 ifTrue: [^ Beeper beep]. "self okToChange ifFalse: [^ self]." upperGuy _ contextStack at: contextStackIndex. meth _ upperGuy method. contextStackIndex+1 to: contextStack size do: [:ind | (contextStack at: ind) method == meth ifTrue: [ second _ upperGuy. upperGuy _ contextStack at: ind]]. second ifNil: [second _ upperGuy]. self resetContext: second. interruptedProcess popTo: self selectedContext.! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 3/4/2004 23:10' prior: 35543959! peelToFirst "Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!" | upperGuy meth second ctxt | contextStackIndex = 0 ifTrue: [^ Beeper beep]. "self okToChange ifFalse: [^ self]." upperGuy _ contextStack at: contextStackIndex. meth _ upperGuy method. contextStackIndex+1 to: contextStack size do: [:ind | (contextStack at: ind) method == meth ifTrue: [ second _ upperGuy. upperGuy _ contextStack at: ind]]. second ifNil: [second _ upperGuy]. ctxt _ interruptedProcess popTo: self selectedContext. ctxt == self selectedContext ifTrue: [self resetContext: second] ifFalse: [self resetContext: ctxt]. "unwind error" ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ads 2/20/2003 08:46'! populateImplementInMenu: aMenu | msg | msg _ self selectedContext at: 1. self selectedContext receiver class withAllSuperclasses do: [:each | aMenu add: each name target: self selector: #implement:inClass: argumentList: (Array with: msg with: each)]. ^ aMenu ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:29' prior: 19979805! proceed: aTopView "Proceed from the interrupted state of the currently selected context. The argument is the topView of the receiver. That view is closed." self okToChange ifFalse: [^ self]. self checkContextSelection. self resumeProcess: aTopView! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 9/7/2001 16:46'! restart "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." "Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46" self okToChange ifFalse: [^ self]. self checkContextSelection. (self selectedContext isKindOf: MethodContext) ifFalse: [(self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: self selectedContext home] ifFalse: [^self]]. self selectedContext restart. self resetContext: self selectedContext. Preferences restartAlsoProceeds ifTrue: [self proceed]! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:27' prior: 35546414! restart "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." "Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46" self okToChange ifFalse: [^ self]. self checkContextSelection. interruptedProcess popTo: self selectedContext; restartTop; stepToSendOrReturn. self resetContext: self selectedContext. Preferences restartAlsoProceeds ifTrue: [self proceed]! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 3/4/2004 23:14' prior: 35547185! restart "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." "Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46" | ctxt noUnwindError | self okToChange ifFalse: [^ self]. self checkContextSelection. ctxt _ interruptedProcess popTo: self selectedContext. noUnwindError _ false. ctxt == self selectedContext ifTrue: [ noUnwindError _ true. interruptedProcess restartTop; stepToSendOrReturn]. self resetContext: ctxt. (Preferences restartAlsoProceeds and: [noUnwindError]) ifTrue: [self proceed]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/30/2001 18:09'! send "Send the selected message in the accessed method, and take control in the method invoked to allow further step or send." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. externalInterrupt ifFalse: [contextStackTop push: proceedValue]. externalInterrupt _ true. "simulation leaves same state as interrupting" currentContext _ self selectedContext.. self contextStackIndex > 1 ifTrue: [currentContext completeCallee: contextStackTop. self resetContext: currentContext] ifFalse: [newContext _ currentContext stepToSendOrReturn. newContext == currentContext ifTrue: [ newContext _ newContext step stepToSendOrReturn]. self resetContext: newContext]! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:29' prior: 35548474! send "Send the selected message in the accessed method, and take control in the method invoked to allow further step or send." self okToChange ifFalse: [^ self]. self checkContextSelection. interruptedProcess step: self selectedContext. self resetContext: interruptedProcess stepToSendOrReturn. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'hmm 7/30/2001 17:56'! stepIntoBlock "Send messages until you return to the present method context. Used to step into a block in the method." | startContext ctxt | startContext _ self selectedContext home. self send. "check if nothing happend on send, otherwise continue until block" ctxt _ contextStackTop. [ctxt home ~= startContext and: [ctxt hasSender: startContext]] whileTrue: [ctxt _ ctxt step]. ctxt _ ctxt stepToSendOrReturn. self resetContext: ctxt! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:46' prior: 35549678! stepIntoBlock "Send messages until you return to the present method context. Used to step into a block in the method." interruptedProcess stepToHome: self selectedContext. self resetContext: interruptedProcess stepToSendOrReturn.! ! !Debugger methodsFor: 'context stack menu' stamp: 'nk 2/6/2001 19:34'! where "Select the expression whose evaluation was interrupted." selectingPC _ true. self contextStackIndex: contextStackIndex oldContextWas: self selectedContext ! ! !Debugger methodsFor: 'code pane' stamp: 'hmm 7/17/2001 20:46'! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i methodNode pc end | (selectingPC and: [contextStackIndex ~= 0]) ifFalse: [^1 to: 0]. sourceMap == nil ifTrue: [methodNode _ self selectedClass compilerClass new parse: contents in: self selectedClass notifying: nil dialect: true. sourceMap _ methodNode sourceMap. tempNames _ methodNode tempNames. self selectedContext method cacheTempNames: tempNames]. sourceMap size = 0 ifTrue: [^1 to: 0]. pc_ self selectedContext pc - (("externalInterrupt" true and: [contextStackIndex=1]) ifTrue: [1] ifFalse: [2]). i _ sourceMap indexForInserting: (Association key: pc value: nil). i < 1 ifTrue: [^1 to: 0]. i > sourceMap size ifTrue: [end _ sourceMap inject: 0 into: [:prev :this | prev max: this value last]. ^ end+1 to: end]. ^(sourceMap at: i) value! ! !Debugger methodsFor: 'code pane' stamp: 'ar 6/28/2003 00:03' prior: 35550772! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i pc end | (selectingPC and: [contextStackIndex ~= 0]) ifFalse: [^1 to: 0]. sourceMap == nil ifTrue: [sourceMap _ theMethodNode sourceMap. tempNames _ theMethodNode tempNames. self selectedContext method cacheTempNames: tempNames]. sourceMap size = 0 ifTrue: [^1 to: 0]. Smalltalk at: #RBProgramNode ifPresent:[:nodeClass| (theMethodNode isKindOf: nodeClass) ifTrue: [ pc _ contextStackIndex = 1 ifTrue: [self selectedContext pc] ifFalse: [self selectedContext previousPc]. i _ sourceMap findLast:[:pcRange | pcRange key <= pc]. i = 0 ifTrue:[^ 1 to: 0]. ^ (sourceMap at: i) value ]. ]. pc_ self selectedContext pc - (("externalInterrupt" true and: [contextStackIndex=1]) ifTrue: [1] ifFalse: [2]). i _ sourceMap indexForInserting: (Association key: pc value: nil). i < 1 ifTrue: [^1 to: 0]. i > sourceMap size ifTrue: [end _ sourceMap inject: 0 into: [:prev :this | prev max: this value last]. ^ end+1 to: end]. ^(sourceMap at: i) value! ! !Debugger methodsFor: 'code pane' stamp: 'nk 7/4/2003 19:56' prior: 35551778! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i pc end | (selectingPC and: [contextStackIndex ~= 0]) ifFalse: [^1 to: 0]. sourceMap == nil ifTrue: [sourceMap _ theMethodNode sourceMap. tempNames _ theMethodNode tempNames. self selectedContext method cacheTempNames: tempNames]. (sourceMap size = 0 or: [ self selectedContext isDead ]) ifTrue: [^1 to: 0]. Smalltalk at: #RBProgramNode ifPresent:[:nodeClass| (theMethodNode isKindOf: nodeClass) ifTrue: [ pc _ contextStackIndex = 1 ifTrue: [self selectedContext pc] ifFalse: [self selectedContext previousPc]. i _ sourceMap findLast:[:pcRange | pcRange key <= pc]. i = 0 ifTrue:[^ 1 to: 0]. ^ (sourceMap at: i) value ]. ]. pc_ self selectedContext pc - (("externalInterrupt" true and: [contextStackIndex=1]) ifTrue: [1] ifFalse: [2]). i _ sourceMap indexForInserting: (Association key: pc value: nil). i < 1 ifTrue: [^1 to: 0]. i > sourceMap size ifTrue: [end _ sourceMap inject: 0 into: [:prev :this | prev max: this value last]. ^ end+1 to: end]. ^(sourceMap at: i) value! ! !Debugger methodsFor: 'code pane' stamp: 'nk 2/20/2004 15:35' prior: 35552993! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i pc end | (selectingPC and: [contextStackIndex ~= 0]) ifFalse: [^1 to: 0]. sourceMap ifNil: [sourceMap _ theMethodNode sourceMap. tempNames _ theMethodNode tempNames. self selectedContext method cacheTempNames: tempNames]. (sourceMap size = 0 or: [ self selectedContext isDead ]) ifTrue: [^1 to: 0]. Smalltalk at: #RBProgramNode ifPresent:[:nodeClass| (theMethodNode isKindOf: nodeClass) ifTrue: [ pc _ contextStackIndex = 1 ifTrue: [self selectedContext pc] ifFalse: [self selectedContext previousPc]. i _ sourceMap findLast:[:pcRange | pcRange key <= pc]. i = 0 ifTrue:[^ 1 to: 0]. ^ (sourceMap at: i) value ]. ]. pc_ self selectedContext pc - (("externalInterrupt" true and: [contextStackIndex=1]) ifTrue: [1] ifFalse: [2]). i _ sourceMap indexForInserting: (Association key: pc value: nil). i < 1 ifTrue: [^1 to: 0]. i > sourceMap size ifTrue: [end _ sourceMap inject: 0 into: [:prev :this | prev max: this value last]. ^ end+1 to: end]. ^(sourceMap at: i) value! ! !Debugger methodsFor: 'dependents access' stamp: 'hmm 7/15/2001 19:48'! updateInspectors "Update the inspectors on the receiver's variables." receiverInspector == nil ifFalse: [receiverInspector update]. contextVariablesInspector == nil ifFalse: [contextVariablesInspector update]! ! !Debugger methodsFor: 'private' stamp: 'ads 2/15/2003 13:34'! askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock | classes chosenClassIndex | classes _ aClass withAllSuperclasses. chosenClassIndex _ PopUpMenu withCaption: 'Define #', aSelector, ' in which class?' chooseFrom: (classes collect: [:c | c name]). chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. ^ classes at: chosenClassIndex! ! !Debugger methodsFor: 'private' stamp: 'yo 8/12/2003 16:34' prior: 19986524! checkContextSelection contextStackIndex = 0 ifTrue: [self contextStackIndex: 1 oldContextWas: nil]. ! ! !Debugger methodsFor: 'private' stamp: 'ajh 1/23/2003 19:34' prior: 19986667! contextStackIndex: anInteger oldContextWas: oldContext | newMethod | contextStackIndex _ anInteger. anInteger = 0 ifTrue: [theMethodNode _ tempNames _ sourceMap _ contents _ nil. self changed: #contextStackIndex. self contentsChanged. contextVariablesInspector object: nil. receiverInspector object: self receiver. ^self]. (newMethod _ oldContext == nil or: [oldContext method ~~ self selectedContext method]) ifTrue: [tempNames _ sourceMap _ nil. theMethodNode _ self selectedContext methodNode. contents _ self selectedMessage. self contentsChanged. self pcRange "will compute tempNamesunless noFrills"]. self changed: #contextStackIndex. tempNames == nil ifTrue: [tempNames _ self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil]. contextVariablesInspector object: self selectedContext. receiverInspector object: self receiver. newMethod ifFalse: [self changed: #contentsSelection]! ! !Debugger methodsFor: 'private' stamp: 'nk 2/17/2004 21:05' prior: 35556393! contextStackIndex: anInteger oldContextWas: oldContext | newMethod | contextStackIndex _ anInteger. anInteger = 0 ifTrue: [currentCompiledMethod _ theMethodNode _ tempNames _ sourceMap _ contents _ nil. self changed: #contextStackIndex. self decorateButtons. self contentsChanged. contextVariablesInspector object: nil. receiverInspector object: self receiver. ^self]. (newMethod _ oldContext == nil or: [oldContext method ~~ (currentCompiledMethod _ self selectedContext method)]) ifTrue: [tempNames _ sourceMap _ nil. theMethodNode _ self selectedContext methodNode. contents _ self selectedMessage. self contentsChanged. self pcRange "will compute tempNamesunless noFrills"]. self changed: #contextStackIndex. self decorateButtons. tempNames == nil ifTrue: [tempNames _ self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil]. contextVariablesInspector object: self selectedContext. receiverInspector object: self receiver. newMethod ifFalse: [self changed: #contentsSelection]! ! !Debugger methodsFor: 'private' stamp: 'nk 2/20/2004 16:51' prior: 35557452! contextStackIndex: anInteger oldContextWas: oldContext "Change the context stack index to anInteger, perhaps in response to user selection." | newMethod | contextStackIndex := anInteger. anInteger = 0 ifTrue: [currentCompiledMethod := theMethodNode := tempNames := sourceMap := contents := nil. self changed: #contextStackIndex. self decorateButtons. self contentsChanged. contextVariablesInspector object: nil. receiverInspector object: self receiver. ^ self]. (newMethod := oldContext == nil or: [oldContext method ~~ (currentCompiledMethod := self selectedContext method)]) ifTrue: [tempNames := sourceMap := nil. theMethodNode := Preferences browseWithPrettyPrint ifTrue: [ self selectedContext methodNodeFormattedAndDecorated: Preferences colorWhenPrettyPrinting ] ifFalse: [ self selectedContext methodNode ]. contents := self selectedMessage. self contentsChanged. self pcRange "will compute tempNamesunless noFrills"]. self changed: #contextStackIndex. self decorateButtons. tempNames == nil ifTrue: [tempNames := self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil]. contextVariablesInspector object: self selectedContext. receiverInspector object: self receiver. newMethod ifFalse: [self changed: #contentsSelection]! ! !Debugger methodsFor: 'private' stamp: 'ads 7/21/2003 17:30'! createMethod "Should only be called when this Debugger was created in response to a MessageNotUnderstood exception. Create a stub for the method that was missing and proceed into it." | msg chosenClass | msg _ contextStackTop tempAt: 1. chosenClass _ self askForSuperclassOf: contextStackTop receiver class toImplement: msg selector ifCancel: [^self]. self implement: msg inClass: chosenClass. self proceed.! ! !Debugger methodsFor: 'private' stamp: 'sw 7/29/2002 23:27'! process: aProcess controller: aController context: aContext isolationHead: projectOrNil super initialize. Smalltalk at: #MessageTally ifPresentAndInMemory: [:c | c new close]. contents _ nil. interruptedProcess _ aProcess. interruptedController _ aController. contextStackTop _ aContext. self newStack: (contextStackTop stackOfSize: 1). contextStackIndex _ 1. externalInterrupt _ false. selectingPC _ true. isolationHead _ projectOrNil. Smalltalk isMorphic ifTrue: [errorWasInUIProcess _ false]! ! !Debugger methodsFor: 'private' stamp: 'ajh 9/25/2001 00:14' prior: 19993464! resetContext: aContext "Used when a new context becomes top-of-stack, for instance when the method of the selected context is re-compiled, or the simulator steps or returns to a new method. There is room for much optimization here, first to save recomputing the whole stack list (and text), and secondly to avoid recomposing all that text (by editing the paragraph instead of recreating it)." | oldContext | oldContext _ self selectedContext. contextStackTop _ aContext. self newStack: contextStackTop contextStack. self changed: #contextStackList. self contextStackIndex: 1 oldContextWas: oldContext. self changed: #content.! ! !Debugger methodsFor: 'private' stamp: 'ar 3/17/2001 23:54'! resumeProcess: aTopView Smalltalk isMorphic ifFalse: [aTopView erase]. savedCursor ifNotNil: [Sensor currentCursor: savedCursor]. isolationHead ifNotNil: [failedProject enterForEmergencyRecovery. isolationHead invoke. isolationHead _ nil]. interruptedProcess suspendedContext method == (Process compiledMethodAt: #terminate) ifFalse: [contextStackIndex > 1 ifTrue: [interruptedProcess popTo: self selectedContext] ifFalse: [interruptedProcess install: self selectedContext]. Smalltalk isMorphic ifTrue: [errorWasInUIProcess ifTrue: [Project resumeProcess: interruptedProcess] ifFalse: [interruptedProcess resume]] ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]]. "if old process was terminated, just terminate current one" interruptedProcess _ nil. "Before delete, so release doesn't terminate it" Smalltalk isMorphic ifTrue: [aTopView delete. World displayWorld] ifFalse: [aTopView controller closeAndUnscheduleNoErase]. Smalltalk installLowSpaceWatcher. "restart low space handler" errorWasInUIProcess == false ifFalse: [Processor terminateActive]! ! !Debugger methodsFor: 'private' stamp: 'ajh 1/24/2003 12:25' prior: 35561794! resumeProcess: aTopView Smalltalk isMorphic ifFalse: [aTopView erase]. savedCursor ifNotNil: [Sensor currentCursor: savedCursor]. isolationHead ifNotNil: [failedProject enterForEmergencyRecovery. isolationHead invoke. isolationHead _ nil]. interruptedProcess suspendedContext method == (Process compiledMethodAt: #terminate) ifFalse: [ Smalltalk isMorphic ifTrue: [errorWasInUIProcess ifTrue: [Project resumeProcess: interruptedProcess] ifFalse: [interruptedProcess resume]] ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]]. "if old process was terminated, just terminate current one" interruptedProcess _ nil. "Before delete, so release doesn't terminate it" Smalltalk isMorphic ifTrue: [aTopView delete. World displayWorld] ifFalse: [aTopView controller closeAndUnscheduleNoErase]. Smalltalk installLowSpaceWatcher. "restart low space handler" errorWasInUIProcess == false ifFalse: [Processor terminateActive]! ! !Debugger methodsFor: 'private' stamp: 'ajh 7/21/2003 10:08' prior: 35563062! resumeProcess: aTopView Smalltalk isMorphic ifFalse: [aTopView erase]. savedCursor ifNotNil: [Sensor currentCursor: savedCursor]. isolationHead ifNotNil: [failedProject enterForEmergencyRecovery. isolationHead invoke. isolationHead _ nil]. interruptedProcess isTerminated ifFalse: [ Smalltalk isMorphic ifTrue: [errorWasInUIProcess ifTrue: [Project resumeProcess: interruptedProcess] ifFalse: [interruptedProcess resume]] ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]]. "if old process was terminated, just terminate current one" interruptedProcess _ nil. "Before delete, so release doesn't terminate it" Smalltalk isMorphic ifTrue: [aTopView delete. World displayWorld] ifFalse: [aTopView controller closeAndUnscheduleNoErase]. Smalltalk installLowSpaceWatcher. "restart low space handler" errorWasInUIProcess == false ifFalse: [Processor terminateActive]! ! !Debugger methodsFor: 'controls' stamp: 'sw 9/3/2002 10:24'! addOptionalButtonsTo: window at: fractions plus: verticalOffset "Add button panes to the window. A row of custom debugger-specific buttons (Proceed, Restart, etc.) is always added, and if optionalButtons is in force, then the standard code-tool buttons are also added. Answer the verticalOffset plus the height added." | delta buttons divider anOffset | anOffset _ (Preferences optionalButtons and: [Preferences extraDebuggerButtons]) ifTrue: [super addOptionalButtonsTo: window at: fractions plus: verticalOffset] ifFalse: [verticalOffset]. delta _ self defaultButtonPaneHeight. buttons _ self customButtonRow. buttons color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]); borderWidth: 0. Preferences alternativeWindowLook ifTrue: [buttons color: Color transparent. buttons submorphsDo:[:m | m borderWidth: 2; borderColor: #raised]]. divider _ BorderedSubpaneDividerMorph forBottomEdge. Preferences alternativeWindowLook ifTrue: [divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2]. window addMorph: buttons fullFrame: (LayoutFrame fractions: fractions offsets: (0@anOffset corner: 0@(anOffset + delta - 1))). window addMorph: divider fullFrame: (LayoutFrame fractions: fractions offsets: (0@(anOffset + delta - 1) corner: 0@(anOffset + delta))). ^ anOffset + delta! ! !Debugger methodsFor: 'as yet unclassified' stamp: 'nk 8/6/2003 13:52'! codePaneMenu: aMenu shifted: shifted aMenu add: 'run to here' target: self selector: #runToSelection: argument: thisContext sender receiver selectionInterval. aMenu addLine. super codePaneMenu: aMenu shifted: shifted. ^aMenu.! ! !Debugger methodsFor: 'as yet unclassified' stamp: 'nk 5/31/2003 07:38'! runToSelection: selectionInterval | currentContext | self pc first >= selectionInterval first ifTrue: [ ^self ]. currentContext _ self selectedContext. [ currentContext == self selectedContext and: [ self pc first < selectionInterval first ] ] whileTrue: [ self doStep ].! ! !Debugger methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 10:08'! toggleBreakOnEntry "Install or uninstall a halt-on-entry breakpoint" | selectedMethod | self selectedClassOrMetaClass isNil ifTrue:[^self]. selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName. selectedMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: selectedMethod] ifFalse: [BreakpointManager installInClass: self selectedClassOrMetaClass selector: self selectedMessageName].! ! !Debugger class methodsFor: 'class initialization' stamp: 'hg 9/29/2001 20:24'! initialize ErrorRecursion _ false. ContextStackKeystrokes _ Dictionary new at: $e put: #send; at: $t put: #doStep; at: $T put: #stepIntoBlock; at: $p put: #proceed; at: $r put: #restart; at: $f put: #fullStack; at: $w put: #where; yourself. "Debugger initialize"! ! !Debugger class methodsFor: 'class initialization' stamp: 'hg 10/2/2001 20:44'! openContext: aContext label: aString contents: contentsStringOrNil | isolationHead | "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." "Simulation guard" ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue: [Smalltalk logError: aString inContext: aContext to: 'SqueakDebug.log']. ErrorRecursion ifTrue: [ErrorRecursion _ false. (isolationHead _ CurrentProjectRefactoring currentIsolationHead) ifNil: [self primitiveError: aString] ifNotNil: [isolationHead revoke]]. ErrorRecursion _ true. self informExistingDebugger: aContext label: aString. (Debugger context: aContext isolationHead: isolationHead) openNotifierContents: contentsStringOrNil label: aString. ErrorRecursion _ false. Processor activeProcess suspend. ! ! !Debugger class methodsFor: 'class initialization' stamp: 'hg 10/2/2001 20:44' prior: 35568241! openContext: aContext label: aString contents: contentsStringOrNil | isolationHead | "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." "Simulation guard" ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue: [Smalltalk logError: aString inContext: aContext to: 'SqueakDebug.log']. ErrorRecursion ifTrue: [ErrorRecursion _ false. (isolationHead _ CurrentProjectRefactoring currentIsolationHead) ifNil: [self primitiveError: aString] ifNotNil: [isolationHead revoke]]. ErrorRecursion _ true. self informExistingDebugger: aContext label: aString. (Debugger context: aContext isolationHead: isolationHead) openNotifierContents: contentsStringOrNil label: aString. ErrorRecursion _ false. Processor activeProcess suspend. ! ! !Debugger class methodsFor: 'instance creation' stamp: 'di 4/14/2000 16:29' prior: 19996279! context: aContext isolationHead: isolationHead "Answer an instance of me for debugging the active process starting with the given context." ^ self new process: Processor activeProcess controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess]) ifTrue: [ScheduledControllers activeController] ifFalse: [nil]) context: aContext isolationHead: isolationHead ! ! !Debugger class methodsFor: 'instance creation' stamp: 'hmm 8/3/2001 13:05'! informExistingDebugger: aContext label: aString "Walking the context chain, we try to find out if we're in a debugger stepping situation. If we find the relevant contexts, we must rearrange them so they look just like they would if the methods were excuted outside of the debugger." | ctx quickStepMethod oldSender baseContext | ctx _ thisContext. quickStepMethod _ ContextPart compiledMethodAt: #quickSend:to:with:super:. [ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: [ctx _ ctx sender]. ctx sender == nil ifTrue: [^self]. baseContext _ ctx. "baseContext is now the context created by the #quickSend... method." oldSender _ ctx _ ctx sender home sender. "oldSender is the context which originally sent the #quickSend... method" [ctx == nil or: [ctx receiver isKindOf: self]] whileFalse: [ctx _ ctx sender]. ctx == nil ifTrue: [^self]. "ctx is the context of the Debugger method #doStep" ctx receiver labelString: aString. ctx receiver externalInterrupt: false; proceedValue: aContext receiver. baseContext swapSender: baseContext sender sender sender. "remove intervening contexts" thisContext swapSender: oldSender. "make myself return to debugger" ErrorRecursion _ false. ^aContext! ! !Debugger class methodsFor: 'opening' stamp: 'hg 10/2/2001 20:45'! openInterrupt: aString onProcess: interruptedProcess "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low." | debugger | "Simulation guard" debugger _ self new. debugger process: interruptedProcess controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == interruptedProcess]) ifTrue: [ScheduledControllers activeController]) context: interruptedProcess suspendedContext. debugger externalInterrupt: true. Preferences logDebuggerStackToFile ifTrue: [(aString includesSubString: 'Space') & (aString includesSubString: 'low') ifTrue: [ Smalltalk logError: aString inContext: debugger interruptedContext to:'LowSpaceDebug.log']]. ^ debugger openNotifierContents: nil label: aString ! ! !Debugger class methodsFor: 'opening' stamp: 'ajh 9/14/2002 22:22'! openOn: process context: context label: title contents: contentsStringOrNil fullView: bool "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." "Simulation guard" [ | debugger | debugger _ self new process: process controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == process]) ifTrue: [ScheduledControllers activeController]) context: context. bool ifTrue: [debugger openFullNoSuspendLabel: title] ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]. Preferences logDebuggerStackToFile ifTrue: [ Smalltalk logError: title inContext: context to: 'SqueakDebug.log']. process isSuspended ifFalse: [process suspend]. ] on: Error do: [:ex | self primitiveError: 'Orginal error: ', title asString, '. Debugger error: ', ([ex description] on: Error do: ['a ', ex class printString]), ':' ]! ! !Debugger class methodsFor: 'opening' stamp: 'ajh 7/20/2003 23:53' prior: 35573035! openOn: process context: context label: title contents: contentsStringOrNil fullView: bool "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." | errorWasInUIProcess | errorWasInUIProcess _ CurrentProjectRefactoring newProcessIfUI: process. [ [ | debugger | debugger _ self new process: process controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == process]) ifTrue: [ScheduledControllers activeController]) context: context. bool ifTrue: [debugger openFullNoSuspendLabel: title] ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]. debugger errorWasInUIProcess: errorWasInUIProcess. Preferences logDebuggerStackToFile ifTrue: [ Smalltalk logError: title inContext: context to: 'SqueakDebug.log']. ] on: Error do: [:ex | self primitiveError: 'Orginal error: ', title asString, '. Debugger error: ', ([ex description] on: Error do: ['a ', ex class printString]), ':' ] ] fork. process suspend. ! ! !Debugger class methodsFor: 'opening' stamp: 'ajh 8/6/2003 11:40' prior: 35574156! openOn: process context: context label: title contents: contentsStringOrNil fullView: bool "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." | controller errorWasInUIProcess | Smalltalk isMorphic ifTrue: [errorWasInUIProcess _ CurrentProjectRefactoring newProcessIfUI: process] ifFalse: [controller _ ScheduledControllers activeControllerProcess == process ifTrue: [ScheduledControllers activeController]]. [ [ | debugger | debugger _ self new process: process controller: controller context: context. bool ifTrue: [debugger openFullNoSuspendLabel: title] ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]. debugger errorWasInUIProcess: errorWasInUIProcess. Preferences logDebuggerStackToFile ifTrue: [ Smalltalk logError: title inContext: context to: 'SqueakDebug.log']. Smalltalk isMorphic ifFalse: [ScheduledControllers searchForActiveController "needed since openNoTerminate (see debugger #open...) does not set up activeControllerProcess if activeProcess (this fork) is not the current activeControllerProcess (see #scheduled:from:)"]. ] on: Error do: [:ex | self primitiveError: 'Orginal error: ', title asString, '. Debugger error: ', ([ex description] on: Error do: ['a ', ex class printString]), ':' ] ] fork. process suspend. ! ! !Debugger class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:10'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Debugger' brightColor: #lightRed pastelColor: #veryPaleRed helpMessage: 'The system debugger.'! ! !DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:38'! testUnwindBlock "test if unwind blocks work properly" | sema process | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. "deadlock on the semaphore" process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "terminate process" process terminate. self assert: sema isSignaled. ! ! !DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:41'! testUnwindDebugger "test if unwind blocks work properly when a debugger is closed" | sema process debugger top | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "everything set up here - open a debug notifier" debugger := Debugger openInterrupt: 'test' onProcess: process. "get into the debugger" debugger debug. top := debugger topView. "set top context" debugger toggleContextStackIndex: 1. "close debugger" top delete. "and see if unwind protection worked" self assert: sema isSignaled.! ! !DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:40'! testUnwindDebuggerWithStep "test if unwind blocks work properly when a debugger is closed" | sema process debugger top | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "everything set up here - open a debug notifier" debugger := Debugger openInterrupt: 'test' onProcess: process. "get into the debugger" debugger debug. top := debugger topView. "set top context" debugger toggleContextStackIndex: 1. "do single step" debugger doStep. "close debugger" top delete. "and see if unwind protection worked" self assert: sema isSignaled.! ! !Decompiler methodsFor: 'initialize-release' stamp: 'ajh 7/21/2003 01:14' prior: 19999275! initSymbols: aClass | nTemps namedTemps | constructor method: method class: aClass literals: method literals. constTable _ constructor codeConstants. instVars _ Array new: aClass instSize. nTemps _ method numTemps. namedTemps _ tempVars ifNil: [method tempNames]. tempVars _ (1 to: nTemps) collect: [:i | i <= namedTemps size ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)] ifFalse: [constructor codeTemp: i - 1]]! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'md 11/14/2003 16:28' prior: 20003481! case: dist "statements = keyStmts CascadeFlag keyValueBlock ... keyStmts" | nextCase end thenJump stmtStream elements b node cases otherBlock | nextCase _ pc + dist. end _ limit. "Now add CascadeFlag & keyValueBlock to statements" statements addLast: stack removeLast. stack addLast: CaseFlag. "set for next pop" statements addLast: (self blockForCaseTo: nextCase). stack last == CaseFlag ifTrue: "Last case" ["ensure jump is within block (in case thenExpr returns wierdly I guess)" stack removeLast. "get rid of CaseFlag" thenJump _ exit <= end ifTrue: [exit] ifFalse: [nextCase]. stmtStream _ ReadStream on: (self popTo: stack removeLast). elements _ OrderedCollection new. b _ OrderedCollection new. [stmtStream atEnd] whileFalse: [(node _ stmtStream next) == CascadeFlag ifTrue: [elements addLast: (constructor codeMessage: (constructor codeBlock: b returns: false) selector: (constructor codeSelector: #-> code: #macro) arguments: (Array with: stmtStream next)). b _ OrderedCollection new] ifFalse: [b addLast: node]]. b size > 0 ifTrue: [self error: 'Bad cases']. cases _ constructor codeBrace: elements. otherBlock _ self blockTo: thenJump. stack addLast: (constructor codeMessage: stack removeLast selector: (constructor codeSelector: #caseOf:otherwise: code: #macro) arguments: (Array with: cases with: otherBlock))]! ! !Decompiler methodsFor: 'public access' stamp: 'LC 1/6/2002 15:50'! decompileBlock: aBlock "Original version timestamp: sn 1/26/98 18:27 (Don't know who's sn?) " "Decompile aBlock, returning the result as a BlockNode. Show temp names from source if available." "Decompiler new decompileBlock: [3 + 4]" | startpc end homeClass blockNode tempNames home source | (home _ aBlock home) ifNil: [^ nil]. method _ home method. (homeClass _ home who first) == #unknown ifTrue: [^ nil]. constructor _ DecompilerConstructor new. method fileIndex ~~ 0 ifTrue: ["got any source code?" source _ [method getSourceFromFile] on: Error do: [:ex | ^ nil]. tempNames _ ([homeClass compilerClass new parse: source in: homeClass notifying: nil] on: (Smalltalk classNamed: 'SyntaxErrorNotification') do: [:ex | ^ nil]) tempNames. self withTempNames: tempNames]. self initSymbols: homeClass. startpc _ aBlock startpc. end _ (method at: startpc - 2) \\ 16 - 4 * 256 + (method at: startpc - 1) + startpc - 1. stack _ OrderedCollection new: method frameSize. statements _ OrderedCollection new: 20. super method: method pc: startpc - 5. blockNode _ self blockTo: end. stack isEmpty ifFalse: [self error: 'stack not empty']. ^ blockNode statements first! ! !Decompiler methodsFor: 'private' stamp: 'ajh 11/15/2003 01:21' prior: 20015345! decompile: aSelector in: aClass method: aMethod using: aConstructor | block | constructor _ aConstructor. method _ aMethod. self initSymbols: aClass. "create symbol tables" method isQuick ifTrue: [block _ self quickMethod] ifFalse: [stack _ OrderedCollection new: method frameSize. statements _ OrderedCollection new: 20. super method: method pc: method initialPC. block _ self blockTo: method endPC + 1. stack isEmpty ifFalse: [self error: 'stack not empty']]. ^constructor codeMethod: aSelector block: block tempVars: tempVars primitive: method primitive class: aClass! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'ajh 7/21/2003 00:53' prior: 20021345! codeMethod: selector block: block tempVars: vars primitive: primitive class: class | node | node _ self codeSelector: selector code: nil. tempVars _ vars. ^MethodNode new selector: node arguments: (tempVars copyFrom: 1 to: nArgs) precedence: selector precedence temporaries: (tempVars copyFrom: nArgs + 1 to: tempVars size) block: block encoder: (Encoder new initScopeAndLiteralTables temps: tempVars literals: literalValues class: class) primitive: primitive! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'ajh 11/15/2003 01:20' prior: 35583279! codeMethod: selector block: block tempVars: vars primitive: primitive class: class | node methodTemps | node _ self codeSelector: selector code: nil. tempVars _ vars. methodTemps _ tempVars select: [:t | t scope >= 0]. ^MethodNode new selector: node arguments: (methodTemps copyFrom: 1 to: nArgs) precedence: selector precedence temporaries: (methodTemps copyFrom: nArgs + 1 to: methodTemps size) block: block encoder: (Encoder new initScopeAndLiteralTables temps: tempVars literals: literalValues class: class) primitive: primitive! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 10/4/2001 13:54'! checkBasicClasses "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. DeepCopier new checkVariables " | str str2 objCls morphCls playerCls | str _ '|veryDeepCopyWith: or veryDeepInner: is out of date.'. (objCls _ self objInMemory: #Object) ifNotNil: [ objCls instSize = 0 ifFalse: [self error: 'Many implementers of veryDeepCopyWith: are out of date']]. (morphCls _ self objInMemory: #Morph) ifNotNil: [ morphCls superclass == Object ifFalse: [self error: 'Morph', str]. (morphCls instVarNames copyFrom: 1 to: 6) = #('bounds' 'owner' 'submorphs' 'fullBounds' 'color' 'extension') ifFalse: [self error: 'Morph', str]]. "added ones are OK" str2 _ 'Player|copyUniClassWith: and DeepCopier|mapUniClasses are out of date'. (playerCls _ self objInMemory: #Player) ifNotNil: [ playerCls class instVarNames = #('scripts' 'slotInfo') ifFalse: [self error: str2]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 15:42'! checkClass: aClass | meth | "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it." self checkBasicClasses. "Unlikely, but important to catch when it does happen." "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." (aClass includesSelector: #veryDeepInner:) ifTrue: [ ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [ aClass instSize > 0 ifTrue: [ self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (aClass includesSelector: #veryDeepCopyWith:) ifTrue: [ meth _ aClass compiledMethodAt: #veryDeepCopyWith:. (meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [ (meth writesField: aClass instSize) ifFalse: [ self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 13:38'! checkDeep "Write exceptions in the Transcript. Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. This check is only run by hand once in a while to make sure nothing was forgotten. (Please do not remove this method.) DeepCopier new checkDeep " | mm | Transcript cr; show: 'Instance variables shared with the original object when it is copied'. (Smalltalk allClassesImplementing: #veryDeepInner:) do: [:aClass | (mm _ aClass instVarNames size) > 0 ifTrue: [ (aClass instSize - mm + 1) to: aClass instSize do: [:index | ((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: [ Transcript cr; show: aClass name; space; show: (aClass allInstVarNames at: index)]]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'nb 5/6/2003 16:50' prior: 35586899! checkDeep "Write exceptions in the Transcript. Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. This check is only run by hand once in a while to make sure nothing was forgotten. (Please do not remove this method.) DeepCopier new checkDeep " | mm | Transcript cr; show: 'Instance variables shared with the original object when it is copied'. (SystemNavigation new allClassesImplementing: #veryDeepInner:) do: [:aClass | (mm _ aClass instVarNames size) > 0 ifTrue: [ (aClass instSize - mm + 1) to: aClass instSize do: [:index | ((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: [ Transcript cr; show: aClass name; space; show: (aClass allInstVarNames at: index)]]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'dvf 8/23/2003 11:52' prior: 35587793! checkDeep "Write exceptions in the Transcript. Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. This check is only run by hand once in a while to make sure nothing was forgotten. (Please do not remove this method.) DeepCopier new checkDeep " | mm | Transcript cr; show: 'Instance variables shared with the original object when it is copied'. (self systemNavigation allClassesImplementing: #veryDeepInner:) do: [:aClass | (mm := aClass instVarNames size) > 0 ifTrue: [aClass instSize - mm + 1 to: aClass instSize do: [:index | ((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: [Transcript cr; show: aClass name; space; show: (aClass allInstVarNames at: index)]]]]! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 10/4/2001 13:45'! checkVariables "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. DeepCopier new checkVariables " | meth | self checkBasicClasses. "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." (Smalltalk allClassesImplementing: #veryDeepInner:) do: [:aClass | ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [ aClass instSize > 0 ifTrue: [ self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (Smalltalk allClassesImplementing: #veryDeepCopyWith:) do: [:aClass | meth _ aClass compiledMethodAt: #veryDeepCopyWith:. (meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [ (meth writesField: aClass instSize) ifFalse: [ self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'nb 5/6/2003 16:51' prior: 35589676! checkVariables "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. DeepCopier new checkVariables " | meth | self checkBasicClasses. "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." (SystemNavigation new allClassesImplementing: #veryDeepInner:) do: [:aClass | ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [ aClass instSize > 0 ifTrue: [ self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (SystemNavigation new allClassesImplementing: #veryDeepCopyWith:) do: [:aClass | meth _ aClass compiledMethodAt: #veryDeepCopyWith:. (meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [ (meth writesField: aClass instSize) ifFalse: [ self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'dvf 8/23/2003 11:53' prior: 35590905! checkVariables "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. DeepCopier new checkVariables " | meth | self checkBasicClasses. "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." (self systemNavigation allClassesImplementing: #veryDeepInner:) do: [:aClass | ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [aClass instSize > 0 ifTrue: [self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (self systemNavigation allClassesImplementing: #veryDeepCopyWith:) do: [:aClass | meth := aClass compiledMethodAt: #veryDeepCopyWith:. meth size > 20 & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [(meth writesField: aClass instSize) ifFalse: [self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/11/2003 13:56'! fixDependents "They are not used much, but need to be right" | newDep newModel | DependentsFields associationsDo: [:pair | pair value do: [:dep | newDep _ references at: dep ifAbsent: [nil]. newDep ifNotNil: [ newModel _ references at: pair key ifAbsent: [pair key]. newModel addDependent: newDep]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 13:44'! initialize: size references _ IdentityDictionary new: size. uniClasses _ IdentityDictionary new. "UniClass -> new UniClass" "self isItTimeToCheckVariables ifTrue: [self checkVariables]." "no more checking at runtime" ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/4/2003 19:40' prior: 35593816! initialize: size references _ IdentityDictionary new: size. uniClasses _ IdentityDictionary new. "UniClass -> new UniClass" "self isItTimeToCheckVariables ifTrue: [self checkVariables]." "no more checking at runtime" newUniClasses _ true.! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 10/4/2001 13:48'! mapUniClasses "For new Uniclasses, map their class vars to the new objects. And their additional class instance vars. (scripts slotInfo) and cross references like (player321)." "Players also refer to each other using associations in the References dictionary. Search the methods of our Players for those. Make new entries in References and point to them." | pp oldPlayer newKey newAssoc oldSelList newSelList | "Uniclasses use class vars to hold onto siblings who are referred to in code" pp _ Player class superclass instSize. uniClasses do: [:playersClass | "values = new ones" playersClass classPool associationsDo: [:assoc | assoc value: (assoc value veryDeepCopyWith: self)]. playersClass scripts: (playersClass privateScripts veryDeepCopyWith: self). "pp+1" "(pp+2) slotInfo was deepCopied in copyUniClass and that's all it needs" pp+3 to: playersClass class instSize do: [:ii | playersClass instVarAt: ii put: ((playersClass instVarAt: ii) veryDeepCopyWith: self)]. ]. "Make new entries in References and point to them." References keys "copy" do: [:playerName | oldPlayer _ References at: playerName. (references includesKey: oldPlayer) ifTrue: [ newKey _ (references at: oldPlayer) "new player" uniqueNameForReference. "now installed in References" (references at: oldPlayer) renameTo: newKey]]. uniClasses "values" do: [:newClass | oldSelList _ OrderedCollection new. newSelList _ OrderedCollection new. newClass selectorsDo: [:sel | (newClass compiledMethodAt: sel) literals do: [:assoc | assoc isVariableBinding ifTrue: [ (References associationAt: assoc key ifAbsent: [nil]) == assoc ifTrue: [ newKey _ (references at: assoc value ifAbsent: [assoc value]) externalName asSymbol. (assoc key ~= newKey) & (References includesKey: newKey) ifTrue: [ newAssoc _ References associationAt: newKey. newClass methodDictionary at: sel put: (newClass compiledMethodAt: sel) clone. "were sharing it" (newClass compiledMethodAt: sel) literalAt: ((newClass compiledMethodAt: sel) literals indexOf: assoc) put: newAssoc. (oldSelList includes: assoc key) ifFalse: [ oldSelList add: assoc key. newSelList add: newKey]]]]]]. oldSelList with: newSelList do: [:old :new | newClass replaceSilently: old to: new]]. "This is text replacement and can be wrong"! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/11/2003 14:14' prior: 35594447! mapUniClasses "For new Uniclasses, map their class vars to the new objects. And their additional class instance vars. (scripts slotInfo) and cross references like (player321)." "Players also refer to each other using associations in the References dictionary. Search the methods of our Players for those. Make new entries in References and point to them." | pp oldPlayer newKey newAssoc oldSelList newSelList | newUniClasses ifFalse: [^ self]. "All will be siblings. uniClasses is empty" "Uniclasses use class vars to hold onto siblings who are referred to in code" pp _ Player class superclass instSize. uniClasses do: [:playersClass | "values = new ones" playersClass classPool associationsDo: [:assoc | assoc value: (assoc value veryDeepCopyWith: self)]. playersClass scripts: (playersClass privateScripts veryDeepCopyWith: self). "pp+1" "(pp+2) slotInfo was deepCopied in copyUniClass and that's all it needs" pp+3 to: playersClass class instSize do: [:ii | playersClass instVarAt: ii put: ((playersClass instVarAt: ii) veryDeepCopyWith: self)]. ]. "Make new entries in References and point to them." References keys "copy" do: [:playerName | oldPlayer _ References at: playerName. (references includesKey: oldPlayer) ifTrue: [ newKey _ (references at: oldPlayer) "new player" uniqueNameForReference. "now installed in References" (references at: oldPlayer) renameTo: newKey]]. uniClasses "values" do: [:newClass | oldSelList _ OrderedCollection new. newSelList _ OrderedCollection new. newClass selectorsDo: [:sel | (newClass compiledMethodAt: sel) literals do: [:assoc | assoc isVariableBinding ifTrue: [ (References associationAt: assoc key ifAbsent: [nil]) == assoc ifTrue: [ newKey _ (references at: assoc value ifAbsent: [assoc value]) externalName asSymbol. (assoc key ~= newKey) & (References includesKey: newKey) ifTrue: [ newAssoc _ References associationAt: newKey. newClass methodDictionary at: sel put: (newClass compiledMethodAt: sel) clone. "were sharing it" (newClass compiledMethodAt: sel) literalAt: ((newClass compiledMethodAt: sel) literals indexOf: assoc) put: newAssoc. (oldSelList includes: assoc key) ifFalse: [ oldSelList add: assoc key. newSelList add: newKey]]]]]]. oldSelList with: newSelList do: [:old :new | newClass replaceSilently: old to: new]]. "This is text replacement and can be wrong"! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/11/2003 14:13'! newUniClasses "If false, all new Players are merely siblings of the old players" ^ newUniClasses! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/4/2003 19:44'! newUniClasses: newVal "If false, all new players are merely siblings of the old players" newUniClasses _ newVal! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 15:29'! objInMemory: ClassSymbol | cls | "Test if this global is in memory and return it if so." cls _ Smalltalk at: ClassSymbol ifAbsent: [^ nil]. ^ cls isInMemory ifTrue: [cls] ifFalse: [nil].! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 15:46'! warnIverNotCopiedIn: aClass sel: sel "Warn the user to update veryDeepCopyWith: or veryDeepInner:" self inform: ('An instance variable was added to to class ', aClass name, ',\and it is not copied in the method ', sel, '.\Please rewrite it to handle all instance variables.\See DeepCopier class comment.') withCRs. Browser openMessageBrowserForClass: aClass selector: sel editString: nil. ! ! !DeepCopier commentStamp: 'tk 3/4/2003 19:39' prior: 0! DeepCopier does a veryDeepCopy. It is a complete tree copy using a dictionary. Any object that is in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy. See Object|veryDeepCopy which calls (self veryDeepCopyWith: aDeepCopier). The dictionary of objects that have been seen, holds the correspondance (uniClass -> new uniClass). When a tree of morphs points at a morph outside of itself, that morph should not be copied. Use our own kind of weak pointers for the 'potentially outside' morphs. Default is that any new class will have all of its fields deeply copied. If a field needs to be weakly copied, define veryDeepInner: and veryDeepFixupWith:. veryDeepInner: has the loop that actually copies the fields. If a class defines its own copy of veryDeepInner: (to leave some fields out), then veryDeepFixupWith: will be called on that object at the end. veryDeepInner: can compute an alternate object to put in a field. (Object veryDeepCopyWith: discovers which superclasses did not define veryDeepInner:, and very deeply copies the variables defined in those classes). To decide if a class needs veryDeepInner: and veryDeepFixupWith:, ask this about an instance: If I duplicate this object, does that mean that I also want to make duplicates of the things it holds onto? If yes, (i.e. a Paragraph does want a new copy of its Text) then do nothing. If no, (i.e. an undo command does not want to copy the objects it acts upon), then define veryDeepInner: and veryDeepFixupWith:. Here is an analysis for the specific case of a morph being held by another morph. Does field X contain a morph (or a Player whose costume is a morph)? If not, no action needed. Is the morph in field X already a submorph of the object? Is it down lower in the submorph tree? If so, no action needed. Could the morph in field X every appear on the screen (be a submorph of some other morph)? If not, no action needed. If it could, you must write the methods veryDeepFixupWith: and veryDeepInner:, and in them, refrain from sending veryDeepCopyWith: to the contents of field X. newUniClasses = true in the normal case. Every duplicated Player gets a new class. When false, all duplicates will be siblings (sister instances) of existing players. ----- Things Ted is still considering ----- Rule: If a morph stores a uniClass class (Player 57) as an object in a field, the new uniClass will not be stored there. Each uniClass instance does have a new class created for it. (fix this by putting the old class in references and allow lookup? Wrong if encounter it before seeing an instance?) Rule: If object A has object C in a field, and A says (^ C) for the copy, but object B has A in a normal field and it gets deepCopied, and A in encountered first, then there will be two copies of C. (just be aware of it) Dependents are now fixed up. Suppose a model has a dependent view. In the DependentFields dictionary, model -> (view ...). If only the model is copied, no dependents are created (no one knows about the new model). If only the view is copied, it is inserted into DependentFields on the right side. model -> (view copiedView ...). If both are copied, the new model has the new view as its dependent. If additional things depend on a model that is copied, the caller must add them to its dependents. ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 2/19/2004 00:34'! next: bytes putAll: aCollection startingAt: startPos (startPos = 1 and:[bytes = aCollection size]) ifTrue:[^self nextPutAll: aCollection]. ^self nextPutAll: (aCollection copyFrom: startPos to: startPos + bytes - 1)! ! !Delay methodsFor: 'delaying' stamp: 'nk 3/14/2001 08:52'! isExpired ^delaySemaphore isSignaled. ! ! !Delay methodsFor: 'private' stamp: 'ar 7/18/2001 20:28'! activate "Private!! Make the receiver the Delay to be awoken when the next timer interrupt occurs. This method should only be called from a block protected by the AccessProtect semaphore." ActiveDelay _ self. ActiveDelayStartTime _ Time millisecondClockValue. ActiveDelayStartTime > resumptionTime ifTrue:[ ActiveDelay signalWaitingProcess. SuspendedDelays isEmpty ifTrue:[ ActiveDelay _ nil. ActiveDelayStartTime _ nil. ] ifFalse:[SuspendedDelays removeFirst activate]. ] ifFalse:[ TimingSemaphore initSignals. Delay primSignal: TimingSemaphore atMilliseconds: resumptionTime. ].! ! !Delay commentStamp: 'ls 10/14/2003 11:46' prior: 0! I am the main way that a process may pause for some amount of time. The simplest usage is like this: (Delay forSeconds: 5) wait. An instance of Delay responds to the message 'wait' by suspending the caller's process for a certain amount of time. The duration of the pause is specified when the Delay is created with the message forMilliseconds: or forSeconds:. A Delay can be used again when the current wait has finished. For example, a clock process might repeatedly wait on a one-second Delay. The maximum delay is (SmallInteger maxVal // 2) milliseconds, or about six days. A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. Delays work across millisecond clock roll-overs. For a more complex example, see #testDelayOf:for:rect: .! ]style[(763 22 2)f1,f1LDelay class testDelayOf:for:rect:;,f1! !Delay class methodsFor: 'instance creation' stamp: 'brp 9/25/2003 13:43'! forDuration: aDuration ^ self forMilliseconds: aDuration asMilliSeconds ! ! !Delay class methodsFor: 'testing'! nextWakeUpTime ^ AccessProtect critical: [ActiveDelay isNil ifTrue: [0] ifFalse: [ActiveDelay resumptionTime]]! ! !DependentsArray methodsFor: 'copying' stamp: 'ar 2/24/2001 17:30'! copyWith: newElement "Re-implemented to not copy any niled out dependents" ^self class streamContents:[:s| self do:[:item| s nextPut: item]. s nextPut: newElement].! ! !DependentsArray methodsFor: 'copying' stamp: 'nk 3/11/2004 09:34'! size ^self inject: 0 into: [ :count :dep | dep ifNotNil: [ count _ count + 1 ]]! ! !DependentsArray methodsFor: 'enumerating' stamp: 'ar 2/11/2001 01:52'! do: aBlock "Refer to the comment in Collection|do:." | dep | 1 to: self size do:[:i| (dep _ self at: i) ifNotNil:[aBlock value: dep]].! ! !DependentsArray methodsFor: 'enumerating' stamp: 'nk 3/11/2004 09:34' prior: 35606678! do: aBlock "Refer to the comment in Collection|do:." | dep | 1 to: self basicSize do:[:i| (dep _ self at: i) ifNotNil:[aBlock value: dep]].! ! !DependentsArray methodsFor: 'enumerating' stamp: 'ar 2/11/2001 01:50'! select: aBlock "Refer to the comment in Collection|select:." | aStream | aStream _ WriteStream on: (self species new: self size). self do:[:obj| (aBlock value: obj) ifTrue: [aStream nextPut: obj]]. ^ aStream contents! ! !DependentsArray commentStamp: '' prior: 0! An array of (weak) dependents of some object.! !Deprecation commentStamp: 'dew 5/21/2003 17:46' prior: 0! This Warning is signalled by methods which are deprecated. The use of Object>>#deprecatedExplanation: aString and Object>>#deprecated: aBlock explanation: aString is recommended. Idiom: Imagine I want to deprecate the message #foo. foo ^ 'foo' I can replace it with: foo self deprecatedExplanation: 'The method #foo was not good. Use Bar>>newFoo instead.' ^ 'foo' Or, for certain cases such as when #foo implements a primitive, #foo can be renamed to #fooDeprecated. fooDeprecated ^ foo ^ self deprecated: [self fooDeprecated] explanation: 'The method #foo was not good. Use Bar>>newFoo instead.' ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! categories "Answer the categoryList of the receiver" ^ categoryList! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! documentation "Answer the documentation of the receiver" ^ documentation! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! formalName "Answer the formalName of the receiver" ^ formalName! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! globalReceiverSymbol "Answer the globalReceiverSymbol of the receiver" ^ globalReceiverSymbol! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! nativitySelector "Answer the nativitySelector of the receiver" ^ nativitySelector! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'dgd 9/2/2003 18:57'! translatedCategories "Answer translated the categoryList of the receiver" ^ self categories collect: [:each | each translated]! ! !DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 8/2/2001 01:04'! formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: aSym nativitySelector: aSel "Set all of the receiver's instance variables from the parameters provided" formalName _ aName. categoryList _ aList. documentation _ aDoc. globalReceiverSymbol _ aSym. nativitySelector _ aSel! ! !DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 10/24/2001 15:29'! sampleImageForm "If I have a sample image form override stored, answer it, else answer one obtained by launching an actual instance" ^ sampleImageForm ifNil: [((Smalltalk at: globalReceiverSymbol) perform: nativitySelector) imageForm]! ! !DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 10/24/2001 16:37'! sampleImageForm: aForm "Set the sample image form" sampleImageForm _ aForm! ! !DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 11/27/2001 13:19'! sampleImageFormOrNil "If I have a sample image form override stored, answer it, dlse answer nil" ^ sampleImageForm ! ! !DescriptionForPartsBin methodsFor: 'printing' stamp: 'sw 8/10/2001 21:48'! printOn: aStream aStream nextPutAll: 'a DescriptionForPartsBin, with categoryList=', categoryList asString, ' docmentation=', documentation asString, ' globalReceiverSymbol=', globalReceiverSymbol asString, ' nativitySelector=', nativitySelector asString ! ! !DescriptionForPartsBin commentStamp: '' prior: 0! An object description, for use with the ObjectsTool and other parts-bin-like repositories. formalName The formal name by which the object is to be known categoryList A list of category symbols, by way of attribute tags documentation For use in balloon help, etc. globalReceiverSymbol A symbol representing the global to whom to send nativitySelector nativitySelector The selector to send to the global receiver to obtain a new instance! !DescriptionForPartsBin class methodsFor: 'instance creation' stamp: 'sw 8/10/2001 14:39'! formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: aSym nativitySelector: aSel "Answer a new instance of the receiver with the given traits" ^ self new formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: aSym nativitySelector: aSel! ! !DescriptionForPartsBin class methodsFor: 'instance creation' stamp: 'sw 8/10/2001 22:33'! fromQuad: aQuad categoryList: aList "Answer an instance of DescriptionForPartsBin from the part-defining quad provided" ^ self formalName: aQuad third categoryList: aList documentation: aQuad fourth globalReceiverSymbol: aQuad first nativitySelector: aQuad second! ! !DialectParser methodsFor: 'as yet unclassified' stamp: 'hmm 7/16/2001 20:12'! messagePart: level repeat: repeat initialKeyword: kwdIfAny | start receiver selector args precedence words keywordStart | [receiver _ parseNode. (self matchKeyword and: [level >= 3]) ifTrue: [start _ self startOfNextToken. selector _ WriteStream on: (String new: 32). selector nextPutAll: kwdIfAny. args _ OrderedCollection new. words _ OrderedCollection new. [self matchKeyword] whileTrue: [keywordStart _ self startOfNextToken + requestorOffset. selector nextPutAll: self advance , ':'. words addLast: (keywordStart to: hereEnd + requestorOffset). self primaryExpression ifFalse: [^ self expected: 'Argument']. args addLast: parseNode]. (Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector contents wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 3] ifFalse: [((hereType == #binary or: [hereType == #verticalBar]) and: [level >= 2]) ifTrue: [start _ self startOfNextToken. selector _ self advance asSymbol. self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 1 repeat: true. args _ Array with: parseNode. precedence _ 2] ifFalse: [(hereType == #word and: [(#(leftParenthesis leftBracket leftBrace) includes: tokenType) not]) ifTrue: [start _ self startOfNextToken. selector _ self advance. args _ #(). words _ OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). (Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 1] ifFalse: [^args notNil]]]. parseNode _ MessageNode new receiver: receiver selector: selector arguments: args precedence: precedence from: encoder sourceRange: (start to: self endOfLastToken). repeat] whileTrue: []. ^true! ! !DialectParser methodsFor: 'as yet unclassified' stamp: 'hmm 7/16/2001 20:09'! temporaries " [ 'Use' (variable)* '.' ]" | vars theActualText | (self matchToken: #'Use') ifFalse: ["no temps" doitFlag ifTrue: [requestor ifNil: [tempsMark _ 1] ifNotNil: [tempsMark _ requestor selectionInterval first]. ^ #()]. tempsMark _ prevEnd+1. tempsMark > 0 ifTrue: [theActualText _ source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark _ tempsMark + 1]]. ^ #()]. vars _ OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance)]. (self match: #period) ifTrue: [tempsMark _ prevMark. ^ vars]. ^ self expected: 'Period'! ! !DialectParser class methodsFor: 'as yet unclassified' stamp: 'sd 4/16/2003 09:19' prior: 20094316! test "DialectParser test" "PrettyPrints the source for every method in the system in the alternative syntax, and then compiles that source and verifies that it generates identical code. No changes are actually made to the system. At the time of this writing, only two methods caused complaints (reported in Transcript and displayed in browse window after running): BalloonEngineSimulation circleCosTable and BalloonEngineSimulation circleSinTable. These are not errors, but merely a case of Floats embedded in literal arrays, and thus not specially checked for roundoff errors. Note that if an error or interruption occurs during execution of this method, the alternativeSyntax preference will be left on. NOTE: Some methods may not compare properly until the system has been recompiled once. Do this by executing... Smalltalk recompileAllFrom: 'AARDVAARK'. " | newCodeString methodNode oldMethod newMethod badOnes n heading | Preferences enable: #printAlternateSyntax. badOnes _ OrderedCollection new. Transcript clear. Smalltalk forgetDoIts. 'Formatting and recompiling all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. Smalltalk allClassesDo: "{MethodNode} do:" "<- to check one class" [:nonMeta | "Transcript cr; show: nonMeta name." {nonMeta. nonMeta class} do: [:cls | cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. newCodeString _ (cls compilerClass new) format: (cls sourceCodeAt: selector) in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting. heading _ cls organization categoryOfElement: selector. methodNode _ cls compilerClass new compile: newCodeString in: cls notifying: (SyntaxError new category: heading) ifFail: []. newMethod _ methodNode generate: #(0 0 0 0). oldMethod _ cls compiledMethodAt: selector. "Transcript cr; show: cls name , ' ' , selector." oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. oldMethod size = newMethod size ifFalse: [Transcript show: ' difft size']. oldMethod header = newMethod header ifFalse: [Transcript show: ' difft header']. oldMethod literals = newMethod literals ifFalse: [Transcript show: ' difft literals']. Transcript endEntry. badOnes add: cls name , ' ' , selector]]]]. ]. SystemNavigation new browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'. Preferences disable: #printAlternateSyntax. ! ! !DialectParser class methodsFor: 'as yet unclassified' stamp: 'dvf 8/23/2003 12:17' prior: 35614981! test "DialectParser test" "PrettyPrints the source for every method in the system in the alternative syntax, and then compiles that source and verifies that it generates identical code. No changes are actually made to the system. At the time of this writing, only two methods caused complaints (reported in Transcript and displayed in browse window after running): BalloonEngineSimulation circleCosTable and BalloonEngineSimulation circleSinTable. These are not errors, but merely a case of Floats embedded in literal arrays, and thus not specially checked for roundoff errors. Note that if an error or interruption occurs during execution of this method, the alternativeSyntax preference will be left on. NOTE: Some methods may not compare properly until the system has been recompiled once. Do this by executing... Smalltalk recompileAllFrom: 'AARDVAARK'. " | newCodeString methodNode oldMethod newMethod badOnes n heading | Preferences enable: #printAlternateSyntax. badOnes _ OrderedCollection new. Transcript clear. Smalltalk forgetDoIts. 'Formatting and recompiling all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. Smalltalk allClassesDo: "{MethodNode} do:" "<- to check one class" [:nonMeta | "Transcript cr; show: nonMeta name." {nonMeta. nonMeta class} do: [:cls | cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. newCodeString _ (cls compilerClass new) format: (cls sourceCodeAt: selector) in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting. heading _ cls organization categoryOfElement: selector. methodNode _ cls compilerClass new compile: newCodeString in: cls notifying: (SyntaxError new category: heading) ifFail: []. newMethod _ methodNode generate: #(0 0 0 0). oldMethod _ cls compiledMethodAt: selector. "Transcript cr; show: cls name , ' ' , selector." oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. oldMethod size = newMethod size ifFalse: [Transcript show: ' difft size']. oldMethod header = newMethod header ifFalse: [Transcript show: ' difft header']. oldMethod literals = newMethod literals ifFalse: [Transcript show: ' difft literals']. Transcript endEntry. badOnes add: cls name , ' ' , selector]]]]. ]. self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'. Preferences disable: #printAlternateSyntax. ! ! !DialectStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 11:20'! colorTable "Answer the table to use to determine colors" ^ colorTable ifNil: [colorTable _ dialect == #SQ00 ifTrue: [Sq00ColorTable] ifFalse: [ST80ColorTable]]! ! !DialectStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 21:05'! withColor: colorSymbol emphasis: emphasisSymbol do: aBlock "Evaluate the given block with the given color and style text attribute" ^ self withAttributes: {TextColor color: (Color perform: colorSymbol). TextEmphasis perform: emphasisSymbol} do: aBlock! ! !DialectStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 11:30'! withStyleFor: elementType do: aBlock "Evaluate aBlock with appropriate emphasis and color for the given elementType" | colorAndStyle | colorAndStyle _ self colorTable at: elementType. ^ self withColor: colorAndStyle first emphasis: colorAndStyle second do: aBlock! ! !DialectStream class methodsFor: 'class initialization' stamp: 'sw 5/20/2001 11:27'! initialize "Initialize the color tables" self initializeST80ColorTable. self initializeSq00ColorTable. "DialectStream initialize" ! ! !DialectStream class methodsFor: 'class initialization' stamp: 'sw 5/20/2001 21:09'! initializeST80ColorTable "Initiialize the colors that characterize the ST80 dialect" ST80ColorTable _ IdentityDictionary new. #( (temporaryVariable blue italic) (methodArgument blue normal) (methodSelector black bold) (blockArgument red normal) (comment brown normal) (variable magenta normal) (literal tan normal) (keyword darkGray bold) (prefixKeyword veryDarkGray bold) (setOrReturn black bold)) do: [:aTriplet | ST80ColorTable at: aTriplet first put: aTriplet allButFirst] "DialectStream initialize"! ! !DialectStream class methodsFor: 'class initialization' stamp: 'sw 5/20/2001 11:25'! initializeSq00ColorTable "Initiialize the colors that characterize the Sq00 dialect" Sq00ColorTable _ IdentityDictionary new. #( (temporaryVariable black normal) (methodArgument black normal) (methodSelector black bold) (blockArgument black normal) (comment brown normal) (variable black normal) (literal blue normal) (keyword darkGray bold) (prefixKeyword veryDarkGray bold) (setOrReturn black bold)) do: [:aTriplet | Sq00ColorTable at: aTriplet first put: aTriplet allButFirst]! ! !DialectStream class methodsFor: 'instance creation' stamp: 'sw 5/20/2001 21:07'! dialect: dialectSymbol contents: blockWithArg "Evaluate blockWithArg on a DialectStream of the given description" | stream | stream _ self on: (Text new: 400). stream setDialect: dialectSymbol. blockWithArg value: stream. ^ stream contents! ! !Dictionary methodsFor: 'accessing' stamp: 'dvf 9/17/2003 16:03'! associations "Answer a Collection containing the receiver's associations." | out | out _ WriteStream on: (Array new: self size). self associationsDo: [:value | out nextPut: value]. ^ out contents! ! !Dictionary methodsFor: 'accessing' stamp: 'di 3/7/2001 15:29'! at: key ifPresentAndInMemory: aBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." | v | v _ self at: key ifAbsent: [^ nil]. v isInMemory ifFalse: [^ nil]. ^ aBlock value: v ! ! !Dictionary methodsFor: 'testing' stamp: 'RAA 8/23/2001 12:56'! includesKey: key "Answer whether the receiver has a key equal to the argument, key." self at: key ifAbsent: [^false]. ^true! ! !Dictionary methodsFor: 'adding' stamp: 'raok 12/17/2003 16:01'! addAll: aKeyedCollection aKeyedCollection == self ifFalse: [ aKeyedCollection keysAndValuesDo: [:key :value | self at: key put: value]]. ^aKeyedCollection! ! !Dictionary methodsFor: 'removing' stamp: 'RAA 5/28/2001 13:38'! unreferencedKeys "TextConstants unreferencedKeys" | n | ^ 'Scanning for references . . .' displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | n _ 0. self keys select: [:key | bar value: (n _ n+1). (Smalltalk allCallsOn: (self associationAt: key)) isEmpty]]! ! !Dictionary methodsFor: 'removing' stamp: 'sd 4/29/2003 12:01' prior: 35624056! unreferencedKeys "TextConstants unreferencedKeys" | n | ^ 'Scanning for references . . .' displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | n _ 0. self keys select: [:key | bar value: (n _ n + 1). (SystemNavigation new allCallsOn: (self associationAt: key)) isEmpty]]! ! !Dictionary methodsFor: 'removing' stamp: 'dvf 8/23/2003 11:51' prior: 35624440! unreferencedKeys "TextConstants unreferencedKeys" | n | ^'Scanning for references . . .' displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | n := 0. self keys select: [:key | bar value: (n := n + 1). (self systemNavigation allCallsOn: (self associationAt: key)) isEmpty]]! ! !Dictionary methodsFor: 'enumerating' stamp: 'dtl 2/17/2003 09:48' prior: 20110104! valuesDo: aBlock "Evaluate aBlock for each of the receiver's values." self associationsDo: [:association | aBlock value: association value]! ! !Dictionary methodsFor: 'private' stamp: 'raok 4/22/2002 12:09'! copy "Must copy the associations, or later store will affect both the original and the copy" ^ self shallowCopy withArray: (array collect: [:assoc | assoc ifNil: [nil] ifNotNil: [Association key: assoc key value: assoc value]])! ! !Dictionary methodsFor: 'user interface' stamp: 'hg 10/3/2001 20:47'! explorerContents | contents | contents _ OrderedCollection new. self keysSortedSafely do: [:key | contents add: (ObjectExplorerWrapper with: (self at: key) name: (key printString contractTo: 32) model: self)]. ^contents ! ! !Dictionary methodsFor: '*Compiler' stamp: 'ar 5/17/2003 14:07'! bindingOf: varName ^self associationAt: varName ifAbsent:[nil]! ! !Dictionary methodsFor: '*Compiler' stamp: 'ar 5/17/2003 14:07' prior: 35626118! bindingOf: varName ^self associationAt: varName ifAbsent:[nil]! ! !Dictionary methodsFor: '*Compiler' stamp: 'ar 5/18/2003 20:33'! bindingsDo: aBlock ^self associationsDo: aBlock! ! !Dictionary methodsFor: '*Compiler' stamp: 'ar 5/18/2003 20:33' prior: 35626400! bindingsDo: aBlock ^self associationsDo: aBlock! ! !Dictionary methodsFor: 'comparing' stamp: 'tk 11/8/2001 15:56'! = other "Equal if it has my keys, is same size, and has the same corresponding value associated with each key." self == other ifTrue: [^ true]. "stop recursion" (other class = self class) ifFalse: [^ false]. "Do we want to require that they be of exactly the same class?" self size = other size ifFalse: [^ false]. self keysAndValuesDo: [:aKey :aValue | (other at: aKey ifAbsent: [^ false]) = aValue ifFalse: [^ false]]. ^ true! ! !Dictionary methodsFor: 'comparing' stamp: 'raok 6/10/2002 15:29' prior: 35626652! = aDictionary "Two dictionaries are equal if (a) they are the same 'kind' of thing. (b) they have the same set of keys. (c) for each (common) key, they have the same value". (aDictionary isKindOf: Dictionary) ifFalse: [^false]. self size = aDictionary size ifFalse: [^false]. self associationsDo: [:assoc| (aDictionary at: assoc key ifAbsent: [^false]) = assoc value ifFalse: [^false]]. ^true ! ! !Dictionary commentStamp: '' prior: 0! I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a container of values that are externally named where the name can be any object that responds to =. The external name is referred to as the key. I inherit many operations from Set.! !DictionaryInspector methodsFor: 'menu' stamp: 'tk 10/18/2002 16:42'! dictionaryMenu: aMenu ^ aMenu labels: 'inspect copy name references objects pointing to this value refresh view add key rename key remove basic inspect' lines: #( 5 8) selections: #(inspectSelection copyName selectionReferences objectReferencesToSelection calculateKeyArray addEntry renameEntry removeSelection inspectBasic) ! ! !DictionaryInspector methodsFor: 'menu' stamp: 'sw 5/16/2003 00:33' prior: 35628004! dictionaryMenu: aMenu "Set up the key-list menu for a dictionary inspector" aMenu title: 'Dictionary key'. Smalltalk isMorphic ifTrue: [aMenu addStayUpItem]. ^ aMenu addList: #( ('inspect' inspectSelection) ('copy name' copyName) ('references' selectionReferences) ('objects pointing to this value' objectReferencesToSelection) ('senders of this key' sendersOfSelectedKey) - ('refresh view' calculateKeyArray) - ('add key' addEntry) ('rename key' renameEntry) ('remove' removeSelection) - ('basic inspect' inspectBasic))! ! !DictionaryInspector methodsFor: 'menu' stamp: 'tk 10/18/2002 16:41'! renameEntry | newKey aKey value | value _ object at: (keyArray at: selectionIndex). newKey _ FillInTheBlank request: 'Enter new key, then type RETURN. (Expression will be evaluated for value.) Examples: #Fred ''a string'' 3+4' initialAnswer: (keyArray at: selectionIndex) printString. aKey _ Compiler evaluate: newKey. object removeKey: (keyArray at: selectionIndex). object at: aKey put: value. self calculateKeyArray. selectionIndex _ keyArray indexOf: aKey. self changed: #inspectObject. self changed: #fieldList. self update! ! !DictionaryInspector methodsFor: 'menu' stamp: 'nk 6/26/2003 21:43' prior: 20119218! selectionReferences "Create a browser on all references to the association of the current selection." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. object class == MethodDictionary ifTrue: [^ self changed: #flash]. self systemNavigation browseAllCallsOn: (object associationAt: (keyArray at: selectionIndex)). ! ! !DictionaryInspector methodsFor: 'menu' stamp: 'sw 5/16/2003 00:00'! sendersOfSelectedKey "Create a browser on all senders of the selected key" | aKey | self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ((aKey _ keyArray at: selectionIndex) isKindOf: Symbol) ifFalse: [^ self changed: #flash]. object class == MethodDictionary ifTrue: [^ self changed: #flash]. Smalltalk browseAllCallsOn: aKey! ! !DictionaryInspector methodsFor: 'menu' stamp: 'wiz 5/16/2004 13:05' prior: 35630129! sendersOfSelectedKey "Create a browser on all senders of the selected key" | aKey | self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ((aKey := keyArray at: selectionIndex) isKindOf: Symbol) ifFalse: [^ self changed: #flash]. object class == MethodDictionary ifTrue: [^ self changed: #flash]. SystemNavigation default browseAllCallsOn: aKey! ! !DictionaryTest methodsFor: 'testing' stamp: 'sd 12/17/2003 20:31'! testAddAll "(self run: #testAddAll)" | dict1 dict2 | dict1 := Dictionary new. dict1 at: #a put:1 ; at: #b put: 2. dict2 := Dictionary new. dict2 at: #a put: 3 ; at: #c put: 4. dict1 addAll: dict2. self assert: (dict1 at: #a) = 3. self assert: (dict1 at: #b) = 2. self assert: (dict1 at: #c) = 4.! ! !DictionaryTest methodsFor: 'testing' stamp: 'sd 12/17/2003 20:30'! testComma "(self run: #testComma)" | dict1 dict2 dict3 | dict1 := Dictionary new. dict1 at: #a put:1 ; at: #b put: 2. dict2 := Dictionary new. dict2 at: #a put: 3 ; at: #c put: 4. dict3 := dict1, dict2. self assert: (dict3 at: #a) = 3. self assert: (dict3 at: #b) = 2. self assert: (dict3 at: #c) = 4.! ! !DiffusionTurtle methodsFor: 'demons' stamp: 'jm 3/3/2001 13:04'! bounce (self turtleCountHere > 1) ifTrue: [ self turnRight: 180 + (self random: 45). self turnLeft: (self random: 45)]. ! ! !DiffusionTurtle methodsFor: 'demons' stamp: 'jm 2/5/2001 19:32'! move self forward: 1. ! ! !DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'ar 2/1/2001 20:18'! initRandomFromString: aString "Ask the user to type a long random string and use the result to seed the secure random number generator." | s k srcIndex | s _ aString. k _ LargePositiveInteger new: (s size min: 64). srcIndex _ 0. k digitLength to: 1 by: -1 do: [:i | k digitAt: i put: (s at: (srcIndex _ srcIndex + 1)) asciiValue]. k _ k + (Random new next * 16r7FFFFFFF) asInteger. "a few additional bits randomness" k highBit > 512 ifTrue: [k _ k bitShift: k highBit - 512]. self initRandom: k. ! ! !DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'gk 2/26/2004 09:52'! initRandomNonInteractively [self initRandom: (SoundService default randomBitsFromSoundInput: 512)] ifError: [self initRandomFromString: Time millisecondClockValue printString, Date today printString, SmalltalkImage current platformName printString].! ! !DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'ads 7/31/2003 14:01' prior: 20137248! generateKeySet "Generate and answer a key set for code signing. The result is a pair (). Each key is an array of four large integers. The signer must be sure to record this keys set and must keep the private key secret to prevent someone from forging their signature." "Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!" "Note: Unguessable random numbers are needed for key generation. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before generating a key set. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams." "DigitalSignatureAlgorithm generateKeySet" | dsa | dsa _ DigitalSignatureAlgorithm new. (self confirm: 'Shall I seed the random generator from the current sound input?') ifTrue: [dsa initRandomNonInteractively] ifFalse: [dsa initRandomFromUser]. ^ dsa generateKeySet ! ! !DirectoryEntry methodsFor: 'multilingual system' stamp: 'yo 11/5/2002 14:02'! convertFromSystemName name isString ifTrue: [name _ name convertFromSystemString]. ! ! !DiskProxy methodsFor: 'as yet unclassified' stamp: 'tk 3/8/2001 09:33'! comeFullyUpOnReload: smartRefStream "Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.) DataStream will substitute the object from this eval for the DiskProxy." | globalObj symbol pr nn arrayIndex | symbol _ globalObjectName. "See if class is mapped to another name" (smartRefStream respondsTo: #renamed) ifTrue: [ "If in outPointers in an ImageSegment, remember original class name. See mapClass:installIn:. Would be lost otherwise." ((thisContext sender sender sender sender sender sender sender sender receiver class == ImageSegment) and: [ thisContext sender sender sender sender method == (DataStream compiledMethodAt: #readArray)]) ifTrue: [ arrayIndex _ (thisContext sender sender sender sender) tempAt: 4. "index var in readArray. Later safer to find i on stack of context." smartRefStream renamedConv at: arrayIndex put: symbol]. "save original name" symbol _ smartRefStream renamed at: symbol ifAbsent: [symbol]]. "map" globalObj _ Smalltalk at: symbol ifAbsent: [ preSelector == nil & (constructorSelector = #yourself) ifTrue: [ Transcript cr; show: symbol, ' is undeclared.'. (Undeclared includesKey: symbol) ifTrue: [^ Undeclared at: symbol]. Undeclared at: symbol put: nil. ^ nil]. ^ self error: 'Global "', symbol, '" not found']. ((symbol == #World) and: [Smalltalk isMorphic not]) ifTrue: [ self inform: 'These objects will work better if opened in a Morphic World. Dismiss and reopen all menus.']. preSelector ifNotNil: [ Symbol hasInterned: preSelector ifTrue: [:selector | globalObj _ globalObj perform: selector]]. symbol == #Project ifTrue: [ (constructorSelector = #fromUrl:) ifTrue: [ nn _ (constructorArgs first findTokens: '/') last. nn _ (nn findTokens: '.|') first. pr _ Project named: nn. ^ pr ifNil: [self] ifNotNil: [pr]]. pr _ globalObj perform: constructorSelector withArguments: constructorArgs. ^ pr ifNil: [self] ifNotNil: [pr]]. "keep the Proxy if Project does not exist" constructorSelector ifNil: [^ globalObj]. Symbol hasInterned: constructorSelector ifTrue: [:selector | ^ globalObj perform: selector withArguments: constructorArgs]. "args not checked against Renamed" ^ nil "was not in proper form"! ! !DiskProxy methodsFor: 'as yet unclassified' stamp: 'yo 11/14/2002 15:23' prior: 35634351! comeFullyUpOnReload: smartRefStream "Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.) DataStream will substitute the object from this eval for the DiskProxy." | globalObj symbol pr nn arrayIndex | symbol _ globalObjectName. "See if class is mapped to another name" (smartRefStream respondsTo: #renamed) ifTrue: [ "If in outPointers in an ImageSegment, remember original class name. See mapClass:installIn:. Would be lost otherwise." ((thisContext sender sender sender sender sender sender sender sender receiver class == ImageSegment) and: [ thisContext sender sender sender sender method == (DataStream compiledMethodAt: #readArray)]) ifTrue: [ arrayIndex _ (thisContext sender sender sender sender) tempAt: 4. "index var in readArray. Later safer to find i on stack of context." smartRefStream renamedConv at: arrayIndex put: symbol]. "save original name" symbol _ smartRefStream renamed at: symbol ifAbsent: [symbol]]. "map" globalObj _ Smalltalk at: symbol ifAbsent: [ preSelector == nil & (constructorSelector = #yourself) ifTrue: [ Transcript cr; show: symbol, ' is undeclared.'. (Undeclared includesKey: symbol) ifTrue: [^ Undeclared at: symbol]. Undeclared at: symbol put: nil. ^ nil]. ^ self error: 'Global "', symbol, '" not found']. ((symbol == #World) and: [Smalltalk isMorphic not]) ifTrue: [ self inform: 'These objects will work better if opened in a Morphic World. Dismiss and reopen all menus.']. preSelector ifNotNil: [ Symbol hasInterned: preSelector ifTrue: [:selector | [globalObj _ globalObj perform: selector] on: Error do: [:ex | ex messageText = 'key not found' ifTrue: [^ nil]. ^ ex signal]] ]. symbol == #Project ifTrue: [ (constructorSelector = #fromUrl:) ifTrue: [ nn _ (constructorArgs first findTokens: '/') last. nn _ (nn findTokens: '.|') first. pr _ Project named: nn. ^ pr ifNil: [self] ifNotNil: [pr]]. pr _ globalObj perform: constructorSelector withArguments: constructorArgs. ^ pr ifNil: [self] ifNotNil: [pr]]. "keep the Proxy if Project does not exist" constructorSelector ifNil: [^ globalObj]. Symbol hasInterned: constructorSelector ifTrue: [:selector | [^ globalObj perform: selector withArguments: constructorArgs] on: Error do: [:ex | ex messageText = 'key not found' ifTrue: [^ nil]. ^ ex signal] ]. "args not checked against Renamed" ^ nil "was not in proper form"! ! !DisplayMedium methodsFor: 'displaying' stamp: 'hmm 9/16/2000 21:27'! deferUpdatesIn: aRectangle while: aBlock "DisplayScreen overrides with something more involved..." ^aBlock value! ! !DisplayScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 18:13'! displayLine: textLine offset: offset leftInRun: leftInRun "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." | done stopCondition nowLeftInRun startIndex string lastPos | line _ textLine. morphicOffset _ offset. lineY _ line top + offset y. lineHeight _ line lineHeight. rightMargin _ line rightMargin + offset x. lastIndex _ line first. leftInRun <= 0 ifTrue: [self setStopConditions]. leftMargin _ (line leftMarginForAlignment: alignment) + offset x. destX _ runX _ leftMargin. fillBlt == nil ifFalse: ["Not right" fillBlt destX: line left destY: lineY width: line width left height: lineHeight; copyBits]. lastIndex _ line first. leftInRun <= 0 ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] ifFalse: [nowLeftInRun _ leftInRun]. destY _ lineY + line baseline - font ascent. runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. spaceCount _ 0. done _ false. string _ text string. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern]. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition]. ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! !DisplayScanner methodsFor: 'scanning' stamp: 'yo 10/7/2002 18:38' prior: 35639498! displayLine: textLine offset: offset leftInRun: leftInRun "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." | done stopCondition nowLeftInRun startIndex string lastPos | line _ textLine. morphicOffset _ offset. lineY _ line top + offset y. lineHeight _ line lineHeight. rightMargin _ line rightMargin + offset x. lastIndex _ line first. leftInRun <= 0 ifTrue: [self setStopConditions]. leftMargin _ (line leftMarginForAlignment: alignment) + offset x. destX _ runX _ leftMargin. fillBlt == nil ifFalse: ["Not right" fillBlt destX: line left destY: lineY width: line width left height: lineHeight; copyBits]. lastIndex _ line first. leftInRun <= 0 ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] ifFalse: [nowLeftInRun _ leftInRun]. destY _ lineY + line baseline - font ascent. runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. spaceCount _ 0. done _ false. string _ text string. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern]. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition. lastIndex > runStopIndex ifTrue: [done _ true]. ]. ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! !DisplayScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 13:28'! placeEmbeddedObject: anchoredMorph anchoredMorph relativeTextAnchorPosition ifNotNil:[ anchoredMorph position: anchoredMorph relativeTextAnchorPosition + (anchoredMorph owner textBounds origin x @ 0) - (0@morphicOffset y) + (0@lineY). ^true ]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. anchoredMorph isMorph ifTrue: [ anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset ] ifFalse: [ destY _ lineY. runX _ destX. anchoredMorph displayOn: bitBlt destForm at: destX - anchoredMorph width @ destY clippingBox: bitBlt clipRect ]. ^ true! ! !DisplayScanner methodsFor: 'private' stamp: 'hmm 9/16/2000 21:29'! setPort: aBitBlt "Install the BitBlt to use" bitBlt _ aBitBlt. bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail" bitBlt sourceForm: nil. "Make sure font installation won't be confused" ! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'hmm 7/16/2000 08:23'! plainTab | oldX | oldX _ destX. super plainTab. fillBlt == nil ifFalse: [fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. alignment = Justified ifTrue:[ "Make a local copy of stop conditions so we don't modify the default" stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #paddedSpace]! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'yo 10/4/2002 20:43' prior: 35644685! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). " alignment = Justified ifTrue: [ stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #paddedSpace] "! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'hmm 7/16/2000 08:23'! tab self plainTab. lastIndex _ lastIndex + 1. ^ false! ! !DisplayScanner methodsFor: 'MVC-compatibility' stamp: 'ls 1/19/2002 16:11'! displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle "The central display routine. The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated)." | runLength done stopCondition leftInRun startIndex string lastPos | "leftInRun is the # of characters left to scan in the current run; when 0, it is time to call 'self setStopConditions'" morphicOffset _ 0@0. leftInRun _ 0. self initializeFromParagraph: aParagraph clippedBy: visibleRectangle. ignoreColorChanges _ false. paragraph _ aParagraph. foregroundColor _ paragraphColor _ aParagraph foregroundColor. backgroundColor _ aParagraph backgroundColor. aParagraph backgroundColor isTransparent ifTrue: [fillBlt _ nil] ifFalse: [fillBlt _ bitBlt copy. "Blt to fill spaces, tabs, margins" fillBlt sourceForm: nil; sourceOrigin: 0@0. fillBlt fillColor: aParagraph backgroundColor]. rightMargin _ aParagraph rightMarginForDisplay. lineY _ aParagraph topAtLineIndex: linesInterval first. bitBlt destForm deferUpdatesIn: visibleRectangle while: [ linesInterval do: [:lineIndex | leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment]). destX _ (runX _ leftMargin). line _ aParagraph lines at: lineIndex. lineHeight _ line lineHeight. fillBlt == nil ifFalse: [fillBlt destX: visibleRectangle left destY: lineY width: visibleRectangle width height: lineHeight; copyBits]. lastIndex _ line first. leftInRun <= 0 ifTrue: [self setStopConditions. "also sets the font" leftInRun _ text runLengthFor: line first]. destY _ lineY + line baseline - font ascent. "Should have happened in setFont" runLength _ leftInRun. runStopIndex _ lastIndex + (runLength - 1) min: line last. leftInRun _ leftInRun - (runStopIndex - lastIndex + 1). spaceCount _ 0. done _ false. string _ text string. self handleIndentation. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern]. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition]. fillBlt == nil ifFalse: [fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits]. lineY _ lineY + lineHeight]]! ! !DisplayScanner methodsFor: 'MVC-compatibility' stamp: 'BG 12/15/2003 13:02' prior: 35645713! displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle "The central display routine. The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated)." | runLength done stopCondition leftInRun startIndex string lastPos | "leftInRun is the # of characters left to scan in the current run; when 0, it is time to call 'self setStopConditions'" morphicOffset _ 0@0. leftInRun _ 0. self initializeFromParagraph: aParagraph clippedBy: visibleRectangle. ignoreColorChanges _ false. paragraph _ aParagraph. foregroundColor _ paragraphColor _ aParagraph foregroundColor. backgroundColor _ aParagraph backgroundColor. aParagraph backgroundColor isTransparent ifTrue: [fillBlt _ nil] ifFalse: [fillBlt _ bitBlt copy. "Blt to fill spaces, tabs, margins" fillBlt sourceForm: nil; sourceOrigin: 0@0. fillBlt fillColor: aParagraph backgroundColor]. rightMargin _ aParagraph rightMarginForDisplay. lineY _ aParagraph topAtLineIndex: linesInterval first. bitBlt destForm deferUpdatesIn: visibleRectangle while: [ linesInterval do: [:lineIndex | leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment]). destX _ (runX _ leftMargin). line _ aParagraph lines at: lineIndex. lineHeight _ line lineHeight. fillBlt == nil ifFalse: [fillBlt destX: visibleRectangle left destY: lineY width: visibleRectangle width height: lineHeight; copyBits]. lastIndex _ line first. leftInRun <= 0 ifTrue: [self setStopConditions. "also sets the font" leftInRun _ text runLengthFor: line first]. destY _ lineY + line baseline - font ascent. "Should have happened in setFont" runLength _ leftInRun. runStopIndex _ lastIndex + (runLength - 1) min: line last. leftInRun _ leftInRun - (runStopIndex - lastIndex + 1). spaceCount _ 0. done _ false. string _ text string. self handleIndentation. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern]. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition]. fi