Christoph Thiede uploaded a new version of Morphic to project The Treated Inbox:
http://source.squeak.org/treated/Morphic-ct.2130.mcz
==================== Summary ====================
Name: Morphic-ct.2130
Author: ct
Time: 11 September 2023, 6:18:59.713063 pm
UUID: 3f9268df-f04d-4d4c-bfee-7651b41c1443
Ancestors: Morphic-mt.2122
Avoids installing a new editor in TextMorph when receiving #textStyle:. Regression from Morphic-ct.2060.
An editor is not expected before the TextMorph has been added to a world/owner. For instance, #fillsOwner: before #openInWorld was previously broken, and thus the BannerMorph required for Objectland.
Please review. I'm not entirely sure whether I identified the correct invariant or whether TextContainer>>#bounds should instead check for a nil owner. Do BannerMorph example openInWorld to reproduce.
=============== Diff against Morphic-mt.2122 ===============
Item was changed:
----- Method: TextMorph>>textStyle: (in category 'accessing') -----
textStyle: aTextStyle
"Change the receiver's set of fonts to aTextStyle. You can access those fonts via the TextFontChange text attribute. If you want to enfore a specific font face or point size, use #font: instead. NOTE THAT you must provide either a freshly created instance of TextStyle or a copy of an existing one. NEVER use, for example, TextStyle class >> #default directly. Also see senders and implementors of #asNewTextStyle."
| previousSelection |
textStyle := aTextStyle.
+ previousSelection := editor ifNotNil: [editor selectionInterval].
- previousSelection := self selectionInterval.
self releaseParagraph; changed.
previousSelection ifNotNil: [self selectionInterval: previousSelection].!
1
0
Christoph Thiede uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-ct.1427.mcz
==================== Summary ====================
Name: System-ct.1427
Author: ct
Time: 12 October 2023, 7:11:28.775818 pm
UUID: ba3f6275-e7ed-4344-b3cf-78ee6190e393
Ancestors: System-codefrau.1426
Adds Marius Dörbandt (mad) to the list of authors. Welcome Marius! :-)
=============== Diff against System-codefrau.1426 ===============
Item was changed:
----- Method: SystemNavigation class>>privateAuthorsRaw (in category 'class initialization') -----
(excessive size, no diff calculated)
Item was changed:
+ (PackageInfo named: 'System') postscript: 'Smalltalk installLowSpaceWatcher.
+
+ SystemNavigation initializeAuthors. "Adds Marius Dörbandt (mad)"'!
- (PackageInfo named: 'System') postscript: 'Smalltalk installLowSpaceWatcher.'!
1
0
Christoph Thiede uploaded a new version of Sound to project The Treated Inbox:
http://source.squeak.org/treated/Sound-mad.90.mcz
==================== Summary ====================
Name: Sound-mad.90
Author: mad
Time: 22 September 2023, 1:54:04.433028 pm
UUID: 903c4996-a9b8-46a7-b794-a8a1e04f41b4
Ancestors: Sound-mt.89
Ports fix of storeSampleCount:bigEndian:on: from AbstractSound (by ct) to SampledSound.
=============== Diff against Sound-mt.89 ===============
Item was removed:
- SystemOrganization addCategory: #'Sound-Scores'!
- SystemOrganization addCategory: #'Sound-Synthesis'!
Item was removed:
- SoundCodec subclass: #ADPCMCodec
- instanceVariableNames: 'predicted index deltaSignMask deltaValueMask deltaValueHighBit frameSizeMask currentByte bitPosition byteIndex encodedBytes samples rightSamples sampleIndex bitsPerSample stepSizeTable indexTable'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !ADPCMCodec commentStamp: '<historical>' 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.)
- !
Item was removed:
- ----- Method: ADPCMCodec class>>new (in category 'instance creation') -----
- new
-
- ^ super new
- initializeForBitsPerSample: 4
- samplesPerFrame: 0.
- !
Item was removed:
- ----- Method: ADPCMCodec class>>newBitsPerSample: (in category 'instance creation') -----
- newBitsPerSample: bitsPerSample
-
- ^ super new
- initializeForBitsPerSample: bitsPerSample
- samplesPerFrame: 0.
- !
Item was removed:
- ----- Method: ADPCMCodec class>>translatedPrimitives (in category 'primitive generation') -----
- translatedPrimitives
- "Answer a string containing the translated C code for my primitives."
- "Note: This code currently must be hand-edited to remove several methods that are inlined (thus not needed) but not pruned out by the ST-to-C translator."
-
- ^#(
- (ADPCMCodec privateDecodeMono:)
- (ADPCMCodec privateDecodeStereo:)
- (ADPCMCodec privateEncodeMono:)
- (ADPCMCodec privateEncodeStereo:)
- (ADPCMCodec indexForDeltaFrom:to:)
- (ADPCMCodec nextBits:)
- (ADPCMCodec nextBits:put:))
- !
Item was removed:
- ----- Method: ADPCMCodec>>bytesPerEncodedFrame (in category 'codec stuff') -----
- 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
- !
Item was removed:
- ----- Method: ADPCMCodec>>compressAndDecompress: (in category 'codec stuff') -----
- compressAndDecompress: aSound
- "Compress and decompress the given sound. Overridden to use same bits per sample for both compressing and decompressing."
-
- | compressed decoder |
- compressed := self compressSound: aSound.
- decoder := self class new
- initializeForBitsPerSample: bitsPerSample
- samplesPerFrame: 0.
- ^ decoder decompressSound: compressed
-
- !
Item was removed:
- ----- Method: ADPCMCodec>>decode:bitsPerSample: (in category 'private') -----
- decode: aByteArray bitsPerSample: bits
-
- ^ self
- decode: aByteArray
- sampleCount: (aByteArray size * 8) // bits
- bitsPerSample: bits
- frameSize: 0
- stereo: false
- !
Item was removed:
- ----- Method: ADPCMCodec>>decode:sampleCount:bitsPerSample:frameSize:stereo: (in category 'private') -----
- decode: aByteArray sampleCount: count bitsPerSample: bits frameSize: frameSize stereo: stereoFlag
-
- self initializeForBitsPerSample: bits samplesPerFrame: frameSize.
- encodedBytes := aByteArray.
- byteIndex := 0.
- bitPosition := 0.
- currentByte := 0.
- stereoFlag
- ifTrue: [
- self resetForStereo.
- samples := SoundBuffer newMonoSampleCount: count.
- rightSamples := SoundBuffer newMonoSampleCount: count.
- sampleIndex := 0.
- self privateDecodeStereo: count.
- ^ Array with: samples with: rightSamples]
- ifFalse: [
- samples := SoundBuffer newMonoSampleCount: count.
- sampleIndex := 0.
- self privateDecodeMono: count.
- ^ samples]
- !
Item was removed:
- ----- Method: ADPCMCodec>>decodeFlash:sampleCount:stereo: (in category 'private') -----
- decodeFlash: aByteArray sampleCount: sampleCount stereo: stereoFlag
-
- | bits |
- encodedBytes := aByteArray.
- byteIndex := 0.
- bitPosition := 0.
- currentByte := 0.
- bits := 2 + (self nextBits: 2). "bits per sample"
- self initializeForBitsPerSample: bits samplesPerFrame: 4096.
- stereoFlag
- ifTrue: [
- self resetForStereo.
- samples := SoundBuffer newMonoSampleCount: sampleCount.
- rightSamples := SoundBuffer newMonoSampleCount: sampleCount.
- sampleIndex := 0.
- self privateDecodeStereo: sampleCount.
- ^ Array with: samples with: rightSamples]
- ifFalse: [
- samples := SoundBuffer newMonoSampleCount: sampleCount.
- sampleIndex := 0.
- self privateDecodeMono: sampleCount.
- ^ Array with: samples].
- !
Item was removed:
- ----- Method: ADPCMCodec>>decodeFrames:from:at:into:at: (in category 'codec stuff') -----
- decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
- "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
- "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."
-
- encodedBytes := srcByteArray.
- byteIndex := srcIndex - 1.
- bitPosition := 0.
- currentByte := 0.
- samples := dstSoundBuffer.
- sampleIndex := dstIndex - 1.
- self privateDecodeMono: (frameCount * self samplesPerFrame).
- ^ Array with: (byteIndex - (srcIndex - 1)) with: (sampleIndex - (dstIndex - 1))
- !
Item was removed:
- ----- Method: ADPCMCodec>>encode:bitsPerSample: (in category 'private') -----
- encode: aSoundBuffer bitsPerSample: bits
-
- ^ self
- encodeLeft: aSoundBuffer
- right: nil
- bitsPerSample: bits
- frameSize: 0
- forFlash: false
- !
Item was removed:
- ----- Method: ADPCMCodec>>encodeFlashLeft:right:bitsPerSample: (in category 'private') -----
- encodeFlashLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits
-
- ^ self
- encodeLeft: leftSoundBuffer
- right: rightSoundBuffer
- bitsPerSample: bits
- frameSize: 4096
- forFlash: true
- !
Item was removed:
- ----- Method: ADPCMCodec>>encodeFrames:from:at:into:at: (in category 'codec stuff') -----
- encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
- "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
- "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."
-
- samples := srcSoundBuffer.
- sampleIndex := srcIndex - 1.
- encodedBytes := dstByteArray.
- byteIndex := dstIndex - 1.
- bitPosition := 0.
- currentByte := 0.
- self privateEncodeMono: (frameCount * self samplesPerFrame).
- ^ Array with: frameCount with: (byteIndex - (dstIndex - 1))
- !
Item was removed:
- ----- Method: ADPCMCodec>>encodeLeft:right:bitsPerSample:frameSize:forFlash: (in category 'private') -----
- 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
- !
Item was removed:
- ----- Method: ADPCMCodec>>headerBitsForSampleCount:stereoFlag: (in category 'private') -----
- headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag
- "Answer the number of extra header bits required for the given number of samples. This will be zero if I am not using frame headers."
-
- | frameCount bitsPerHeader |
- frameSizeMask = 0 ifTrue: [^ 0].
- frameCount := (sampleCount / self samplesPerFrame) ceiling.
- bitsPerHeader := 16 + 6.
- stereoFlag ifTrue: [bitsPerHeader := 2 * bitsPerHeader].
- ^ frameCount * bitsPerHeader
- !
Item was removed:
- ----- Method: ADPCMCodec>>indexForDeltaFrom:to: (in category 'private') -----
- 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 |
- <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
- !
Item was removed:
- ----- Method: ADPCMCodec>>initializeForBitsPerSample:samplesPerFrame: (in category 'private') -----
- initializeForBitsPerSample: sampleBits samplesPerFrame: frameSize
-
- self resetForMono.
- stepSizeTable := #(7 8 9 10 11 12 13 14 16 17 19 21 23 25 28 31 34 37 41 45 50 55 60 66 73 80 88 97 107 118 130 143 157 173 190 209 230 253 279 307 337 371 408 449 494 544 598 658 724 796 876 963 1060 1166 1282 1411 1552 1707 1878 2066 2272 2499 2749 3024 3327 3660 4026 4428 4871 5358 5894 6484 7132 7845 8630 9493 10442 11487 12635 13899 15289 16818 18500 20350 22385 24623 27086 29794 32767).
-
- indexTable := nil.
- sampleBits = 2 ifTrue: [
- indexTable := #(-1 2)].
- sampleBits = 3 ifTrue: [
- indexTable := #(-1 -1 2 4)].
- sampleBits = 4 ifTrue: [
- indexTable := #(-1 -1 -1 -1 2 4 6 8)].
- sampleBits = 5 ifTrue: [
- indexTable := #(-1 -1 -1 -1 -1 -1 -1 -1 1 2 4 6 8 10 13 16)].
- indexTable ifNil: [self error: 'unimplemented bits/sample'].
-
- bitsPerSample := sampleBits.
- deltaSignMask := 1 bitShift: bitsPerSample - 1.
- deltaValueMask := deltaSignMask - 1.
- deltaValueHighBit := deltaSignMask / 2.
-
- frameSize <= 1
- ifTrue: [frameSizeMask := 0]
- ifFalse: [
- (frameSize = (1 bitShift: frameSize highBit - 1))
- ifFalse: [self error: 'frameSize must be a power of two'].
- frameSizeMask := frameSize - 1].
-
- "keep as SoundBuffer to allow fast access from primitive"
- indexTable := SoundBuffer fromArray: indexTable.
- stepSizeTable := SoundBuffer fromArray: stepSizeTable.
- !
Item was removed:
- ----- Method: ADPCMCodec>>nextBits: (in category 'bit streaming') -----
- nextBits: n
- "Answer the next n bits of my bit stream as an unsigned integer."
-
- | result remaining shift |
- <inline: true>
-
- result := 0.
- remaining := n.
-
- [
- shift := remaining - bitPosition.
- shift > 0
- ifTrue: [ "consumed currentByte buffer; fetch next byte"
- result := result + (currentByte << shift).
- remaining := remaining - bitPosition.
- currentByte := (encodedBytes at: (byteIndex := byteIndex + 1)).
- bitPosition := 8]
- ifFalse: [ "still some bits left in currentByte buffer"
- result := result + (currentByte >> (0 - shift)).
- bitPosition := bitPosition - remaining.
- "mask out the consumed bits:"
- currentByte := currentByte bitAnd: (255 >> (8 - bitPosition)).
- ^ result]] repeat
- !
Item was removed:
- ----- Method: ADPCMCodec>>nextBits:put: (in category 'bit streaming') -----
- nextBits: n put: anInteger
- "Write the next n bits to my bit stream."
-
- | buf bufBits bitsAvailable shift |
- <inline: true>
-
- buf := anInteger.
- bufBits := n.
- [
- bitsAvailable := 8 - bitPosition.
- shift := bitsAvailable - bufBits. "either left or right shift"
- "append high bits of buf to end of currentByte:"
- shift < 0
- ifTrue: [ "currentByte buffer filled; output it"
- currentByte := currentByte + (buf >> (0 - shift)).
- encodedBytes at: (byteIndex := byteIndex + 1) put: currentByte.
- bitPosition := 0.
- currentByte := 0.
- "clear saved high bits of buf:"
- buf := buf bitAnd: (1 << (0 - shift)) - 1.
- bufBits := bufBits - bitsAvailable]
- ifFalse: [ "still some bits available in currentByte buffer"
- currentByte := currentByte + (buf << shift).
- bitPosition := bitPosition + bufBits.
- ^ self]] repeat
- !
Item was removed:
- ----- Method: ADPCMCodec>>privateDecodeMono: (in category 'private') -----
- privateDecodeMono: count
-
- | delta step predictedDelta bit |
- <primitive: 'primitiveDecodeMono' module: 'ADPCMCodecPlugin'>
- <var: #stepSizeTable declareC: 'short int *stepSizeTable'>
- <var: #indexTable declareC: 'short int *indexTable'>
- <var: #samples declareC: 'short int *samples'>
- <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]].
- !
Item was removed:
- ----- Method: ADPCMCodec>>privateDecodeStereo: (in category 'private') -----
- privateDecodeStereo: count
-
- | predictedLeft predictedRight indexLeft indexRight deltaLeft deltaRight
- stepLeft stepRight predictedDeltaLeft predictedDeltaRight bit |
-
- <primitive: 'primitiveDecodeStereo' module: 'ADPCMCodecPlugin'>
- <var: #stepSizeTable declareC: 'short int *stepSizeTable'>
- <var: #indexTable declareC: 'short int *indexTable'>
- <var: #samples declareC: 'short int *samples'>
- <var: #encodedBytes declareC: 'unsigned char *encodedBytes'>
- <var: #rightSamples declareC: 'short int *rightSamples'>
- <var: #predicted declareC: 'short int *predicted'>
- <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.
- !
Item was removed:
- ----- Method: ADPCMCodec>>privateEncodeMono: (in category 'private') -----
- privateEncodeMono: count
-
- | step sign diff delta predictedDelta bit p |
- <primitive: 'primitiveEncodeMono' module: 'ADPCMCodecPlugin'>
- <var: #stepSizeTable declareC: 'short int *stepSizeTable'>
- <var: #indexTable declareC: 'short int *indexTable'>
- <var: #samples declareC: 'short int *samples'>
- <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].
- !
Item was removed:
- ----- Method: ADPCMCodec>>privateEncodeStereo: (in category 'private') -----
- privateEncodeStereo: count
-
- <primitive: 'primitiveEncodeStereo' module: 'ADPCMCodecPlugin'>
- <inline: false>
- "not yet implemented"
- self success: false.!
Item was removed:
- ----- Method: ADPCMCodec>>reset (in category 'codec stuff') -----
- reset
-
- self resetForMono.
- !
Item was removed:
- ----- Method: ADPCMCodec>>resetForMono (in category 'codec stuff') -----
- resetForMono
- "Reset my encoding and decoding state for mono."
-
- predicted := 0.
- index := 0.
- !
Item was removed:
- ----- Method: ADPCMCodec>>resetForStereo (in category 'codec stuff') -----
- resetForStereo
- "Reset my encoding and decoding state for stereo."
-
- "keep state as SoundBuffers to allow fast access from primitive"
- predicted := SoundBuffer new: 2.
- index := SoundBuffer new: 2.
- !
Item was removed:
- ----- Method: ADPCMCodec>>samplesPerFrame (in category 'codec stuff') -----
- samplesPerFrame
- "Answer the number of sound samples per compression frame."
-
- frameSizeMask > 0 ifTrue: [^ frameSizeMask + 1].
- ^ 8 "frame size when there are no running headers"
- !
Item was removed:
- Object subclass: #AIFFFileReader
- instanceVariableNames: 'in fileType channelCount frameCount bitsPerSample samplingRate channelData channelDataOffset markers pitch gain isLooped skipDataChunk mergeIfStereo'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !AIFFFileReader commentStamp: '<historical>' prior: 0!
- I am a parser for AIFF (audio interchange file format) files. I can read uncompressed 8-bit and 16-bit mono, stereo, or multichannel AIFF files. I read the marker information used by the TransferStation utility to mark the loop points in sounds extracted from commercial sampled-sound CD-ROMs.
- !
Item was removed:
- ----- Method: AIFFFileReader>>bitsPerSample (in category 'accessing') -----
- bitsPerSample
-
- ^ bitsPerSample
- !
Item was removed:
- ----- Method: AIFFFileReader>>channelCount (in category 'accessing') -----
- channelCount
-
- ^ channelCount
- !
Item was removed:
- ----- Method: AIFFFileReader>>channelData (in category 'accessing') -----
- channelData
-
- ^ channelData
- !
Item was removed:
- ----- Method: AIFFFileReader>>channelDataOffset (in category 'accessing') -----
- channelDataOffset
-
- ^ channelDataOffset
- !
Item was removed:
- ----- Method: AIFFFileReader>>frameCount (in category 'accessing') -----
- frameCount
-
- ^ frameCount
- !
Item was removed:
- ----- Method: AIFFFileReader>>gain (in category 'accessing') -----
- gain
-
- ^ gain
- !
Item was removed:
- ----- Method: AIFFFileReader>>isLooped (in category 'accessing') -----
- isLooped
-
- ^ isLooped
- !
Item was removed:
- ----- Method: AIFFFileReader>>isStereo (in category 'accessing') -----
- isStereo
-
- ^ channelData size = 2
- !
Item was removed:
- ----- Method: AIFFFileReader>>leftSamples (in category 'accessing') -----
- leftSamples
-
- ^ channelData at: 1
- !
Item was removed:
- ----- Method: AIFFFileReader>>loopEnd (in category 'accessing') -----
- loopEnd
- ^ markers second last!
Item was removed:
- ----- Method: AIFFFileReader>>loopLength (in category 'accessing') -----
- loopLength
- ^ markers second last - markers first last!
Item was removed:
- ----- Method: AIFFFileReader>>markers (in category 'accessing') -----
- markers
-
- ^ markers
- !
Item was removed:
- ----- Method: AIFFFileReader>>pitch (in category 'accessing') -----
- pitch
-
- ^ pitch
- !
Item was removed:
- ----- Method: AIFFFileReader>>pitchForKey: (in category 'other') -----
- pitchForKey: midiKey
- "Convert my MIDI key number to a pitch and return it."
-
- | indexInOctave octave p |
- indexInOctave := (midiKey \\ 12) + 1.
- octave := (midiKey // 12) + 1.
- "Table generator: (0 to: 11) collect: [:i | 16.3516 * (2.0 raisedTo: i asFloat / 12.0)]"
- p := #(16.3516 17.32391 18.35405 19.44544 20.60173 21.82677
- 23.12466 24.49972 25.95655 27.50000 29.13524 30.86771) at: indexInOctave.
- ^ p * (#(0.5 1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0) at: octave)
- !
Item was removed:
- ----- Method: AIFFFileReader>>readChunk:size: (in category 'private') -----
- readChunk: chunkType size: chunkSize
- "Read a AIFF chunk of the given type. Skip unrecognized chunks. Leave the input stream positioned chunkSize bytes past its position when this method is called."
-
- chunkType = 'COMM' ifTrue: [^ self readCommonChunk: chunkSize].
- chunkType = 'SSND' ifTrue: [^ self readSamplesChunk: chunkSize].
- chunkType = 'INST' ifTrue: [^ self readInstrumentChunk: chunkSize].
- chunkType = 'MARK' ifTrue: [^ self readMarkerChunk: chunkSize].
- in skip: chunkSize. "skip unknown chunks"
- !
Item was removed:
- ----- Method: AIFFFileReader>>readCommonChunk: (in category 'private') -----
- readCommonChunk: chunkSize
- "Read a COMM chunk. All AIFF files have exactly one chunk of this type."
-
- | compressionType |
- channelCount := in nextNumber: 2.
- frameCount := in nextNumber: 4.
- bitsPerSample := in nextNumber: 2.
- samplingRate := self readExtendedFloat.
- chunkSize > 18 ifTrue: [
- fileType = 'AIFF'
- ifTrue: [self error: 'unexpectedly long COMM chunk size for AIFF file'].
- compressionType := (in next: 4) asString.
- compressionType = 'NONE' ifFalse: [self error: 'cannot read compressed AIFF files'].
- in skip: (chunkSize - 22)]. "skip the reminder of AIFF-C style chunk"
- !
Item was removed:
- ----- Method: AIFFFileReader>>readExtendedFloat (in category 'private') -----
- readExtendedFloat
- "Read and answer an Apple extended-precision 80-bit floating point number from the input stream."
- "Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do."
-
- | signAndExp mantissa sign exp |
- signAndExp := in nextNumber: 2.
- mantissa := in nextNumber: 8. "scaled by (2 raisedTo: -64) below"
- (signAndExp bitAnd: 16r8000) = 0
- ifTrue: [sign := 1.0]
- ifFalse: [sign := -1.0].
- exp := (signAndExp bitAnd: 16r7FFF) - 16r4000 + 2. "not sure why +2 is needed..."
- ^ (sign * mantissa asFloat * (2.0 raisedTo: exp - 64)) roundTo: 0.00000001
- !
Item was removed:
- ----- Method: AIFFFileReader>>readFrom: (in category 'private') -----
- readFrom: aBinaryStream
- "Read AIFF data from the given binary stream."
- "Details: An AIFF file consists of a header (FORM chunk) followed by a sequence of tagged data chunks. Each chunk starts with a header consisting of a four-byte tag (a string) and a four byte size. These eight bytes of chunk header are not included in the chunk size. For each chunk, the readChunk:size: method consumes chunkSize bytes of the input stream, parsing recognized chunks or skipping unrecognized ones. If chunkSize is odd, it will be followed by a padding byte. Chunks may occur in any order."
-
- | sz end chunkType chunkSize p |
- in := aBinaryStream.
-
- "read FORM chunk"
- (in next: 4) asString = 'FORM' ifFalse: [^ self error: 'not an AIFF file'].
- sz := in nextNumber: 4.
- end := in position + sz.
- fileType := (in next: 4) asString.
-
- [in atEnd not and: [in position < end]] whileTrue: [
- chunkType := (in next: 4) asString.
- chunkSize := in nextNumber: 4.
- p := in position.
- self readChunk: chunkType size: chunkSize.
- (in position = (p + chunkSize))
- ifFalse: [self error: 'chunk size mismatch; bad AIFF file?'].
- chunkSize odd ifTrue: [in skip: 1]]. "skip padding byte"
- !
Item was removed:
- ----- Method: AIFFFileReader>>readFromFile: (in category 'reading') -----
- readFromFile: fileName
- "Read the AIFF file of the given name."
- "AIFFFileReader new readFromFile: 'test.aiff'"
-
- self readFromFile: fileName
- mergeIfStereo: false
- skipDataChunk: false.
- !
Item was removed:
- ----- Method: AIFFFileReader>>readFromFile:mergeIfStereo:skipDataChunk: (in category 'reading') -----
- 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.
- !
Item was removed:
- ----- Method: AIFFFileReader>>readFromStream:mergeIfStereo:skipDataChunk: (in category '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.
- !
Item was removed:
- ----- Method: AIFFFileReader>>readInstrumentChunk: (in category 'private') -----
- readInstrumentChunk: chunkSize
- | midiKey detune lowNote highNote lowVelocity highVelocity sustainMode sustainStartID sustainEndID releaseMode releaseStartID releaseEndID |
- midiKey := in next.
- detune := in next.
- lowNote := in next.
- highNote := in next.
- lowVelocity := in next.
- highVelocity := in next.
- gain := in nextNumber: 2.
- sustainMode := in nextNumber: 2.
- sustainStartID := in nextNumber: 2.
- sustainEndID := in nextNumber: 2.
- releaseMode := in nextNumber: 2.
- releaseStartID := in nextNumber: 2.
- releaseEndID := in nextNumber: 2.
- isLooped := sustainMode = 1.
- (isLooped
- and: [markers notNil])
- ifTrue: [(markers first last > frameCount
- or: [markers second last > frameCount])
- ifTrue: ["bad loop data; some sample CD files claim to be
- looped but aren't"
- isLooped := false]].
- pitch := self pitchForKey: midiKey!
Item was removed:
- ----- Method: AIFFFileReader>>readMarkerChunk: (in category 'private') -----
- readMarkerChunk: chunkSize
-
- | markerCount id position labelBytes label |
- markerCount := in nextNumber: 2.
- markers := Array new: markerCount.
- 1 to: markerCount do: [:i |
- id := in nextNumber: 2.
- position := in nextNumber: 4.
- labelBytes := in next.
- label := (in next: labelBytes) asString.
- labelBytes even ifTrue: [in skip: 1].
- markers at: i put: (Array with: id with: label with: position)].
-
- !
Item was removed:
- ----- Method: AIFFFileReader>>readMergedStereoChannelDataFrom: (in category 'private') -----
- readMergedStereoChannelDataFrom: s
- "Read stereophonic channel data from the given stream, mixing the two channels to create a single monophonic channel. Each frame contains two samples."
-
- | buf w1 w2 |
- buf := channelData at: 1.
- bitsPerSample = 8
- ifTrue: [
- 1 to: frameCount do: [:i |
- w1 := s next.
- w1 > 127 ifTrue: [w1 := w1 - 256].
- w2 := s next.
- w2 > 127 ifTrue: [w2 := w2 - 256].
- buf at: i put: ((w1 + w2) bitShift: 7)]]
- ifFalse: [
- 1 to: frameCount do: [:i |
- w1 := (s next bitShift: 8) + s next.
- w1 > 32767 ifTrue: [w1 := w1 - 65536].
- w2 := (s next bitShift: 8) + s next.
- w2 > 32767 ifTrue: [w2 := w2 - 65536].
- buf at: i put: ((w1 + w2) bitShift: -1)]].
- !
Item was removed:
- ----- Method: AIFFFileReader>>readMonoChannelDataFrom: (in category 'private') -----
- readMonoChannelDataFrom: s
- "Read monophonic channel data from the given stream. Each frame contains a single sample."
-
- | buf w |
- buf := channelData at: 1. "the only buffer"
- bitsPerSample = 8
- ifTrue: [
- 1 to: frameCount do: [:i |
- w := s next.
- w > 127 ifTrue: [w := w - 256].
- buf at: i put: (w bitShift: 8)]]
- ifFalse: [
- 1 to: frameCount do: [:i |
- w := (s next bitShift: 8) + s next.
- w > 32767 ifTrue: [w := w - 65536].
- buf at: i put: w]].
- !
Item was removed:
- ----- Method: AIFFFileReader>>readMultiChannelDataFrom: (in category 'private') -----
- readMultiChannelDataFrom: s
- "Read multi-channel data from the given stream. Each frame contains channelCount samples."
-
- | w |
- bitsPerSample = 8
- ifTrue: [
- 1 to: frameCount do: [:i |
- 1 to: channelCount do: [:ch |
- w := s next.
- w > 127 ifTrue: [w := w - 256].
- (channelData at: ch) at: i put: (w bitShift: 8)]]]
- ifFalse: [
- 1 to: frameCount do: [:i |
- 1 to: channelCount do: [:ch |
- w := (s next bitShift: 8) + s next.
- w > 32767 ifTrue: [w := w - 65536].
- (channelData at: ch) at: i put: w]]].
- !
Item was removed:
- ----- Method: AIFFFileReader>>readSamplesChunk: (in category 'private') -----
- 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.
- !
Item was removed:
- ----- Method: AIFFFileReader>>readStereoChannelDataFrom: (in category 'private') -----
- readStereoChannelDataFrom: s
- "Read stereophonic channel data from the given stream. Each frame contains two samples."
-
- | left right w |
- left := channelData at: 1.
- right := channelData at: 2.
- bitsPerSample = 8
- ifTrue: [
- 1 to: frameCount do: [:i |
- w := s next.
- w > 127 ifTrue: [w := w - 256].
- left at: i put: (w bitShift: 8).
- w := s next.
- w > 127 ifTrue: [w := w - 256].
- right at: i put: (w bitShift: 8)]]
- ifFalse: [
- 1 to: frameCount do: [:i |
- w := (s next bitShift: 8) + s next.
- w > 32767 ifTrue: [w := w - 65536].
- left at: i put: w.
- w := (s next bitShift: 8) + s next.
- w > 32767 ifTrue: [w := w - 65536].
- right at: i put: w]].
- !
Item was removed:
- ----- Method: AIFFFileReader>>rightSamples (in category 'accessing') -----
- rightSamples
-
- ^ channelData at: 2
- !
Item was removed:
- ----- Method: AIFFFileReader>>samplingRate (in category 'accessing') -----
- samplingRate
-
- ^ samplingRate
- !
Item was removed:
- ----- Method: AIFFFileReader>>sound (in category 'other') -----
- sound
- "Answer the sound represented by this AIFFFileReader. This method should be called only after readFrom: has been done."
-
- | snd rightSnd |
- snd := SampledSound
- samples: (channelData at: 1)
- samplingRate: samplingRate.
- self isStereo ifTrue: [
- rightSnd := SampledSound
- samples: (channelData at: 2)
- samplingRate: samplingRate.
- snd := MixedSound new
- add: snd pan: 0;
- add: rightSnd pan: 1.0].
- ^ snd
- !
Item was removed:
- Object subclass: #AbstractScoreEvent
- instanceVariableNames: 'time'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !AbstractScoreEvent commentStamp: '<historical>' prior: 0!
- Abstract class for timed events in a MIDI score.
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>adjustTimeBy: (in category 'accessing') -----
- adjustTimeBy: delta
-
- time := time + delta
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>endTime (in category 'accessing') -----
- endTime
- "Subclasses should override to return the ending time if the event has some duration."
-
- ^ time
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>isControlChange (in category 'classification') -----
- isControlChange
-
- ^ false
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>isNoteEvent (in category 'classification') -----
- isNoteEvent
-
- ^ false
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>isPitchBend (in category 'classification') -----
- isPitchBend
-
- ^ false
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>isProgramChange (in category 'classification') -----
- isProgramChange
-
- ^ false
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>isTempoEvent (in category 'classification') -----
- isTempoEvent
-
- ^ false
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>outputOnMidiPort: (in category 'midi') -----
- outputOnMidiPort: aMidiPort
- "Output this event to the given MIDI port. This default implementation does nothing."
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>time (in category 'accessing') -----
- time
-
- ^ time
- !
Item was removed:
- ----- Method: AbstractScoreEvent>>time: (in category 'accessing') -----
- time: aNumber
-
- time := aNumber.
- !
Item was removed:
- Object subclass: #AbstractSound
- instanceVariableNames: 'envelopes mSecsSinceStart samplesUntilNextControl scaledVol scaledVolIncr scaledVolLimit'
- classVariableNames: 'FloatScaleFactor MaxScaledValue PitchesForBottomOctave ScaleFactor Sounds TopOfBottomOctave UnloadedSnd'
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: AbstractSound class>>bachFugue (in category 'examples-bach fugue BWV847') -----
- bachFugue
- "Play a fugue by J. S. Bach using and instance of me as the sound for all four voices."
- "PluckedSound bachFugue play"
-
- ^ self bachFugueOn: self default
- !
Item was removed:
- ----- Method: AbstractSound class>>bachFugueOn: (in category 'examples-bach fugue BWV847') -----
- bachFugueOn: aSound
- "Play a fugue by J. S. Bach using the given sound as the sound for all four voices."
- "PluckedSound bachFugue play"
-
- ^ MixedSound new
- add: (self bachFugueVoice1On: aSound) pan: 1.0;
- add: (self bachFugueVoice2On: aSound) pan: 0.0;
- add: (self bachFugueVoice3On: aSound) pan: 1.0;
- add: (self bachFugueVoice4On: aSound) pan: 0.0.
- !
Item was removed:
- ----- Method: AbstractSound class>>bachFugueVoice1On: (in category 'examples-bach fugue BWV847') -----
- bachFugueVoice1On: aSound
- "Voice one of a fugue by J. S. Bach."
-
- ^ self noteSequenceOn: aSound from: #(
- (1047 0.15 268)
- (988 0.15 268)
- (1047 0.30 268)
- (784 0.30 268)
- (831 0.30 268)
- (1047 0.15 268)
- (988 0.15 268)
- (1047 0.30 268)
- (1175 0.30 268)
- (784 0.30 268)
- (1047 0.15 268)
- (988 0.15 268)
- (1047 0.30 268)
- (1175 0.30 268)
- (698 0.15 268)
- (784 0.15 268)
- (831 0.60 268)
- (784 0.15 268)
- (698 0.15 268)
- (622 0.15 268)
- (1047 0.15 268)
- (988 0.15 268)
- (880 0.15 268)
- (784 0.15 268)
- (698 0.15 268)
- (622 0.15 268)
- (587 0.15 268)
- (523 0.30 268)
- (1245 0.30 268)
- (1175 0.30 268)
- (1047 0.30 268)
- (932 0.30 268)
- (880 0.30 268)
- (932 0.30 268)
- (1047 0.30 268)
- (740 0.30 268)
- (784 0.30 268)
- (880 0.30 268)
- (740 0.30 268)
- (784 0.60 268)
- (rest 0.15)
- (523 0.15 268)
- (587 0.15 268)
- (622 0.15 268)
- (698 0.15 268)
- (784 0.15 268)
- (831 0.45 268)
- (587 0.15 268)
- (622 0.15 268)
- (698 0.15 268)
- (784 0.15 268)
- (880 0.15 268)
- (932 0.45 268)
- (622 0.15 268)
- (698 0.15 268)
- (784 0.15 268)
- (831 0.15 268)
- (784 0.15 268)
- (698 0.15 268)
- (622 0.15 268)
- (587 0.30 268)
- (1047 0.15 268)
- (988 0.15 268)
- (1047 0.60 268)
- (rest 0.9)
- (1397 0.30 268)
- (1245 0.30 268)
- (1175 0.30 268)
- (rest 0.3)
- (831 0.30 268)
- (784 0.30 268)
- (698 0.30 268)
- (784 0.30 268)
- (698 0.15 268)
- (622 0.15 268)
- (698 0.30 268)
- (587 0.30 268)
- (784 0.60 268)
- (rest 0.3)
- (988 0.30 268)
- (1047 0.30 268)
- (1047 0.15 268)
- (988 0.15 268)
- (1047 0.30 268)
- (784 0.30 268)
- (831 0.60 268)
- (rest 0.3)
- (880 0.30 268)
- (932 0.30 268)
- (932 0.15 268)
- (880 0.15 268)
- (932 0.30 268)
- (698 0.30 268)
- (784 0.60 268)
- (rest 0.3)
- (784 0.30 268)
- (831 0.30 268)
- (831 0.30 268)
- (784 0.30 268)
- (698 0.30 268)
- (rest 0.3)
- (415 0.30 268)
- (466 0.30 268)
- (523 0.30 268)
- (rest 0.3)
- (415 0.15 268)
- (392 0.15 268)
- (415 0.30 268)
- (349 0.30 268)
- (466 0.30 268)
- (523 0.30 268)
- (466 0.30 268)
- (415 0.30 268)
- (466 0.30 268)
- (392 0.30 268)
- (349 0.30 268)
- (311 0.30 268)
- (349 0.30 268)
- (554 0.30 268)
- (523 0.30 268)
- (466 0.30 268)
- (523 0.30 268)
- (415 0.30 268)
- (392 0.30 268)
- (349 0.30 268)
- (392 0.30 268)
- (784 0.15 268)
- (740 0.15 268)
- (784 0.30 268)
- (523 0.30 268)
- (622 0.30 268)
- (784 0.15 268)
- (740 0.15 268)
- (784 0.30 268)
- (880 0.30 268)
- (587 0.30 268)
- (784 0.15 268)
- (740 0.15 268)
- (784 0.30 268)
- (880 0.30 268)
- (523 0.15 268)
- (587 0.15 268)
- (622 0.60 268)
- (587 0.15 268)
- (523 0.15 268)
- (466 0.30 346)
- (rest 0.45)
- (587 0.15 346)
- (659 0.15 346)
- (740 0.15 346)
- (784 0.15 346)
- (880 0.15 346)
- (932 0.45 346)
- (659 0.15 346)
- (698 0.15 346)
- (784 0.15 346)
- (880 0.15 346)
- (932 0.15 346)
- (1047 0.45 346)
- (740 0.15 346)
- (784 0.15 346)
- (880 0.15 346)
- (932 0.30 346)
- (622 0.15 346)
- (587 0.15 346)
- (622 0.30 346)
- (392 0.30 346)
- (415 0.30 346)
- (698 0.15 346)
- (622 0.15 346)
- (698 0.30 346)
- (440 0.30 346)
- (466 0.30 346)
- (784 0.15 346)
- (698 0.15 346)
- (784 0.30 346)
- (494 0.30 346)
- (523 0.15 346)
- (698 0.15 346)
- (622 0.15 346)
- (587 0.15 346)
- (523 0.15 346)
- (466 0.15 346)
- (440 0.15 346)
- (392 0.15 346)
- (349 0.30 346)
- (831 0.30 346)
- (784 0.30 346)
- (698 0.30 346)
- (622 0.30 346)
- (587 0.30 346)
- (622 0.30 346)
- (698 0.30 346)
- (494 0.30 346)
- (523 0.30 346)
- (587 0.30 346)
- (494 0.30 346)
- (523 0.60 346)
- (rest 0.3)
- (659 0.30 346)
- (698 0.30 346)
- (698 0.15 346)
- (659 0.15 346)
- (698 0.30 346)
- (523 0.30 346)
- (587 0.60 346)
- (rest 0.3)
- (587 0.30 346)
- (622 0.30 346)
- (622 0.15 346)
- (587 0.15 346)
- (622 0.30 346)
- (466 0.30 346)
- (523 1.20 346)
- (523 0.30 346)
- (587 0.15 346)
- (622 0.15 346)
- (698 0.15 346)
- (622 0.15 346)
- (698 0.15 346)
- (587 0.15 346)
- (494 0.30 457)
- (rest 0.6)
- (494 0.30 457)
- (523 0.30 457)
- (rest 0.6)
- (622 0.30 457)
- (587 0.30 457)
- (rest 0.6)
- (698 0.60 457)
- (rest 0.6)
- (698 0.30 457)
- (622 0.30 457)
- (831 0.30 457)
- (784 0.30 457)
- (698 0.30 457)
- (622 0.30 457)
- (587 0.30 457)
- (622 0.30 457)
- (698 0.30 457)
- (494 0.30 457)
- (523 0.30 457)
- (587 0.30 457)
- (494 0.30 457)
- (494 0.30 457)
- (523 0.30 457)
- (rest 0.3)
- (523 0.30 457)
- (698 0.15 457)
- (587 0.15 457)
- (622 0.15 457)
- (523 0.45 457)
- (494 0.30 457)
- (523 0.60 457)
- (rest 0.3)
- (659 0.30 268)
- (698 0.60 268)
- (rest 0.3)
- (698 0.30 268)
- (698 0.30 268)
- (622 0.15 268)
- (587 0.15 268)
- (622 0.30 268)
- (698 0.30 268)
- (587 0.40 268)
- (rest 0.4)
- (587 0.40 268)
- (rest 0.4)
- (523 1.60 268)).!
Item was removed:
- ----- Method: AbstractSound class>>bachFugueVoice2On: (in category 'examples-bach fugue BWV847') -----
- bachFugueVoice2On: aSound
- "Voice two of a fugue by J. S. Bach."
-
- ^ self noteSequenceOn: aSound from: #(
- (rest 4.8)
- (1568 0.15 346)
- (1480 0.15 346)
- (1568 0.30 346)
- (1047 0.30 346)
- (1245 0.30 346)
- (1568 0.15 346)
- (1480 0.15 346)
- (1568 0.30 346)
- (1760 0.30 346)
- (1175 0.30 346)
- (1568 0.15 346)
- (1480 0.15 346)
- (1568 0.30 346)
- (1760 0.30 346)
- (1047 0.15 346)
- (1175 0.15 346)
- (1245 0.60 346)
- (1175 0.15 346)
- (1047 0.15 346)
- (932 0.30 346)
- (1245 0.15 346)
- (1175 0.15 346)
- (1245 0.30 346)
- (784 0.30 346)
- (831 0.30 346)
- (1397 0.15 346)
- (1245 0.15 346)
- (1397 0.30 346)
- (880 0.30 346)
- (932 0.30 346)
- (1568 0.15 346)
- (1397 0.15 346)
- (1568 0.30 346)
- (988 0.30 346)
- (1047 0.30 346)
- (1175 0.15 346)
- (1245 0.15 346)
- (1397 0.90 346)
- (1245 0.15 346)
- (1175 0.15 346)
- (1047 0.15 346)
- (932 0.15 346)
- (831 0.15 346)
- (784 0.15 346)
- (698 0.30 346)
- (1661 0.30 346)
- (1568 0.30 346)
- (1397 0.30 346)
- (1245 0.30 346)
- (1175 0.30 346)
- (1245 0.30 346)
- (1397 0.30 346)
- (988 0.30 346)
- (1047 0.30 346)
- (1175 0.30 346)
- (988 0.30 346)
- (1047 0.30 457)
- (1568 0.15 457)
- (1480 0.15 457)
- (1568 0.30 457)
- (1175 0.30 457)
- (1245 0.60 457)
- (rest 0.3)
- (1319 0.30 457)
- (1397 0.30 457)
- (1397 0.15 457)
- (1319 0.15 457)
- (1397 0.30 457)
- (1047 0.30 457)
- (1175 0.60 457)
- (rest 0.3)
- (1175 0.30 457)
- (1245 0.30 457)
- (1245 0.15 457)
- (1175 0.15 457)
- (1245 0.30 457)
- (932 0.30 457)
- (1047 0.30 457)
- (1245 0.15 457)
- (1175 0.15 457)
- (1245 0.30 457)
- (1397 0.30 457)
- (932 0.30 457)
- (1245 0.15 457)
- (1175 0.15 457)
- (1245 0.30 457)
- (1397 0.30 457)
- (831 0.15 457)
- (932 0.15 457)
- (1047 0.60 457)
- (932 0.15 457)
- (831 0.15 457)
- (784 0.15 457)
- (622 0.15 457)
- (698 0.15 457)
- (784 0.15 457)
- (831 0.15 457)
- (932 0.15 457)
- (1047 0.15 457)
- (1175 0.15 457)
- (1245 0.15 457)
- (1175 0.15 457)
- (1047 0.15 457)
- (1175 0.15 457)
- (1245 0.15 457)
- (1397 0.15 457)
- (1568 0.15 457)
- (1760 0.15 457)
- (1865 0.15 457)
- (698 0.15 457)
- (784 0.15 457)
- (831 0.15 457)
- (932 0.15 457)
- (1047 0.15 457)
- (1175 0.15 457)
- (1319 0.15 457)
- (1397 0.15 457)
- (1245 0.15 457)
- (1175 0.15 457)
- (1245 0.15 457)
- (1397 0.15 457)
- (1568 0.15 457)
- (1760 0.15 457)
- (1976 0.15 457)
- (2093 0.30 457)
- (1976 0.15 457)
- (1760 0.15 457)
- (1568 0.15 457)
- (1397 0.15 457)
- (1245 0.15 457)
- (1175 0.15 457)
- (1047 0.30 457)
- (1245 0.30 457)
- (1175 0.30 457)
- (1047 0.30 457)
- (932 0.30 457)
- (880 0.30 457)
- (932 0.30 457)
- (1047 0.30 457)
- (740 0.30 457)
- (784 0.30 457)
- (880 0.30 457)
- (740 0.30 457)
- (784 0.30 457)
- (1175 0.15 457)
- (1047 0.15 457)
- (1175 0.30 457)
- (rest 0.6)
- (1319 0.15 457)
- (1175 0.15 457)
- (1319 0.30 457)
- (rest 0.6)
- (1480 0.15 457)
- (1319 0.15 457)
- (1480 0.30 457)
- (rest 0.6)
- (784 0.15 457)
- (698 0.15 457)
- (784 0.30 457)
- (rest 0.6)
- (880 0.15 457)
- (784 0.15 457)
- (880 0.30 457)
- (rest 0.6)
- (988 0.15 457)
- (880 0.15 457)
- (988 0.30 457)
- (rest 0.6)
- (1047 0.15 457)
- (988 0.15 457)
- (1047 0.30 457)
- (784 0.30 457)
- (831 0.30 457)
- (1047 0.15 457)
- (988 0.15 457)
- (1047 0.30 457)
- (1175 0.30 457)
- (784 0.30 457)
- (1047 0.15 457)
- (988 0.15 457)
- (1047 0.30 457)
- (1175 0.30 457)
- (698 0.15 457)
- (784 0.15 457)
- (831 0.60 457)
- (784 0.15 457)
- (698 0.15 457)
- (622 0.30 457)
- (1047 0.15 457)
- (988 0.15 457)
- (1047 0.30 457)
- (784 0.30 457)
- (831 0.60 457)
- (rest 0.3)
- (880 0.30 457)
- (932 0.30 457)
- (932 0.15 457)
- (880 0.15 457)
- (932 0.30 457)
- (698 0.30 457)
- (784 0.60 457)
- (rest 0.3)
- (784 0.60 457)
- (831 0.15 457)
- (932 0.15 457)
- (1047 0.15 457)
- (988 0.15 457)
- (1047 0.15 457)
- (831 0.15 457)
- (698 1.20 457)
- (698 0.30 591)
- (1175 0.15 591)
- (1047 0.15 591)
- (1175 0.30 591)
- (698 0.30 591)
- (622 0.30 591)
- (1245 0.15 591)
- (1175 0.15 591)
- (1245 0.30 591)
- (784 0.30 591)
- (698 0.30 591)
- (1397 0.15 591)
- (1245 0.15 591)
- (1397 0.30 591)
- (831 0.30 591)
- (784 0.15 591)
- (1397 0.15 591)
- (1245 0.15 591)
- (1175 0.15 591)
- (1047 0.15 591)
- (988 0.15 591)
- (880 0.15 591)
- (784 0.15 591)
- (1047 0.30 591)
- (1397 0.30 591)
- (1245 0.30 591)
- (1175 0.30 591)
- (rest 0.3)
- (831 0.30 591)
- (784 0.30 591)
- (698 0.30 591)
- (784 0.30 591)
- (698 0.15 591)
- (622 0.15 591)
- (698 0.30 591)
- (587 0.30 591)
- (831 0.30 591)
- (784 0.30 591)
- (rest 0.3)
- (880 0.30 591)
- (988 0.30 591)
- (1047 0.30 591)
- (698 0.15 591)
- (622 0.15 591)
- (587 0.15 591)
- (523 0.15 591)
- (523 0.30 591)
- (1047 0.15 346)
- (988 0.15 346)
- (1047 0.30 346)
- (784 0.30 346)
- (831 0.30 346)
- (1047 0.15 346)
- (988 0.15 346)
- (1047 0.30 346)
- (1175 0.30 346)
- (784 0.30 346)
- (1047 0.15 346)
- (988 0.15 346)
- (1047 0.30 346)
- (1175 0.30 346)
- (698 0.20 346)
- (784 0.20 346)
- (831 0.80 346)
- (784 0.20 346)
- (698 0.20 346)
- (659 1.60 346)).
- !
Item was removed:
- ----- Method: AbstractSound class>>bachFugueVoice3On: (in category 'examples-bach fugue BWV847') -----
- bachFugueVoice3On: aSound
- "Voice three of a fugue by J. S. Bach."
-
- ^ self noteSequenceOn: aSound from: #(
- (rest 14.4)
- (523 0.15 457)
- (494 0.15 457)
- (523 0.30 457)
- (392 0.30 457)
- (415 0.30 457)
- (523 0.15 457)
- (494 0.15 457)
- (523 0.30 457)
- (587 0.30 457)
- (392 0.30 457)
- (523 0.15 457)
- (494 0.15 457)
- (523 0.30 457)
- (587 0.30 457)
- (349 0.15 457)
- (392 0.15 457)
- (415 0.60 457)
- (392 0.15 457)
- (349 0.15 457)
- (311 0.15 457)
- (523 0.15 457)
- (494 0.15 457)
- (440 0.15 457)
- (392 0.15 457)
- (349 0.15 457)
- (311 0.15 457)
- (294 0.15 457)
- (262 0.15 457)
- (294 0.15 457)
- (311 0.15 457)
- (294 0.15 457)
- (262 0.15 457)
- (233 0.15 457)
- (208 0.15 457)
- (196 0.15 457)
- (175 0.15 457)
- (466 0.15 457)
- (415 0.15 457)
- (392 0.15 457)
- (349 0.15 457)
- (311 0.15 457)
- (294 0.15 457)
- (262 0.15 457)
- (233 0.15 457)
- (262 0.15 457)
- (294 0.15 457)
- (262 0.15 457)
- (233 0.15 457)
- (208 0.15 457)
- (196 0.15 457)
- (175 0.15 457)
- (156 0.15 457)
- (415 0.15 457)
- (392 0.15 457)
- (349 0.15 457)
- (311 0.15 457)
- (277 0.15 457)
- (262 0.15 457)
- (233 0.15 457)
- (208 0.30 457)
- (523 0.30 457)
- (466 0.30 457)
- (415 0.30 457)
- (392 0.30 457)
- (349 0.30 457)
- (392 0.30 457)
- (415 0.30 457)
- (294 0.30 457)
- (311 0.30 457)
- (349 0.30 457)
- (294 0.30 457)
- (311 0.30 457)
- (415 0.30 457)
- (392 0.30 457)
- (349 0.30 457)
- (392 0.30 457)
- (311 0.30 457)
- (294 0.30 457)
- (262 0.30 457)
- (294 0.30 457)
- (466 0.30 457)
- (415 0.30 457)
- (392 0.30 457)
- (415 0.30 457)
- (349 0.30 457)
- (311 0.30 457)
- (294 0.30 457)
- (311 0.30 457)
- (rest 1.2)
- (262 0.30 457)
- (233 0.30 457)
- (220 0.30 457)
- (rest 0.3)
- (311 0.30 457)
- (294 0.30 457)
- (262 0.30 457)
- (294 0.30 457)
- (262 0.15 457)
- (233 0.15 457)
- (262 0.30 457)
- (294 0.30 457)
- (196 0.30 591)
- (466 0.15 591)
- (440 0.15 591)
- (466 0.30 591)
- (294 0.30 591)
- (311 0.30 591)
- (523 0.15 591)
- (466 0.15 591)
- (523 0.30 591)
- (330 0.30 591)
- (349 0.30 591)
- (587 0.15 591)
- (523 0.15 591)
- (587 0.30 591)
- (370 0.30 591)
- (392 0.60 591)
- (rest 0.15)
- (196 0.15 591)
- (220 0.15 591)
- (247 0.15 591)
- (262 0.15 591)
- (294 0.15 591)
- (311 0.45 591)
- (220 0.15 591)
- (233 0.15 591)
- (262 0.15 591)
- (294 0.15 591)
- (311 0.15 591)
- (349 0.45 591)
- (247 0.15 591)
- (262 0.15 591)
- (294 0.15 591)
- (311 0.30 591)
- (rest 0.6)
- (330 0.30 591)
- (349 0.30 591)
- (175 0.30 591)
- (156 0.30 591)
- (147 0.30 591)
- (rest 0.3)
- (208 0.30 591)
- (196 0.30 591)
- (175 0.30 591)
- (196 0.30 591)
- (175 0.15 591)
- (156 0.15 591)
- (175 0.30 591)
- (196 0.30 591)
- (262 0.15 591)
- (294 0.15 591)
- (311 0.15 591)
- (294 0.15 591)
- (262 0.15 591)
- (233 0.15 591)
- (208 0.15 591)
- (196 0.15 591)
- (175 0.15 591)
- (466 0.15 591)
- (415 0.15 591)
- (392 0.15 591)
- (349 0.15 591)
- (311 0.15 591)
- (294 0.15 591)
- (262 0.15 591)
- (233 0.15 591)
- (262 0.15 591)
- (294 0.15 591)
- (262 0.15 591)
- (233 0.15 591)
- (208 0.15 591)
- (196 0.15 591)
- (175 0.15 591)
- (156 0.15 591)
- (415 0.15 591)
- (392 0.15 591)
- (349 0.15 591)
- (311 0.15 591)
- (294 0.15 591)
- (262 0.15 591)
- (233 0.15 591)
- (208 0.15 591)
- (233 0.15 591)
- (262 0.15 591)
- (233 0.15 591)
- (208 0.15 591)
- (196 0.15 591)
- (175 0.15 591)
- (156 0.15 591)
- (147 0.15 591)
- (392 0.15 591)
- (349 0.15 591)
- (311 0.15 591)
- (294 0.15 591)
- (262 0.15 591)
- (247 0.15 591)
- (220 0.15 591)
- (196 0.60 772)
- (196 0.60 772)
- (rest 0.15)
- (196 0.15 772)
- (220 0.15 772)
- (247 0.15 772)
- (262 0.15 772)
- (294 0.15 772)
- (311 0.15 772)
- (349 0.15 772)
- (392 0.15 772)
- (349 0.15 772)
- (415 0.15 772)
- (392 0.15 772)
- (349 0.15 772)
- (311 0.15 772)
- (294 0.15 772)
- (262 0.15 772)
- (247 0.30 772)
- (262 0.15 772)
- (494 0.15 772)
- (262 0.30 772)
- (196 0.30 772)
- (208 0.30 772)
- (262 0.15 772)
- (247 0.15 772)
- (262 0.30 772)
- (294 0.30 772)
- (196 0.30 772)
- (262 0.15 772)
- (247 0.15 772)
- (262 0.30 772)
- (294 0.30 772)
- (175 0.15 772)
- (196 0.15 772)
- (208 0.60 772)
- (196 0.15 772)
- (175 0.15 772)
- (156 0.60 772)
- (rest 0.3)
- (311 0.30 772)
- (294 0.30 772)
- (262 0.30 772)
- (392 0.30 772)
- (196 0.30 772)
- (262 3.60 268)
- (494 0.40 268)
- (rest 0.4)
- (494 0.40 268)
- (rest 0.4)
- (392 1.60 268)).
- !
Item was removed:
- ----- Method: AbstractSound class>>bachFugueVoice4On: (in category 'examples-bach fugue BWV847') -----
- bachFugueVoice4On: aSound
- "Voice four of a fugue by J. S. Bach."
-
- ^ self noteSequenceOn: aSound from: #(
- (rest 61.2)
- (131 0.15 500)
- (123 0.15 500)
- (131 0.30 500)
- (98 0.30 500)
- (104 0.30 500)
- (131 0.15 500)
- (123 0.15 500)
- (131 0.30 500)
- (147 0.30 500)
- (98 0.30 500)
- (131 0.15 500)
- (123 0.15 500)
- (131 0.30 500)
- (147 0.30 500)
- (87 0.15 500)
- (98 0.15 500)
- (104 0.60 500)
- (98 0.15 500)
- (87 0.15 500)
- (78 0.60 500)
- (rest 0.3)
- (156 0.30 500)
- (147 0.30 500)
- (131 0.30 500)
- (196 0.30 500)
- (98 0.30 500)
- (131 3.60 268)
- (131 3.20 205)).
- !
Item was removed:
- ----- Method: AbstractSound class>>busySignal: (in category 'utilities') -----
- busySignal: count
- "AbstractSound busySignal: 3"
- | m s |
- s := SequentialSound new.
- m := MixedSound new.
- m add: (FMSound new setPitch: 480 dur: 0.5 loudness: 0.5);
- add: (FMSound new setPitch: 620 dur: 0.5 loudness: 0.5).
- s add: m.
- s add: (FMSound new setPitch: 1 dur: 0.5 loudness: 0).
- ^ (RepeatingSound repeat: s count: count) play.
-
- !
Item was removed:
- ----- Method: AbstractSound class>>chromaticPitchesFrom: (in category 'examples') -----
- chromaticPitchesFrom: aPitch
-
- | halfStep pitch |
- halfStep := 2.0 raisedTo: (1.0 / 12.0).
- pitch := aPitch isNumber
- ifTrue: [aPitch]
- ifFalse: [self pitchForName: aPitch].
- pitch := pitch / halfStep.
- ^ (0 to: 14) collect: [:i | pitch := pitch * halfStep]
- !
Item was removed:
- ----- Method: AbstractSound class>>chromaticRunFrom:to:on: (in category 'examples') -----
- chromaticRunFrom: startPitch to: endPitch on: aSound
- "Answer a composite sound consisting of a rapid chromatic run between the given pitches on the given sound."
- "(AbstractSound chromaticRunFrom: 'c3' to: 'c#5' on: FMSound oboe1) play"
-
- | scale halfStep pEnd p |
- scale := SequentialSound new.
- halfStep := 2.0 raisedTo: (1.0 / 12.0).
- endPitch isNumber
- ifTrue: [pEnd := endPitch asFloat]
- ifFalse: [pEnd := AbstractSound pitchForName: endPitch].
- startPitch isNumber
- ifTrue: [p := startPitch asFloat]
- ifFalse: [p := AbstractSound pitchForName: startPitch].
- [p <= pEnd] whileTrue: [
- scale add: (aSound soundForPitch: p dur: 0.2 loudness: 0.5).
- p := p * halfStep].
- ^ scale
- !
Item was removed:
- ----- Method: AbstractSound class>>chromaticScale (in category 'examples') -----
- chromaticScale
- "PluckedSound chromaticScale play"
-
- ^ self chromaticScaleOn: self default
- !
Item was removed:
- ----- Method: AbstractSound class>>chromaticScaleOn: (in category 'examples') -----
- chromaticScaleOn: aSound
- "PluckedSound chromaticScale play"
-
- ^ self noteSequenceOn: aSound
- from: (((self chromaticPitchesFrom: #c4) copyFrom: 1 to: 13)
- collect: [:pitch | Array with: pitch with: 0.5 with: 300])
- !
Item was removed:
- ----- Method: AbstractSound class>>default (in category 'instance creation') -----
- default
- "Return a default sound prototype for this class, with envelopes if appropriate. (This is in contrast to new, which returns a raw instance without envelopes.)"
-
- ^ self new
- !
Item was removed:
- ----- Method: AbstractSound class>>dial: (in category 'utilities') -----
- dial: aString
- | s |
- "AbstractSound dial: '867-5309'" "ask for Jenny"
-
- s := SequentialSound new.
- aString do: [ :c | | lo m index hi |
- c = $,
- ifTrue: [ s add: (FMSound new setPitch: 1 dur: 1 loudness: 0) ]
- ifFalse: [
- (index := ('123A456B789C*0#D' indexOf: c)) > 0
- ifTrue: [
- lo := #(697 770 852 941) at: (index - 1 // 4 + 1).
- hi := #(1209 1336 1477 1633) at: (index - 1 \\ 4 + 1).
- m := MixedSound new.
- m add: (FMSound new setPitch: lo dur: 0.15 loudness: 0.5).
- m add: (FMSound new setPitch: hi dur: 0.15 loudness: 0.5).
- s add: m.
- s add: (FMSound new setPitch: 1 dur: 0.05 loudness: 0)]]].
- ^ s play.
-
- !
Item was removed:
- ----- Method: AbstractSound class>>dialTone: (in category 'utilities') -----
- dialTone: duration
- "AbstractSound dialTone: 2"
- | m |
- m := MixedSound new.
- m add: (FMSound new setPitch: 350 dur: duration loudness: 0.5).
- m add: (FMSound new setPitch: 440 dur: duration loudness: 0.5).
- m play.
- ^ m!
Item was removed:
- ----- Method: AbstractSound class>>dur: (in category 'instance creation') -----
- dur: d
- "Return a rest of the given duration."
-
- ^ self basicNew setDur: d
- !
Item was removed:
- ----- Method: AbstractSound class>>fileInSoundLibrary (in category 'sound library-file in/out') -----
- fileInSoundLibrary
- "Prompt the user for a file name and the file in the sound library with that name."
- "AbstractSound fileInSoundLibrary"
-
- | fileName |
- fileName := UIManager default request: 'Sound library file name?'.
- fileName isEmptyOrNil ifTrue: [^ self].
- (fileName endsWith: '.sounds') ifFalse: [fileName := fileName, '.sounds'].
- self fileInSoundLibraryNamed: fileName.
- !
Item was removed:
- ----- Method: AbstractSound class>>fileInSoundLibraryNamed: (in category 'sound library-file in/out') -----
- fileInSoundLibraryNamed: fileName
- "File in the sound library with the given file name, and add its contents to the current sound library."
-
- | s newSounds |
- s := FileStream readOnlyFileNamed: fileName.
- newSounds := s fileInObjectAndCode.
- s close.
- newSounds associationsDo:
- [:assoc | self storeFiledInSound: assoc value named: assoc key].
- AbstractSound updateScorePlayers.
- Smalltalk garbageCollect. "Large objects may have been released"
- !
Item was removed:
- ----- Method: AbstractSound class>>fileOutSoundLibrary (in category 'sound library-file in/out') -----
- fileOutSoundLibrary
- "File out the current sound library."
- "AbstractSound fileOutSoundLibrary"
-
- self fileOutSoundLibrary: Sounds.
- !
Item was removed:
- ----- Method: AbstractSound class>>fileOutSoundLibrary: (in category 'sound library-file in/out') -----
- fileOutSoundLibrary: aDictionary
- "File out the given dictionary, which is assumed to contain sound and instrument objects keyed by their names."
- "Note: This method is separated out so that one can file out edited sound libraries, as well as the system sound library. To make such a collection, you can inspect AbstractSound sounds and remove the items you don't want. Then do: 'AbstractSound fileOutSoundLibrary: self' from the Dictionary inspector."
-
- | fileName refStream |
- (aDictionary isKindOf: Dictionary)
- ifFalse: [self error: 'arg should be a dictionary of sounds'].
- fileName := UIManager default request: 'Sound library file name?'.
- fileName isEmptyOrNil ifTrue: [^ self].
- refStream := SmartRefStream fileNamed: fileName, '.sounds'.
- refStream nextPut: aDictionary.
- refStream close.
- !
Item was removed:
- ----- Method: AbstractSound class>>hangUpWarning: (in category 'utilities') -----
- hangUpWarning: count
- "AbstractSound hangUpWarning: 20"
- | m s |
- s := SequentialSound new.
- m := MixedSound new.
- m add: (FMSound new setPitch: 1400 dur: 0.1 loudness: 0.5);
- add: (FMSound new setPitch: 2060 dur: 0.1 loudness: 0.5).
- s add: m; add: (FMSound new setPitch: 1 dur: 0.1 loudness: 0).
- ^ (RepeatingSound repeat: s count: count) play
-
- !
Item was removed:
- ----- Method: AbstractSound class>>hiMajorScale (in category 'examples') -----
- hiMajorScale
- "FMSound hiMajorScale play"
-
- ^ self hiMajorScaleOn: self default
- !
Item was removed:
- ----- Method: AbstractSound class>>hiMajorScaleOn: (in category 'examples') -----
- hiMajorScaleOn: aSound
- "FMSound hiMajorScale play"
-
- ^ self majorScaleOn: aSound from: #c6!
Item was removed:
- ----- Method: AbstractSound class>>indexOfBottomOctavePitch: (in category 'utilities') -----
- indexOfBottomOctavePitch: p
- "Answer the index of the first pitch in the bottom octave equal to or higher than the given pitch. Assume that the given pitch is below the top pitch of the bottom octave."
-
- 1 to: PitchesForBottomOctave size do: [:i |
- (PitchesForBottomOctave at: i) >= p ifTrue: [^ i]].
- self error: 'implementation error: argument pitch should be below or within the bottom octave'.
- !
Item was removed:
- ----- Method: AbstractSound class>>initSounds (in category 'sound library') -----
- initSounds
- "AbstractSound initSounds"
-
- Sounds := Dictionary new.
- (FMSound class organization listAtCategoryNamed: #instruments)
- do: [:sel | Sounds at: sel asString put: (FMSound perform: sel)].
- !
Item was removed:
- ----- Method: AbstractSound class>>initialize (in category 'class initialization') -----
- initialize
- "AbstractSound initialize"
-
- | bottomC |
- ScaleFactor := 2 raisedTo: 15.
- FloatScaleFactor := ScaleFactor asFloat.
- MaxScaledValue := ((2 raisedTo: 31) // ScaleFactor) - 1. "magnitude of largest scaled value in 32-bits"
-
- "generate pitches for c-1 through c0"
- bottomC := (440.0 / 32) * (2.0 raisedTo: -9.0 / 12.0).
- PitchesForBottomOctave := (0 to: 12) collect: [:i | bottomC * (2.0 raisedTo: i asFloat / 12.0)].
- TopOfBottomOctave := PitchesForBottomOctave last.
- !
Item was removed:
- ----- Method: AbstractSound class>>lowMajorScale (in category 'examples') -----
- lowMajorScale
- "PluckedSound lowMajorScale play"
-
- ^ self lowMajorScaleOn: self default
- !
Item was removed:
- ----- Method: AbstractSound class>>lowMajorScaleOn: (in category 'examples') -----
- lowMajorScaleOn: aSound
- "PluckedSound lowMajorScale play"
-
- ^ self majorScaleOn: aSound from: #c3!
Item was removed:
- ----- Method: AbstractSound class>>majorChord (in category 'examples') -----
- majorChord
- "FMSound majorChord play"
- ^ self majorChordOn: self default from: #c4!
Item was removed:
- ----- Method: AbstractSound class>>majorChordOn:from: (in category 'examples') -----
- majorChordOn: aSound from: aPitch
- "FMSound majorChord play"
-
- | score majorScale leadingRest pan |
- majorScale := self majorPitchesFrom: aPitch.
- score := MixedSound new.
- leadingRest := pan := 0.
- #(1 3 5 8) do: [:noteIndex | | note |
- note := aSound
- soundForPitch: (majorScale at: noteIndex)
- dur: 2.0 - leadingRest
- loudness: 0.3.
- score add: (RestSound dur: leadingRest), note pan: pan.
- leadingRest := leadingRest + 0.2.
- pan := pan + 0.3].
- ^ score
- !
Item was removed:
- ----- Method: AbstractSound class>>majorPitchesFrom: (in category 'examples') -----
- majorPitchesFrom: aPitch
- | chromatic |
- chromatic := self chromaticPitchesFrom: aPitch.
- ^ #(1 3 5 6 8 10 12 13 15 13 12 10 8 6 5 3 1) collect: [:i | chromatic at: i].
- !
Item was removed:
- ----- Method: AbstractSound class>>majorScale (in category 'examples') -----
- majorScale
- "FMSound majorScale play"
-
- ^ self majorScaleOn: self default
- !
Item was removed:
- ----- Method: AbstractSound class>>majorScaleOn: (in category 'examples') -----
- majorScaleOn: aSound
- "FMSound majorScale play"
-
- ^ self majorScaleOn: aSound from: #c5!
Item was removed:
- ----- Method: AbstractSound class>>majorScaleOn:from: (in category 'examples') -----
- majorScaleOn: aSound from: aPitch
- "FMSound majorScale play"
-
- ^ self noteSequenceOn: aSound
- from: ((self majorPitchesFrom: aPitch)
- collect: [:pitch | Array with: pitch with: 0.5 with: 300])
- !
Item was removed:
- ----- Method: AbstractSound class>>majorScaleOn:from:octaves: (in category 'examples') -----
- majorScaleOn: aSound from: aPitch octaves: octaveCount
- "(AbstractSound majorScaleOn: FMSound oboe1 from: #c2 octaves: 5) play"
-
- | startingPitch pitches chromatic |
- startingPitch := aPitch isNumber
- ifTrue: [aPitch]
- ifFalse: [self pitchForName: aPitch].
- pitches := OrderedCollection new.
- 0 to: octaveCount - 1 do: [:i |
- chromatic := self chromaticPitchesFrom: startingPitch * (2 raisedTo: i).
- #(1 3 5 6 8 10 12) do: [:j | pitches addLast: (chromatic at: j)]].
- pitches addLast: startingPitch * (2 raisedTo: octaveCount).
- ^ self noteSequenceOn: aSound
- from: (pitches collect: [:pitch | Array with: pitch with: 0.5 with: 300])
- !
Item was removed:
- ----- Method: AbstractSound class>>midiKeyForPitch: (in category 'utilities') -----
- midiKeyForPitch: pitchNameOrNumber
- "Answer the midiKey closest to the given pitch. Pitch may be a numeric pitch or a pitch name string such as 'c4'."
- "AbstractSound midiKeyForPitch: 440.0"
-
- | p octave i midiKey |
- pitchNameOrNumber isNumber
- ifTrue: [p := pitchNameOrNumber asFloat]
- ifFalse: [p := AbstractSound pitchForName: pitchNameOrNumber].
- octave := -1.
- [p >= TopOfBottomOctave] whileTrue: [
- octave := octave + 1.
- p := p / 2.0].
-
- i := self indexOfBottomOctavePitch: p.
- (i > 1) ifTrue: [
- (p - (PitchesForBottomOctave at: i - 1)) < ((PitchesForBottomOctave at: i) - p)
- ifTrue: [i := i - 1]].
-
- midiKey := ((octave * 12) + 11 + i).
- midiKey > 127 ifTrue: [midiKey := 127].
- ^ midiKey
- !
Item was removed:
- ----- Method: AbstractSound class>>noteSequenceOn:from: (in category 'instance creation') -----
- noteSequenceOn: aSound from: anArray
- "Build a note sequence (i.e., a SequentialSound) from the given array using the given sound as the instrument. Elements are either (pitch, duration, loudness) triples or (#rest duration) pairs. Pitches can be given as names or as numbers."
- | score |
- score := SequentialSound new.
- anArray do: [:el | | pitch |
- el size = 3
- ifTrue: [
- pitch := el at: 1.
- pitch isNumber ifFalse: [pitch := self pitchForName: pitch].
- score add: (
- aSound
- soundForPitch: pitch
- dur: (el at: 2)
- loudness: (el at: 3) / 1000.0)]
- ifFalse: [
- score add: (RestSound dur: (el at: 2))]].
- ^ score
- !
Item was removed:
- ----- Method: AbstractSound class>>pitch:dur:loudness: (in category 'instance creation') -----
- pitch: p dur: d loudness: l
- "Return a new sound object for a note with the given parameters."
-
- ^ self new setPitch: p dur: d loudness: l
- !
Item was removed:
- ----- Method: AbstractSound class>>pitchForMIDIKey: (in category 'utilities') -----
- pitchForMIDIKey: midiKey
- "Answer the pitch for the given MIDI key."
- "(1 to: 127) collect: [:i | AbstractSound pitchForMIDIKey: i]"
-
- | indexInOctave octave |
- indexInOctave := (midiKey \\ 12) + 1.
- octave := (midiKey // 12) + 1.
- ^ (PitchesForBottomOctave at: indexInOctave) *
- (#(1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0 1024.0) at: octave)
- !
Item was removed:
- ----- Method: AbstractSound class>>pitchForName: (in category 'utilities') -----
- pitchForName: aString
- "AbstractSound pitchForName: 'c2'"
- "#(c 'c#' d eb e f fs g 'g#' a bf b) collect: [ :s | AbstractSound pitchForName: s, '4']"
-
- | s modifier octave i j noteName p |
- s := ReadStream on: aString.
- modifier := $n.
- noteName := s next.
- (s atEnd not and: [s peek isDigit]) ifFalse: [ modifier := s next ].
- s atEnd
- ifTrue: [ octave := 4 ]
- ifFalse: [ octave := Integer readFrom: s ].
- octave < 0 ifTrue: [ self error: 'cannot use negative octave number' ].
- i := 'cdefgab' indexOf: noteName.
- i = 0 ifTrue: [ self error: 'bad note name: ', noteName asString ].
- i := #(2 4 6 7 9 11 13) at: i.
- j := 's#fb' indexOf: modifier.
- j = 0 ifFalse: [ i := i + (#(1 1 -1 -1) at: j) ]. "i is now in range: [1..14]"
- "Table generator: (1 to: 14) collect: [ :i | 16.3516 * (2.0 raisedTo: (i - 2) asFloat / 12.0)]"
- p := #(15.4339 16.3516 17.3239 18.354 19.4454 20.6017 21.8268 23.1247 24.4997 25.9565 27.5 29.1352 30.8677 32.7032) at: i.
- octave timesRepeat: [ p := 2.0 * p ].
- ^ p
- !
Item was removed:
- ----- Method: AbstractSound class>>pitchTable (in category 'utilities') -----
- pitchTable
- "AbstractSound pitchTable"
-
- | out note i |
- out := WriteStream on: (String new: 1000).
- i := 12.
- 0 to: 8 do: [:octave |
- #(c 'c#' d eb e f fs g 'g#' a bf b) do: [:noteName |
- note := noteName, octave printString.
- out nextPutAll: note; tab.
- out nextPutAll: i printString; tab.
- out nextPutAll: (AbstractSound pitchForName: note) printString; cr.
- i := i + 1]].
- ^ out contents
- !
Item was removed:
- ----- Method: AbstractSound class>>scaleFactor (in category 'class initialization') -----
- scaleFactor
-
- ^ ScaleFactor
- !
Item was removed:
- ----- Method: AbstractSound class>>scaleTest (in category 'examples') -----
- scaleTest
- "AbstractSound scaleTest play"
-
- ^ MixedSound new
- add: FMSound majorScale pan: 0;
- add: (PluckedSound lowMajorScale delayedBy: 0.5) pan: 1.0.
- !
Item was removed:
- ----- Method: AbstractSound class>>soundNamed: (in category 'sound library') -----
- soundNamed: soundName
-
- ^ Sounds at: soundName
- !
Item was removed:
- ----- Method: AbstractSound class>>soundNamed:ifAbsent: (in category 'sound library') -----
- soundNamed: soundName ifAbsent: aBlock
-
- ^ Sounds at: soundName ifAbsent: aBlock
- !
Item was removed:
- ----- Method: AbstractSound class>>soundNamed:put: (in category 'sound library') -----
- soundNamed: soundName put: aSound
-
- Sounds at: soundName put: aSound.
- AbstractSound updateScorePlayers.
- !
Item was removed:
- ----- Method: AbstractSound class>>soundNames (in category 'sound library') -----
- soundNames
-
- "AbstractSound soundNames asSortedCollection do:
- [:n |
- (n padded: #right to: 10 with: $ ) asParagraph displayAt: Sensor cursorPoint - 32.
- (AbstractSound soundNamed: n) ifNotNil:
- [:s| s playAndWaitUntilDone. (Delay forMilliseconds: 250) wait]]"
-
- ^ Sounds keys asArray sort
- !
Item was removed:
- ----- Method: AbstractSound class>>sounds (in category 'sound library') -----
- sounds
-
- ^ Sounds
- !
Item was removed:
- ----- Method: AbstractSound class>>stereoBachFugue (in category 'examples-bach fugue BWV847') -----
- stereoBachFugue
- "Play fugue by J. S. Bach in stereo using different timbres."
- "AbstractSound stereoBachFugue play"
-
- "(AbstractSound bachFugueVoice1On: FMSound flute1) play"
- "(AbstractSound bachFugueVoice1On: PluckedSound default) play"
-
- ^ MixedSound new
- add: (self bachFugueVoice1On: FMSound oboe1) pan: 0.2;
- add: (self bachFugueVoice2On: FMSound organ1) pan: 0.8;
- add: (self bachFugueVoice3On: PluckedSound default) pan: 0.4;
- add: (self bachFugueVoice4On: FMSound brass1) pan: 0.6.
- !
Item was removed:
- ----- Method: AbstractSound class>>storeFiledInSound:named: (in category 'sound library-file in/out') -----
- storeFiledInSound: snd named: sndName
- "Store the given sound in the sound library. Use the given name if it isn't in use, otherwise ask the user what to do."
-
- | choice i |
- (Sounds includesKey: sndName) ifFalse: [ "no name clash"
- Sounds at: sndName put: snd.
- ^ self].
-
- (Sounds at: sndName) == UnloadedSnd ifTrue: [
- "re-loading a sound that was unloaded to save space"
- Sounds at: sndName put: snd.
- ^ self].
-
- "the given sound name is already used"
- choice := Project uiManager
- chooseOptionFrom: #('replace the existing sound' 'rename the new sound' 'skip it')
- values: #('replace the existing sound' 'rename the new sound' 'skip it')
- title: '"', sndName, '" has the same name as an existing sound'.
- (choice beginsWith: 'replace') ifTrue: [
- Sounds at: sndName put: snd.
- ^ self].
- (choice beginsWith: 'rename') ifTrue: [
- i := 2.
- [Sounds includesKey: (sndName, ' v', i printString)] whileTrue: [i := i + 1].
- Sounds at: (sndName, ' v', i printString) put: snd].
- !
Item was removed:
- ----- Method: AbstractSound class>>testFMInteractively (in category 'examples') -----
- testFMInteractively
- "Experiment with different settings of the FM modulation and multiplier settings interactively by moving the mouse. The top-left corner of the screen is 0 for both parameters. Stop when the mouse is pressed."
- "AbstractSound testFMInteractively"
-
- | s mousePt lastVal status mod ratio |
- SoundPlayer startPlayerProcessBufferSize: 1100 rate: 11025 stereo: false.
- s := FMSound pitch: 440.0 dur: 200.0 loudness: 0.2.
-
- SoundPlayer playSound: s.
- lastVal := nil.
- [Sensor anyButtonPressed] whileFalse: [
- mousePt := Sensor cursorPoint.
- mousePt ~= lastVal ifTrue: [
- mod := mousePt x asFloat / 20.0.
- ratio := mousePt y asFloat / 20.0.
- s modulation: mod ratio: ratio.
- lastVal := mousePt.
- status :=
- 'mod: ', mod printString, '
- ratio: ', ratio printString.
- status displayOn: Display at: 10@10]].
-
- SoundPlayer shutDown: true.
- !
Item was removed:
- ----- Method: AbstractSound class>>translatedPrimitives (in category 'primitive generation') -----
- translatedPrimitives
- ^#(
- (FMSound mixSampleCount:into:startingAt:leftVol:rightVol:)
- (PluckedSound mixSampleCount:into:startingAt:leftVol:rightVol:)
- (LoopedSampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
- (SampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
- (ReverbSound applyReverbTo:startingAt:count:)
- ).
- !
Item was removed:
- ----- Method: AbstractSound class>>unloadSampledTimbres (in category 'sound library-file in/out') -----
- unloadSampledTimbres
- "This can be done to unload those bulky sampled timbres to shrink the image. The unloaded sounds are replaced by a well-known 'unloaded sound' object to enable the unloaded sounds to be detected when the process is reversed."
- "AbstractSound unloadSampledTimbres"
-
- Sounds keys do: [:soundName |
- (((Sounds at: soundName) isKindOf: SampledInstrument) or:
- [(Sounds at: soundName) isKindOf: LoopedSampledSound]) ifTrue: [
- Sounds at: soundName put: self unloadedSound]].
- self updateScorePlayers.
- Smalltalk garbageCollect.
- !
Item was removed:
- ----- Method: AbstractSound class>>unloadSoundNamed: (in category 'sound library-file in/out') -----
- unloadSoundNamed: soundName
-
- (Sounds includesKey: soundName) ifTrue: [
- Sounds at: soundName put: self unloadedSound].
- self updateScorePlayers.
- !
Item was removed:
- ----- Method: AbstractSound class>>unloadedSound (in category 'sound library-file in/out') -----
- unloadedSound
- "Answer a sound to be used as the place-holder for sounds that have been unloaded."
-
- UnloadedSnd ifNil: [UnloadedSnd := UnloadedSound default copy].
- ^ UnloadedSnd
- !
Item was removed:
- ----- Method: AbstractSound class>>updateFMSounds (in category 'sound library') -----
- updateFMSounds
- "AbstractSound updateFMSounds"
-
- Sounds keys do: [:k |
- ((Sounds at: k) isKindOf: FMSound) ifTrue: [
- Sounds removeKey: k ifAbsent: []]].
-
- (FMSound class organization listAtCategoryNamed: #instruments) do:
- [:sel | Sounds at: sel asString put: (FMSound perform: sel)].
- !
Item was removed:
- ----- Method: AbstractSound>>+ (in category 'composition') -----
- + aSound
- "Return the mix of the receiver and the argument sound."
-
- ^(MixedSound new)
- add: self;
- add: aSound;
- yourself
- !
Item was removed:
- ----- Method: AbstractSound>>, (in category 'composition') -----
- , aSound
- "Return the concatenation of the receiver and the argument sound."
-
- ^(SequentialSound new)
- add: self;
- add: aSound;
- yourself!
Item was removed:
- ----- Method: AbstractSound>>addEnvelope: (in category 'envelopes') -----
- addEnvelope: anEnvelope
- "Add the given envelope to my envelopes list."
-
- anEnvelope target: self.
- envelopes := envelopes copyWith: anEnvelope.
- !
Item was removed:
- ----- Method: AbstractSound>>adjustVolumeTo:overMSecs: (in category 'volume') -----
- adjustVolumeTo: vol overMSecs: mSecs
- "Adjust the volume of this sound to the given volume, a number in the range [0.0..1.0], over the given number of milliseconds. The volume will be changed a little bit on each sample until the desired volume is reached."
-
- | newScaledVol |
-
- self flag: #bob. "I removed the upper limit to allow making sounds louder. hmm..."
-
- newScaledVol := (32768.0 * vol) truncated.
- newScaledVol = scaledVol ifTrue: [^ self].
- scaledVolLimit := newScaledVol.
- "scaledVolLimit > ScaleFactor ifTrue: [scaledVolLimit := ScaleFactor]."
- scaledVolLimit < 0 ifTrue: [scaledVolLimit := 0].
- mSecs = 0
- ifTrue: [ "change immediately"
- scaledVol := scaledVolLimit.
- scaledVolIncr := 0]
- ifFalse: [
- scaledVolIncr :=
- ((scaledVolLimit - scaledVol) * 1000) // (self samplingRate * mSecs)].
- !
Item was removed:
- ----- Method: AbstractSound>>asSampledSound (in category 'conversion') -----
- 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
- !
Item was removed:
- ----- Method: AbstractSound>>asSound (in category 'composition') -----
- asSound
-
- ^ self
- !
Item was removed:
- ----- Method: AbstractSound>>computeSamplesForSeconds: (in category 'playing') -----
- computeSamplesForSeconds: seconds
- "Compute the samples of this sound without outputting them, and return the resulting buffer of samples."
-
- | buf |
- self reset.
- buf := SoundBuffer newStereoSampleCount: (self samplingRate * seconds) asInteger.
- self playSampleCount: buf stereoSampleCount into: buf startingAt: 1.
- ^ buf
- !
Item was removed:
- ----- Method: AbstractSound>>controlRate (in category 'sampling rates') -----
- controlRate
- "Answer the number of control changes per second."
-
- ^ 100
- !
Item was removed:
- ----- Method: AbstractSound>>copyEnvelopes (in category 'copying') -----
- copyEnvelopes
- "Private!! Support for copying. Copy my envelopes."
-
- envelopes := envelopes collect: [:e | e copy target: self].
- !
Item was removed:
- ----- Method: AbstractSound>>delayedBy: (in category 'composition') -----
- delayedBy: seconds
- "Return a composite sound consisting of a rest for the given amount of time followed by the receiver."
-
- ^ (RestSound dur: seconds), self
- !
Item was removed:
- ----- Method: AbstractSound>>doControl (in category 'sound generation') -----
- doControl
- "Update the control parameters of this sound using its envelopes, if any."
- "Note: This is only called at a small fraction of the sampling rate."
-
- | pitchModOrRatioChange |
- envelopes size > 0 ifTrue: [
- pitchModOrRatioChange := false.
- 1 to: envelopes size do: [:i |
- ((envelopes at: i) updateTargetAt: mSecsSinceStart)
- ifTrue: [pitchModOrRatioChange := true]].
- pitchModOrRatioChange ifTrue: [self internalizeModulationAndRatio]].
- mSecsSinceStart := mSecsSinceStart + (1000 // self controlRate).
- !
Item was removed:
- ----- Method: AbstractSound>>duration: (in category 'initialization') -----
- duration: seconds
- "Scale my envelopes to the given duration. Subclasses overriding this method should include a resend to super."
-
- envelopes do: [:e | e duration: seconds].
- !
Item was removed:
- ----- Method: AbstractSound>>envelopes (in category 'envelopes') -----
- envelopes
- "Return my collection of envelopes."
-
- ^ envelopes
- !
Item was removed:
- ----- Method: AbstractSound>>initialVolume: (in category 'volume') -----
- initialVolume: vol
- "Set the initial volume of this sound to the given volume, a number in the range [0.0..1.0]."
-
- scaledVol := (((vol asFloat min: 1.0) max: 0.0) * ScaleFactor) rounded.
- scaledVolLimit := scaledVol.
- scaledVolIncr := 0.
- !
Item was removed:
- ----- Method: AbstractSound>>initialize (in category 'initialization') -----
- initialize
- super initialize.
- envelopes := #().
- mSecsSinceStart := 0.
- samplesUntilNextControl := 0.
- scaledVol := (1.0 * ScaleFactor) rounded.
- scaledVolIncr := 0.
- scaledVolLimit := scaledVol.
- !
Item was removed:
- ----- Method: AbstractSound>>internalizeModulationAndRatio (in category 'sound generation') -----
- internalizeModulationAndRatio
- "Overridden by FMSound. This default implementation does nothing."
- !
Item was removed:
- ----- Method: AbstractSound>>isPlaying (in category 'playing') -----
- isPlaying
- "Return true if the receiver is currently playing"
- ^ SoundPlayer isPlaying: self!
Item was removed:
- ----- Method: AbstractSound>>isStereo (in category 'accessing') -----
- 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
- !
Item was removed:
- ----- Method: AbstractSound>>loudness (in category 'volume') -----
- loudness
- "Answer the current volume setting for this sound."
-
- ^ envelopes detect: [:e | e isKindOf: VolumeEnvelope]
- ifFound: [ :envelope | envelope scale ]
- ifNone: [scaledVol asFloat / FloatScaleFactor]
- !
Item was removed:
- ----- Method: AbstractSound>>loudness: (in category 'initialization') -----
- loudness: aNumber
- "Initialize my volume envelopes and initial volume. Subclasses overriding this method should include a resend to super."
-
- | vol |
- vol := (aNumber asFloat max: 0.0) min: 1.0.
- envelopes do: [:e |
- (e isKindOf: VolumeEnvelope) ifTrue: [e scale: vol]].
- self initialVolume: vol.
- !
Item was removed:
- ----- Method: AbstractSound>>millisecondsSinceStart (in category 'playing') -----
- millisecondsSinceStart
-
- ^ mSecsSinceStart!
Item was removed:
- ----- Method: AbstractSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1. The leftVol and rightVol parameters determine the volume of the sound in each channel, where 0 is silence and ScaleFactor is full volume."
-
- self subclassResponsibility.
- !
Item was removed:
- ----- Method: AbstractSound>>nameOrNumberToPitch: (in category 'initialization') -----
- nameOrNumberToPitch: aStringOrNumber
- "Answer the pitch in cycles/second for the given pitch specification. The specification can be either a numeric pitch or pitch name such as 'c4'."
-
- aStringOrNumber isNumber
- ifTrue: [^ aStringOrNumber asFloat]
- ifFalse: [^ AbstractSound pitchForName: aStringOrNumber]
- !
Item was removed:
- ----- Method: AbstractSound>>originalSamplingRate (in category 'sampling rates') -----
- 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
- !
Item was removed:
- ----- Method: AbstractSound>>pause (in category 'playing') -----
- pause
- "Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning."
-
- SoundPlayer pauseSound: self.!
Item was removed:
- ----- Method: AbstractSound>>play (in category 'playing') -----
- play
- "Play this sound to the sound output port in real time. Use the sound service to check for sound preferences."
-
- SoundService playSound: self.!
Item was removed:
- ----- Method: AbstractSound>>playAndWaitUntilDone (in category 'playing') -----
- playAndWaitUntilDone
- "Play this sound to the sound ouput port and wait until it has finished playing before returning."
-
- | duration timeTaken delay |
- duration := [self duration] on: MessageNotUnderstood do: [:ex| SmallInteger maxVal].
- timeTaken := Time utcMicrosecondClock.
- self play.
- timeTaken := Time utcMicrosecondClock - timeTaken // 1000.
- duration > timeTaken ifTrue:
- [delay := Delay forMilliseconds: (SoundPlayer bufferMSecs min: duration - timeTaken).
- [self samplesRemaining > 0] whileTrue: [delay wait]].
- (Delay forMilliseconds: SoundPlayer bufferMSecs) wait "ensure last buffer has been output"
-
- "AndreasSystemProfiler spyOn: [PluckedSound bachFugue playAndWaitUntilDone]"!
Item was removed:
- ----- Method: AbstractSound>>playChromaticRunFrom:to: (in category 'playing') -----
- playChromaticRunFrom: startPitch to: endPitch
- "Play a fast chromatic run between the given pitches. Useful for auditioning a sound."
-
- (AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play.
- !
Item was removed:
- ----- Method: AbstractSound>>playSampleCount:into:startingAt: (in category 'playing') -----
- playSampleCount: n into: aSoundBuffer startingAt: startIndex
- "Mix the next n samples of this sound into the given buffer starting at the given index. Update the receiver's control parameters periodically."
-
- | fullVol samplesBetweenControlUpdates pastEnd i remainingSamples count |
- fullVol := AbstractSound scaleFactor.
- samplesBetweenControlUpdates := self samplingRate // self controlRate.
- pastEnd := startIndex + n. "index just after the last sample"
- i := startIndex.
- [i < pastEnd] whileTrue: [
- remainingSamples := self samplesRemaining.
- remainingSamples <= 0 ifTrue: [^ self].
- count := pastEnd - i.
- samplesUntilNextControl < count ifTrue: [count := samplesUntilNextControl].
- remainingSamples < count ifTrue: [count := remainingSamples].
- self mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: fullVol rightVol: fullVol.
- samplesUntilNextControl := samplesUntilNextControl - count.
- samplesUntilNextControl <= 0 ifTrue: [
- self doControl.
- samplesUntilNextControl := samplesBetweenControlUpdates].
- i := i + count].
- !
Item was removed:
- ----- Method: AbstractSound>>playSilently (in category 'playing') -----
- playSilently
- "Compute the samples of this sound without outputting them. Used for performance analysis."
-
- | bufSize buf |
- self reset.
- bufSize := self samplingRate // 10.
- buf := SoundBuffer newStereoSampleCount: bufSize.
- [self samplesRemaining > 0] whileTrue: [
- buf primFill: 0.
- self playSampleCount: bufSize into: buf startingAt: 1].
- !
Item was removed:
- ----- Method: AbstractSound>>playSilentlyUntil: (in category 'playing') -----
- playSilentlyUntil: startTime
- "Compute the samples of this sound without outputting them. Used to fast foward to a particular starting time. The start time is given in seconds."
-
- | buf startSample nextSample samplesRemaining n |
- self reset.
- buf := SoundBuffer newStereoSampleCount: (self samplingRate // 10).
- startSample := (startTime * self samplingRate) asInteger.
- nextSample := 1.
- [self samplesRemaining > 0] whileTrue: [
- nextSample >= startSample ifTrue: [^ self].
- samplesRemaining := startSample - nextSample.
- samplesRemaining > buf stereoSampleCount
- ifTrue: [n := buf stereoSampleCount]
- ifFalse: [n := samplesRemaining].
- self playSampleCount: n into: buf startingAt: 1.
- nextSample := nextSample + n].
- !
Item was removed:
- ----- Method: AbstractSound>>postCopy (in category 'copying') -----
- postCopy
- "A sound should copy all of the state needed to play itself, allowing two copies of a sound to play at the same time. These semantics require a recursive copy but only down to the level of immutable data. For example, a SampledSound need not copy its sample buffer. Subclasses overriding this method should include a resend to super."
-
- super postCopy.
- self copyEnvelopes
- !
Item was removed:
- ----- Method: AbstractSound>>removeAllEnvelopes (in category 'envelopes') -----
- removeAllEnvelopes
- "Remove all envelopes from my envelopes list."
-
- envelopes := #().
- !
Item was removed:
- ----- Method: AbstractSound>>removeEnvelope: (in category 'envelopes') -----
- removeEnvelope: anEnvelope
- "Remove the given envelope from my envelopes list."
-
- envelopes := envelopes copyWithout: anEnvelope.
- !
Item was removed:
- ----- Method: AbstractSound>>reset (in category 'sound generation') -----
- reset
- "Reset my internal state for a replay. Methods that override this method should do super reset."
-
- mSecsSinceStart := 0.
- samplesUntilNextControl := 0.
- envelopes size > 0 ifTrue: [
- 1 to: envelopes size do: [:i | (envelopes at: i) reset]].
- !
Item was removed:
- ----- Method: AbstractSound>>resumePlaying (in category 'playing') -----
- resumePlaying
- "Resume playing this sound from where it last stopped."
-
- SoundPlayer resumePlaying: self.
- !
Item was removed:
- ----- Method: AbstractSound>>samples (in category 'playing') -----
- 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
- !
Item was removed:
- ----- Method: AbstractSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
- "Answer the number of samples remaining until the end of this sound. A sound with an indefinite ending time should answer some large integer such as 1000000."
-
- ^ 1000000
- !
Item was removed:
- ----- Method: AbstractSound>>samplingRate (in category 'sampling rates') -----
- samplingRate
- "Answer the sampling rate in samples per second."
-
- ^ SoundPlayer samplingRate
- !
Item was removed:
- ----- Method: AbstractSound>>setPitch:dur:loudness: (in category 'initialization') -----
- setPitch: pitchNameOrNumber dur: d loudness: l
- "Initialize my envelopes for the given parameters. Subclasses overriding this method should include a resend to super."
-
- | p |
- p := self nameOrNumberToPitch: pitchNameOrNumber.
- envelopes do: [:e |
- e volume: l.
- e centerPitch: p].
- self initialVolume: l.
- self duration: d.
- !
Item was removed:
- ----- Method: AbstractSound>>soundForMidiKey:dur:loudness: (in category 'initialization') -----
- soundForMidiKey: midiKey dur: d loudness: l
- "Answer an initialized sound object (a copy of the receiver) that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)."
-
- ^ self copy
- setPitch: (AbstractSound pitchForMIDIKey: midiKey)
- dur: d
- loudness: l
- !
Item was removed:
- ----- Method: AbstractSound>>soundForPitch:dur:loudness: (in category 'initialization') -----
- soundForPitch: pitchNameOrNumber dur: d loudness: l
- "Answer an initialized sound object (a copy of the receiver) that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0."
-
- ^ self copy setPitch: pitchNameOrNumber dur: d loudness: l
- !
Item was removed:
- ----- Method: AbstractSound>>sounds (in category 'copying') -----
- sounds
- "Allows simple sounds to behave as, eg, sequential sounds"
-
- ^ Array with: self!
Item was removed:
- ----- Method: AbstractSound>>stopAfterMSecs: (in category 'sound generation') -----
- stopAfterMSecs: mSecs
- "Terminate this sound this note after the given number of milliseconds. This default implementation does nothing."
- !
Item was removed:
- ----- Method: AbstractSound>>stopGracefully (in category 'sound generation') -----
- stopGracefully
- "End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes."
-
- | decayInMs env |
- envelopes isEmpty
- ifTrue: [
- self adjustVolumeTo: 0 overMSecs: 10.
- decayInMs := 10]
- ifFalse: [
- env := envelopes first.
- decayInMs := env attackTime + env decayTime].
- self duration: (mSecsSinceStart + decayInMs) / 1000.0.
- self stopAfterMSecs: decayInMs.
- !
Item was removed:
- ----- Method: AbstractSound>>storeAIFFOnFileNamed: (in category 'file i/o') -----
- storeAIFFOnFileNamed: fileName
- "Store this sound as a AIFF file of the given name."
-
- | f |
- f := (FileStream fileNamed: fileName) binary.
- self storeAIFFSamplesOn: f.
- f close.
- !
Item was removed:
- ----- Method: AbstractSound>>storeAIFFSamplesOn: (in category 'file i/o') -----
- 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.
- !
Item was removed:
- ----- Method: AbstractSound>>storeExtendedFloat:on: (in category 'file i/o') -----
- storeExtendedFloat: aNumber on: aBinaryStream
- "Store an Apple extended-precision 80-bit floating point number on the given stream."
- "Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do."
-
- | n isNeg exp mantissa |
- n := aNumber asFloat.
- isNeg := false.
- n < 0.0 ifTrue: [
- n := 0.0 - n.
- isNeg := true].
- exp := (n log: 2.0) ceiling.
- mantissa := (n * (2 raisedTo: 64 - exp)) truncated.
- exp := exp + 16r4000 - 2. "not sure why the -2 is needed..."
- isNeg ifTrue: [exp := exp bitOr: 16r8000]. "set sign bit"
- aBinaryStream nextPut: ((exp bitShift: -8) bitAnd: 16rFF).
- aBinaryStream nextPut: (exp bitAnd: 16rFF).
- 8 to: 1 by: -1 do: [:i | aBinaryStream nextPut: (mantissa digitAt: i)].
- !
Item was removed:
- ----- Method: AbstractSound>>storeSample:in:at:leftVol:rightVol: (in category 'sound generation') -----
- storeSample: sample in: aSoundBuffer at: sliceIndex leftVol: leftVol rightVol: rightVol
- "This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, this method is hand-inlined into all sound generation methods that use it."
-
- | i s |
- leftVol > 0 ifTrue: [
- i := (2 * sliceIndex) - 1.
- s := (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor).
- s > 32767 ifTrue: [s := 32767]. "clipping!!"
- s < -32767 ifTrue: [s := -32767]. "clipping!!"
- aSoundBuffer at: i put: s].
- rightVol > 0 ifTrue: [
- i := 2 * sliceIndex.
- s := (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor).
- s > 32767 ifTrue: [s := 32767]. "clipping!!"
- s < -32767 ifTrue: [s := -32767]. "clipping!!"
- aSoundBuffer at: i put: s].
- !
Item was removed:
- ----- Method: AbstractSound>>storeSampleCount:bigEndian:on: (in category 'file i/o') -----
- 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 streamDirect |
- self reset.
- bufSize := (2 * self samplingRate rounded) min: samplesToStore. "two second buffer"
- stereoBuffer := SoundBuffer newStereoSampleCount: bufSize.
- streamDirect := aBinaryStream isKindOf: StandardFileStream.
- reverseBytes := (bigEndianFlag xor: Smalltalk isBigEndian) xor: streamDirect not.
-
- 'Storing audio...'
- displayProgressFrom: 0 to: samplesToStore during: [:bar | | remaining out |
- remaining := samplesToStore.
- [remaining > 0] whileTrue: [
- bar value: samplesToStore - remaining.
- stereoBuffer primFill: 0. "clear the buffer"
- self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1.
- out := self isStereo
- ifTrue: [stereoBuffer]
- ifFalse: [stereoBuffer extractLeftChannel].
- reverseBytes ifTrue: [out reverseEndianness].
- streamDirect
- 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]].!
Item was removed:
- ----- Method: AbstractSound>>storeSunAudioOnFileNamed: (in category 'file i/o') -----
- 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.
- !
Item was removed:
- ----- Method: AbstractSound>>storeSunAudioSamplesOn: (in category 'file i/o') -----
- 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.
- !
Item was removed:
- ----- Method: AbstractSound>>storeWAVOnFileNamed: (in category 'file i/o') -----
- 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.
- !
Item was removed:
- ----- Method: AbstractSound>>storeWAVSamplesOn: (in category 'file i/o') -----
- 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.
- !
Item was removed:
- ----- Method: AbstractSound>>updateVolume (in category 'sound generation') -----
- updateVolume
- "Increment the volume envelope of this sound. To avoid clicks, the volume envelope must be interpolated at the sampling rate, rather than just at the control rate like other envelopes. At the control rate, the volume envelope computes the slope and next target volume volume for the current segment of the envelope (i.e., it sets the rate of change for the volume parameter). When that target volume is reached, incrementing is stopped until a new increment is set."
- "This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, it is hand-inlined into all sound generation methods that use it."
-
- scaledVolIncr ~= 0 ifTrue: [
- scaledVol := scaledVol + scaledVolIncr.
- ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
- [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
- ifTrue: [ "reached the limit; stop incrementing"
- scaledVol := scaledVolLimit.
- scaledVolIncr := 0]].
- !
Item was removed:
- ----- Method: AbstractSound>>volumeEnvelopeScaledTo: (in category 'volume') -----
- volumeEnvelopeScaledTo: scalePoint
- "Return a collection of values representing my volume envelope scaled by the given point. The scale point's x component is pixels/second and its y component is the number of pixels for full volume."
-
- self error: 'not yet implemented'.
- !
Item was removed:
- AbstractScoreEvent subclass: #AmbientEvent
- instanceVariableNames: 'morph target selector arguments'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
Item was removed:
- ----- Method: AmbientEvent>>morph (in category 'accessing') -----
- morph
- ^ morph!
Item was removed:
- ----- Method: AmbientEvent>>morph: (in category 'accessing') -----
- morph: m
- morph := m!
Item was removed:
- ----- Method: AmbientEvent>>occurAtTime:inScorePlayer:atIndex:inEventTrack:secsPerTick: (in category 'sound generation') -----
- occurAtTime: ticks inScorePlayer: player atIndex: index inEventTrack: track secsPerTick: secsPerTick
- (target == nil or: [selector == nil]) ifTrue:
- [morph ifNil: [^ self].
- ^ morph encounteredAtTime: ticks inScorePlayer: player atIndex: index
- inEventTrack: track secsPerTick: secsPerTick].
- target perform: selector withArguments: arguments!
Item was removed:
- ----- Method: AmbientEvent>>target:selector:arguments: (in category 'accessing') -----
- target: t selector: s arguments: a
- target := t.
- selector := s.
- arguments := a.
- !
Item was removed:
- AbstractSoundSystem subclass: #BaseSoundSystem
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !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.!
Item was removed:
- ----- Method: BaseSoundSystem class>>initialize (in category 'class initialization') -----
- initialize
-
- SoundService register: self.
-
- SoundService defaultOrNil
- ifNil: [SoundService default: self].!
Item was removed:
- ----- Method: BaseSoundSystem class>>unload (in category 'class initialization') -----
- unload
- SoundService unregister: self!
Item was removed:
- ----- Method: BaseSoundSystem>>beep (in category 'playing') -----
- beep
- "There is sound support, so we use the default
- sampled sound for a beep."
-
- ^ SampledSound beep!
Item was removed:
- ----- Method: BaseSoundSystem>>playSampledSound:rate: (in category 'playing') -----
- playSampledSound: samples rate: rate
-
- ^ (SampledSound samples: samples samplingRate: rate) play!
Item was removed:
- ----- Method: BaseSoundSystem>>playSound: (in category 'playing') -----
- playSound: sound
-
- SoundPlayer playSound: sound.
- ^ sound!
Item was removed:
- ----- Method: BaseSoundSystem>>playSoundNamed: (in category 'playing') -----
- playSoundNamed: soundName
- "There is sound support, so we play the given sound."
-
- ^ SampledSound playSoundNamed: soundName asString!
Item was removed:
- ----- Method: BaseSoundSystem>>playSoundNamed:ifAbsentReadFrom: (in category 'playing') -----
- playSoundNamed: soundName ifAbsentReadFrom: aifFileName
-
- (SampledSound soundNames includes: soundName) ifFalse: [
- (FileDirectory default fileExists: aifFileName) ifTrue: [
- SampledSound
- addLibrarySoundNamed: soundName
- fromAIFFfileNamed: aifFileName]].
-
- (SampledSound soundNames includes: soundName) ifTrue: [
- ^ SampledSound playSoundNamed: soundName].
-
- ^ nil!
Item was removed:
- ----- Method: BaseSoundSystem>>playSoundNamedOrBeep: (in category 'playing') -----
- playSoundNamedOrBeep: soundName
- "There is sound support, so we play the given sound
- instead of beeping."
-
- ^ self playSoundNamed: soundName!
Item was removed:
- ----- Method: BaseSoundSystem>>randomBitsFromSoundInput: (in category 'misc') -----
- 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
- !
Item was removed:
- ----- Method: BaseSoundSystem>>sampledSoundChoices (in category 'misc') -----
- sampledSoundChoices
- ^ SampledSound soundNames!
Item was removed:
- ----- Method: BaseSoundSystem>>shutDown (in category 'misc') -----
- shutDown
-
- SoundPlayer shutDown: true.
- ScorePlayer shutDown: true.!
Item was removed:
- ----- Method: BaseSoundSystem>>soundNamed: (in category 'misc') -----
- soundNamed: soundName
- ^ SampledSound soundNamed: soundName!
Item was removed:
- Object subclass: #CompressedSoundData
- instanceVariableNames: 'channels soundClassName codecName loopEnd loopLength perceivedPitch samplingRate gain firstSample cachedSound'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !CompressedSoundData commentStamp: '<historical>' prior: 0!
- Instances of this class hold the data resulting from compressing a sound. Each carries a reference to the codec class that created it, so that it can reconstruct a sound similar to the original in response to the message asSound.
-
- In order to facilitate integration with existing sounds, a CompressedSoundData instance can masquerade as a sound by caching a copy of its original sound and delegating the essential sound-playing protocol to that cached copy. It should probably be made a subclass of AbstractSound to complete the illusion.!
Item was removed:
- ----- Method: CompressedSoundData>>asSound (in category 'asSound') -----
- asSound
- "Answer the result of decompressing the receiver."
-
- | codecClass |
- codecClass := Smalltalk at: codecName
- ifAbsent: [^ self error: 'The codec for decompressing this sound is not available'].
- ^ (codecClass new decompressSound: self) reset
- !
Item was removed:
- ----- Method: CompressedSoundData>>channels (in category 'accessing') -----
- channels
- "Answer an array of ByteArrays containing the compressed sound data for each channel."
-
- ^ channels
- !
Item was removed:
- ----- Method: CompressedSoundData>>channels: (in category 'accessing') -----
- channels: anArray
-
- channels := anArray.
- !
Item was removed:
- ----- Method: CompressedSoundData>>codecName (in category 'accessing') -----
- codecName
- "Answer the name of the sound codec used to compress this sound. Typically, this is the name of a class that can be used to decode the sound, but it is possible that the codec has not yet been implemented or is not filed into this image."
-
- ^ codecName
- !
Item was removed:
- ----- Method: CompressedSoundData>>codecName: (in category 'accessing') -----
- codecName: aStringOrSymbol
-
- codecName := aStringOrSymbol asSymbol.
- !
Item was removed:
- ----- Method: CompressedSoundData>>compressWith: (in category 'compressing') -----
- compressWith: codecClass
-
- codecName == codecClass name asSymbol ifTrue: [^self].
- ^self asSound compressWith: codecClass!
Item was removed:
- ----- Method: CompressedSoundData>>compressWith:atRate: (in category 'compressing') -----
- compressWith: codecClass atRate: aSamplingRate
-
- (codecName == codecClass name asSymbol and: [samplingRate = aSamplingRate]) ifTrue: [^self].
- ^self asSound compressWith: codecClass atRate: aSamplingRate!
Item was removed:
- ----- Method: CompressedSoundData>>doControl (in category 'asSound') -----
- doControl
-
- cachedSound doControl
- !
Item was removed:
- ----- Method: CompressedSoundData>>firstSample (in category 'accessing') -----
- firstSample
- "Answer the firstSample of the original sound."
-
- ^ firstSample
- !
Item was removed:
- ----- Method: CompressedSoundData>>firstSample: (in category 'accessing') -----
- firstSample: anInteger
-
- firstSample := anInteger.
- !
Item was removed:
- ----- Method: CompressedSoundData>>gain (in category 'accessing') -----
- gain
- "Answer the gain of the original sound."
-
- ^ gain
- !
Item was removed:
- ----- Method: CompressedSoundData>>gain: (in category 'accessing') -----
- gain: aNumber
-
- gain := aNumber.
- !
Item was removed:
- ----- Method: CompressedSoundData>>loopEnd (in category 'accessing') -----
- loopEnd
- "Answer index of the last sample of the loop, or nil if the original sound was not looped."
-
- ^ loopEnd
- !
Item was removed:
- ----- Method: CompressedSoundData>>loopEnd: (in category 'accessing') -----
- loopEnd: anInteger
-
- loopEnd := anInteger.
- !
Item was removed:
- ----- Method: CompressedSoundData>>loopLength (in category 'accessing') -----
- loopLength
- "Answer length of the loop, or nil if the original sound was not looped."
-
- ^ loopLength
- !
Item was removed:
- ----- Method: CompressedSoundData>>loopLength: (in category 'accessing') -----
- loopLength: anInteger
-
- loopLength := anInteger.
- !
Item was removed:
- ----- Method: CompressedSoundData>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'asSound') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
-
- cachedSound mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- !
Item was removed:
- ----- Method: CompressedSoundData>>perceivedPitch (in category 'accessing') -----
- perceivedPitch
- "Answer the perceived pitch of the original sound. By convention, unpitched sounds (like drum hits) are given an arbitrary pitch of 100.0."
-
- ^ perceivedPitch
- !
Item was removed:
- ----- Method: CompressedSoundData>>perceivedPitch: (in category 'accessing') -----
- perceivedPitch: aNumber
-
- perceivedPitch := aNumber.
- !
Item was removed:
- ----- Method: CompressedSoundData>>reset (in category 'asSound') -----
- reset
- "This message is the cue to start behaving like a real sound in order to be played.
- We do this by caching a decompressed version of this sound.
- See also samplesRemaining."
-
- cachedSound == nil ifTrue: [cachedSound := self asSound].
- cachedSound reset
- !
Item was removed:
- ----- Method: CompressedSoundData>>samples (in category 'asSound') -----
- samples
-
- ^ self asSound samples!
Item was removed:
- ----- Method: CompressedSoundData>>samplesRemaining (in category 'asSound') -----
- samplesRemaining
- "This message is the cue that the cached sound may no longer be needed.
- We know it is done playing when samplesRemaining=0."
-
- | samplesRemaining |
- samplesRemaining := cachedSound samplesRemaining.
- samplesRemaining <= 0 ifTrue: [cachedSound := nil].
- ^ samplesRemaining!
Item was removed:
- ----- Method: CompressedSoundData>>samplingRate (in category 'accessing') -----
- samplingRate
- "Answer the samplingRate of the original sound."
-
- ^ samplingRate
- !
Item was removed:
- ----- Method: CompressedSoundData>>samplingRate: (in category 'accessing') -----
- samplingRate: aNumber
-
- samplingRate := aNumber.
- !
Item was removed:
- ----- Method: CompressedSoundData>>soundClassName (in category 'accessing') -----
- soundClassName
- "Answer the class name of the uncompressed sound."
-
- ^ soundClassName
- !
Item was removed:
- ----- Method: CompressedSoundData>>soundClassName: (in category 'accessing') -----
- soundClassName: aStringOrSymbol
-
- soundClassName := aStringOrSymbol asSymbol.
- !
Item was removed:
- ----- Method: CompressedSoundData>>withEToySound:samplingRate: (in category 'initialize-release') -----
- withEToySound: aByteArray samplingRate: anInteger
-
- soundClassName := #SampledSound.
- channels := {aByteArray}.
- codecName := #GSMCodec.
- loopEnd := nil. "???"
- loopLength := nil.
- perceivedPitch := 100.0.
- samplingRate := anInteger.
- gain := 1.0. "???"
- firstSample := 1.
- cachedSound := nil. "???"!
Item was removed:
- AbstractScoreEvent subclass: #ControlChangeEvent
- instanceVariableNames: 'control value channel'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
Item was removed:
- ----- Method: ControlChangeEvent>>channel (in category 'accessing') -----
- channel
-
- ^ channel
- !
Item was removed:
- ----- Method: ControlChangeEvent>>channel: (in category 'accessing') -----
- channel: midiChannel
-
- channel := midiChannel.
- !
Item was removed:
- ----- Method: ControlChangeEvent>>control (in category 'accessing') -----
- control
-
- ^ control
- !
Item was removed:
- ----- Method: ControlChangeEvent>>control: (in category 'accessing') -----
- control: midiControl
-
- control := midiControl.
- !
Item was removed:
- ----- Method: ControlChangeEvent>>control:value:channel: (in category 'accessing') -----
- control: midiControl value: midiControlValue channel: midiChannel
-
- control := midiControl.
- value := midiControlValue.
- channel := midiChannel.
- !
Item was removed:
- ----- Method: ControlChangeEvent>>isControlChange (in category 'classification') -----
- isControlChange
-
- ^ true
- !
Item was removed:
- ----- Method: ControlChangeEvent>>outputOnMidiPort: (in category 'midi') -----
- outputOnMidiPort: aMidiPort
- "Output this event to the given MIDI port."
-
- aMidiPort
- midiCmd: 16rB0
- channel: channel
- byte: control
- byte: value.
- !
Item was removed:
- ----- Method: ControlChangeEvent>>printOn: (in category 'printing') -----
- printOn: aStream
- aStream
- nextPut: $(;
- print: time;
- nextPutAll: ': ctrl[';
- print: control;
- nextPutAll: ']=';
- print: value;
- nextPut: $)!
Item was removed:
- ----- Method: ControlChangeEvent>>value (in category 'accessing') -----
- value
-
- ^ value
- !
Item was removed:
- ----- Method: ControlChangeEvent>>value: (in category 'accessing') -----
- value: midiControlValue
-
- value := midiControlValue.
- !
Item was removed:
- Object subclass: #Envelope
- instanceVariableNames: 'points loopStartIndex loopEndIndex loopStartMSecs loopMSecs target updateSelector loopEndMSecs endMSecs scale decayScale lastValue currValue valueIncr nextRecomputeTime noChangesDuringLoop'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !Envelope commentStamp: '<historical>' prior: 0!
- An envelope models a three-stage progression for a musical note: attack, sustain, decay. Envelopes can either return the envelope value at a given time or can update some target object using a client-specified message selector.
-
- The points instance variable holds an array of (time, value) points, where the times are in milliseconds. The points array must contain at least two points. The time coordinate of the first point must be zero and the time coordinates of subsequent points must be in ascending order, although the spacing between them is arbitrary. Envelope values between points are computed by linear interpolation.
-
- The scale slot is initially set so that the peak of envelope matches some note attribute, such as its loudness. When entering the decay phase, the scale is adjusted so that the decay begins from the envelope's current value. This avoids a potential sharp transient when entering the decay phase.
-
- The loopStartIndex and loopEndIndex slots contain the indices of points in the points array; if they are equal, then the envelope holds a constant value for the sustain phase of the note. Otherwise, envelope values are computed by repeatedly looping between these two points.
-
- The loopEndMSecs slot can be set in advance (as when playing a score) or dynamically (as when responding to interactive inputs from a MIDI keyboard). In the latter case, the value of scale is adjusted to start the decay phase with the current envelope value. Thus, if a note ends before its attack is complete, the decay phase is started immediately (i.e., the attack phase is never completed).
-
- For best results, amplitude envelopes should start and end with zero values. Otherwise, the sharp transient at the beginning or end of the note may cause audible clicks or static. For envelopes on other parameters, this may not be necessary.
- !
Item was removed:
- ----- Method: Envelope class>>example (in category 'instance creation') -----
- example
- "Envelope example"
-
- | p |
- p := Array with: 0@0 with: 100(a)1.0 with: 250(a)0.7 with: 400(a)1.0 with: 500@0.
- ^ (self points: p loopStart: 2 loopEnd: 4) sustainEnd: 1200.
- !
Item was removed:
- ----- Method: Envelope class>>exponentialDecay: (in category 'instance creation') -----
- exponentialDecay: multiplier
- "(Envelope exponentialDecay: 0.95) "
-
- | mSecsPerStep pList t v last |
- mSecsPerStep := 10.
- ((multiplier > 0.0) and: [multiplier < 1.0])
- ifFalse: [self error: 'multiplier must be greater than 0.0 and less than 1.0'].
- pList := OrderedCollection new.
- pList add: 0(a)0.0.
- last := 0.0.
- v := 1.0.
- t := 10.
- [v > 0.01] whileTrue: [
- (v - last) abs > 0.02 ifTrue: [
- "only record substatial changes"
- pList add: t@v.
- last := v].
- t := t + mSecsPerStep.
- v := v * multiplier].
- pList add: (t + mSecsPerStep)(a)0.0.
-
- ^ self points: pList asArray
- loopStart: pList size
- loopEnd: pList size
- !
Item was removed:
- ----- Method: Envelope class>>points:loopStart:loopEnd: (in category 'instance creation') -----
- points: pList loopStart: loopStart loopEnd: loopEnd
-
- ^ self new setPoints: pList asArray
- loopStart: loopStart
- loopEnd: loopEnd
- !
Item was removed:
- ----- Method: Envelope>>attackTime (in category 'accessing') -----
- attackTime
- "Return the time taken by the attack phase."
-
- ^ (points at: loopStartIndex) x
- !
Item was removed:
- ----- Method: Envelope>>centerPitch: (in category 'accessing') -----
- centerPitch: aNumber
- "Set the center pitch of a pitch-controlling envelope. This default implementation does nothing."
- !
Item was removed:
- ----- Method: Envelope>>checkParameters (in category 'private') -----
- checkParameters
- "Verify that the point array, loopStartIndex, and loopStopIndex obey the rules."
-
- | lastT t |
- points size > 1
- ifFalse: [^ self error: 'the point list must contain at least two points'].
- points first x = 0
- ifFalse: [^ self error: 'the time of the first point must be zero'].
- lastT := points first x.
- 2 to: points size do: [:i |
- t := (points at: i) x.
- t >= lastT
- ifFalse: [^ self error: 'the points must be in ascending time order']].
-
- (loopStartIndex isInteger and:
- [(loopStartIndex > 0) and: [loopStartIndex <= points size]])
- ifFalse: [^ self error: 'loopStartIndex is not a valid point index'].
- (loopEndIndex isInteger and:
- [(loopEndIndex > 0) and: [loopEndIndex <= points size]])
- ifFalse: [^ self error: 'loopEndIndex is not a valid point index'].
- loopStartIndex <= loopEndIndex
- ifFalse: [^ self error: 'loopEndIndex must not precede loopStartIndex'].
- !
Item was removed:
- ----- Method: Envelope>>computeIncrementAt:between:and:scale: (in category 'private') -----
- computeIncrementAt: mSecs between: p1 and: p2 scale: combinedScale
- "Compute the current and increment values for the given time between the given inflection points."
- "Assume: p1 x <= mSecs <= p2 x"
-
- | valueRange timeRange |
- valueRange := (p2 y - p1 y) asFloat.
- timeRange := (p2 x - p1 x) asFloat.
- currValue := (p1 y + (((mSecs - p1 x) asFloat / timeRange) * valueRange)) * combinedScale.
- valueIncr := (((p2 y * combinedScale) - currValue) / (p2 x - mSecs)) * 10.0.
- ^ currValue
- !
Item was removed:
- ----- Method: Envelope>>computeSustainValueAtMSecs: (in category 'applying') -----
- computeSustainValueAtMSecs: mSecs
- "Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope."
- "Note: Unlike the private method incrementalComputeValueAtMSecs:, this method does is not increment. Thus it is slower, but it doesn't depend on being called sequentially at fixed time intervals.
- Note: this is the same as computeValueAtMSecs: apart from removing the first section that requires loopEndMSecs t obe nil; this appears to cause a problem when a sound in playing and is stopped whilst the #computeSlopeAtMSecs: method is run inside the SoundPlayer loop"
-
- | t i |
- mSecs < 0 ifTrue: [^ 0.0].
-
- mSecs < loopStartMSecs ifTrue: [ "attack phase"
- i := self indexOfPointAfterMSecs: mSecs startingAt: 1.
- i = 1 ifTrue: [^ (points at: 1) y * scale].
- ^ self interpolate: mSecs between: (points at: i - 1) and: (points at: i)].
-
- "sustain phase"
- loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y * scale]. "looping on a single point"
- t := loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
- i := self indexOfPointAfterMSecs: t startingAt: loopStartIndex.
-
- ^ self interpolate: t between: (points at: i - 1) and: (points at: i)
- !
Item was removed:
- ----- Method: Envelope>>decayEndIndex (in category 'accessing') -----
- decayEndIndex
-
- ^ points size
- !
Item was removed:
- ----- Method: Envelope>>decayTime (in category 'accessing') -----
- decayTime
- "Return the time taken by the decay phase."
-
- ^ points last x - (points at: loopEndIndex) x
- !
Item was removed:
- ----- Method: Envelope>>duration (in category 'accessing') -----
- duration
- "Return the time of the final point."
-
- loopEndMSecs == nil
- ifTrue: [^ points last x]
- ifFalse: [^ loopEndMSecs + self decayTime].
- !
Item was removed:
- ----- Method: Envelope>>duration: (in category 'accessing') -----
- duration: seconds
- "Set the note duration to the given number of seconds."
- "Details: The duration is reduced by 19 mSec to ensure proper cutoffs even when the sound starts playing between doControl epochs."
- "Note: This is a hack. With a little additional work on the envelope logic, it should be possible to reduce or eliminate this fudge factor. In particular, an envelope should use the time remaining, rather than time-since-start to determine when to enter its decay phase. In addition, an envelope must be able to cut off in minimum time (~5-10 msec) if there isn't enough time to do their normal decay. All of this is to allow instruments with leisurely decays to play very short notes if necessary (say, when fast-forwarding through a score)."
-
- | attack decay endTime |
- endMSecs := (seconds * 1000.0) asInteger - 19.
- attack := self attackTime.
- decay := self decayTime.
- endMSecs > (attack + decay)
- ifTrue: [endTime := endMSecs - decay]
- ifFalse: [
- endMSecs >= attack
- ifTrue: [endTime := attack]
- ifFalse: [endTime := endMSecs]].
-
- self sustainEnd: (endTime max: 0).
- !
Item was removed:
- ----- Method: Envelope>>incrementalComputeValueAtMSecs: (in category 'private') -----
- incrementalComputeValueAtMSecs: mSecs
- "Compute the current value, per-step increment, and the time of the next inflection point."
- "Note: This method is part of faster, but less general, way of computing envelope values. It depends on a known, fixed control updating rate."
-
- | t i |
- ((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [ "decay phase"
- t := (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
- i := self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
- i == nil ifTrue: [ "past end"
- currValue := points last y * scale * decayScale.
- valueIncr := 0.0.
- nextRecomputeTime := mSecs + 1000000.
- ^ currValue].
- nextRecomputeTime := mSecs + ((points at: i) x - t).
- ^ self computeIncrementAt: t
- between: (points at: i - 1)
- and: (points at: i)
- scale: scale * decayScale].
-
- mSecs < loopStartMSecs
- ifTrue: [ "attack phase"
- t := mSecs.
- i := self indexOfPointAfterMSecs: t startingAt: 1.
- nextRecomputeTime := mSecs + ((points at: i) x - t)]
- ifFalse: [ "sustain (looping) phase"
- noChangesDuringLoop ifTrue: [
- currValue := (points at: loopEndIndex) y * scale.
- valueIncr := 0.0.
- loopEndMSecs == nil
- ifTrue: [nextRecomputeTime := mSecs + 10] "unknown end time"
- ifFalse: [nextRecomputeTime := loopEndMSecs].
- ^ currValue].
- t := loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
- i := self indexOfPointAfterMSecs: t startingAt: loopStartIndex.
- nextRecomputeTime := (mSecs + ((points at: i) x - t)) min: loopEndMSecs].
-
- ^ self computeIncrementAt: t
- between: (points at: i - 1)
- and: (points at: i)
- scale: scale.
- !
Item was removed:
- ----- Method: Envelope>>indexOfPointAfterMSecs:startingAt: (in category 'private') -----
- indexOfPointAfterMSecs: mSecs startingAt: startIndex
- "Return the index of the first point whose time is greater that mSecs, starting with the given index. Return nil if mSecs is after the last point's time."
-
- startIndex to: points size do:
- [:i | (points at: i) x > mSecs ifTrue: [^ i]].
- ^ nil
- !
Item was removed:
- ----- Method: Envelope>>interpolate:between:and: (in category 'private') -----
- interpolate: mSecs between: p1 and: p2
- "Return the scaled, interpolated value for the given time between the given time points."
- "Assume: p1 x <= mSecs <= p2 x"
-
- | valueRange timeRange |
- valueRange := (p2 y - p1 y) asFloat.
- valueRange = 0.0 ifTrue: [^ p1 y * scale].
- timeRange := (p2 x - p1 x) asFloat.
- ^ (p1 y + (((mSecs - p1 x) asFloat / timeRange) * valueRange)) * scale.
- !
Item was removed:
- ----- Method: Envelope>>loopEndIndex (in category 'accessing') -----
- loopEndIndex
-
- ^ loopEndIndex
- !
Item was removed:
- ----- Method: Envelope>>loopStartIndex (in category 'accessing') -----
- loopStartIndex
-
- ^ loopStartIndex
- !
Item was removed:
- ----- Method: Envelope>>name (in category 'accessing') -----
- name
-
- ^ self updateSelector allButLast
- !
Item was removed:
- ----- Method: Envelope>>points (in category 'accessing') -----
- points
-
- ^ points
- !
Item was removed:
- ----- Method: Envelope>>reset (in category 'applying') -----
- reset
- "Reset the state for this envelope."
-
- lastValue := -100000.0. "impossible value"
- nextRecomputeTime := 0.
- self updateTargetAt: 0.
- !
Item was removed:
- ----- Method: Envelope>>scale (in category 'accessing') -----
- scale
-
- ^ scale
- !
Item was removed:
- ----- Method: Envelope>>scale: (in category 'accessing') -----
- scale: aNumber
-
- scale := aNumber asFloat.
- !
Item was removed:
- ----- Method: Envelope>>setPoints:loopStart:loopEnd: (in category 'private') -----
- setPoints: pointList loopStart: startIndex loopEnd: endIndex
-
- | lastVal |
- points := pointList asArray collect: [:p | p x asInteger @ p y asFloat].
- loopStartIndex := startIndex.
- loopEndIndex := endIndex.
- self checkParameters.
- loopStartMSecs := (points at: loopStartIndex) x.
- loopMSecs := (points at: loopEndIndex) x - (points at: loopStartIndex) x.
- loopEndMSecs := nil. "unknown end time; sustain until end time is known"
- scale ifNil: [scale := 1.0].
- decayScale ifNil: [decayScale := 1.0].
-
- "note if there are no changes during the loop phase"
- noChangesDuringLoop := true.
- lastVal := (points at: loopStartIndex) y.
- loopStartIndex to: loopEndIndex do: [:i |
- (points at: i) y ~= lastVal ifTrue: [
- noChangesDuringLoop := false.
- ^ self]].
- !
Item was removed:
- ----- Method: Envelope>>storeOn: (in category 'storing') -----
- storeOn: strm
- strm nextPutAll: '((' , self class name;
- nextPutAll: ' points: '; store: (points collect: [:p | p x @ (p y roundTo: 0.00001)]);
- nextPutAll: ' loopStart: '; print: loopStartIndex;
- nextPutAll: ' loopEnd: '; print: loopEndIndex; nextPutAll: ')';
- nextPutAll: ' updateSelector: '; store: self updateSelector; nextPutAll: ';';
- nextPutAll: ' scale: '; print: scale; nextPutAll: ')'.
- !
Item was removed:
- ----- Method: Envelope>>sustainEnd: (in category 'applying') -----
- sustainEnd: mSecs
- "Set the ending time of the sustain phase of this envelope; the decay phase will start this
- point. Typically derived from a note's duration.
- Details: to avoid a sharp transient, the decay phase is scaled so that the beginning of the
- decay matches the envelope's instantaneous value when the decay phase starts."
-
- | vIfSustaining firstVOfDecay |
- loopEndMSecs := mSecs. "no longer set to nil in order to pretend to be sustaining"
- decayScale := 1.0.
- nextRecomputeTime := 0.
- vIfSustaining := self computeSustainValueAtMSecs: mSecs. "get value at end of sustain phase"
- "loopEndMSecs := mSecs. not required any more"
- firstVOfDecay := (points at: loopEndIndex) y * scale.
- firstVOfDecay = 0.0
- ifTrue: [decayScale := 1.0]
- ifFalse: [decayScale := vIfSustaining / firstVOfDecay].
- !
Item was removed:
- ----- Method: Envelope>>target (in category 'accessing') -----
- target
-
- ^ target
- !
Item was removed:
- ----- Method: Envelope>>target: (in category 'accessing') -----
- target: anObject
-
- target := anObject.
- !
Item was removed:
- ----- Method: Envelope>>updateSelector (in category 'accessing') -----
- updateSelector
-
- ^ updateSelector
- !
Item was removed:
- ----- Method: Envelope>>updateSelector: (in category 'accessing') -----
- updateSelector: aSymbol
-
- updateSelector := aSymbol.
- !
Item was removed:
- ----- Method: Envelope>>updateTargetAt: (in category 'applying') -----
- updateTargetAt: mSecs
- "Send my updateSelector to the given target object with the value of this envelope at the given number of milliseconds from its onset. Answer true if the value changed."
-
- | newValue |
- newValue := self valueAtMSecs: mSecs.
- newValue = lastValue ifTrue: [^ false].
- target
- perform: updateSelector
- with: newValue.
- lastValue := newValue.
- ^ true
- !
Item was removed:
- ----- Method: Envelope>>valueAtMSecs: (in category 'applying') -----
- valueAtMSecs: mSecs
- "Return the value of this envelope at the given number of milliseconds from its onset. Return zero for times outside the time range of this envelope."
-
- mSecs < 0 ifTrue: [^ 0.0].
- mSecs < nextRecomputeTime
- ifTrue: [currValue := currValue + valueIncr]
- ifFalse: [currValue := self incrementalComputeValueAtMSecs: mSecs].
- ^ currValue
- !
Item was removed:
- ----- Method: Envelope>>volume: (in category 'accessing') -----
- volume: aNumber
- "Set the maximum volume of a volume-controlling envelope. This default implementation does nothing."
- !
Item was removed:
- Object subclass: #FFT
- instanceVariableNames: 'nu n sinTable permTable realData imagData window'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !FFT commentStamp: '<historical>' prior: 0!
- This class implements the Fast Fourier Transform roughly as described on page 367
- of "Theory and Application of Digital Signal Processing" by Rabiner and Gold.
- Each instance caches tables used for transforming a given size (n = 2^nu samples) of data.
-
- It would have been cleaner using complex numbers, but often the data is all real.!
Item was removed:
- ----- Method: FFT class>>new: (in category 'instance creation') -----
- new: anIntegerPowerOfTwo
- "Answer a new FFT instance for transforming data packets of the given size."
-
- ^ self new setSize: anIntegerPowerOfTwo
- !
Item was removed:
- ----- Method: FFT>>imagData (in category 'testing') -----
- imagData
-
- ^ imagData
- !
Item was removed:
- ----- Method: FFT>>initializeHammingWindow: (in category 'bulk processing') -----
- initializeHammingWindow: alpha
- "Initialize the windowing function to the generalized Hamming window. See F. Richard Moore, Elements of Computer Music, p. 100. An alpha of 0.54 gives the Hamming window, 0.5 gives the hanning window."
-
- | v midPoint |
- window := Float32Array new: n.
- midPoint := (n + 1) / 2.0.
- 1 to: n do: [:i |
- v := alpha + ((1.0 - alpha) * (2.0 * Float pi * ((i - midPoint) / n)) cos).
- window at: i put: v].
-
- !
Item was removed:
- ----- Method: FFT>>initializeTriangularWindow (in category 'bulk processing') -----
- initializeTriangularWindow
- "Initialize the windowing function to the triangular, or Parzen, window. See F. Richard Moore, Elements of Computer Music, p. 100."
-
- | v |
- window := Float32Array new: n.
- 0 to: (n // 2) - 1 do: [:i |
- v := i / ((n // 2) - 1).
- window at: (i + 1) put: v.
- window at: (n - i) put: v].
- !
Item was removed:
- ----- Method: FFT>>n (in category 'initialization') -----
- n
-
- ^ n
- !
Item was removed:
- ----- Method: FFT>>nu: (in category 'initialization') -----
- nu: order
- "Initialize variables and tables for transforming 2^nu points"
- | j perms k |
- nu := order.
- n := 2 bitShift: nu-1.
-
- "Initialize permutation table (bit-reversed indices)"
- j:=0.
- perms := WriteStream on: (Array new: n).
- 0 to: n-2 do:
- [:i |
- i < j ifTrue: [perms nextPut: i+1; nextPut: j+1].
- k := n // 2.
- [k <= j] whileTrue: [j := j-k. k := k//2].
- j := j + k].
- permTable := perms contents.
-
- "Initialize sin table 0..pi/2 in n/4 steps."
- sinTable := (0 to: n/4) collect: [:i | (i asFloat / (n//4) * Float pi / 2.0) sin]!
Item was removed:
- ----- Method: FFT>>permuteData (in category 'transforming') -----
- permuteData
- | i end a b |
- i := 1.
- end := permTable size.
- [i <= end] whileTrue:
- [a := permTable at: i.
- b := permTable at: i+1.
- realData swap: a with: b.
- imagData swap: a with: b.
- i := i + 2]!
Item was removed:
- ----- Method: FFT>>plot:in: (in category 'testing') -----
- plot: samples in: rect
- "Throw-away code just to check out a couple of examples"
- | dx pen min max x divisor offset |
- Display fillWhite: rect; border: (rect expandBy: 2) width: 2.
- min := 1.0e30. max := -1.0e30.
- samples do:
- [:v |
- min := min min: v.
- max := max max: v].
- max = min
- ifTrue: [divisor := rect height asFloat.
- offset := rect height / 2.0]
- ifFalse: [divisor := max - min.
- offset := 0.0].
- pen := Pen new. pen up.
- x := rect left.
- dx := rect width asFloat / samples size.
- samples do:
- [:v | | y |
- y := (max - v) / divisor * rect height + offset.
- pen goto: x asInteger @ (rect top + y asInteger); down.
- x := x + dx].
- max printString displayOn: Display at: (x + 2) @ (rect top - 9).
- min printString displayOn: Display at: (x + 2) @ (rect bottom - 9)!
Item was removed:
- ----- Method: FFT>>pluginPrepareData (in category 'plugin-testing') -----
- pluginPrepareData
- "The FFT plugin requires data to be represented in WordArrays or FloatArrays"
- sinTable := sinTable asFloat32Array.
- permTable := permTable asWordArray.
- realData := realData asFloat32Array.
- imagData := imagData asFloat32Array.!
Item was removed:
- ----- Method: FFT>>pluginTest (in category 'plugin-testing') -----
- pluginTest "Display restoreAfter: [(FFT new nu: 12) pluginTest]."
- "Test on an array of 256 samples"
- "Initialize to pure (co)Sine Wave, plot, transform, plot, invert and plot again"
- self realData: ((1 to: n) collect: [:i | (Float pi * (i-1) / (n/8)) cos]).
- self plot: realData in: (100@20 extent: 256@60).
- self pluginPrepareData.
- Transcript cr; print: (Time millisecondsToRun:[self pluginTransformData: true]); endEntry.
- self plot: realData in: (100@100 extent: 256@60).
- self plot: imagData in: (100@180 extent: 256@60).
- Transcript cr; print: (Time millisecondsToRun:[self pluginTransformData: false]); endEntry.
- self plot: realData in: (100@260 extent: 256@60)!
Item was removed:
- ----- Method: FFT>>pluginTransformData: (in category 'plugin-testing') -----
- pluginTransformData: forward
- "Plugin testing -- if the primitive is not implemented
- or cannot be found run the simulation. See also: FFTPlugin"
- <primitive: 'primitiveFFTTransformData' module: 'FFTPlugin'>
- ^(Smalltalk at: #FFTPlugin ifAbsent:[^self primitiveFailed])
- doPrimitive: 'primitiveFFTTransformData'.!
Item was removed:
- ----- Method: FFT>>realData (in category 'testing') -----
- realData
-
- ^ realData
- !
Item was removed:
- ----- Method: FFT>>realData: (in category 'initialization') -----
- realData: real
- realData := real.
- imagData := real collect: [:i | 0.0] "imaginary component all zero"!
Item was removed:
- ----- Method: FFT>>realData:imagData: (in category 'initialization') -----
- realData: real imagData: imag
- realData := real.
- imagData := imag!
Item was removed:
- ----- Method: FFT>>samplesPerCycleForIndex: (in category 'testing') -----
- samplesPerCycleForIndex: i
- "Answer the number of samples per cycle corresponding to a power peak at the given index. Answer zero if i = 1, since an index of 1 corresponds to the D.C. component."
-
- | windowSize |
- windowSize := 2 raisedTo: nu.
- (i < 1 or: [i > (windowSize // 2)]) ifTrue: [^ self error: 'index is out of range'].
- i = 1 ifTrue: [^ 0]. "the D.C. component"
- ^ windowSize asFloat / (i - 1)
- !
Item was removed:
- ----- Method: FFT>>scaleData (in category 'transforming') -----
- scaleData
- "Scale all elements by 1/n when doing inverse"
- | realN |
- realN := n asFloat.
- 1 to: n do:
- [:i |
- realData at: i put: (realData at: i) / realN.
- imagData at: i put: (imagData at: i) / realN]!
Item was removed:
- ----- Method: FFT>>setSize: (in category 'bulk processing') -----
- setSize: anIntegerPowerOfTwo
- "Initialize variables and tables for performing an FFT on the given number of samples. The number of samples must be an integral power of two (e.g. 1024). Prepare data for use with the fast primitive."
-
- self nu: (anIntegerPowerOfTwo log: 2) asInteger.
- n = anIntegerPowerOfTwo ifFalse: [self error: 'size must be a power of two'].
- sinTable := sinTable asFloat32Array.
- permTable := permTable asWordArray.
- realData := Float32Array new: n.
- imagData := Float32Array new: n.
- self initializeHammingWindow: 0.54. "0.54 for Hamming, 0.5 for hanning"
- !
Item was removed:
- ----- Method: FFT>>test (in category 'testing') -----
- test "Display restoreAfter: [(FFT new nu: 8) test]. -- Test on an array of 256 samples"
- "Initialize to pure (co)Sine Wave, plot, transform, plot, invert and plot again"
- self realData: ((1 to: n) collect: [:i | (Float pi * (i-1) / (n/8)) cos]).
- self plot: realData in: (100@20 extent: 256@60).
- self transformForward: true.
- self plot: realData in: (100@100 extent: 256@60).
- self plot: imagData in: (100@180 extent: 256@60).
- self transformForward: false.
- self plot: realData in: (100@260 extent: 256@60)!
Item was removed:
- ----- Method: FFT>>transformDataFrom:startingAt: (in category 'bulk processing') -----
- transformDataFrom: anIndexableCollection startingAt: index
- "Forward transform a block of real data taken from from the given indexable collection starting at the given index. Answer a block of values representing the normalized magnitudes of the frequency components."
-
- | j real imag out |
- j := 0.
- index to: index + n - 1 do: [:i |
- realData at: (j := j + 1) put: (anIndexableCollection at: i)].
- realData *= window.
- imagData := Float32Array new: n.
- self transformForward: true.
-
- "compute the magnitudes of the complex results"
- "note: the results are in bottom half; the upper half is just its mirror image"
- real := realData copyFrom: 1 to: (n / 2).
- imag := imagData copyFrom: 1 to: (n / 2).
- out := (real * real) + (imag * imag).
- 1 to: out size do: [:i | out at: i put: (out at: i) sqrt].
- ^ out
- !
Item was removed:
- ----- Method: FFT>>transformForward: (in category 'transforming') -----
- transformForward: forward
- | lev lev1 ip theta realU imagU realT imagT i |
- <primitive: 'primitiveFFTTransformData' module: 'FFTPlugin'>
- self permuteData.
- 1 to: nu do:
- [:level |
- lev := 1 bitShift: level.
- lev1 := lev // 2.
- 1 to: lev1 do:
- [:j |
- theta := j-1 * (n // lev). "pi * (j-1) / lev1 mapped onto 0..n/2"
- theta < (n//4) "Compute U, the complex multiplier for each level"
- ifTrue:
- [realU := sinTable at: sinTable size - theta.
- imagU := sinTable at: theta + 1]
- ifFalse:
- [realU := (sinTable at: theta - (n//4) + 1) negated.
- imagU := sinTable at: (n//2) - theta + 1].
- forward ifFalse: [imagU := imagU negated].
- "
- Here is the inner loop...
- j to: n by: lev do:
- [:i | hand-transformed to whileTrue...
- "
- i := j.
- [i <= n] whileTrue:
- [ip := i + lev1.
- realT := ((realData at: ip) * realU) - ((imagData at: ip) * imagU).
- imagT := ((realData at: ip) * imagU) + ((imagData at: ip) * realU).
- realData at: ip put: (realData at: i) - realT.
- imagData at: ip put: (imagData at: i) - imagT.
- realData at: i put: (realData at: i) + realT.
- imagData at: i put: (imagData at: i) + imagT.
- i := i + lev]]].
- forward ifFalse: [self scaleData] "Reverse transform must scale to be an inverse"!
Item was removed:
- FMSound subclass: #FMBassoonSound
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: FMBassoonSound>>setPitch:dur:loudness: (in category 'initialization') -----
- setPitch: pitchNameOrNumber dur: d loudness: l
- "Select a modulation ratio and modulation envelope scale based on my pitch."
-
- | p modScale |
- p := self nameOrNumberToPitch: pitchNameOrNumber.
- modScale := 9.4.
- p > 100.0 ifTrue: [modScale := 8.3].
- p > 150.0 ifTrue: [modScale := 6.4].
- p > 200.0 ifTrue: [modScale := 5.2].
- p > 300.0 ifTrue: [modScale := 3.9].
- p > 400.0 ifTrue: [modScale := 2.8].
- p > 600.0 ifTrue: [modScale := 1.7].
-
- envelopes size > 0 ifTrue: [
- envelopes do: [:e |
- (e updateSelector = #modulation:)
- ifTrue: [e scale: modScale]]].
-
- super setPitch: p dur: d loudness: l.
- !
Item was removed:
- FMSound subclass: #FMClarinetSound
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: FMClarinetSound>>setPitch:dur:loudness: (in category 'initialization') -----
- setPitch: pitchNameOrNumber dur: d loudness: l
- "Select a modulation ratio and modulation envelope scale based on my pitch."
-
- | p modScale |
- p := self nameOrNumberToPitch: pitchNameOrNumber.
- p < 262.0
- ifTrue: [modScale := 25.0. self ratio: 4]
- ifFalse: [modScale := 20.0. self ratio: 2].
- p > 524.0 ifTrue: [modScale := 8.0].
-
- envelopes size > 0 ifTrue: [
- envelopes do: [:e |
- (e updateSelector = #modulation:)
- ifTrue: [e scale: modScale]]].
-
- super setPitch: p dur: d loudness: l.
- !
Item was removed:
- AbstractSound subclass: #FMSound
- instanceVariableNames: 'initialCount count waveTable scaledWaveTableSize scaledIndex scaledIndexIncr modulation multiplier normalizedModulation scaledOffsetIndex scaledOffsetIndexIncr'
- classVariableNames: 'SineTable'
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: FMSound class>>bass1 (in category 'instruments') -----
- bass1
- "FMSound bass1 play"
- "(FMSound lowMajorScaleOn: FMSound bass1) play"
-
- | snd |
- snd := FMSound new modulation: 0 ratio: 0.
- snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.95).
- ^ snd setPitch: 220 dur: 1.0 loudness: 0.3
- !
Item was removed:
- ----- Method: FMSound class>>bassoon1 (in category 'instruments') -----
- bassoon1
- "FMSound bassoon1 play"
- "(FMSound lowMajorScaleOn: FMSound bassoon1) play"
-
- | snd p env |
- snd := FMBassoonSound new ratio: 1.
-
- p := OrderedCollection new.
- p add: 0(a)0.0; add: 40(a)0.45; add: 90(a)1.0; add: 180(a)0.9; add: 270(a)1.0; add: 320(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5).
-
- p := OrderedCollection new.
- p add: 0(a)0.2; add: 40(a)0.9; add: 90(a)0.6; add: 270(a)0.6; add: 320(a)0.5.
- env := Envelope points: p loopStart: 3 loopEnd: 4.
- env updateSelector: #modulation:; scale: 5.05.
- snd addEnvelope: env.
-
- ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>brass1 (in category 'instruments') -----
- brass1
- "FMSound brass1 play"
- "(FMSound lowMajorScaleOn: FMSound brass1) play"
-
- | snd p env |
- snd := FMSound new modulation: 0 ratio: 1.
- p := OrderedCollection new.
- p add: 0(a)0.0; add: 30(a)0.8; add: 90(a)1.0; add: 120(a)0.9; add: 220(a)0.7; add: 320(a)0.9; add: 360(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 4 loopEnd: 6).
-
- p := OrderedCollection new.
- p add: 0(a)0.5; add: 60(a)1.0; add: 120(a)0.8; add: 220(a)0.65; add: 320(a)0.8; add: 360(a)0.0.
- env := Envelope points: p loopStart: 3 loopEnd: 5.
- env target: snd; updateSelector: #modulation:; scale: 5.0.
- snd addEnvelope: env.
-
- ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>brass2 (in category 'instruments') -----
- brass2
- "FMSound brass2 play"
- "(FMSound lowMajorScaleOn: FMSound brass2) play"
-
- | snd p env |
- snd := FMSound new modulation: 1 ratio: 1.
-
- p := OrderedCollection new.
- p add: 0(a)0.0; add: 20(a)1.0; add: 40(a)0.9; add: 100(a)0.7; add: 160(a)0.9; add: 200(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5).
-
- p := OrderedCollection new.
- p add: 0(a)0.5; add: 30(a)1.0; add: 40(a)0.8; add: 100(a)0.7; add: 160(a)0.8; add: 200(a)0.0.
- env := Envelope points: p loopStart: 3 loopEnd: 5.
- env updateSelector: #modulation:; scale: 5.0.
- snd addEnvelope: env.
-
- ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>clarinet (in category 'instruments') -----
- clarinet
- "FMSound clarinet play"
- "(FMSound lowMajorScaleOn: FMSound clarinet) play"
-
- | snd p env |
- snd := FMSound new modulation: 0 ratio: 2.
-
- p := OrderedCollection new.
- p add: 0(a)0.0; add: 60(a)1.0; add: 310(a)1.0; add: 350(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
-
- p := OrderedCollection new.
- p add: 0(a)0.0167; add: 60(a)0.106; add: 310(a)0.106; add: 350(a)0.0.
- env := Envelope points: p loopStart: 2 loopEnd: 3.
- env updateSelector: #modulation:; scale: 10.0.
- snd addEnvelope: env.
-
- ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>clarinet2 (in category 'instruments') -----
- clarinet2
- "FMSound clarinet2 play"
- "(FMSound lowMajorScaleOn: FMSound clarinet2) play"
-
- | snd p env |
- snd := FMClarinetSound new modulation: 0 ratio: 2.
-
- p := OrderedCollection new.
- p add: 0(a)0.0; add: 60(a)1.0; add: 310(a)1.0; add: 350(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
-
- p := OrderedCollection new.
- p add: 0(a)0.0167; add: 60(a)0.106; add: 310(a)0.106; add: 350(a)0.0.
- env := Envelope points: p loopStart: 2 loopEnd: 3.
- env updateSelector: #modulation:; scale: 10.0.
- snd addEnvelope: env.
-
- ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
-
- !
Item was removed:
- ----- Method: FMSound class>>default (in category 'instruments') -----
- default
-
- ^ self oboe1
- !
Item was removed:
- ----- Method: FMSound class>>flute1 (in category 'instruments') -----
- flute1
- "FMSound flute1 play"
- "(FMSound majorScaleOn: FMSound flute1) play"
-
- | snd p |
- snd := FMSound new.
- p := OrderedCollection new.
- p add: 0@0; add: 20(a)1.0; add: 100(a)1.0; add: 120(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
- ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>flute2 (in category 'instruments') -----
- flute2
- "FMSound flute2 play"
- "(FMSound majorScaleOn: FMSound flute2) play"
-
- | snd p |
- snd := FMSound new.
- p := OrderedCollection new.
- p add: 0@0; add: 20(a)1.0; add: 100(a)1.0; add: 120(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
- snd addEnvelope: (RandomEnvelope for: #pitch:).
- ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>initialize (in category 'class initialization') -----
- initialize
- "Build a sine wave table."
- "FMSound initialize"
-
- | tableSize radiansPerStep peak |
- tableSize := 4000.
- SineTable := SoundBuffer newMonoSampleCount: tableSize.
- radiansPerStep := (2.0 * Float pi) / tableSize asFloat.
- peak := ((1 bitShift: 15) - 1) asFloat. "range is +/- (2^15 - 1)"
- 1 to: tableSize do: [:i |
- SineTable at: i put: (peak * (radiansPerStep * (i - 1)) sin) rounded].
- !
Item was removed:
- ----- Method: FMSound class>>marimba (in category 'instruments') -----
- marimba
- "FMSound marimba play"
- "(FMSound majorScaleOn: FMSound marimba) play"
-
- | snd p env |
- snd := FMSound new modulation: 1 ratio: 0.98.
-
- p := OrderedCollection new.
- p add: 0(a)1.0; add: 10(a)0.3; add: 40(a)0.1; add: 80(a)0.02; add: 120(a)0.1; add: 160(a)0.02; add: 220(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 4 loopEnd: 6).
-
- p := OrderedCollection new.
- p add: 0(a)1.2; add: 80(a)0.85; add: 120(a)1.0; add: 160(a)0.85; add: 220(a)0.0.
- env := Envelope points: p loopStart: 2 loopEnd: 4.
- env updateSelector: #modulation:.
- snd addEnvelope: env.
-
- ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>mellowBrass (in category 'instruments') -----
- mellowBrass
- "FMSound mellowBrass play"
- "(FMSound lowMajorScaleOn: FMSound mellowBrass) play"
-
- | snd p env |
- snd := FMSound new modulation: 0 ratio: 1.
-
- p := OrderedCollection new.
- p add: 0(a)0.0; add: 70(a)0.325; add: 120(a)0.194; add: 200(a)0.194; add: 320(a)0.194; add: 380(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5).
-
- p := OrderedCollection new.
- p add: 0(a)0.1; add: 70(a)0.68; add: 120(a)0.528; add: 200(a)0.519; add: 320(a)0.528; add: 380(a)0.0.
- env := Envelope points: p loopStart: 3 loopEnd: 5.
- env updateSelector: #modulation:; scale: 5.0.
- snd addEnvelope: env.
-
- ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>oboe1 (in category 'instruments') -----
- oboe1
- "FMSound oboe1 play"
- "(FMSound majorScaleOn: FMSound oboe1) play"
-
- | snd p |
- snd := FMSound new modulation: 1 ratio: 1.
- p := OrderedCollection new.
- p add: 0(a)0.0; add: 10(a)1.0; add: 100(a)1.0; add: 120(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
- ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>oboe2 (in category 'instruments') -----
- oboe2
- "FMSound oboe2 play"
- "(FMSound majorScaleOn: FMSound oboe2) play"
-
- | snd p |
- snd := FMSound new modulation: 1 ratio: 1.
- p := OrderedCollection new.
- p add: 0@0; add: 20(a)1.0; add: 100(a)1.0; add: 120(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
- snd addEnvelope: (RandomEnvelope for: #pitch:).
- ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>organ1 (in category 'instruments') -----
- organ1
- "FMSound organ1 play"
- "(FMSound majorScaleOn: FMSound organ1) play"
-
- | snd p |
- snd := FMSound new.
- p := OrderedCollection new.
- p add: 0@0; add: 60(a)1.0; add: 110(a)0.8; add: 200(a)1.0; add: 250(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 4).
- ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>pluckedElecBass (in category 'instruments') -----
- pluckedElecBass
- "FMSound pluckedElecBass play"
- "(FMSound lowMajorScaleOn: FMSound pluckedElecBass) play"
-
- | snd p env |
- snd := FMSound new modulation: 1 ratio: 3.0.
-
- p := OrderedCollection new.
- p add: 0(a)0.4; add: 20(a)1.0; add: 30(a)0.6; add: 100(a)0.6; add: 130(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 4).
-
- p := OrderedCollection new.
- p add: 0(a)1.0; add: 20(a)2.0; add: 30(a)4.5; add: 100(a)4.5; add: 130(a)0.0.
- env := Envelope points: p loopStart: 3 loopEnd: 4.
- env updateSelector: #modulation:.
- snd addEnvelope: env.
-
- p := OrderedCollection new.
- p add: 0(a)6.0; add: 20(a)4.0; add: 30(a)3.0; add: 100(a)3.0; add: 130(a)3.0.
- env := Envelope points: p loopStart: 3 loopEnd: 4.
- env updateSelector: #ratio:.
- snd addEnvelope: env.
-
- ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>randomWeird1 (in category 'instruments') -----
- randomWeird1
- "FMSound randomWeird1 play"
-
- | snd p |
- snd := FMSound new.
- snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96).
- p := Array with: 0@0 with: 100(a)1.0 with: 250(a)0.7 with: 400(a)1.0 with: 500@0.
- snd addEnvelope: (PitchEnvelope points: p loopStart: 2 loopEnd: 4).
- ^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>randomWeird2 (in category 'instruments') -----
- randomWeird2
- "FMSound randomWeird2 play"
-
- | snd |
- snd := FMSound new.
- snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96).
- snd addEnvelope: (PitchEnvelope exponentialDecay: 0.98).
- ^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5
- !
Item was removed:
- ----- Method: FMSound class>>sineTable (in category 'class initialization') -----
- sineTable
- "Answer a SoundBuffer containing one complete cycle of a sine wave."
-
- ^ SineTable
- !
Item was removed:
- ----- Method: FMSound>>duration (in category 'accessing') -----
- duration
-
- ^ initialCount asFloat / self samplingRate asFloat
- !
Item was removed:
- ----- Method: FMSound>>duration: (in category 'accessing') -----
- duration: seconds
-
- super duration: seconds.
- count := initialCount := (seconds * self samplingRate) rounded.
- !
Item was removed:
- ----- Method: FMSound>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- waveTable := SineTable.
- scaledWaveTableSize := waveTable size * ScaleFactor.
- self setPitch: 440.0 dur: 1.0 loudness: 0.2.
- !
Item was removed:
- ----- Method: FMSound>>internalizeModulationAndRatio (in category 'accessing') -----
- internalizeModulationAndRatio
- "Recompute the internal state for the modulation index and frequency ratio relative to the current pitch."
-
- modulation < 0.0 ifTrue: [modulation := modulation negated].
- multiplier < 0.0 ifTrue: [multiplier := multiplier negated].
- normalizedModulation :=
- ((modulation * scaledIndexIncr) / ScaleFactor) asInteger.
- scaledOffsetIndexIncr := (multiplier * scaledIndexIncr) asInteger.
-
- "clip to maximum values if necessary"
- normalizedModulation > MaxScaledValue ifTrue: [
- normalizedModulation := MaxScaledValue.
- modulation := (normalizedModulation * ScaleFactor) asFloat / scaledIndexIncr].
- scaledOffsetIndexIncr > (scaledWaveTableSize // 2) ifTrue: [
- scaledOffsetIndexIncr := scaledWaveTableSize // 2.
- multiplier := scaledOffsetIndexIncr asFloat / scaledIndexIncr].
- !
Item was removed:
- ----- Method: FMSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy."
- "(FMSound pitch: 440.0 dur: 1.0 loudness: 0.5) play"
-
- | doingFM lastIndex sample offset i s |
- <primitive:'primitiveMixFMSound' module:'SoundGenerationPlugin'>
- <var: #aSoundBuffer declareC: 'short int *aSoundBuffer'>
- <var: #waveTable declareC: 'short int *waveTable'>
-
- doingFM := (normalizedModulation ~= 0) and: [scaledOffsetIndexIncr ~= 0].
- lastIndex := (startIndex + n) - 1.
- startIndex to: lastIndex do: [:sliceIndex |
- sample := (scaledVol * (waveTable at: (scaledIndex // ScaleFactor) + 1)) // ScaleFactor.
- doingFM
- ifTrue: [
- offset := normalizedModulation * (waveTable at: (scaledOffsetIndex // ScaleFactor) + 1).
- scaledOffsetIndex := (scaledOffsetIndex + scaledOffsetIndexIncr) \\ scaledWaveTableSize.
- scaledOffsetIndex < 0
- ifTrue: [scaledOffsetIndex := scaledOffsetIndex + scaledWaveTableSize].
- scaledIndex := (scaledIndex + scaledIndexIncr + offset) \\ scaledWaveTableSize.
- scaledIndex < 0
- ifTrue: [scaledIndex := scaledIndex + scaledWaveTableSize]]
- ifFalse: [
- scaledIndex := (scaledIndex + scaledIndexIncr) \\ scaledWaveTableSize].
-
- leftVol > 0 ifTrue: [
- i := (2 * sliceIndex) - 1.
- s := (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor).
- s > 32767 ifTrue: [s := 32767]. "clipping!!"
- s < -32767 ifTrue: [s := -32767]. "clipping!!"
- aSoundBuffer at: i put: s].
- rightVol > 0 ifTrue: [
- i := 2 * sliceIndex.
- s := (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor).
- s > 32767 ifTrue: [s := 32767]. "clipping!!"
- s < -32767 ifTrue: [s := -32767]. "clipping!!"
- aSoundBuffer at: i put: s].
-
- scaledVolIncr ~= 0 ifTrue: [
- scaledVol := scaledVol + scaledVolIncr.
- ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
- [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
- ifTrue: [ "reached the limit; stop incrementing"
- scaledVol := scaledVolLimit.
- scaledVolIncr := 0]]].
-
- count := count - n.
- !
Item was removed:
- ----- Method: FMSound>>modulation (in category 'accessing') -----
- modulation
- "Return the FM modulation index."
-
- ^ modulation
- !
Item was removed:
- ----- Method: FMSound>>modulation: (in category 'accessing') -----
- modulation: mod
- "Set the FM modulation index. Typical values range from 0 (no modulation) to 5, although values up to about 10 are sometimes useful."
- "Warning: This method is intended primarily for use by envelopes. For efficiency during envelope processing, this change will not take effect until internalizeModulationAndRatio is called."
-
- modulation := mod asFloat.
- !
Item was removed:
- ----- Method: FMSound>>modulation:multiplier: (in category 'accessing') -----
- modulation: mod multiplier: freqRatio
- "For backward compatibility. Needed to read old .fmp files."
-
- self modulation: mod ratio: freqRatio.
- !
Item was removed:
- ----- Method: FMSound>>modulation:ratio: (in category 'accessing') -----
- modulation: mod ratio: freqRatio
- "Set the modulation index and carrier to modulation frequency ratio for this sound, and compute the internal state that depends on these parameters."
-
- modulation := mod asFloat.
- multiplier := freqRatio asFloat.
- self internalizeModulationAndRatio.
- !
Item was removed:
- ----- Method: FMSound>>multiplier (in category 'accessing') -----
- multiplier
-
- ^ multiplier
- !
Item was removed:
- ----- Method: FMSound>>pitch (in category 'accessing') -----
- pitch
-
- ^ (self samplingRate asFloat * scaledIndexIncr / ScaleFactor) asFloat / waveTable size
- !
Item was removed:
- ----- Method: FMSound>>pitch: (in category 'accessing') -----
- pitch: p
- "Warning: Since the modulation and ratio are relative to the current pitch, some internal state must be recomputed when the pitch is changed. However, for efficiency during envelope processing, this compuation will not be done until internalizeModulationAndRatio is called."
-
- scaledIndexIncr :=
- ((p asFloat * waveTable size asFloat * ScaleFactor asFloat) / self samplingRate asFloat) asInteger
- min: (waveTable size // 2) * ScaleFactor.
- !
Item was removed:
- ----- Method: FMSound>>ratio (in category 'accessing') -----
- ratio
- "Return the FM modulation to carrier frequency ratio."
-
- ^ multiplier
- !
Item was removed:
- ----- Method: FMSound>>ratio: (in category 'accessing') -----
- ratio: freqRatio
- "Set the FM modulation to carrier frequency ratio."
- "Warning: This method is intended primarily for use by envelopes. For efficiency during envelope processing, this change will not take effect until internalizeModulationAndRatio is called."
-
- multiplier := freqRatio asFloat.
- !
Item was removed:
- ----- Method: FMSound>>reset (in category 'sound generation') -----
- reset
-
- self internalizeModulationAndRatio.
- super reset.
- count := initialCount.
- scaledIndex := 0.
- scaledOffsetIndex := 0.
- !
Item was removed:
- ----- Method: FMSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
-
- ^ count
- !
Item was removed:
- ----- Method: FMSound>>setPitch:dur:loudness: (in category 'initialization') -----
- setPitch: pitchNameOrNumber dur: d loudness: vol
- "(FMSound pitch: 'a4' dur: 2.5 loudness: 0.4) play"
-
- super setPitch: pitchNameOrNumber dur: d loudness: vol.
- modulation ifNil: [modulation := 0.0].
- multiplier ifNil: [multiplier := 0.0].
- self pitch: (self nameOrNumberToPitch: pitchNameOrNumber).
- self reset.
- !
Item was removed:
- ----- Method: FMSound>>setWavetable: (in category 'initialization') -----
- setWavetable: anArray
- "(AbstractSound lowMajorScaleOn: (FMSound new setWavetable: AA)) play"
-
- | samples p dur vol |
- "copy the array into a SoundBuffer if necessary"
- anArray class isPointers
- ifTrue: [samples := SoundBuffer fromArray: anArray]
- ifFalse: [samples := anArray].
-
- p := self pitch.
- dur := self duration.
- vol := self loudness.
- waveTable := samples.
- scaledWaveTableSize := waveTable size * ScaleFactor.
- self setPitch: p dur: dur loudness: vol.
- !
Item was removed:
- ----- Method: FMSound>>stopAfterMSecs: (in category 'sound generation') -----
- stopAfterMSecs: mSecs
- "Terminate this sound this note after the given number of milliseconds."
-
- count := (mSecs * self samplingRate) // 1000.
- !
Item was removed:
- ----- Method: FMSound>>storeOn: (in category 'storing') -----
- storeOn: strm
- | env |
- strm nextPutAll: '(((FMSound';
- nextPutAll: ' pitch: '; print: self pitch;
- nextPutAll: ' dur: '; print: self duration;
- nextPutAll: ' loudness: '; print: self loudness; nextPutAll: ')';
- nextPutAll: ' modulation: '; print: self modulation;
- nextPutAll: ' ratio: '; print: self ratio; nextPutAll: ')'.
- 1 to: envelopes size do:
- [:i | env := envelopes at: i.
- strm cr; nextPutAll: ' addEnvelope: '. env storeOn: strm.
- i < envelopes size ifTrue: [strm nextPutAll: ';']].
- strm nextPutAll: ')'.
- !
Item was removed:
- Object subclass: #FWT
- instanceVariableNames: 'alpha beta coeffs h g hTilde gTilde samples nSamples nLevels transform'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !FWT commentStamp: '<historical>' prior: 0!
- This class implements the Fast Wavelet Transform. It follows Mac Cody's article in Dr. Dobb's Journal, April 1992. See also...
- http://www.dfw.net/~mcody/fwt/fwt.html
-
- Notable features of his implementation include...
- 1. The ability to generate a large family of wavelets (including the Haar (alpha=beta) and Daubechies) from two parameters, alpha and beta, which range between -pi and pi.
- 2. All data arrays have 5 elements added on to allow for convolution overrun with filters up to 6 in length (the max for this implementation).
- 3. After a forward transform, the detail coefficients of the deomposition are found in transform at: 2*i, for i = 1, 2, ... nLevels; and the approximation coefficients are in transform at: (2*nLevels-1). these together comprise the complete wavelet transform.
-
- The following changes from cody's listings should also be noted...
- 1. The three DotProduct routines have been merged into one.
- 2. The four routines WaveletDecomposition, DecomposeBranches, WaveletReconstruction, ReconstructBranches have all been merged into transformForward:.
- 3. All indexing follows the Smalltalk 1-to-N convention, naturally.!
Item was removed:
- ----- Method: FWT>>coeffs (in category 'access') -----
- coeffs
- "Return all coefficients needed to reconstruct the original samples"
- | header csize strm |
- header := Array with: nSamples with: nLevels with: alpha with: beta.
- csize := header size.
- 1 to: nLevels do: [:i | csize := csize + (transform at: i*2) size].
- csize := csize + (transform at: nLevels*2-1) size.
- coeffs := Array new: csize.
- strm := WriteStream on: coeffs.
- strm nextPutAll: header.
- 1 to: nLevels do: [:i | strm nextPutAll: (transform at: i*2)].
- strm nextPutAll: (transform at: nLevels*2-1).
- ^ coeffs!
Item was removed:
- ----- Method: FWT>>coeffs: (in category 'access') -----
- coeffs: coeffArray
- "Initialize this instance from the given coeff array (including header)."
- | header strm |
- strm := ReadStream on: coeffArray.
- header := strm next: 4.
- self nSamples: header first nLevels: header second.
- self setAlpha: header third beta: header fourth.
- 1 to: nLevels do: [:i | transform at: i*2 put: (strm next: (transform at: i*2) size)].
- transform at: nLevels*2-1 put: (strm next: (transform at: nLevels*2-1) size).
- strm atEnd ifFalse: [self error: 'Data size error'].
- !
Item was removed:
- ----- Method: FWT>>convolveAndDec:dataLen:filter:out: (in category 'computation') -----
- convolveAndDec: inData dataLen: inLen filter: filter out: outData
- "convolve the input sequence with the filter and decimate by two"
- | filtLen offset outi dotp |
- filtLen := filter size.
- outi := 1.
- 1 to: inLen+9 by: 2 do:
- [:i |
- i < filtLen
- ifTrue:
- [dotp := self dotpData: inData endIndex: i filter: filter
- start: 1 stop: i inc: 1]
- ifFalse:
- [i > (inLen+5)
- ifTrue:
- [offset := i - (inLen+5).
- dotp := self dotpData: inData endIndex: inLen+5 filter: filter
- start: 1+offset stop: filtLen inc: 1]
- ifFalse:
- [dotp := self dotpData: inData endIndex: i filter: filter
- start: 1 stop: filtLen inc: 1]].
- outData at: outi put: dotp.
- outi := outi + 1]!
Item was removed:
- ----- Method: FWT>>convolveAndInt:dataLen:filter:sumOutput:into: (in category 'computation') -----
- convolveAndInt: inData dataLen: inLen filter: filter sumOutput:
- sumOutput into: outData
- "insert zeros between each element of the input sequence and
- convolve with the filter to interpolate the data"
- | outi filtLen oddTerm evenTerm j |
- outi := 1.
- filtLen := filter size.
-
- "every other dot product interpolates the data"
- filtLen // 2 to: inLen + filtLen - 2 do:
- [:i |
- oddTerm := self dotpData: inData endIndex: i filter: filter
- start: 2 stop: filter size inc: 2.
- evenTerm := self dotpData: inData endIndex: i+1 filter: filter
- start: 1 stop: filter size inc: 2.
- sumOutput
- ifTrue:
- ["summation with previous convolution if true"
- outData at: outi put: (outData at: outi) + oddTerm.
- outData at: outi+1 put: (outData at: outi+1) + evenTerm]
- ifFalse:
- ["first convolution of pair if false"
- outData at: outi put: oddTerm.
- outData at: outi+1 put: evenTerm].
- outi := outi + 2].
-
- "Ought to be able to fit this last term into the above loop."
- j := inLen + filtLen - 1.
- oddTerm := self dotpData: inData endIndex: j filter: filter
- start: 2 stop: filter size inc: 2.
- sumOutput
- ifTrue: [outData at: outi put: (outData at: outi) + oddTerm]
- ifFalse: [outData at: outi put: oddTerm].
- !
Item was removed:
- ----- Method: FWT>>doWaveDemo (in category 'testing') -----
- doWaveDemo "FWT new doWaveDemo"
- "Printing the above should yield a small number -- I get 1.1e-32"
- | originalData |
- self nSamples: 312 nLevels: 3.
- self setAlpha: 0.0 beta: 0.0.
-
- "Install a sine wave as sample data"
- self samples: ((1 to: nSamples) collect: [:i | ((i-1) * 0.02 * Float pi) sin] as: Float64Array).
- originalData := samples copy.
- FFT new plot: (samples copyFrom: 1 to: nSamples) in: (0@0 extent: nSamples@100).
-
- "Transform forward and plot the decomposition"
- self transformForward: true.
- transform withIndexDo:
- [:w :i |
- FFT new plot: (w copyFrom: 1 to: w size-5)
- in: (i-1\\2*320@(i+1//2*130) extent: (w size-5)@100)].
-
- "Test copy out and read in the transform coefficients"
- self coeffs: self coeffs.
-
- "Ttransform back, plot the reconstruction, and return the error figure"
- self transformForward: false.
- FFT new plot: (samples copyFrom: 1 to: nSamples) in: (320@0 extent: nSamples@100).
- ^ self meanSquareError: originalData!
Item was removed:
- ----- Method: FWT>>dotpData:endIndex:filter:start:stop:inc: (in category 'computation') -----
- dotpData: data endIndex: endIndex filter: filter start: start stop: stop inc: inc
- | sum i j |
- sum := 0.0.
- j := endIndex.
- i := start.
- [i <= stop] whileTrue:
- [sum := sum + ((data at: j) * (filter at: i)).
- i := i + inc.
- j := j - 1].
- ^ sum!
Item was removed:
- ----- Method: FWT>>meanSquareError: (in category 'testing') -----
- meanSquareError: otherData
- "Return the mean-square error between the current sample array and
- some other data, presumably to evaluate a compression scheme."
- | topSum bottomSum pointDiff |
- topSum := bottomSum := 0.0.
- 1 to: nSamples do:
- [:i | pointDiff := (samples at: i) - (otherData at: i).
- topSum := topSum + (pointDiff * pointDiff).
- bottomSum := bottomSum + ((otherData at: i) * (otherData at: i))].
- ^ topSum / bottomSum!
Item was removed:
- ----- Method: FWT>>nSamples:nLevels: (in category 'initialization') -----
- nSamples: n nLevels: nLevs
- "Initialize a wavelet transform."
- "Note the sample array size must be N + 5, where N is a multiple of 2^nLevels"
- | dyadSize |
- (n // (1 bitShift: nLevs)) > 0 ifFalse: [self error: 'Data size error'].
- (n \\ (1 bitShift: nLevs)) = 0 ifFalse: [self error: 'Data size error'].
- nSamples := n.
- samples := Float64Array new: n + 5.
- nLevels := nLevs.
- transform := Array new: nLevels*2. "Transformed data is stored as a tree of coeffs"
- dyadSize := nSamples.
- 1 to: nLevels do:
- [:i | dyadSize := dyadSize // 2.
- transform at: 2*i-1 put: (Float64Array new: dyadSize + 5).
- transform at: 2*i put: (Float64Array new: dyadSize + 5)]!
Item was removed:
- ----- Method: FWT>>samples (in category 'access') -----
- samples
- ^ samples copyFrom: 1 to: nSamples!
Item was removed:
- ----- Method: FWT>>samples: (in category 'access') -----
- samples: anArray
- 1 to: anArray size do:
- [:i | samples at: i put: (anArray at: i)].
- nSamples+1 to: nSamples+5 do:
- [:i | samples at: i put: 0.0]!
Item was removed:
- ----- Method: FWT>>setAlpha:beta: (in category 'initialization') -----
- setAlpha: alph beta: bet
- "Set alpha and beta, compute wavelet coeefs, and derive hFilter and lFilter"
- | tcosa tcosb tsina tsinb |
- alpha := alph.
- beta := bet.
-
- "WaveletCoeffs..."
- "precalculate cosine of alpha and sine of beta"
- tcosa := alpha cos.
- tcosb := beta cos.
- tsina := alpha sin.
- tsinb := beta sin.
- coeffs := Float64Array new: 6.
-
- "calculate first two wavelet coefficients a := a(-2) and b := a(-1)"
- coeffs at: 1 put: ((1.0 + tcosa + tsina) * (1.0 - tcosb - tsinb)
- + (2.0 * tsinb * tcosa)) / 4.0.
- coeffs at: 2 put: ((1.0 - tcosa + tsina) * (1.0 + tcosb - tsinb)
- - (2.0 * tsinb * tcosa)) / 4.0.
-
- "precalculate cosine and sine of alpha minus beta"
- tcosa := (alpha - beta) cos.
- tsina := (alpha - beta) sin.
-
- "calculate last four wavelet coefficients c := a(0), d := a(1), e := a(2), and f := a(3)"
- coeffs at: 3 put: (1.0 + tcosa + tsina) / 2.0.
- coeffs at: 4 put: (1.0 + tcosa - tsina) / 2.0.
- coeffs at: 5 put: 1.0 - (coeffs at: 1) - (coeffs at: 3).
- coeffs at: 6 put: 1.0 - (coeffs at: 2) - (coeffs at: 4).
-
- "MakeFiltersFromCoeffs..."
- "Select the non-zero wavelet coefficients"
- coeffs := coeffs copyFrom: (coeffs findFirst: [:c | c abs > 1.0e-14])
- to: (coeffs findLast: [:c | c abs > 1.0e-14]).
-
- "Form the low pass and high pass filters for decomposition"
- hTilde := coeffs reversed collect: [:c | c / 2.0].
- gTilde := coeffs collect: [:c | c / 2.0].
- 1 to: gTilde size by: 2 do:
- [:i | gTilde at: i put: (gTilde at: i) negated].
-
- "Form the low pass and high pass filters for reconstruction"
- h := coeffs copy.
- g := coeffs reversed.
- 2 to: g size by: 2 do:
- [:i | g at: i put: (g at: i) negated]
- !
Item was removed:
- ----- Method: FWT>>transformForward: (in category 'computation') -----
- transformForward: forward
- | inData inLen outData |
- forward
- ifTrue:
- ["first InData is input signal, following are intermediate approx coefficients"
- inData := samples. inLen := nSamples.
- 1 to: nLevels do:
- [:i |
- self convolveAndDec: inData dataLen: inLen
- filter: hTilde out: (transform at: 2*i-1).
- self convolveAndDec: inData dataLen: inLen
- filter: gTilde out: (transform at: 2*i).
- inData := transform at: 2*i-1. inLen := inLen // 2]]
- ifFalse:
- [inLen := nSamples >> nLevels.
- "all but last outData are next higher intermediate approximations,
- last is final reconstruction of samples"
- nLevels to: 1 by: -1 do:
- [:i |
- outData := i = 1 ifTrue: [samples]
- ifFalse: [transform at: 2*(i-1)-1].
- self convolveAndInt: (transform at: 2*i-1) dataLen: inLen
- filter: h sumOutput: false into: outData.
- self convolveAndInt: (transform at: 2*i) dataLen: inLen
- filter: g sumOutput: true into: outData.
- inLen := inLen * 2]]
- !
Item was removed:
- ----- Method: FWT>>viewPhiAndPsi (in category 'testing') -----
- viewPhiAndPsi "(FWT new nSamples: 256 nLevels: 6) viewPhiAndPsi"
- "View the scaling function and mother wavelets for this transform"
- | p |
- Display fillWhite: (0@0 extent: 300@300).
- Display border: (0@0 extent: 300@300) width: 2.
- [Sensor anyButtonPressed] whileFalse:
- ["Move mouse around in the outer rectangle to explore"
- p := Sensor cursorPoint min: 300@300.
- self setAlpha: (p x - 150) / 150.0 * Float pi
- beta: (p y - 150) / 150.0 * Float pi.
- 'alpha=', (alpha printShowingMaxDecimalPlaces: 2), ' ',
- 'beta=', (beta printShowingMaxDecimalPlaces: 2), ' ' displayAt: 50@5.
- transform do: [:w | w atAllPut: 0.0].
- (transform at: transform size - 1) at: (nSamples>>nLevels) put: 1.0.
- self transformForward: false.
- FFT new plot: (samples copyFrom: 1 to: nSamples) in: (20@30 extent: nSamples@100).
-
- transform do: [:w | w atAllPut: 0.0].
- (transform at: transform size) at: (nSamples>>nLevels) put: 1.0.
- self transformForward: false.
- FFT new plot: (samples copyFrom: 1 to: nSamples) in: (20@170 extent: nSamples@100)].
- Sensor waitNoButton!
Item was removed:
- SoundCodec subclass: #GSMCodec
- instanceVariableNames: 'encodeState decodeState'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: GSMCodec class>>new (in category 'instance creation') -----
- new
-
- ^ super new reset
- !
Item was removed:
- ----- Method: GSMCodec>>bytesPerEncodedFrame (in category 'subclass responsibilities') -----
- bytesPerEncodedFrame
-
- ^ 33
- !
Item was removed:
- ----- Method: GSMCodec>>decodeFrames:from:at:into:at: (in category 'subclass responsibilities') -----
- decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
-
- | p |
- p := self primDecode: decodeState frames: frameCount
- from: srcByteArray at: srcIndex
- into: dstSoundBuffer at: dstIndex.
- ^ Array with: p x with: p y
- !
Item was removed:
- ----- Method: GSMCodec>>encodeFrames:from:at:into:at: (in category 'subclass responsibilities') -----
- encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
-
- | p |
- p := self primEncode: encodeState frames: frameCount
- from: srcSoundBuffer at: srcIndex
- into: dstByteArray at: dstIndex.
- ^ Array with: p x with: p y
- !
Item was removed:
- ----- Method: GSMCodec>>primDecode:frames:from:at:into:at: (in category 'primitives') -----
- primDecode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
-
- <primitive: 'primitiveGSMDecode' module: 'SoundCodecPrims'>
- self primitiveFailed.
- !
Item was removed:
- ----- Method: GSMCodec>>primEncode:frames:from:at:into:at: (in category 'primitives') -----
- primEncode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
-
- <primitive: 'primitiveGSMEncode' module: 'SoundCodecPrims'>
- self primitiveFailed.
- !
Item was removed:
- ----- Method: GSMCodec>>primNewState (in category 'primitives') -----
- primNewState
-
- <primitive: 'primitiveGSMNewState' module: 'SoundCodecPrims'>
- self error: 'The SoundCodecPrims plugin is not available'.
- !
Item was removed:
- ----- Method: GSMCodec>>reset (in category 'subclass responsibilities') -----
- reset
- "Reset my encoding/decoding state to prepare to encode or decode a new sound stream."
-
- encodeState := self primNewState.
- decodeState := self primNewState.
- !
Item was removed:
- ----- Method: GSMCodec>>samplesPerFrame (in category 'subclass responsibilities') -----
- samplesPerFrame
-
- ^ 160
- !
Item was removed:
- AbstractSound subclass: #LoopedSampledSound
- instanceVariableNames: 'initialCount count releaseCount sampleCountForRelease leftSamples rightSamples originalSamplingRate perceivedPitch gain firstSample lastSample loopEnd scaledLoopLength scaledIndex scaledIndexIncr'
- classVariableNames: 'FloatLoopIndexScaleFactor LoopIndexFractionMask LoopIndexScaleFactor'
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !LoopedSampledSound commentStamp: '<historical>' prior: 0!
- I respresent a sequence of sound samples, often used to record a single note played by a real instrument. I can be pitch-shifted up or down, and can include a looped portion to allow a sound to be sustained indefinitely.
- !
Item was removed:
- ----- Method: LoopedSampledSound class>>fromAIFFFileNamed:mergeIfStereo: (in category 'instance creation') -----
- fromAIFFFileNamed: fileName mergeIfStereo: mergeFlag
- "Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."
-
- | aiffFileReader |
- aiffFileReader := AIFFFileReader new.
- aiffFileReader readFromFile: fileName
- mergeIfStereo: mergeFlag
- skipDataChunk: false.
- self new fromAIFFFileReader: aiffFileReader mergeIfStereo: mergeFlag!
Item was removed:
- ----- Method: LoopedSampledSound class>>initialize (in category 'class initialization') -----
- initialize
- "LoopedSampledSound initialize"
-
- LoopIndexScaleFactor := 512.
- FloatLoopIndexScaleFactor := LoopIndexScaleFactor asFloat.
- LoopIndexFractionMask := LoopIndexScaleFactor - 1.
- !
Item was removed:
- ----- Method: LoopedSampledSound class>>samples:loopEnd:loopLength:pitch:samplingRate: (in category 'instance creation') -----
- samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz
- "See the comment in the instance method of this name."
-
- ^ self basicNew
- samples: aSoundBuffer
- loopEnd: loopEndIndex
- loopLength: loopSampleCount
- pitch: perceivedPitchInHz
- samplingRate: samplingRateInHz
- !
Item was removed:
- ----- Method: LoopedSampledSound class>>unloopedSamples:pitch:samplingRate: (in category 'instance creation') -----
- unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz
- "See the comment in the instance method of this name."
-
- ^ self basicNew
- unloopedSamples: aSoundBuffer
- pitch: perceivedPitchInHz
- samplingRate: samplingRateInHz
- !
Item was removed:
- ----- Method: LoopedSampledSound>>addReleaseEnvelope (in category 'initialization') -----
- addReleaseEnvelope
- "Add a simple release envelope to this sound."
-
- | p env |
- p := OrderedCollection new.
- p add: 0(a)1.0; add: 10(a)1.0; add: 100(a)1.0; add: 120(a)0.0.
- env := (VolumeEnvelope points: p loopStart: 2 loopEnd: 3) target: self.
- envelopes size > 0 ifTrue: [ "remove any existing volume envelopes"
- envelopes copy do: [:e |
- (e isKindOf: VolumeEnvelope) ifTrue: [self removeEnvelope: e]]].
- self addEnvelope: env.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>beUnlooped (in category 'accessing') -----
- beUnlooped
-
- scaledLoopLength := 0.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>comeFullyUpOnReload: (in category 'disk i/o') -----
- comeFullyUpOnReload: smartRefStream
- "Convert my sample buffers from ByteArrays into SampleBuffers after raw loading from a DataStream. Answer myself."
-
- leftSamples == rightSamples
- ifTrue: [
- leftSamples := SoundBuffer fromByteArray: self leftSamples.
- rightSamples := leftSamples]
- ifFalse: [
- leftSamples := SoundBuffer fromByteArray: self leftSamples.
- rightSamples := SoundBuffer fromByteArray: self rightSamples].
-
- !
Item was removed:
- ----- Method: LoopedSampledSound>>computeSampleCountForRelease (in category 'initialization') -----
- computeSampleCountForRelease
- "Calculate the number of samples before the end of the note after which looping back will be be disabled. The units of this value, sampleCountForRelease, are samples at the original sampling rate. When playing a specific note, this value is converted to releaseCount, which is number of samples to be computed at the current pitch and sampling rate."
- "Details: For short loops, set the sampleCountForRelease to the loop length plus the number of samples between loopEnd and lastSample. Otherwise, set it to 1/10th of a second worth of samples plus the number of samples between loopEnd and lastSample. In this case, the trailing samples will be played only if the last loop-back occurs within 1/10th of a second of the total note duration, and the note may be shortened by up to 1/10th second. For long loops, this is the best we can do."
-
- (scaledLoopLength > 0 and: [lastSample > loopEnd])
- ifTrue: [
- sampleCountForRelease := (lastSample - loopEnd) +
- (self loopLength min: (originalSamplingRate / 10.0)) asInteger]
- ifFalse: [sampleCountForRelease := 0].
-
- releaseCount := sampleCountForRelease.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>copyDownSampledLowPassFiltering: (in category 'other') -----
- copyDownSampledLowPassFiltering: doFiltering
- "Answer a copy of the receiver at half its sampling rate. The result consumes half the memory space, but has only half the frequency range of the original. If doFiltering is true, the original sound buffers are low-pass filtered before down-sampling. This is slower, but prevents aliasing of any high-frequency components of the original signal. (While it may be possible to avoid low-pass filtering when down-sampling from 44.1 kHz to 22.05 kHz, it is probably essential when going to lower sampling rates.)"
-
- ^ self copy downSampleLowPassFiltering: doFiltering
- !
Item was removed:
- ----- Method: LoopedSampledSound>>downSampleLowPassFiltering: (in category 'private') -----
- downSampleLowPassFiltering: doFiltering
- "Cut my sampling rate in half. Use low-pass filtering (slower) if doFiltering is true."
- "Note: This operation loses information, and modifies the receiver in place."
-
- | stereo newLoopLength |
- stereo := self isStereo.
- leftSamples := leftSamples downSampledLowPassFiltering: doFiltering.
- stereo
- ifTrue: [rightSamples := rightSamples downSampledLowPassFiltering: doFiltering]
- ifFalse: [rightSamples := leftSamples].
- originalSamplingRate := originalSamplingRate / 2.0.
- loopEnd odd
- ifTrue: [newLoopLength := (self loopLength / 2.0) + 0.5]
- ifFalse: [newLoopLength := self loopLength / 2.0].
- firstSample := (firstSample + 1) // 2.
- lastSample := (lastSample + 1) // 2.
- loopEnd := (loopEnd + 1) // 2.
- scaledLoopLength := (newLoopLength * LoopIndexScaleFactor) asInteger.
- scaledIndexIncr := scaledIndexIncr // 2.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>duration (in category 'accessing') -----
- duration
- "Answer the duration of this sound in seconds."
-
- ^ initialCount asFloat / self samplingRate asFloat
- !
Item was removed:
- ----- Method: LoopedSampledSound>>duration: (in category 'accessing') -----
- duration: seconds
-
- super duration: seconds.
- count := initialCount := (seconds * self samplingRate) rounded.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>fftAt: (in category 'other') -----
- fftAt: startIndex
- "Answer the Fast Fourier Transform (FFT) of my samples (only the left channel, if stereo) starting at the given index."
-
- | availableSamples fftWinSize |
- availableSamples := (leftSamples size - startIndex) + 1.
- fftWinSize := 2 raisedTo: (((availableSamples - 1) log: 2) truncated + 1).
- fftWinSize := fftWinSize min: 4096.
- fftWinSize > availableSamples ifTrue: [fftWinSize := fftWinSize / 2].
- ^ self fftWindowSize: fftWinSize startingAt: startIndex
- !
Item was removed:
- ----- Method: LoopedSampledSound>>fftWindowSize:startingAt: (in category 'private') -----
- fftWindowSize: windowSize startingAt: startIndex
- "Answer a Fast Fourier Transform (FFT) of the given number of samples starting at the given index (the left channel only, if stereo). The window size will be rounded up to the nearest power of two greater than the requested size. There must be enough samples past the given starting index to accomodate this window size."
-
- | nu n fft |
- nu := ((windowSize - 1) log: 2) truncated + 1.
- n := 2 raisedTo: nu.
- fft := FFT new nu: nu.
- fft realData: ((startIndex to: startIndex + n - 1) collect: [:i | leftSamples at: i]).
- ^ fft transformForward: true.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>findStartPointAfter: (in category 'other') -----
- findStartPointAfter: index
- "Answer the index of the last zero crossing sample before the given index."
-
- | i |
- i := index min: lastSample.
-
- "scan backwards to the last zero-crossing"
- (leftSamples at: i) > 0
- ifTrue: [
- [i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i := i - 1]]
- ifFalse: [
- [i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i := i - 1]].
- ^ i
- !
Item was removed:
- ----- Method: LoopedSampledSound>>findStartPointForThreshold: (in category 'other') -----
- findStartPointForThreshold: threshold
- "Answer the index of the last zero crossing sample before the first sample whose absolute value (in either the right or left channel) exceeds the given threshold."
-
- | i |
- i := self indexOfFirstPointOverThreshold: threshold.
- i >= lastSample ifTrue: [^ self error: 'no sample exceeds the given threshold'].
-
- "scan backwards to the last zero-crossing"
- (leftSamples at: i) > 0
- ifTrue: [
- [i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i := i - 1]]
- ifFalse: [
- [i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i := i - 1]].
- ^ i
- !
Item was removed:
- ----- Method: LoopedSampledSound>>firstSample (in category 'accessing') -----
- firstSample
-
- ^ firstSample
- !
Item was removed:
- ----- Method: LoopedSampledSound>>firstSample: (in category 'accessing') -----
- firstSample: aNumber
-
- firstSample := (aNumber asInteger max: 1) min: lastSample.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>fromAIFFFileNamed:mergeIfStereo: (in category 'initialization') -----
- fromAIFFFileNamed: fileName mergeIfStereo: mergeFlag
- "Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."
-
- | aiffFileReader |
- aiffFileReader := AIFFFileReader new.
- aiffFileReader readFromFile: fileName
- mergeIfStereo: mergeFlag
- skipDataChunk: false.
- aiffFileReader isLooped
- ifTrue: [
- self samples: aiffFileReader leftSamples
- loopEnd: aiffFileReader loopEnd
- loopLength: aiffFileReader loopLength
- pitch: aiffFileReader pitch
- samplingRate: aiffFileReader samplingRate]
- ifFalse: [
- self unloopedSamples: aiffFileReader leftSamples
- pitch: aiffFileReader pitch
- samplingRate: aiffFileReader samplingRate].
-
- "the following must be done second, since the initialization above sets
- leftSamples and rightSamples to the same sample data"
- aiffFileReader isStereo
- ifTrue: [rightSamples := aiffFileReader rightSamples].
-
- initialCount := (leftSamples size * self samplingRate) // originalSamplingRate.
- self loudness: 1.0.
-
- self addReleaseEnvelope.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>fromAIFFFileReader:mergeIfStereo: (in category 'initialization') -----
- fromAIFFFileReader: aiffFileReader mergeIfStereo: mergeFlag
- "Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound."
-
- aiffFileReader isLooped
- ifTrue: [
- self samples: aiffFileReader leftSamples
- loopEnd: aiffFileReader loopEnd
- loopLength: aiffFileReader loopLength
- pitch: aiffFileReader pitch
- samplingRate: aiffFileReader samplingRate]
- ifFalse: [
- self unloopedSamples: aiffFileReader leftSamples
- pitch: aiffFileReader pitch
- samplingRate: aiffFileReader samplingRate].
-
- "the following must be done second, since the initialization above sets
- leftSamples and rightSamples to the same sample data"
- aiffFileReader isStereo
- ifTrue: [rightSamples := aiffFileReader rightSamples].
-
- initialCount := (leftSamples size * self samplingRate) // originalSamplingRate.
- self loudness: 1.0.
-
- self addReleaseEnvelope.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>gain (in category 'accessing') -----
- gain
-
- ^ gain
- !
Item was removed:
- ----- Method: LoopedSampledSound>>gain: (in category 'accessing') -----
- gain: aNumber
-
- gain := aNumber asFloat.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>highestSignificantFrequencyAt: (in category 'other') -----
- highestSignificantFrequencyAt: startIndex
- "Answer the highest significant frequency in the sample window starting at the given index. The a frequency is considered significant if it's power is at least 1/50th that of the maximum frequency component in the frequency spectrum."
-
- | fft powerArray threshold indices |
- fft := self fftAt: startIndex.
- powerArray := self normalizedResultsFromFFT: fft.
- threshold := powerArray max / 50.0.
- indices := (1 to: powerArray size) select: [:i | (powerArray at: i) > threshold].
- ^ originalSamplingRate / (fft samplesPerCycleForIndex: indices last)
- !
Item was removed:
- ----- Method: LoopedSampledSound>>indexOfFirstPointOverThreshold: (in category 'other') -----
- indexOfFirstPointOverThreshold: threshold
- "Answer the index of the first sample whose absolute value exceeds the given threshold."
-
- | s |
- leftSamples == rightSamples
- ifTrue: [
- 1 to: lastSample do: [:i |
- s := leftSamples at: i.
- s < 0 ifTrue: [s := 0 - s].
- s > threshold ifTrue: [^ i]]]
- ifFalse: [
- 1 to: lastSample do: [:i |
- s := leftSamples at: i.
- s < 0 ifTrue: [s := 0 - s].
- s > threshold ifTrue: [^ i].
- s := rightSamples at: i.
- s < 0 ifTrue: [s := 0 - s].
- s > threshold ifTrue: [^ i]]].
- ^ lastSample + 1
- !
Item was removed:
- ----- Method: LoopedSampledSound>>initialize (in category 'initialization') -----
- initialize
- "This default initialization creates a loop consisting of a single cycle of a sine wave."
- "(LoopedSampledSound pitch: 440.0 dur: 1.0 loudness: 0.4) play"
-
- | samples |
- super initialize.
- samples := FMSound sineTable.
- self samples: samples
- loopEnd: samples size
- loopLength: samples size
- pitch: 1.0
- samplingRate: samples size.
- self addReleaseEnvelope.
- self setPitch: 440.0 dur: 1.0 loudness: 0.5.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>isLooped (in category 'accessing') -----
- isLooped
-
- ^ scaledLoopLength ~= 0. "zero loop length means unlooped"
- !
Item was removed:
- ----- Method: LoopedSampledSound>>isStereo (in category 'accessing') -----
- isStereo
-
- ^ leftSamples ~~ rightSamples
- !
Item was removed:
- ----- Method: LoopedSampledSound>>leftSamples (in category 'accessing') -----
- leftSamples
-
- ^ leftSamples
- !
Item was removed:
- ----- Method: LoopedSampledSound>>leftSamples: (in category 'accessing') -----
- leftSamples: aSampleBuffer
-
- leftSamples := aSampleBuffer.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>loopEnd (in category 'accessing') -----
- loopEnd
-
- ^ loopEnd
- !
Item was removed:
- ----- Method: LoopedSampledSound>>loopLength (in category 'accessing') -----
- loopLength
-
- ^ scaledLoopLength / FloatLoopIndexScaleFactor
- !
Item was removed:
- ----- Method: LoopedSampledSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy. If a loop length is specified, then the index is looped back when the loopEnd index is reached until count drops below releaseCount. This allows a short sampled sound to be sustained indefinitely."
- "(LoopedSampledSound pitch: 440.0 dur: 5.0 loudness: 0.5) play"
-
- | lastIndex sampleIndex i s compositeLeftVol compositeRightVol nextSampleIndex m isInStereo rightVal leftVal |
- <primitive:'primitiveMixLoopedSampledSound' module:'SoundGenerationPlugin'>
- <var: #aSoundBuffer declareC: 'short int *aSoundBuffer'>
- <var: #leftSamples declareC: 'short int *leftSamples'>
- <var: #rightSamples declareC: 'short int *rightSamples'>
-
- isInStereo := leftSamples ~~ rightSamples.
- compositeLeftVol := (leftVol * scaledVol) // ScaleFactor.
- compositeRightVol := (rightVol * scaledVol) // ScaleFactor.
-
- i := (2 * startIndex) - 1.
- lastIndex := (startIndex + n) - 1.
- startIndex to: lastIndex do: [:sliceIndex |
- sampleIndex := (scaledIndex := scaledIndex + scaledIndexIncr) // LoopIndexScaleFactor.
- ((sampleIndex > loopEnd) and: [count > releaseCount]) ifTrue: [
- "loop back if not within releaseCount of the note end"
- "note: unlooped sounds will have loopEnd = lastSample"
- sampleIndex := (scaledIndex := scaledIndex - scaledLoopLength) // LoopIndexScaleFactor].
- (nextSampleIndex := sampleIndex + 1) > lastSample ifTrue: [
- sampleIndex > lastSample ifTrue: [count := 0. ^ nil]. "done!!"
- scaledLoopLength = 0
- ifTrue: [nextSampleIndex := sampleIndex]
- ifFalse: [nextSampleIndex := ((scaledIndex - scaledLoopLength) // LoopIndexScaleFactor) + 1]].
-
- m := scaledIndex bitAnd: LoopIndexFractionMask.
- rightVal := leftVal :=
- (((leftSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) +
- ((leftSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor.
- isInStereo ifTrue: [
- rightVal :=
- (((rightSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) +
- ((rightSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor].
-
- leftVol > 0 ifTrue: [
- s := (aSoundBuffer at: i) + ((compositeLeftVol * leftVal) // ScaleFactor).
- s > 32767 ifTrue: [s := 32767]. "clipping!!"
- s < -32767 ifTrue: [s := -32767]. "clipping!!"
- aSoundBuffer at: i put: s].
- i := i + 1.
- rightVol > 0 ifTrue: [
- s := (aSoundBuffer at: i) + ((compositeRightVol * rightVal) // ScaleFactor).
- s > 32767 ifTrue: [s := 32767]. "clipping!!"
- s < -32767 ifTrue: [s := -32767]. "clipping!!"
- aSoundBuffer at: i put: s].
- i := i + 1.
-
- scaledVolIncr ~= 0 ifTrue: [ "update volume envelope if it is changing"
- scaledVol := scaledVol + scaledVolIncr.
- ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
- [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
- ifTrue: [ "reached the limit; stop incrementing"
- scaledVol := scaledVolLimit.
- scaledVolIncr := 0].
- compositeLeftVol := (leftVol * scaledVol) // ScaleFactor.
- compositeRightVol := (rightVol * scaledVol) // ScaleFactor]].
-
- count := count - n.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>normalizedResultsFromFFT: (in category 'private') -----
- normalizedResultsFromFFT: fft
- "Answer an array whose size is half of the FFT window size containing power in each frequency band, normalized to the average power over the entire FFT. A value of 10.0 in this array thus means that the power at the corresponding frequences is ten times the average power across the entire FFT."
-
- | r avg |
- r := (1 to: fft realData size // 2) collect:
- [:i | ((fft realData at: i) squared + (fft imagData at: i) squared) sqrt].
- avg := r sum / r size.
- ^ r collect: [:v | v / avg].
- !
Item was removed:
- ----- Method: LoopedSampledSound>>objectForDataStream: (in category 'disk i/o') -----
- objectForDataStream: refStrm
- "Answer an object to store on a data stream, a copy of myself whose SampleBuffers have been converted into ByteArrays."
-
- refStrm replace: leftSamples with: leftSamples asByteArray.
- refStrm replace: rightSamples with: rightSamples asByteArray.
- "substitution will be made in DataStream nextPut:"
- ^ self
- !
Item was removed:
- ----- Method: LoopedSampledSound>>originalSamplingRate (in category 'accessing') -----
- originalSamplingRate
-
- ^ originalSamplingRate
- !
Item was removed:
- ----- Method: LoopedSampledSound>>perceivedPitch (in category 'accessing') -----
- perceivedPitch
-
- ^ perceivedPitch
- !
Item was removed:
- ----- Method: LoopedSampledSound>>pitch (in category 'accessing') -----
- pitch
-
- ^ (scaledIndexIncr asFloat * perceivedPitch * self samplingRate asFloat) /
- (originalSamplingRate * FloatLoopIndexScaleFactor)
- !
Item was removed:
- ----- Method: LoopedSampledSound>>pitch: (in category 'accessing') -----
- pitch: p
-
- scaledIndexIncr :=
- ((p asFloat * originalSamplingRate * FloatLoopIndexScaleFactor) /
- (perceivedPitch * self samplingRate asFloat)) asInteger.
-
- sampleCountForRelease > 0
- ifTrue: [releaseCount := (sampleCountForRelease * LoopIndexScaleFactor) // scaledIndexIncr]
- ifFalse: [releaseCount := 0].
- !
Item was removed:
- ----- Method: LoopedSampledSound>>reset (in category 'sound generation') -----
- reset
-
- super reset.
- count := initialCount.
- scaledIndex := firstSample * LoopIndexScaleFactor.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>rightSamples (in category 'accessing') -----
- rightSamples
-
- ^ rightSamples
- !
Item was removed:
- ----- Method: LoopedSampledSound>>rightSamples: (in category 'accessing') -----
- rightSamples: aSampleBuffer
-
- rightSamples := aSampleBuffer.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>samples (in category 'accessing') -----
- samples
- "For compatibility with SampledSound. Just return my left channel (which is the only channel if I am mono)."
-
- ^ leftSamples
- !
Item was removed:
- ----- Method: LoopedSampledSound>>samples:loopEnd:loopLength:pitch:samplingRate: (in category 'initialization') -----
- samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz
- "Make this sound use the given samples array with a loop of the given length starting at the given index. The loop length may have a fractional part; this is necessary to achieve pitch accuracy for short loops."
-
- | loopStartIndex |
- super initialize.
- loopStartIndex := (loopEndIndex - loopSampleCount) truncated + 1.
- ((1 <= loopStartIndex) and:
- [loopStartIndex < loopEndIndex and:
- [loopEndIndex <= aSoundBuffer size]])
- ifFalse: [self error: 'bad loop parameters'].
-
- leftSamples := rightSamples := aSoundBuffer.
- originalSamplingRate := samplingRateInHz asFloat.
- perceivedPitch := perceivedPitchInHz asFloat.
- gain := 1.0.
- firstSample := 1.
- lastSample := leftSamples size.
- lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [
- self error: 'cannot handle more than ',
- (SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples'].
- loopEnd := loopEndIndex.
- scaledLoopLength := (loopSampleCount * LoopIndexScaleFactor) asInteger.
- scaledIndexIncr := (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate.
- self computeSampleCountForRelease.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
- "Answer the number of samples remaining until the end of this sound."
-
- ^ count
- !
Item was removed:
- ----- Method: LoopedSampledSound>>setPitch:dur:loudness: (in category 'initialization') -----
- setPitch: pitchNameOrNumber dur: d loudness: vol
- "(LoopedSampledSound pitch: 440.0 dur: 2.5 loudness: 0.4) play"
-
- super setPitch: pitchNameOrNumber dur: d loudness: vol.
- self pitch: (self nameOrNumberToPitch: pitchNameOrNumber).
- self reset.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>stopAfterMSecs: (in category 'sound generation') -----
- stopAfterMSecs: mSecs
- "Terminate this sound this note after the given number of milliseconds."
-
- count := (mSecs * self samplingRate) // 1000.
- !
Item was removed:
- ----- Method: LoopedSampledSound>>storeSampleCount:bigEndian:on: (in category 'file i/o') -----
- 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)."
-
- | reverseBytes |
- (self isStereo or: [self samplingRate ~= originalSamplingRate]) ifTrue: [
- ^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream].
-
- "optimization: if I'm not stereo and sampling rates match, just store my buffer"
- reverseBytes := bigEndianFlag ~= Smalltalk isBigEndian.
- reverseBytes ifTrue: [leftSamples reverseEndianness].
- (aBinaryStream isKindOf: StandardFileStream)
- ifTrue: [ "optimization for files: write sound buffer directly to file"
- aBinaryStream next: (leftSamples size // 2) putAll: leftSamples startingAt: 1] "size in words"
- ifFalse: [ "for non-file streams:"
- 1 to: leftSamples monoSampleCount do: [:i | aBinaryStream int16: (leftSamples at: i)]].
- reverseBytes ifTrue: [leftSamples reverseEndianness]. "restore to original endianness"
- !
Item was removed:
- ----- Method: LoopedSampledSound>>unloopedSamples:pitch:samplingRate: (in category 'initialization') -----
- unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz
- "Make this sound play the given samples unlooped. The samples have the given perceived pitch when played at the given sampling rate. By convention, unpitched sounds such as percussion sounds should specify a pitch of nil or 100 Hz."
-
- super initialize.
- leftSamples := rightSamples := aSoundBuffer.
- originalSamplingRate := samplingRateInHz asFloat.
- perceivedPitchInHz
- ifNil: [perceivedPitch := 100.0]
- ifNotNil: [perceivedPitch := perceivedPitchInHz asFloat].
- gain := 1.0.
- firstSample := 1.
- lastSample := leftSamples size.
- lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [
- self error: 'cannot handle more than ',
- (SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples'].
- loopEnd := leftSamples size.
- scaledLoopLength := 0. "zero length means unlooped"
- scaledIndexIncr := (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate.
- self computeSampleCountForRelease.
- !
Item was removed:
- Object subclass: #MIDIFileReader
- instanceVariableNames: 'stream fileType trackCount ticksPerQuarter tracks trackInfo tempoMap strings track trackStream activeEvents maxNoteTicks'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !MIDIFileReader commentStamp: '<historical>' prior: 0!
- A reader for Standard 1.0 format MIDI files.
- MIDI File Types:
- type 0 -- one multi-channel track
- type 1 -- one or more simultaneous tracks
- type 2 -- a number on independent single-track patterns
-
- Instance variables:
- stream source of MIDI data
- fileType MIDI file type
- trackCount number of tracks in file
- ticksPerQuarter number of ticks per quarter note for all tracks in this file
- tracks collects track data for non-empty tracks
- strings collects all strings in the MIDI file
- tempoMap nil or a MIDITrack consisting only of tempo change events
- trackStream stream on buffer containing track chunk
- track track being read
- activeEvents notes that have been turned on but not off
- !
Item was removed:
- ----- Method: MIDIFileReader class>>scoreFromFileNamed: (in category 'reading') -----
- scoreFromFileNamed: fileName
-
- | f |
- f := (StandardFileStream readOnlyFileNamed: fileName) binary.
- ^[(self new readMIDIFrom: f) asScore]
- ensure: [f close]!
Item was removed:
- ----- Method: MIDIFileReader class>>scoreFromStream: (in category 'reading') -----
- scoreFromStream: binaryStream
-
- | score |
- score := (self new readMIDIFrom: binaryStream) asScore.
- ^ score
- !
Item was removed:
- ----- Method: MIDIFileReader class>>scoreFromURL: (in category 'reading') -----
- scoreFromURL: urlString
-
- | data |
- data := HTTPSocket httpGet: urlString accept: 'audio/midi'.
- data binary.
- ^ (self new readMIDIFrom: data) asScore.
- !
Item was removed:
- ----- Method: MIDIFileReader class>>standardMIDIInstrumentNames (in category 'instruments') -----
- standardMIDIInstrumentNames
- "Answer an array of Standard MIDI instrument names."
-
- ^ #(
- 'Grand Piano'
- 'Bright Piano'
- 'Electric Grand Piano'
- 'Honky-tonk Piano'
- 'Electric Piano 1'
- 'Electric Piano 2'
- 'Harpsichord'
- 'Clavichord'
- 'Celesta'
- 'Glockenspiel'
- 'Music Box'
- 'Vibraphone'
- 'Marimba'
- 'Xylophone'
- 'Tubular Bells'
- 'Duclimer'
- 'Drawbar Organ'
- 'Percussive Organ'
- 'Rock Organ'
- 'Church Organ'
- 'Reed Organ'
- 'Accordion'
- 'Harmonica'
- 'Tango Accordion'
- 'Nylon Guitar'
- 'Steel Guitar'
- 'Electric Guitar 1'
- 'Electric Guitar 2'
- 'Electric Guitar 3'
- 'Overdrive Guitar'
- 'Distorted Guitar'
- 'Guitar Harmonics'
- 'Acoustic Bass'
- 'Electric Bass 1'
- 'Electric Bass 2'
- 'Fretless Bass'
- 'Slap Bass 1'
- 'Slap Bass 2'
- 'Synth Bass 1'
- 'Synth Bass 2'
- 'Violin'
- 'Viola'
- 'Cello'
- 'Contrabass'
- 'Tremolo Strings'
- 'Pizzicato Strings'
- 'Orchestral Harp'
- 'Timpani'
- 'String Ensemble 1'
- 'String Ensemble 2'
- 'Synth Strings 1'
- 'Synth Strings 2'
- 'Choir Ahhs'
- 'Choir Oohs'
- 'Synth Voice'
- 'Orchestra Hit'
- 'Trumpet'
- 'Trombone'
- 'Tuba'
- 'Muted Trumpet'
- 'French Horn'
- 'Brass Section'
- 'Synth Brass 1'
- 'Synth Brass 2'
- 'Soprano Sax'
- 'Alto Sax'
- 'Tenor Sax'
- 'Baritone Sax'
- 'Oboe'
- 'English Horn'
- 'Bassoon'
- 'Clarinet'
- 'Piccolo'
- 'Flute'
- 'Recorder'
- 'Pan Flute'
- 'Blown Bottle'
- 'Shakuhachi'
- 'Whistle'
- 'Ocarina'
- 'Lead 1 (square)'
- 'Lead 2 (sawtooth)'
- 'Lead 3 (calliope)'
- 'Lead 4 (chiff)'
- 'Lead 5 (charang)'
- 'Lead 6 (voice)'
- 'Lead 7 (fifths)'
- 'Lead 8 (bass+lead)'
- 'Pad 1 (new age)'
- 'Pad 2 (warm)'
- 'Pad 3 (polysynth)'
- 'Pad 4 (choir)'
- 'Pad 5 (bowed)'
- 'Pad 6 (metallic)'
- 'Pad 7 (halo)'
- 'Pad 8 (sweep)'
- 'FX 1 (rain)'
- 'FX 2 (soundtrack)'
- 'FX 3 (crystals)'
- 'FX 4 (atmosphere)'
- 'FX 5 (brightness)'
- 'FX 6 (goblins)'
- 'FX 7 (echoes)'
- 'FX 8 (sci-fi)'
- 'Sitar'
- 'Banjo'
- 'Shamisen'
- 'Koto'
- 'Kalimba'
- 'Bagpipe'
- 'Fiddle'
- 'Shanai'
- 'Tinkle Bell'
- 'Agogo'
- 'Steel Drum'
- 'Woodblock'
- 'Taiko Drum'
- 'Melodic Tom'
- 'Synth Drum'
- 'Reverse Cymbal'
- 'Guitar Fret Noise'
- 'Breath Noise'
- 'Seashore'
- 'Bird Tweet'
- 'Telephone Ring'
- 'Helicopter'
- 'Applause'
- 'Gunshot')
- !
Item was removed:
- ----- Method: MIDIFileReader>>asScore (in category 'chunk reading') -----
- asScore
-
- ^ MIDIScore new
- tracks: tracks trackInfo: trackInfo;
- tempoMap: tempoMap;
- ticksPerQuarterNote: ticksPerQuarter;
- source: stream localName
- !
Item was removed:
- ----- Method: MIDIFileReader>>endAllNotesAt: (in category 'track reading') -----
- endAllNotesAt: endTicks
- "End of score; end any notes still sounding."
- "Details: Some MIDI files have missing note-off events, resulting in very long notes. Truncate any such notes encountered."
-
-
- activeEvents do: [:e | | dur |
- dur := endTicks - e time.
- dur > maxNoteTicks ifTrue: [dur := ticksPerQuarter]. "truncate long note"
- e duration: dur].
- activeEvents := activeEvents species new.
- !
Item was removed:
- ----- Method: MIDIFileReader>>endNote:chan:at: (in category 'track reading') -----
- endNote: midiKey chan: channel at: endTicks
-
- | evt |
- evt := activeEvents
- detect: [:e | (e midiKey = midiKey) and: [e channel = channel]]
- ifNone: [^ self].
- evt duration: (endTicks - evt time).
- activeEvents remove: evt ifAbsent: [].
- !
Item was removed:
- ----- Method: MIDIFileReader>>guessMissingInstrumentNames (in category 'private') -----
- guessMissingInstrumentNames
- "Attempt to guess missing instrument names from the first program change in that track."
-
- | progChange instrIndex instrName |
- 1 to: tracks size do: [:i |
- (trackInfo at: i) isEmpty ifTrue: [
- progChange := (tracks at: i) detect: [:e | e isProgramChange] ifNone: [nil].
- progChange ifNotNil: [
- instrIndex := progChange program + 1.
- instrName := self class standardMIDIInstrumentNames at: instrIndex.
- trackInfo at: i put: instrName]]].
- !
Item was removed:
- ----- Method: MIDIFileReader>>isTempoTrack: (in category 'track reading') -----
- isTempoTrack: anEventList
- "Return true if the given event list is non-empty and contains only tempo change events."
-
- anEventList isEmpty ifTrue: [^ false].
- anEventList do: [:evt | evt isTempoEvent ifFalse: [^ false]].
- ^ true
- !
Item was removed:
- ----- Method: MIDIFileReader>>metaEventAt: (in category 'track reading') -----
- metaEventAt: ticks
- "Read a meta event. Event types appear roughly in order of expected frequency."
-
- | type length tempo |
- type := trackStream next.
- length := self readVarLengthIntFrom: trackStream.
-
- type = 16r51 ifTrue: [ "tempo"
- tempo := 0.
- length timesRepeat: [tempo := (tempo bitShift: 8) + trackStream next].
- track add: (TempoEvent new tempo: tempo; time: ticks).
- ^ self].
-
- type = 16r2F ifTrue: [ "end of track"
- length = 0 ifFalse: [self error: 'length of end-of-track chunk should be zero'].
- self endAllNotesAt: ticks.
- trackStream skip: length.
- ^ self].
-
- type = 16r58 ifTrue: [ "time signature"
- length = 4 ifFalse: [self error: 'length of time signature chunk should be four'].
- trackStream skip: length.
- ^ self].
-
- type = 16r59 ifTrue: [ "key signature"
- length = 2 ifFalse: [self error: 'length of key signature chunk should be two'].
- trackStream skip: length.
- ^ self].
-
- ((type >= 1) and: [type <= 7]) ifTrue: [ "string"
- strings add: (trackStream next: length) asString.
- ^ self].
-
- ( type = 16r21 or: "mystery; found in MIDI files but not in MIDI File 1.0 Spec"
- [(type = 16r7F) or: "sequencer specific meta event"
- [(type = 16r00) or: "sequence number"
- [(type = 16r20)]]]) "MIDI channel prefix"
- ifTrue: [
- trackStream skip: length.
- ^ self].
-
- type = 16r54 ifTrue: [
- "SMPTE offset"
- self report: 'Ignoring SMPTE offset'.
- trackStream skip: length.
- ^ self].
-
- "skip unrecognized meta event"
- self report:
- 'skipping unrecognized meta event: ', (type printStringBase: 16),
- ' (', length printString, ' bytes)'.
- trackStream skip: length.
- !
Item was removed:
- ----- Method: MIDIFileReader>>next16BitWord (in category 'private') -----
- next16BitWord
- "Read a 16-bit positive integer from the input stream, most significant byte first."
- "Assume: Stream has at least two bytes left."
-
- | n |
- n := stream next.
- ^ (n bitShift: 8) + stream next
- !
Item was removed:
- ----- Method: MIDIFileReader>>next32BitWord: (in category 'private') -----
- next32BitWord: msbFirst
- "Read a 32-bit positive integer from the input stream."
- "Assume: Stream has at least four bytes left."
-
- | n |
- n := stream next: 4.
- ^msbFirst
- ifTrue:[((n at: 1) bitShift: 24) + ((n at: 2) bitShift: 16) + ((n at: 3) bitShift: 8) + (n at: 4)]
- ifFalse:[((n at: 4) bitShift: 24) + ((n at: 3) bitShift: 16) + ((n at: 2) bitShift: 8) + (n at: 1)]
- !
Item was removed:
- ----- Method: MIDIFileReader>>readChunkSize (in category 'private') -----
- readChunkSize
- "Read a 32-bit positive integer from the next 4 bytes, most significant byte first."
- "Assume: Stream has at least four bytes left."
-
- | n |
- n := 0.
- 1 to: 4 do: [:ignore | n := (n bitShift: 8) + stream next].
- ^ n
- !
Item was removed:
- ----- Method: MIDIFileReader>>readChunkType (in category 'private') -----
- readChunkType
- "Read a chunk ID string from the next 4 bytes."
- "Assume: Stream has at least four bytes left."
-
- | s |
- s := String new: 4.
- 1 to: 4 do: [:i | s at: i put: (stream next) asCharacter].
- ^ s
- !
Item was removed:
- ----- Method: MIDIFileReader>>readHeaderChunk (in category 'chunk reading') -----
- readHeaderChunk
-
- | chunkType chunkSize division |
- chunkType := self readChunkType.
- chunkType = 'RIFF' ifTrue:[chunkType := self riffSkipToMidiChunk].
- chunkType = 'MThd' ifFalse: [self scanForMIDIHeader].
- chunkSize := self readChunkSize.
- fileType := self next16BitWord.
- trackCount := self next16BitWord.
- division := self next16BitWord.
- (division anyMask: 16r8000)
- ifTrue: [self error: 'SMPTE time formats are not yet supported']
- ifFalse: [ticksPerQuarter := division].
- maxNoteTicks := 12 * 4 * ticksPerQuarter.
- "longest acceptable note; used to detect stuck notes"
-
- "sanity checks"
- ((chunkSize < 6) or: [chunkSize > 100])
- ifTrue: [self error: 'unexpected MIDI header size ', chunkSize printString].
- (#(0 1 2) includes: fileType)
- ifFalse: [self error: 'unknown MIDI file type ', fileType printString].
-
- Transcript
- show: 'Reading Type ', fileType printString, ' MIDI File (';
- show: trackCount printString, ' tracks, ';
- show: ticksPerQuarter printString, ' ticks per quarter note)';
- cr.
- !
Item was removed:
- ----- Method: MIDIFileReader>>readMIDIFrom: (in category 'chunk reading') -----
- readMIDIFrom: aBinaryStream
- "Read one or more MIDI tracks from the given binary stream."
-
- stream := aBinaryStream.
- tracks := OrderedCollection new.
- trackInfo := OrderedCollection new.
- self readHeaderChunk.
- trackCount timesRepeat: [self readTrackChunk].
- stream atEnd ifFalse: [self report: 'data beyond final track'].
- fileType = 0 ifTrue: [self splitIntoTracks].
- self guessMissingInstrumentNames.
- !
Item was removed:
- ----- Method: MIDIFileReader>>readTrackChunk (in category 'chunk reading') -----
- readTrackChunk
-
- | chunkType chunkSize |
- chunkType := self readChunkType.
- [chunkType = 'MTrk'] whileFalse: [
- self report: 'skipping unexpected chunk type "', chunkType, '"'.
- stream skip: (self readChunkSize). "skip it"
- chunkType := (stream next: 4) asString].
- chunkSize := self readChunkSize.
- chunkSize < 10000000 ifFalse: [
- self error: 'suspiciously large track chunk; this may not be MIDI file'].
-
- self readTrackContents: chunkSize.
- !
Item was removed:
- ----- Method: MIDIFileReader>>readTrackContents: (in category 'track reading') -----
- readTrackContents: byteCount
-
- | info |
- strings := OrderedCollection new.
- track := OrderedCollection new.
- trackStream := ReadStream on: (stream next: byteCount).
- activeEvents := OrderedCollection new.
- self readTrackEvents.
- (tracks isEmpty and: [self isTempoTrack: track])
- ifTrue: [tempoMap := track asArray]
- ifFalse: [
- "Note: Tracks without note events are currently not saved to
- eliminate clutter in the score player. In control applications,
- this can be easily changed by modifying the following test."
- (self trackContainsNotes: track) ifTrue: [
- tracks add: track asArray.
- info := WriteStream on: (String new: 100).
- strings do: [:s | info nextPutAll: s; cr].
- trackInfo add: info contents]].
- strings := track := trackStream := activeEvents := nil.
- !
Item was removed:
- ----- Method: MIDIFileReader>>readTrackEvents (in category 'track reading') -----
- readTrackEvents
- "Read the events of the current track."
-
- | cmd chan key vel ticks byte length evt |
- cmd := #unknown.
- chan := key := vel := 0.
- ticks := 0.
- [trackStream atEnd] whileFalse: [
- ticks := ticks + (self readVarLengthIntFrom: trackStream).
- byte := trackStream next.
- byte >= 16rF0
- ifTrue: [ "meta or system exclusive event"
- byte = 16rFF ifTrue: [self metaEventAt: ticks].
- ((byte = 16rF0) or: [byte = 16rF7]) ifTrue: [ "system exclusive data"
- length := self readVarLengthIntFrom: trackStream.
- trackStream skip: length].
- cmd := #unknown]
- ifFalse: [ "channel message event"
- byte >= 16r80
- ifTrue: [ "new command"
- cmd := byte bitAnd: 16rF0.
- chan := byte bitAnd: 16r0F.
- key := trackStream next]
- ifFalse: [ "use running status"
- cmd == #unknown
- ifTrue: [self error: 'undefined running status; bad MIDI file?'].
- key := byte].
-
- ((cmd = 16rC0) or: [cmd = 16rD0]) ifFalse: [
- "all but program change and channel pressure have two data bytes"
- vel := trackStream next].
-
- cmd = 16r80 ifTrue: [ "note off"
- self endNote: key chan: chan at: ticks].
-
- cmd = 16r90 ifTrue: [ "note on"
- vel = 0
- ifTrue: [self endNote: key chan: chan at: ticks]
- ifFalse: [self startNote: key vel: vel chan: chan at: ticks]].
-
- "cmd = 16A0 -- polyphonic key pressure; skip"
-
- cmd = 16rB0 ifTrue: [
- evt := ControlChangeEvent new control: key value: vel channel: chan.
- evt time: ticks.
- track add: evt].
-
- cmd = 16rC0 ifTrue: [
- evt := ProgramChangeEvent new program: key channel: chan.
- evt time: ticks.
- track add: evt].
-
- "cmd = 16D0 -- channel aftertouch pressure; skip"
-
- cmd = 16rE0 ifTrue: [
- evt := PitchBendEvent new bend: key + (vel bitShift: 7) channel: chan.
- evt time: ticks.
- track add: evt]
- ]].
- !
Item was removed:
- ----- Method: MIDIFileReader>>readVarLengthIntFrom: (in category 'private') -----
- readVarLengthIntFrom: aBinaryStream
- "Read a one to four byte positive integer from the given stream, most significant byte first. Use only the lowest seven bits of each byte. The highest bit of a byte is set for all bytes except the last."
-
- | n byte |
- n := 0.
- 1 to: 4 do: [:ignore |
- byte := aBinaryStream next.
- byte < 128 ifTrue: [
- n = 0
- ifTrue: [^ byte] "optimization for one-byte lengths"
- ifFalse: [^ (n bitShift: 7) + byte]].
- n := (n bitShift: 7) + (byte bitAnd: 16r7F)].
-
- self error: 'variable length quantity must not exceed four bytes'.
- !
Item was removed:
- ----- Method: MIDIFileReader>>report: (in category 'private') -----
- report: aString
-
- Transcript show: aString; cr.
- !
Item was removed:
- ----- Method: MIDIFileReader>>riffSkipToMidiChunk (in category 'private') -----
- riffSkipToMidiChunk
- "This file is a RIFF file which may (or may not) contain a MIDI chunk. Thanks to Andreas Raab for this code."
-
- | dwLength fourcc |
- "Read length of all data"
- dwLength := self next32BitWord: false.
- "Get RIFF contents type "
- fourcc := self readChunkType.
- fourcc = 'RMID' ifFalse:[^fourcc]. "We can only read RMID files here"
- "Search for data"
- [[fourcc := self readChunkType.
- dwLength := self next32BitWord: false.
- fourcc = 'data'] whileFalse:[
- "Skip chunk - rounded to word boundary"
- stream skip: (dwLength + 1 bitAnd: 16rFFFFFFFE).
- stream atEnd ifTrue:[^'']].
- "Data chunk is raw - look into if it contains MIDI data and skip if not"
- fourcc := self readChunkType.
- fourcc = 'MThd'] whileFalse:[
- "Skip data (chunk - 4bytes) rounded to word boundary"
- stream skip: (dwLength - 3 bitAnd: 16rFFFFFFFE)].
- ^fourcc!
Item was removed:
- ----- Method: MIDIFileReader>>scanForMIDIHeader (in category 'private') -----
- scanForMIDIHeader
- "Scan the first part of this file in search of the MIDI header string 'MThd'. Report an error if it is not found. Otherwise, leave the input stream positioned to the first byte after this string."
-
- | asciiM p lastSearchPosition byte restOfHeader |
- asciiM := $M asciiValue.
- stream skip: -3.
- p := stream position.
- lastSearchPosition := p + 10000. "search only the first 10000 bytes of the file"
- [p < lastSearchPosition and: [stream atEnd not]] whileTrue: [
- [(byte := stream next) ~= asciiM and: [byte ~~ nil]] whileTrue. "find the next 'M' or file end"
- restOfHeader := (stream next: 3) asString.
- restOfHeader = 'Thd'
- ifTrue: [^ self]
- ifFalse: [restOfHeader size = 3 ifTrue: [stream skip: -3]].
- p := stream position].
-
- self error: 'MIDI header chunk not found'.
- !
Item was removed:
- ----- Method: MIDIFileReader>>splitIntoTracks (in category 'private') -----
- splitIntoTracks
- "Split a type zero MIDI file into separate tracks by channel number."
-
- | newTempoMap newTracks |
- tracks size = 1 ifFalse: [self error: 'expected exactly one track in type 0 file'].
- tempoMap ifNotNil: [self error: 'did not expect a tempo map in type 0 file'].
- newTempoMap := OrderedCollection new.
- newTracks := (1 to: 16) collect: [:i | OrderedCollection new].
- tracks first do: [:e |
- e isTempoEvent
- ifTrue: [newTempoMap addLast: e]
- ifFalse: [(newTracks at: e channel + 1) addLast: e]].
- newTempoMap size > 0 ifTrue: [tempoMap := newTempoMap asArray].
- newTracks := newTracks select: [:t | self trackContainsNotes: t].
- tracks := newTracks collect: [:t | t asArray].
- trackInfo := trackInfo, ((2 to: tracks size) collect: [:i | '']).
- !
Item was removed:
- ----- Method: MIDIFileReader>>startNote:vel:chan:at: (in category 'track reading') -----
- startNote: midiKey vel: vel chan: chan at: startTicks
- "Record the beginning of a note."
- "Details: Some MIDI scores have missing note-off events, causing a note-on to be received for a (key, channel) that is already sounding. If the previous note is suspiciously long, truncate it."
-
- | noteOnEvent newActiveEvents |
- newActiveEvents := nil.
- activeEvents do: [:e | | dur |
- ((e midiKey = midiKey) and: [e channel = chan]) ifTrue: [
- "turn off key already sounding"
- dur := startTicks - e time.
- dur > maxNoteTicks ifTrue: [dur := ticksPerQuarter]. "truncate"
- e duration: dur.
- newActiveEvents ifNil: [newActiveEvents := activeEvents copy].
- newActiveEvents remove: e ifAbsent: []]].
- newActiveEvents ifNotNil: [activeEvents := newActiveEvents].
-
- noteOnEvent := NoteEvent new key: midiKey velocity: vel channel: chan.
- noteOnEvent time: startTicks.
- track add: noteOnEvent.
- activeEvents add: noteOnEvent.
- !
Item was removed:
- ----- Method: MIDIFileReader>>trackContainsNotes: (in category 'track reading') -----
- trackContainsNotes: eventList
- "Answer true if the given track contains at least one note event."
-
- eventList do: [:e | e isNoteEvent ifTrue: [^ true]].
- ^ false
- !
Item was removed:
- Object subclass: #MIDIInputParser
- instanceVariableNames: 'cmdActionTable midiPort received rawDataBuffer sysExBuffer ignoreSysEx startTime timeNow state lastSelector lastCmdByte argByte1 argByte2'
- classVariableNames: 'DefaultMidiTable'
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !MIDIInputParser commentStamp: '<historical>' prior: 0!
- I am a parser for a MIDI data stream. I support:
-
- real-time MIDI recording,
- overdubbing (recording while playing),
- monitoring incoming MIDI, and
- interactive MIDI performances.
-
- Note: MIDI controllers such as pitch benders and breath controllers generate large volumes of data which consume processor time. In cases where this information is not of interest to the program using it, it is best to filter it out as soon as possible. I support various options for doing this filtering, including filtering by MIDI channel and/or by command type.
- !
Item was removed:
- ----- Method: MIDIInputParser class>>initialize (in category 'class initialization') -----
- initialize
- "Build the default MIDI command-byte action table. This table maps MIDI command bytes to the action to be performed when that is received. Note that MIDI data bytes (bytes whose value is < 128) are never used to index into this table."
- "MIDIInputParser initialize"
-
- DefaultMidiTable := Array new: 255 withAll: #undefined:.
- 128 to: 143 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "key off"
- 144 to: 159 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "key on"
- 160 to: 175 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "polyphonic after-touch"
- 176 to: 191 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "control change"
- 192 to: 207 do: [:i | DefaultMidiTable at: i put: #recordOne:]. "program change"
- 208 to: 223 do: [:i | DefaultMidiTable at: i put: #recordOne:]. "channel after-touch"
- 224 to: 239 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "pitch bend"
-
- DefaultMidiTable at: 240 put: #startSysExclusive:. "start a system exclusive block"
- DefaultMidiTable at: 241 put: #recordOne:. "MIDI time code quarter frame"
- DefaultMidiTable at: 242 put: #recordTwo:. "song position select"
- DefaultMidiTable at: 243 put: #recordOne:. "song select"
- DefaultMidiTable at: 244 put: #undefined:.
- DefaultMidiTable at: 245 put: #undefined:.
- DefaultMidiTable at: 246 put: #recordZero:. "tune request"
- DefaultMidiTable at: 247 put: #endSysExclusive:. "end a system exclusive block"
- DefaultMidiTable at: 248 put: #recordZero:. "timing clock"
- DefaultMidiTable at: 249 put: #undefined:.
- DefaultMidiTable at: 250 put: #recordZero:. "start"
- DefaultMidiTable at: 251 put: #recordZero:. "continue"
- DefaultMidiTable at: 252 put: #recordZero:. "stop/Clock"
- DefaultMidiTable at: 253 put: #undefined:.
- DefaultMidiTable at: 254 put: #recordZero:. "active sensing"
- DefaultMidiTable at: 255 put: #recordZero:. "system reset"
- !
Item was removed:
- ----- Method: MIDIInputParser class>>on: (in category 'instance creation') -----
- on: aSimpleMIDIPort
- "Answer a new MIDI parser on the given port."
-
- ^ super new setMIDIPort: aSimpleMIDIPort
- !
Item was removed:
- ----- Method: MIDIInputParser>>clearBuffers (in category 'recording') -----
- clearBuffers
- "Clear the MIDI record buffers. This should be called at the start of recording or real-time MIDI processing."
-
- received := received species new: 5000.
- rawDataBuffer := ByteArray new: 1000.
- sysExBuffer := WriteStream on: (ByteArray new: 100).
- midiPort ifNotNil: [midiPort ensureOpen; flushInput].
- startTime := Time millisecondClockValue.
- state := #idle.
- !
Item was removed:
- ----- Method: MIDIInputParser>>endSysExclusive: (in category 'private-state machine') -----
- endSysExclusive: cmdByte
- "Error!! Received 'end system exclusive' command when not receiving system exclusive data."
-
- self error: 'unexpected ''End of System Exclusive'' command'.
- !
Item was removed:
- ----- Method: MIDIInputParser>>ignoreChannel: (in category 'midi filtering') -----
- ignoreChannel: channel
- "Don't record any events arriving on the given MIDI channel (in the range 1-16)."
-
- ((channel isInteger not) | (channel < 1) | (channel > 16))
- ifTrue: [^ self error: 'bad MIDI channel number', channel printString].
-
- "two-arg channel messages"
- #(128 144 160 176 224) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreTwo:].
-
- "one-arg channel messages"
- #(192 208) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreOne:].
- !
Item was removed:
- ----- Method: MIDIInputParser>>ignoreCommand: (in category 'midi filtering') -----
- ignoreCommand: midiCmd
- "Don't record the given MIDI command on any channel."
-
- | cmd sel |
- ((midiCmd isInteger not) | (midiCmd < 128) | (midiCmd > 255))
- ifTrue: [^ self error: 'bad MIDI command'].
-
- midiCmd < 240 ifTrue: [ "channel commands; ignore on all channels"
- cmd := midiCmd bitAnd: 2r11110000.
- sel := (#(128 144 160 176 224) includes: cmd)
- ifTrue: [#ignoreTwo:]
- ifFalse: [#ignoreOne:].
- 1 to: 16 do: [:ch | cmdActionTable at: (cmd bitOr: ch - 1) put: sel].
- ^ self].
-
- (#(240 241 244 245 247 249 253) includes: midiCmd) ifTrue: [
- ^ self error: 'You can''t ignore the undefined MIDI command: ', midiCmd printString].
-
- midiCmd = 242 ifTrue: [ "two-arg command"
- cmdActionTable at: midiCmd put: #ignoreTwo:.
- ^ self].
-
- midiCmd = 243 ifTrue: [ "one-arg command"
- cmdActionTable at: midiCmd put: #ignoreOne:.
- ^ self].
-
- (#(246 248 250 251 252 254 255) includes: midiCmd) ifTrue: [ "zero-arg command"
- cmdActionTable at: midiCmd put: #ignore.
- ^ self].
-
- "we should not get here"
- self error: 'implementation error'.
- !
Item was removed:
- ----- Method: MIDIInputParser>>ignoreOne: (in category 'private-state machine') -----
- ignoreOne: cmdByte
- "Ignore a one argument command."
-
- lastCmdByte := cmdByte.
- lastSelector := #ignoreOne:.
- state := #ignore1.
- !
Item was removed:
- ----- Method: MIDIInputParser>>ignoreSysEx: (in category 'midi filtering') -----
- ignoreSysEx: aBoolean
- "If the argument is true, then ignore incoming system exclusive message."
-
- ignoreSysEx := aBoolean.
- !
Item was removed:
- ----- Method: MIDIInputParser>>ignoreTuneAndRealTimeCommands (in category 'midi filtering') -----
- ignoreTuneAndRealTimeCommands
- "Ignore tuning requests and real-time commands."
-
- cmdActionTable at: 246 put: #ignoreZero:. "tune request"
- cmdActionTable at: 248 put: #ignoreZero:. "timing clock"
- cmdActionTable at: 250 put: #ignoreZero:. "start"
- cmdActionTable at: 251 put: #ignoreZero:. "continue"
- cmdActionTable at: 252 put: #ignoreZero:. "stop/Clock"
- cmdActionTable at: 254 put: #ignoreZero:. "active sensing"
- cmdActionTable at: 255 put: #ignoreZero:. "system reset"
- !
Item was removed:
- ----- Method: MIDIInputParser>>ignoreTwo: (in category 'private-state machine') -----
- ignoreTwo: cmdByte
- "Ignore a two argument command."
-
- lastCmdByte := cmdByte.
- lastSelector := #ignoreTwo:.
- state := #ignore2.
- !
Item was removed:
- ----- Method: MIDIInputParser>>ignoreZero: (in category 'private-state machine') -----
- ignoreZero: cmdByte
- "Ignore a zero argument command, such as tune request or a real-time message. Stay in the current and don't change active status. Note that real-time messages can arrive between data bytes without disruption."
-
- "do nothing"
- !
Item was removed:
- ----- Method: MIDIInputParser>>midiDo: (in category 'real-time processing') -----
- midiDo: aBlock
- "Poll the incoming MIDI stream in real time and call the given block for each complete command that has been received. The block takes one argument, which is an array of the form (<time><cmd byte>[<arg1>[<arg2>]]). The number of arguments depends on the command byte. For system exclusive commands, the argument is a ByteArray containing the system exclusive message."
-
- self processMIDIData.
- [received isEmpty] whileFalse:
- [aBlock value: received removeFirst].
- !
Item was removed:
- ----- Method: MIDIInputParser>>midiDoUntilMouseDown: (in category 'real-time processing') -----
- midiDoUntilMouseDown: midiActionBlock
- "Process the incoming MIDI stream in real time by calling midiActionBlock for each MIDI event. This block takes three arguments: the MIDI command byte and two argument bytes. One or both argument bytes may be nil, depending on the MIDI command. If not nil, evaluatue idleBlock regularly whether MIDI data is available or not. Pressing any mouse button terminates the interaction."
-
- | time cmd arg1 arg2 |
- self clearBuffers.
- [Sensor anyButtonPressed] whileFalse: [
- self midiDo: [:item |
- time := item at: 1.
- cmd := item at: 2.
- arg1 := arg2 := nil.
- item size > 2 ifTrue: [
- arg1 := item at: 3.
- item size > 3 ifTrue: [arg2 := item at: 4]].
- midiActionBlock value: cmd value: arg1 value: arg2]].
- !
Item was removed:
- ----- Method: MIDIInputParser>>midiPort (in category 'accessing') -----
- midiPort
-
- ^ midiPort
- !
Item was removed:
- ----- Method: MIDIInputParser>>midiPort: (in category 'accessing') -----
- midiPort: aMIDIPort
- "Use the given MIDI port."
-
- midiPort := aMIDIPort.
- self clearBuffers.
- !
Item was removed:
- ----- Method: MIDIInputParser>>monitor (in category 'midi monitor') -----
- monitor
- "Print MIDI messages to the transcript until any mouse button is pressed."
-
- self midiDoUntilMouseDown: [:cmd :arg1 :arg2 |
- self printCmd: cmd with: arg1 with: arg2].
- !
Item was removed:
- ----- Method: MIDIInputParser>>noFiltering (in category 'midi filtering') -----
- noFiltering
- "Revert to accepting all MIDI commands on all channels. This undoes any earlier request to filter the incoming MIDI stream."
-
- cmdActionTable := DefaultMidiTable deepCopy.
- ignoreSysEx := false.
- !
Item was removed:
- ----- Method: MIDIInputParser>>printCmd:with:with: (in category 'midi monitor') -----
- printCmd: cmdByte with: arg1 with: arg2
- "Print the given MIDI command."
-
- | cmd ch bend |
- cmdByte < 240
- ifTrue: [ "channel message"
- cmd := cmdByte bitAnd: 2r11110000.
- ch := (cmdByte bitAnd: 2r00001111) + 1]
- ifFalse: [cmd := cmdByte]. "system message"
-
- cmd = 128 ifTrue: [
- ^ Transcript show: ('key up ', arg1 printString, ' vel: ', arg2 printString, ' chan: ', ch printString); cr].
- cmd = 144 ifTrue: [
- ^ Transcript show: ('key down: ', arg1 printString, ' vel: ', arg2 printString, ' chan: ', ch printString); cr].
- cmd = 160 ifTrue: [
- ^ Transcript show: ('key pressure: ', arg1 printString, ' val: ', arg2 printString, ' chan: ', ch printString); cr].
- cmd = 176 ifTrue: [
- ^ Transcript show: ('CC', arg1 printString, ': val: ', arg2 printString, ' chan: ', ch printString); cr].
- cmd = 192 ifTrue: [
- ^ Transcript show: ('prog: ', (arg1 + 1) printString, ' chan: ', ch printString); cr].
- cmd = 208 ifTrue: [
- ^ Transcript show: ('channel pressure ', arg1 printString, ' chan: ', ch printString); cr].
- cmd = 224 ifTrue: [
- bend := ((arg2 bitShift: 7) + arg1) - 8192.
- ^ Transcript show: ('bend: ', bend printString, ' chan: ', ch printString); cr].
-
- cmd = 240 ifTrue: [
- ^ Transcript show: ('system exclusive: ', (arg1 at: 1) printString, ' (', arg1 size printString, ' bytes)'); cr].
-
- Transcript show: 'cmd: ', cmd printString, ' arg1: ', arg1 printString, ' arg2: ', arg2 printString; cr.
- !
Item was removed:
- ----- Method: MIDIInputParser>>processByte: (in category 'private-state machine') -----
- processByte: aByte
- "Process the given incoming MIDI byte and record completed commands."
- "Details: Because this must be fast, it has been hand-tuned. Be careful!!"
-
- aByte > 247 ifTrue: [ "real-time message; can arrive at any time"
- ^ self perform: (cmdActionTable at: aByte) with: aByte].
-
- #idle = state ifTrue: [
- aByte >= 128
- ifTrue: [ "command byte in idle state: start new command"
- ^ self perform: (cmdActionTable at: aByte) with: aByte]
- ifFalse: [ "data byte in idle state: use running status if possible"
- lastCmdByte ifNil: [^ self]. "running status unknown; skip byte"
- "process this data as if it had the last command byte in front of it"
- self perform: lastSelector with: lastCmdByte.
-
- "the previous line put us into a new state; we now 'fall through'
- to process the data byte given this new state."]].
-
- #ignore1 = state ifTrue: [^ state := #idle].
- #ignore2 = state ifTrue: [^ state := #ignore1].
-
- #want1of2 = state ifTrue: [
- argByte1 := aByte.
- ^ state := #want2of2].
-
- #want2of2 = state ifTrue: [
- argByte2 := aByte.
- received addLast: (Array with: timeNow with: lastCmdByte with: argByte1 with: argByte2).
- ^ state := #idle].
-
- #want1only = state ifTrue: [
- argByte1 := aByte.
- received addLast: (Array with: timeNow with: lastCmdByte with: argByte1).
- ^ state := #idle].
-
- #sysExclusive = state ifTrue: [
- aByte < 128 ifTrue: [
- "record a system exclusive data byte"
- ignoreSysEx ifFalse: [sysExBuffer nextPut: aByte].
- ^ self]
- ifFalse: [
- aByte < 248 ifTrue: [
- "a system exclusive message is terminated by any non-real-time command byte"
- ignoreSysEx ifFalse: [
- received addLast: (Array with: timeNow with: lastCmdByte with: sysExBuffer contents)].
- state := #idle.
- aByte = 247
- ifTrue: [^ self] "endSysExclusive command, nothing left to do"
- ifFalse: [^ self processByte: aByte]]]]. "no endSysExclusive; just start the next command"
- !
Item was removed:
- ----- Method: MIDIInputParser>>processMIDIData (in category 'recording') -----
- processMIDIData
- "Process all MIDI data that has arrived since the last time this method was executed. This method should be called frequently to process, filter, and timestamp MIDI data as it arrives."
-
- | bytesRead |
- [(bytesRead := midiPort readInto: rawDataBuffer) > 0] whileTrue: [
- timeNow := (midiPort bufferTimeStampFrom: rawDataBuffer) - startTime.
- 5 to: bytesRead do: [:i | self processByte: (rawDataBuffer at: i)]].
- !
Item was removed:
- ----- Method: MIDIInputParser>>received (in category 'recording') -----
- received
- "Answer my current collection of all MIDI commands received. Items in this list have the form (<time><cmd byte>[<arg1>[<arg2>]]). Note that the real-time processing facility, midiDo:, removes items from this list as it processes them."
-
- ^ received
- !
Item was removed:
- ----- Method: MIDIInputParser>>recordOne: (in category 'private-state machine') -----
- recordOne: cmdByte
- "Record a one argument command at the current time."
-
- lastCmdByte := cmdByte.
- lastSelector := #recordOne:.
- state := #want1only.
- !
Item was removed:
- ----- Method: MIDIInputParser>>recordOnlyChannels: (in category 'midi filtering') -----
- recordOnlyChannels: channelList
- "Record only MIDI data arriving on the given list of channel numbers (in the range 1-16)."
-
- channelList do: [:ch |
- ((ch isInteger not) | (ch < 1) | (ch > 16))
- ifTrue: [^ self error: 'bad Midi channel specification: ', ch printString]].
-
- 1 to: 16 do: [:ch | (channelList includes: ch) ifFalse: [self ignoreChannel: ch]].
- !
Item was removed:
- ----- Method: MIDIInputParser>>recordTwo: (in category 'private-state machine') -----
- recordTwo: cmdByte
- "Record a two argument command at the current time."
-
- lastCmdByte := cmdByte.
- lastSelector := #recordTwo:.
- state := #want1of2.
- !
Item was removed:
- ----- Method: MIDIInputParser>>recordZero: (in category 'private-state machine') -----
- recordZero: cmdByte
- "Record a zero-byte message, such as tune request or a real-time message. Don't change active status. Note that real-time messages can arrive between data bytes without disruption."
-
- received addLast: (Array with: timeNow with: cmdByte).
- !
Item was removed:
- ----- Method: MIDIInputParser>>setMIDIPort: (in category 'private-other') -----
- setMIDIPort: aMIDIPort
- "Initialize this instance for recording from the given MIDI port. Tune and real-time commands are filtered out by default; the client can send noFiltering to receive these messages."
-
- midiPort := aMIDIPort.
- received := OrderedCollection new.
- self noFiltering. "initializes cmdActionTable"
- self ignoreTuneAndRealTimeCommands.
- !
Item was removed:
- ----- Method: MIDIInputParser>>startSysExclusive: (in category 'private-state machine') -----
- startSysExclusive: cmdByte
- "The beginning of a variable length 'system exclusive' command."
-
- sysExBuffer resetContents.
- lastCmdByte := nil. "system exclusive commands clear running status"
- lastSelector := nil.
- state := #sysExclusive.
- !
Item was removed:
- ----- Method: MIDIInputParser>>undefined: (in category 'private-state machine') -----
- undefined: cmdByte
- "We have received an unexpected MIDI byte (e.g., a data byte when we were expecting a command). This should never happen."
-
- self error: 'unexpected MIDI byte ', cmdByte printString.
- !
Item was removed:
- Object subclass: #MIDIScore
- instanceVariableNames: 'tracks trackInfo ambientTrack tempoMap ticksPerQuarterNote source'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !MIDIScore commentStamp: '<historical>' prior: 0!
- A MIDIScore is a container for a number of MIDI tracks as well as an ambient track for such things as sounds, book page triggers and other related events.!
Item was removed:
- ----- Method: MIDIScore>>addAmbientEvent: (in category 'ambient track') -----
- addAmbientEvent: evt
- | i |
- i := ambientTrack findFirst: [:e | e time >= evt time].
- i = 0 ifTrue: [^ ambientTrack := ambientTrack , (Array with: evt)].
- ambientTrack := ambientTrack copyReplaceFrom: i to: i-1 with: (Array with: evt)!
Item was removed:
- ----- Method: MIDIScore>>ambientEventAfter:ticks: (in category 'ambient track') -----
- ambientEventAfter: eventIndex ticks: scoreTicks
- | evt |
- (ambientTrack == nil or: [eventIndex > ambientTrack size]) ifTrue: [^ nil].
- evt := ambientTrack at: eventIndex.
- evt time <= scoreTicks ifTrue: [^ evt].
- ^ nil!
Item was removed:
- ----- Method: MIDIScore>>ambientTrack (in category 'ambient track') -----
- ambientTrack
- ^ ambientTrack ifNil: [ambientTrack := Array new]!
Item was removed:
- ----- Method: MIDIScore>>appendEvent:fullDuration:at: (in category 'editing') -----
- appendEvent: noteEvent fullDuration: fullDuration at: selection
- "It is assumed that the noteEvent already has the proper time"
-
- | track noteLoc |
- track := tracks at: selection first.
- noteLoc := selection third + 1.
- noteEvent midiKey = -1
- ifTrue: [noteLoc := noteLoc - 1]
- ifFalse: ["If not a rest..."
- track := track copyReplaceFrom: noteLoc to: noteLoc - 1
- with: (Array with: noteEvent)].
- track size >= (noteLoc + 1) ifTrue:
- ["Adjust times of following events"
- noteLoc + 1 to: track size do:
- [:i | (track at: i) adjustTimeBy: fullDuration]].
- tracks at: selection first put: track!
Item was removed:
- ----- Method: MIDIScore>>cutSelection: (in category 'editing') -----
- cutSelection: selection
-
- | track selStartTime delta |
- track := tracks at: selection first.
- selStartTime := (track at: selection second) time.
- track := track copyReplaceFrom: selection second to: selection third with: Array new.
- track size >= selection second ifTrue:
- ["Adjust times of following events"
- delta := selStartTime - (track at: selection second) time.
- selection second to: track size do:
- [:i | (track at: i) adjustTimeBy: delta]].
- tracks at: selection first put: track!
Item was removed:
- ----- Method: MIDIScore>>durationInTicks (in category 'accessing') -----
- durationInTicks
-
- | t |
- t := 0.
- tracks, {self ambientTrack} do:
- [:track |
- track do:
- [:n | (n isNoteEvent)
- ifTrue: [t := t max: n endTime]
- ifFalse: [t := t max: n time]]].
- ^ t
- !
Item was removed:
- ----- Method: MIDIScore>>eventForTrack:after:ticks: (in category 'editing') -----
- eventForTrack: trackIndex after: eventIndex ticks: scoreTick
-
- | track evt |
- track := tracks at: trackIndex.
- eventIndex > track size ifTrue: [^ nil].
- evt := track at: eventIndex.
- evt time > scoreTick ifTrue: [^ nil].
- ^ evt
- !
Item was removed:
- ----- Method: MIDIScore>>eventMorphsDo: (in category 'ambient track') -----
- eventMorphsDo: aBlock
- "Evaluate aBlock for all morphs related to the ambient events."
-
- ambientTrack == nil ifTrue: [^ self].
- ambientTrack do: [:evt | evt morph ifNotNil: aBlock].
- !
Item was removed:
- ----- Method: MIDIScore>>eventMorphsWithTimeDo: (in category 'ambient track') -----
- eventMorphsWithTimeDo: aBlock
- "Evaluate aBlock for all morphs and times related to the ambient events."
-
- ambientTrack == nil ifTrue: [^ self].
- ambientTrack do: [:evt | evt morph ifNotNil: [aBlock value: evt morph value: evt time]].
- !
Item was removed:
- ----- Method: MIDIScore>>gridToNextQuarterNote: (in category 'editing') -----
- gridToNextQuarterNote: tickTime
-
- ^ self gridToQuarterNote: tickTime + ticksPerQuarterNote!
Item was removed:
- ----- Method: MIDIScore>>gridToQuarterNote: (in category 'editing') -----
- gridToQuarterNote: tickTime
-
- ^ tickTime truncateTo: ticksPerQuarterNote!
Item was removed:
- ----- Method: MIDIScore>>gridTrack:toQuarter:at: (in category 'editing') -----
- gridTrack: trackIndex toQuarter: quarterDelta at: indexInTrack
-
- | track selStartTime delta |
- track := tracks at: trackIndex.
- selStartTime := (track at: indexInTrack) time.
- delta := (self gridToQuarterNote: selStartTime + (quarterDelta*ticksPerQuarterNote))
- - selStartTime.
- indexInTrack to: track size do:
- [:i | (track at: i) adjustTimeBy: delta].
- !
Item was removed:
- ----- Method: MIDIScore>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- tracks := #().
- ambientTrack := Array new.
- tempoMap := #().
- ticksPerQuarterNote := 100.
- !
Item was removed:
- ----- Method: MIDIScore>>insertEvents:at: (in category 'editing') -----
- insertEvents: events at: selection
-
- | track selStartTime delta |
- track := tracks at: selection first.
- selection second = 0
- ifTrue: [selStartTime := 0.
- selection at: 2 put: 1]
- ifFalse: [selStartTime := (track at: selection second) time].
- track := track copyReplaceFrom: selection second to: selection second - 1
- with: (events collect: [:e | e copy]).
- track size >= (selection second + events size) ifTrue:
- ["Adjust times of following events"
- delta := selStartTime - (track at: selection second) time.
- selection second to: selection second + events size - 1 do:
- [:i | (track at: i) adjustTimeBy: delta].
- delta := (self gridToNextQuarterNote: (track at: selection second + events size - 1) endTime)
- - (track at: selection second + events size) time.
- selection second + events size to: track size do:
- [:i | (track at: i) adjustTimeBy: delta].
- ].
- tracks at: selection first put: track!
Item was removed:
- ----- Method: MIDIScore>>jitterStartAndEndTimesBy: (in category 'editing') -----
- jitterStartAndEndTimesBy: mSecs
-
- | r range halfRange |
- r := Random new.
- range := 2.0 * mSecs.
- halfRange := mSecs.
- tracks do: [:t |
- t do: [:e | | newEnd newStart oldEnd |
- e isNoteEvent ifTrue: [
- oldEnd := e time + e duration.
- newEnd := oldEnd + ((r next * range) asInteger - halfRange).
- newStart := e time + ((r next * range) asInteger - halfRange).
- e time: newStart.
- e duration: (newEnd - newStart)]]].
-
- !
Item was removed:
- ----- Method: MIDIScore>>pauseFrom: (in category 'playing') -----
- pauseFrom: scorePlayer
- self eventMorphsDo: [:p | p pauseFrom: scorePlayer]!
Item was removed:
- ----- Method: MIDIScore>>printOn: (in category 'printing') -----
- printOn: stream
-
- self source
- ifNotNil: [:s | s printOn: stream]
- ifNil: [super printOn: stream].!
Item was removed:
- ----- Method: MIDIScore>>removeAmbientEventWithMorph: (in category 'ambient track') -----
- removeAmbientEventWithMorph: aMorph
- | i |
- i := ambientTrack findFirst: [:e | e morph == aMorph].
- i = 0 ifTrue: [^ self].
- ambientTrack := ambientTrack copyReplaceFrom: i to: i with: Array new!
Item was removed:
- ----- Method: MIDIScore>>resetFrom: (in category 'playing') -----
- resetFrom: scorePlayer
- self eventMorphsDo: [:p | p resetFrom: scorePlayer]!
Item was removed:
- ----- Method: MIDIScore>>resumeFrom: (in category 'playing') -----
- resumeFrom: scorePlayer
- self eventMorphsDo: [:p | p resumeFrom: scorePlayer]!
Item was removed:
- ----- Method: MIDIScore>>source (in category 'accessing') -----
- source
- ^ source!
Item was removed:
- ----- Method: MIDIScore>>source: (in category 'accessing') -----
- source: anObject
- source := anObject.!
Item was removed:
- ----- Method: MIDIScore>>tempoMap (in category 'accessing') -----
- tempoMap
-
- ^ tempoMap
- !
Item was removed:
- ----- Method: MIDIScore>>tempoMap: (in category 'accessing') -----
- tempoMap: tempoEventList
-
- tempoEventList ifNil: [
- tempoMap := #().
- ^ self].
- tempoMap := tempoEventList asArray.
- !
Item was removed:
- ----- Method: MIDIScore>>ticksPerQuarterNote (in category 'accessing') -----
- ticksPerQuarterNote
-
- ^ ticksPerQuarterNote
- !
Item was removed:
- ----- Method: MIDIScore>>ticksPerQuarterNote: (in category 'accessing') -----
- ticksPerQuarterNote: anInteger
-
- ticksPerQuarterNote := anInteger.
- !
Item was removed:
- ----- Method: MIDIScore>>trackInfo (in category 'accessing') -----
- trackInfo
-
- ^ trackInfo ifNil: [tracks collect: [:i | String new]]
- !
Item was removed:
- ----- Method: MIDIScore>>trackInfo: (in category 'accessing') -----
- trackInfo: trackInfoList
-
- trackInfo := trackInfoList asArray.
- !
Item was removed:
- ----- Method: MIDIScore>>tracks (in category 'accessing') -----
- tracks
-
- ^ tracks
- !
Item was removed:
- ----- Method: MIDIScore>>tracks: (in category 'accessing') -----
- tracks: trackList
-
- tracks := trackList asArray collect: [:trackEvents | trackEvents asArray].
- self ambientTrack. "Assure it's not nil"!
Item was removed:
- ----- Method: MIDIScore>>tracks:trackInfo: (in category 'accessing') -----
- tracks: trackList trackInfo: trackInfoList
-
- self tracks: trackList; trackInfo: trackInfoList.!
Item was removed:
- ScorePlayer subclass: #MIDISound
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !MIDISound commentStamp: 'mt 4/6/2016 10:19' prior: 0!
- This empty class just makes the fact explicit that this object is a sound object that needs can be played. Just like other sounds.
-
- Example: (MIDISound fromFileNamed: 'some.mid') play!
Item was removed:
- ----- Method: MIDISound>>play (in category 'playing') -----
- play
- "The base class ScorePlayer has two interfaces: a sound and a sound player. Choose the right interface depending on whether MIDI support is present."
-
- SoundService soundEnabled ifFalse: [^ self].
-
- SimpleMIDIPort useMIDIDeviceForOutput ifTrue: [
- [self openMIDIPort]
- on: Error
- do: [
- SimpleMIDIPort askForDefault.
- [self openMIDIPort]
- on: Error
- do: [
- self inform: 'Use of MIDI device is not working. Using custom synthesis.\Go to preferences to change again.' withCRs.
- SimpleMIDIPort useMIDIDeviceForOutput: false]]].
-
- self reset; resumePlaying.!
Item was removed:
- Object subclass: #MIDISynth
- instanceVariableNames: 'midiParser channels process'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !MIDISynth commentStamp: '<historical>' prior: 0!
- I implement a simple real-time MIDI synthesizer on platforms that support MIDI input. I work best on platforms that allow the sound buffer to be made very short--under 50 milliseconds is good and under 20 milliseconds is preferred (see below). The buffer size is changed by modifying the class initialization method of SoundPlayer and executing the do-it there to re-start the sound player.
-
- Each instance of me takes input from a single MIDI input port. Multiple instances of me can be used to handle multiple MIDI input ports. I distribute incoming commands among my sixteen MIDISynthChannel objects. Most of the interpretation of the MIDI commands is done by these channel objects.
-
- Buffer size notes: At the moment, most fast PowerPC Macintosh computers can probably work with buffer sizes down to 50 milliseconds, and the Powerbook G3 works down to about 15 milliseconds. You will need to experiment to discover the minimum buffer size that does not result in clicking during sound output. (Hint: Be sure to turn off power cycling on your Powerbook. Other applications and extensions can steal cycles from Squeak, causing intermittent clicking. Experimentation may be necessary to find a configuration that works for you.)
- !
Item was removed:
- ----- Method: MIDISynth class>>example (in category 'examples') -----
- example
- "Here's one way to run the MIDI synth. It will get a nice Morphic UI later. Click the mouse to stop running it. (Mac users note: be sure you have MIDI interface adaptor plugged in, or Squeak will hang waiting for the external clock signal.)."
- "MIDISynth example"
-
- | portNum synth |
- portNum := SimpleMIDIPort inputPortNumFromUser.
- portNum ifNil: [^ self].
- SoundPlayer useShortBuffer.
- synth := MIDISynth new
- midiPort: (SimpleMIDIPort openOnPortNumber: portNum).
- synth midiParser ignoreCommand: 224. "filter out pitch bends"
- 1 to: 16 do: [:i |
- (synth channel: i) instrument:
- (AbstractSound soundNamed: 'oboe1')].
- 1 to: 16 do: [:ch | synth volumeForChannel: ch put: 0.2].
-
- synth processMIDIUntilMouseDown.
- SoundPlayer shutDown: true; initialize. "revert to normal buffer size"
- !
Item was removed:
- ----- Method: MIDISynth>>channel: (in category 'channels') -----
- channel: i
-
- ^ channels at: i
- !
Item was removed:
- ----- Method: MIDISynth>>closeMIDIPort (in category 'midi port') -----
- closeMIDIPort
-
- midiParser midiPort ifNil: [^ self].
- midiParser midiPort close.
- midiParser midiPort: nil.
- !
Item was removed:
- ----- Method: MIDISynth>>initialize (in category 'initialize-release') -----
- initialize
-
- super initialize.
- midiParser := MIDIInputParser on: nil.
- channels := (1 to: 16) collect: [:ch | MIDISynthChannel new initialize].
- !
Item was removed:
- ----- Method: MIDISynth>>instrumentForChannel: (in category 'channels') -----
- instrumentForChannel: channelIndex
-
- ^ (channels at: channelIndex) instrument
- !
Item was removed:
- ----- Method: MIDISynth>>instrumentForChannel:put: (in category 'channels') -----
- instrumentForChannel: channelIndex put: aSoundProto
-
- (channels at: channelIndex) instrument: aSoundProto.
- !
Item was removed:
- ----- Method: MIDISynth>>isOn (in category 'testing') -----
- isOn
-
- ^ process notNil
- !
Item was removed:
- ----- Method: MIDISynth>>midiParser (in category 'accessing') -----
- midiParser
-
- ^ midiParser
- !
Item was removed:
- ----- Method: MIDISynth>>midiPort (in category 'midi port') -----
- midiPort
-
- ^ midiParser midiPort
- !
Item was removed:
- ----- Method: MIDISynth>>midiPort: (in category 'midi port') -----
- midiPort: aMIDIPortOrNil
-
- midiParser midiPort: aMIDIPortOrNil.
- !
Item was removed:
- ----- Method: MIDISynth>>midiTrackingLoop (in category 'tracking') -----
- midiTrackingLoop
-
- midiParser clearBuffers.
-
- [self processMIDI ifFalse: [(Delay forMilliseconds: 5) wait]] repeat!
Item was removed:
- ----- Method: MIDISynth>>mutedForChannel:put: (in category 'channels') -----
- mutedForChannel: channelIndex put: aBoolean
-
- ^ (channels at: channelIndex) muted: aBoolean
- !
Item was removed:
- ----- Method: MIDISynth>>panForChannel: (in category 'channels') -----
- panForChannel: channelIndex
-
- ^ (channels at: channelIndex) pan
- !
Item was removed:
- ----- Method: MIDISynth>>panForChannel:put: (in category 'channels') -----
- panForChannel: channelIndex put: newPan
-
- (channels at: channelIndex) pan: newPan.
- !
Item was removed:
- ----- Method: MIDISynth>>processMIDI (in category 'private-tracking') -----
- processMIDI
- "Process some MIDI commands. Answer true if any commands were processed."
-
- | didSomething |
- didSomething := false.
- midiParser midiDo: [:item | | cmdByte byte1 chan cmd byte2 |
- didSomething := true.
- cmdByte := item at: 2.
- byte1 := byte2 := nil.
- item size > 2 ifTrue: [
- byte1 := item at: 3.
- item size > 3 ifTrue: [byte2 := item at: 4]].
- cmdByte < 240
- ifTrue: [ "channel message"
- cmd := cmdByte bitAnd: 2r11110000.
- chan := (cmdByte bitAnd: 2r00001111) + 1.
- (channels at: chan) doChannelCmd: cmd byte1: byte1 byte2: byte2]
- ifFalse: [ "system message"
- "process system messages here"
- ]].
- ^ didSomething
- !
Item was removed:
- ----- Method: MIDISynth>>processMIDIUntilMouseDown (in category 'private-tracking') -----
- processMIDIUntilMouseDown
- "Used for debugging. Do MIDI processing until the mouse is pressed."
-
- midiParser clearBuffers.
- [Sensor anyButtonPressed] whileFalse: [self processMIDI].
- !
Item was removed:
- ----- Method: MIDISynth>>setAllChannelMasterVolumes: (in category 'channels') -----
- setAllChannelMasterVolumes: aNumber
-
- | vol |
- vol := (aNumber asFloat min: 1.0) max: 0.0.
- channels do: [:ch | ch masterVolume: vol].
- !
Item was removed:
- ----- Method: MIDISynth>>startMIDITracking (in category 'tracking') -----
- startMIDITracking
-
- midiParser ifNil: [^ self].
- midiParser midiPort ifNil: [^ self].
- midiParser midiPort ensureOpen.
- self stopMIDITracking.
- SoundPlayer useShortBuffer.
- process := [self midiTrackingLoop] newProcess.
- process priority: Processor userInterruptPriority.
- process resume.
- !
Item was removed:
- ----- Method: MIDISynth>>stopMIDITracking (in category 'tracking') -----
- stopMIDITracking
-
- process ifNotNil: [
- process terminate.
- process := nil].
- SoundPlayer shutDown: true; initialize. "revert to normal buffer size"
- !
Item was removed:
- ----- Method: MIDISynth>>volumeForChannel: (in category 'channels') -----
- volumeForChannel: channelIndex
-
- ^ (channels at: channelIndex) masterVolume
- !
Item was removed:
- ----- Method: MIDISynth>>volumeForChannel:put: (in category 'channels') -----
- volumeForChannel: channelIndex put: newVolume
-
- (channels at: channelIndex) masterVolume: newVolume.
- !
Item was removed:
- Object subclass: #MIDISynthChannel
- instanceVariableNames: 'channel instrument muted masterVolume channelVolume pan pitchBend activeSounds'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !MIDISynthChannel commentStamp: '<historical>' prior: 0!
- I implement one polyphonic channel of a 16-channel MIDI synthesizer. Many MIDI commands effect all the notes played on a particular channel, so I record the state for a single channel, including a list of notes currently playing.
-
- This initial implementation is extremely spartan, having just enough functionality to play notes. Things that are not implemented include:
-
- 1. program changes
- 2. sustain pedal
- 3. aftertouch (either kind)
- 4. most controllers
- 5. portamento
- 6. mono-mode
- !
Item was removed:
- ----- Method: MIDISynthChannel>>adjustPitch: (in category 'other') -----
- adjustPitch: bend
- "Handle a pitch-bend change."
-
- | pitchAdj |
- pitchBend := bend.
- pitchAdj := 2.0 raisedTo: (bend asFloat / 8192.0) / 6.0.
- activeSounds copy do: [:entry | | snd centerPitch |
- snd := entry at: 2.
- centerPitch := entry at: 3.
- snd pitch: pitchAdj * centerPitch.
- snd internalizeModulationAndRatio].
- !
Item was removed:
- ----- Method: MIDISynthChannel>>channelPressure: (in category 'midi dispatching') -----
- channelPressure: newPressure
- "Handle a channel pressure (channel aftertouch) change."
-
- self newVolume: newPressure.
- !
Item was removed:
- ----- Method: MIDISynthChannel>>control:value: (in category 'midi dispatching') -----
- control: control value: newValue
- "Handle a continuous controller change."
-
- control = 2 ifTrue: [self newVolume: newValue]. "breath controller"
- !
Item was removed:
- ----- Method: MIDISynthChannel>>convertVelocity: (in category 'other') -----
- convertVelocity: valueByte
- "Map a value in the range 0..127 to a volume in the range 0.0..1.0."
- "Details: A quadratic function seems to give a good keyboard feel."
-
- | r |
- r := (valueByte * valueByte) / 12000.0.
- r > 1.0 ifTrue: [^ 1.0].
- r < 0.08 ifTrue: [^ 0.08].
- ^ r
- !
Item was removed:
- ----- Method: MIDISynthChannel>>doChannelCmd:byte1:byte2: (in category 'midi dispatching') -----
- doChannelCmd: cmdByte byte1: byte1 byte2: byte2
- "Dispatch a channel command with the given arguments."
- "Details: Cases appear in order of expected frequency, most frequent cases first."
-
- cmdByte = 144 ifTrue: [
- byte2 = 0
- ifTrue: [^ self keyUp: byte1 vel: 0]
- ifFalse: [^ self keyDown: byte1 vel: byte2]].
- cmdByte = 128 ifTrue: [^ self keyUp: byte1 vel: byte2].
- cmdByte = 224 ifTrue: [^ self pitchBend: ((byte2 bitShift: 7) + byte1) - 8192].
- cmdByte = 176 ifTrue: [^ self control: byte1 value: byte2].
- cmdByte = 208 ifTrue: [^ self channelPressure: byte1].
- cmdByte = 160 ifTrue: [^ self key: byte1 pressure: byte2].
- cmdByte = 192 ifTrue: [^ self programChange: byte1].
- !
Item was removed:
- ----- Method: MIDISynthChannel>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- instrument := FMSound default.
- muted := false.
- masterVolume := 0.5.
- channelVolume := 1.0.
- pan := 0.5.
- pitchBend := 0.0.
- activeSounds := OrderedCollection new.
- !
Item was removed:
- ----- Method: MIDISynthChannel>>instrument (in category 'accessing') -----
- instrument
-
- ^ instrument
- !
Item was removed:
- ----- Method: MIDISynthChannel>>instrument: (in category 'accessing') -----
- instrument: aSound
-
- instrument := aSound.
- !
Item was removed:
- ----- Method: MIDISynthChannel>>key:pressure: (in category 'midi dispatching') -----
- key: key pressure: press
- "Handle a key pressure (polyphonic aftertouch) change. Rarely implemented."
-
- "Do nothing for now."
- !
Item was removed:
- ----- Method: MIDISynthChannel>>keyDown:vel: (in category 'midi dispatching') -----
- keyDown: key vel: vel
- "Handle a key down event with non-zero velocity."
-
- | pitch snd |
- muted ifTrue: [^ self].
- pitch := AbstractSound pitchForMIDIKey: key.
- snd := instrument
- soundForPitch: pitch
- dur: 10000.0 "sustain a long time, or until turned off"
- loudness: masterVolume * channelVolume * (self convertVelocity: vel).
- snd := (MixedSound new add: snd pan: pan) reset.
- SoundPlayer resumePlaying: snd quickStart: false.
- activeSounds add: (Array with: key with: snd with: pitch).
- !
Item was removed:
- ----- Method: MIDISynthChannel>>keyUp:vel: (in category 'midi dispatching') -----
- keyUp: key vel: vel
- "Handle a key up event."
-
-
- activeSounds copy do: [:entry | | snd |
- (entry at: 1) = key ifTrue: [
- snd := entry at: 2.
- snd stopGracefully.
- activeSounds remove: entry]].
- !
Item was removed:
- ----- Method: MIDISynthChannel>>masterVolume (in category 'accessing') -----
- masterVolume
-
- ^ masterVolume
- !
Item was removed:
- ----- Method: MIDISynthChannel>>masterVolume: (in category 'accessing') -----
- masterVolume: aNumber
- "Set the master volume the the given value (0.0 to 1.0)."
-
- masterVolume := aNumber asFloat.
- !
Item was removed:
- ----- Method: MIDISynthChannel>>muted (in category 'accessing') -----
- muted
-
- ^ muted
- !
Item was removed:
- ----- Method: MIDISynthChannel>>muted: (in category 'accessing') -----
- muted: aBoolean
-
- muted := aBoolean.
- !
Item was removed:
- ----- Method: MIDISynthChannel>>newVolume: (in category 'other') -----
- newVolume: valueByte
- "Set the channel volume to the level given by the given number in the range 0..127."
-
- | newVolume |
- channelVolume := valueByte asFloat / 127.0.
- newVolume := masterVolume * channelVolume.
- activeSounds do: [:entry | | snd |
- snd := entry at: 2.
- snd adjustVolumeTo: newVolume overMSecs: 10].
- !
Item was removed:
- ----- Method: MIDISynthChannel>>pan (in category 'accessing') -----
- pan
-
- ^ pan
- !
Item was removed:
- ----- Method: MIDISynthChannel>>pan: (in category 'accessing') -----
- pan: aNumber
- "Set the left-right pan to the given value (0.0 to 1.0)."
-
- pan := aNumber asFloat.
- !
Item was removed:
- ----- Method: MIDISynthChannel>>pitchBend: (in category 'midi dispatching') -----
- pitchBend: bend
- "Handle a pitch-bend change."
-
- self adjustPitch: bend.
- !
Item was removed:
- ----- Method: MIDISynthChannel>>programChange: (in category 'midi dispatching') -----
- programChange: newProgram
- "Handle a program (instrument) change."
-
- "Do nothing for now."
- !
Item was removed:
- AbstractSound subclass: #MixedSound
- instanceVariableNames: 'sounds leftVols rightVols soundDone'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: MixedSound>>+ (in category 'composition') -----
- + aSound
- "Return the mix of the receiver and the argument sound."
-
- self add: aSound
- !
Item was removed:
- ----- Method: MixedSound>>add: (in category 'composition') -----
- add: aSound
- "Add the given sound with a pan setting of centered and no attenuation."
-
- self add: aSound pan: 0.5 volume: 1.0.
- ^aSound
- !
Item was removed:
- ----- Method: MixedSound>>add:pan: (in category 'composition') -----
- add: aSound pan: leftRightPan
- "Add the given sound with the given left-right panning and no attenuation."
-
- self add: aSound pan: leftRightPan volume: 1.0.
- !
Item was removed:
- ----- Method: MixedSound>>add:pan:volume: (in category 'composition') -----
- add: aSound pan: leftRightPan volume: volume
- "Add the given sound with the given left-right pan, where 0.0 is full left, 1.0 is full right, and 0.5 is centered. The loudness of the sound will be scaled by volume, which ranges from 0 to 1.0."
-
- | pan vol |
- pan := ((leftRightPan * ScaleFactor) asInteger max: 0) min: ScaleFactor.
- vol := ((volume * ScaleFactor) asInteger max: 0) min: ScaleFactor.
- "Sounds have state. If a sound occurs more than once in sounds then mixing can produce some very strange results"
- sounds := sounds copyWith: ((sounds includes: aSound) ifTrue: [aSound copy] ifFalse: [aSound]).
- leftVols := leftVols copyWith: ((ScaleFactor - pan) * vol) // ScaleFactor.
- rightVols := rightVols copyWith: (pan * vol) // ScaleFactor!
Item was removed:
- ----- Method: MixedSound>>copySounds (in category 'copying') -----
- copySounds
- "Private!! Support for copying. Copy my component sounds and settings array."
-
- sounds := sounds collect: [:s | s copy].
- leftVols := leftVols copy.
- rightVols := rightVols copy.
- !
Item was removed:
- ----- Method: MixedSound>>doControl (in category 'sound generation') -----
- doControl
-
- super doControl.
- 1 to: sounds size do: [:i | (sounds at: i) doControl].
- !
Item was removed:
- ----- Method: MixedSound>>duration (in category 'accessing') -----
- duration
- "Answer the duration of this sound in seconds."
-
- | dur |
- dur := 0.
- sounds do: [:snd | dur := dur max: snd duration].
- ^ dur
- !
Item was removed:
- ----- Method: MixedSound>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- sounds := Array new.
- leftVols := Array new.
- rightVols := Array new.
- !
Item was removed:
- ----- Method: MixedSound>>isStereo (in category 'accessing') -----
- isStereo
-
- ^ true
- !
Item was removed:
- ----- Method: MixedSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Play a number of sounds concurrently. The level of each sound can be set independently for the left and right channels."
-
- | snd left right |
- soundDone
- ifNil:
- [1 to: sounds size do:
- [:i |
- snd := sounds at: i.
- left := (leftVol * (leftVols at: i) * scaledVol / ScaleFactor) // ScaleFactor.
- right := (rightVol * (rightVols at: i) * scaledVol / ScaleFactor) // ScaleFactor.
- snd samplesRemaining > 0 ifTrue:
- [snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right]]]
- ifNotNil:
- [1 to: sounds size do:
- [:i |
- (soundDone at: i) ifFalse:
- [snd := sounds at: i.
- left := (leftVol * (leftVols at: i) * scaledVol / ScaleFactor) // ScaleFactor.
- right := (rightVol * (rightVols at: i) * scaledVol / ScaleFactor) // ScaleFactor.
- snd samplesRemaining > 0
- ifTrue: [snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right]
- ifFalse: [soundDone at: i put: true]]]]!
Item was removed:
- ----- Method: MixedSound>>postCopy (in category 'copying') -----
- postCopy
- "Copy my component sounds."
-
- super postCopy.
- self copySounds
- !
Item was removed:
- ----- Method: MixedSound>>reset (in category 'sound generation') -----
- reset
-
- super reset.
- sounds do: [:snd | snd reset].
- soundDone := (Array new: sounds size) atAllPut: false.
- !
Item was removed:
- ----- Method: MixedSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
-
- | remaining r |
- remaining := 0.
- 1 to: sounds size do: [:i |
- r := (sounds at: i) samplesRemaining.
- r > remaining ifTrue: [remaining := r]].
-
- ^ remaining
- !
Item was removed:
- ----- Method: MixedSound>>sounds (in category 'accessing') -----
- sounds
-
- ^ sounds
- !
Item was removed:
- ----- Method: MixedSound>>stopGracefully (in category 'sound generation') -----
- stopGracefully
- "End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes."
-
- super stopGracefully.
- sounds do: [:s | s stopGracefully].
- !
Item was removed:
- SoundCodec subclass: #MuLawCodec
- instanceVariableNames: ''
- classVariableNames: 'DecodingTable'
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !MuLawCodec commentStamp: '<historical>' prior: 0!
- I represent a mu-law (u-law) codec. I compress sound data by a factor of 2:1 by encoding the most significant 12 bits of each 16-bit sample as a signed, exponentially encoded byte. The idea is to use more resolution for smaller lower sample values. This encoding was developed for the North American phone system and a variant of it, a-law, is a European phone standard. It is a popular sound encoding on Unix platforms (.au files).
- !
Item was removed:
- ----- Method: MuLawCodec class>>initialize (in category 'class initialization') -----
- initialize
- "Build the 256 entry table to be used to decode 8-bit uLaw-encoded samples."
- "MuLawCodec initialize"
-
- | encoded codec lastEncodedPos lastEncodedNeg |
- DecodingTable := Array new: 256.
- codec := self new.
- lastEncodedPos := nil.
- lastEncodedNeg := nil.
- 4095 to: 0 by: -1 do: [:s |
- encoded := codec uLawEncode12Bits: s.
- lastEncodedPos = encoded
- ifFalse: [
- DecodingTable at: (encoded + 1) put: (s bitShift: 3).
- lastEncodedPos := encoded].
- encoded := encoded bitOr: 16r80.
- lastEncodedNeg = encoded
- ifFalse: [
- DecodingTable at: (encoded + 1) put: (s bitShift: 3) negated.
- lastEncodedNeg := encoded]].
- !
Item was removed:
- ----- Method: MuLawCodec>>bytesPerEncodedFrame (in category 'subclass responsibility') -----
- bytesPerEncodedFrame
- "Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size."
-
- ^ 1
- !
Item was removed:
- ----- Method: MuLawCodec>>decodeFrames:from:at:into:at: (in category 'subclass responsibility') -----
- decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
- "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
- "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."
-
- | dst |
- dst := dstIndex.
- srcIndex to: srcIndex + frameCount - 1 do: [:src |
- dstSoundBuffer at: dst put: (DecodingTable at: (srcByteArray at: src) + 1).
- dst := dst + 1].
- ^ Array with: frameCount with: frameCount
- !
Item was removed:
- ----- Method: MuLawCodec>>encodeFrames:from:at:into:at: (in category 'subclass responsibility') -----
- encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
- "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
- "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."
-
- srcIndex to: srcIndex + frameCount - 1 do: [:i |
- dstByteArray at: i put: (self uLawEncodeSample: (srcSoundBuffer at: i))].
- ^ Array with: frameCount with: frameCount
- !
Item was removed:
- ----- Method: MuLawCodec>>samplesPerFrame (in category 'subclass responsibility') -----
- samplesPerFrame
- "Answer the number of sound samples per compression frame."
-
- ^ 1
- !
Item was removed:
- ----- Method: MuLawCodec>>uLawDecodeSample: (in category 'external access') -----
- uLawDecodeSample: byte
- "Decode a 16-bit signed sample from 8 bits using uLaw decoding"
-
- ^ DecodingTable at: byte + 1!
Item was removed:
- ----- Method: MuLawCodec>>uLawEncode12Bits: (in category 'private') -----
- uLawEncode12Bits: s
- "Encode a 12-bit unsigned sample (0-4095) into 7 bits using uLaw encoding.
- This gets called by a method that scales 16-bit signed integers down to a
- 12-bit magnitude, and then ORs in 16r80 if they were negative.
- Detail: May get called with s >= 4096, and this works fine."
-
- s < 496 ifTrue: [
- s < 112 ifTrue: [
- s < 48 ifTrue: [
- s < 16
- ifTrue: [^ 16r70 bitOr: (15 - s)]
- ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]].
- ^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))].
- s < 240
- ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))]
- ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]].
-
- s < 2032 ifTrue: [
- s < 1008
- ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))]
- ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]].
-
- s < 4080
- ifTrue: [^ 15 - ((s - 2032) bitShift: -7)]
- ifFalse: [^ 0].
- !
Item was removed:
- ----- Method: MuLawCodec>>uLawEncodeSample: (in category 'external access') -----
- uLawEncodeSample: sample
- "Encode a 16-bit signed sample into 8 bits using uLaw encoding"
-
- | s |
- s := sample // 8. "drop 3 least significant bits"
- s < 0 ifTrue: [^ (self uLawEncode12Bits: 0-s) + 16r80]
- ifFalse: [^ (self uLawEncode12Bits: s)].
- !
Item was removed:
- AbstractScoreEvent subclass: #NoteEvent
- instanceVariableNames: 'duration midiKey velocity channel'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !NoteEvent commentStamp: '<historical>' prior: 0!
- Represents a note on or off event in a MIDI score.
- !
Item was removed:
- ----- Method: NoteEvent>>channel (in category 'accessing') -----
- channel
-
- ^ channel
- !
Item was removed:
- ----- Method: NoteEvent>>channel: (in category 'accessing') -----
- channel: midiChannel
-
- channel := midiChannel.
- !
Item was removed:
- ----- Method: NoteEvent>>duration (in category 'accessing') -----
- duration
-
- ^ duration
- !
Item was removed:
- ----- Method: NoteEvent>>duration: (in category 'accessing') -----
- duration: aNumber
-
- duration := aNumber.
- !
Item was removed:
- ----- Method: NoteEvent>>endNoteOnMidiPort: (in category 'midi') -----
- endNoteOnMidiPort: aMidiPort
- "Output a noteOff event to the given MIDI port. (Actually, output a noteOff event with zero velocity. This does the same thing, but allows running status to be used when sending a mixture of note on and off commands.)"
-
- aMidiPort
- midiCmd: 16r90
- channel: channel
- byte: midiKey
- byte: 0.
- !
Item was removed:
- ----- Method: NoteEvent>>endTime (in category 'accessing') -----
- endTime
-
- ^ time + duration
- !
Item was removed:
- ----- Method: NoteEvent>>isNoteEvent (in category 'classification') -----
- isNoteEvent
-
- ^ true
- !
Item was removed:
- ----- Method: NoteEvent>>key:velocity:channel: (in category 'accessing') -----
- key: midiKeyNum velocity: midiVelocity channel: midiChannel
-
- midiKey := midiKeyNum.
- velocity := midiVelocity.
- channel := midiChannel.
- !
Item was removed:
- ----- Method: NoteEvent>>keyName (in category 'printing') -----
- keyName
- "Return a note name for my pitch."
-
- | pitchName octave |
- pitchName := #(c cs d ef e f fs g af a bf b) at: (midiKey \\ 12) + 1.
- octave := (#(-1 0 1 2 3 4 5 6 7 8 9) at: (midiKey // 12) + 1) printString.
- ^ pitchName, octave
- !
Item was removed:
- ----- Method: NoteEvent>>midiKey (in category 'accessing') -----
- midiKey
-
- ^ midiKey
- !
Item was removed:
- ----- Method: NoteEvent>>midiKey: (in category 'accessing') -----
- midiKey: midiKeyNum
-
- midiKey := midiKeyNum.
- !
Item was removed:
- ----- Method: NoteEvent>>pitch (in category 'accessing') -----
- pitch
- "Convert my MIDI key number to a pitch and return it."
-
- ^ AbstractSound pitchForMIDIKey: midiKey
- !
Item was removed:
- ----- Method: NoteEvent>>printOn: (in category 'printing') -----
- printOn: aStream
-
- aStream nextPut: $(.
- time printOn: aStream.
- aStream nextPutAll: ': '.
- aStream nextPutAll: self keyName.
- aStream space.
- duration printOn: aStream.
- aStream nextPut: $).
- !
Item was removed:
- ----- Method: NoteEvent>>startNoteOnMidiPort: (in category 'midi') -----
- startNoteOnMidiPort: aMidiPort
- "Output a noteOn event to the given MIDI port."
-
- aMidiPort
- midiCmd: 16r90
- channel: channel
- byte: midiKey
- byte: velocity.
- !
Item was removed:
- ----- Method: NoteEvent>>velocity (in category 'accessing') -----
- velocity
-
- ^ velocity
- !
Item was removed:
- ----- Method: NoteEvent>>velocity: (in category 'accessing') -----
- velocity: midiVelocity
-
- velocity := midiVelocity.
- !
Item was removed:
- AbstractScoreEvent subclass: #PitchBendEvent
- instanceVariableNames: 'bend channel'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
Item was removed:
- ----- Method: PitchBendEvent>>bend (in category 'accessing') -----
- bend
-
- ^ bend
- !
Item was removed:
- ----- Method: PitchBendEvent>>bend: (in category 'accessing') -----
- bend: midiPitchBend
-
- bend := midiPitchBend.
- !
Item was removed:
- ----- Method: PitchBendEvent>>bend:channel: (in category 'accessing') -----
- bend: midiPitchBend channel: midiChannel
-
- bend := midiPitchBend.
- channel := midiChannel.
- !
Item was removed:
- ----- Method: PitchBendEvent>>channel (in category 'accessing') -----
- channel
-
- ^ channel
- !
Item was removed:
- ----- Method: PitchBendEvent>>channel: (in category 'accessing') -----
- channel: midiChannel
-
- channel := midiChannel.
- !
Item was removed:
- ----- Method: PitchBendEvent>>isPitchBend (in category 'classification') -----
- isPitchBend
-
- ^ true
- !
Item was removed:
- ----- Method: PitchBendEvent>>outputOnMidiPort: (in category 'midi') -----
- outputOnMidiPort: aMidiPort
- "Output this event to the given MIDI port."
-
- aMidiPort
- midiCmd: 16rE0
- channel: channel
- byte: (bend bitAnd: 16r7F)
- byte: (bend bitShift: -7).
- !
Item was removed:
- ----- Method: PitchBendEvent>>printOn: (in category 'printing') -----
- printOn: aStream
-
- aStream nextPut: $(.
- time printOn: aStream.
- aStream nextPutAll: ': bend '.
- bend printOn: aStream.
- aStream nextPut: $).
- !
Item was removed:
- Envelope subclass: #PitchEnvelope
- instanceVariableNames: 'centerPitch'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: PitchEnvelope>>centerPitch (in category 'accessing') -----
- centerPitch
-
- ^ centerPitch
- !
Item was removed:
- ----- Method: PitchEnvelope>>centerPitch: (in category 'accessing') -----
- centerPitch: aNumber
-
- centerPitch := aNumber.
- !
Item was removed:
- ----- Method: PitchEnvelope>>updateSelector (in category 'accessing') -----
- updateSelector
- "Needed by the envelope editor."
-
- ^ #pitch:
- !
Item was removed:
- ----- Method: PitchEnvelope>>updateTargetAt: (in category 'applying') -----
- updateTargetAt: mSecs
- "Update the pitch for my target. Answer true if the value changed."
- "Details: Assume envelope range is 0.0..2.0, with 1 being the center pitch. Subtracting one yields the range -1.0..1.0. Raising two to this power yields pitches between half and double the center pitch; i.e. from an octave below to an octave about the center pitch."
-
- | newValue |
- newValue := self valueAtMSecs: mSecs.
- newValue ~= lastValue ifTrue: [
- target pitch: (2.0 raisedTo: newValue - (scale / 2.0)) * centerPitch.
- lastValue := newValue.
- ^ true].
-
- ^ false
- !
Item was removed:
- AbstractSound subclass: #PluckedSound
- instanceVariableNames: 'initialCount count ring scaledIndex scaledIndexIncr scaledIndexLimit'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !PluckedSound commentStamp: '<historical>' prior: 0!
- The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string. Fractional indexing is used to allow precise tuning; without this, the pitch would be rounded to the pitch corresponding to the nearest buffer size.
- !
Item was removed:
- ----- Method: PluckedSound class>>default (in category 'instruments') -----
- default
- "PluckedSound default play"
- "(AbstractSound majorScaleOn: PluckedSound default) play"
-
- | snd p env |
- snd := PluckedSound new.
- p := OrderedCollection new.
- p add: 0(a)1.0; add: 10(a)1.0; add: 20(a)0.0.
- env := VolumeEnvelope points: p loopStart: 2 loopEnd: 2.
- env target: snd; scale: 0.3.
- ^ snd
- addEnvelope: env;
- setPitch: 220 dur: 3.0 loudness: 0.3
- !
Item was removed:
- ----- Method: PluckedSound>>copyRing (in category 'copying') -----
- copyRing
- "Private!! Support for copying"
-
- ring := ring copy.
- !
Item was removed:
- ----- Method: PluckedSound>>duration (in category 'accessing') -----
- duration
- "Answer the duration of this sound in seconds."
-
- ^ initialCount asFloat / self samplingRate
- !
Item was removed:
- ----- Method: PluckedSound>>duration: (in category 'accessing') -----
- duration: seconds
-
- super duration: seconds.
- count := initialCount := (seconds * self samplingRate) rounded.
- !
Item was removed:
- ----- Method: PluckedSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string."
- "(PluckedSound pitch: 220.0 dur: 6.0 loudness: 0.8) play"
-
- | lastIndex scaledThisIndex scaledNextIndex average sample i s |
- <primitive:'primitiveMixPluckedSound' module:'SoundGenerationPlugin'>
- <var: #aSoundBuffer declareC: 'short int *aSoundBuffer'>
- <var: #ring declareC: 'short int *ring'>
-
- lastIndex := (startIndex + n) - 1.
- scaledThisIndex := scaledNextIndex := scaledIndex.
- startIndex to: lastIndex do: [:sliceIndex |
- scaledNextIndex := scaledThisIndex + scaledIndexIncr.
- scaledNextIndex >= scaledIndexLimit
- ifTrue: [scaledNextIndex := ScaleFactor + (scaledNextIndex - scaledIndexLimit)].
- average :=
- ((ring at: scaledThisIndex // ScaleFactor) +
- (ring at: scaledNextIndex // ScaleFactor)) // 2.
- ring at: scaledThisIndex // ScaleFactor put: average.
- sample := (average * scaledVol) // ScaleFactor. "scale by volume"
- scaledThisIndex := scaledNextIndex.
-
- leftVol > 0 ifTrue: [
- i := (2 * sliceIndex) - 1.
- s := (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor).
- s > 32767 ifTrue: [s := 32767]. "clipping!!"
- s < -32767 ifTrue: [s := -32767]. "clipping!!"
- aSoundBuffer at: i put: s].
- rightVol > 0 ifTrue: [
- i := 2 * sliceIndex.
- s := (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor).
- s > 32767 ifTrue: [s := 32767]. "clipping!!"
- s < -32767 ifTrue: [s := -32767]. "clipping!!"
- aSoundBuffer at: i put: s].
-
- scaledVolIncr ~= 0 ifTrue: [
- scaledVol := scaledVol + scaledVolIncr.
- ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
- [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
- ifTrue: [ "reached the limit; stop incrementing"
- scaledVol := scaledVolLimit.
- scaledVolIncr := 0]]].
-
- scaledIndex := scaledNextIndex.
- count := count - n.
- !
Item was removed:
- ----- Method: PluckedSound>>postCopy (in category 'copying') -----
- postCopy
-
- super postCopy.
- self copyRing
- !
Item was removed:
- ----- Method: PluckedSound>>reset (in category 'sound generation') -----
- reset
- "Fill the ring with random noise."
-
- | seed n |
- super reset.
- seed := 17.
- n := ring monoSampleCount.
- 1 to: n do: [:i |
- seed := ((seed * 1309) + 13849) bitAnd: 65535.
- ring at: i put: seed - 32768].
- count := initialCount.
- scaledIndex := ScaleFactor.
- !
Item was removed:
- ----- Method: PluckedSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
-
- ^ count
- !
Item was removed:
- ----- Method: PluckedSound>>setPitch:dur:loudness: (in category 'initialization') -----
- setPitch: pitchNameOrNumber dur: d loudness: vol
-
- | p sz |
- super setPitch: pitchNameOrNumber dur: d loudness: vol.
- p := self nameOrNumberToPitch: pitchNameOrNumber.
- initialCount := (d * self samplingRate asFloat) asInteger.
- ring := SoundBuffer newMonoSampleCount:
- (((2.0 * self samplingRate) / p) asInteger max: 2).
- sz := ring monoSampleCount.
- scaledIndexLimit := (sz + 1) * ScaleFactor.
- scaledIndexIncr := (p * sz * ScaleFactor) // (2.0 * self samplingRate).
- self reset.
- !
Item was removed:
- ----- Method: PluckedSound>>stopAfterMSecs: (in category 'sound generation') -----
- stopAfterMSecs: mSecs
- "Terminate this sound this note after the given number of milliseconds."
-
- count := (mSecs * self samplingRate) // 1000.
- !
Item was removed:
- AbstractScoreEvent subclass: #ProgramChangeEvent
- instanceVariableNames: 'program channel'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
Item was removed:
- ----- Method: ProgramChangeEvent>>channel (in category 'accessing') -----
- channel
-
- ^ channel
- !
Item was removed:
- ----- Method: ProgramChangeEvent>>channel: (in category 'accessing') -----
- channel: midiChannel
-
- channel := midiChannel.
- !
Item was removed:
- ----- Method: ProgramChangeEvent>>isProgramChange (in category 'classification') -----
- isProgramChange
-
- ^ true
- !
Item was removed:
- ----- Method: ProgramChangeEvent>>outputOnMidiPort: (in category 'midi') -----
- outputOnMidiPort: aMidiPort
- "Output this event to the given MIDI port."
-
- aMidiPort
- midiCmd: 16rC0
- channel: channel
- byte: program.
- !
Item was removed:
- ----- Method: ProgramChangeEvent>>printOn: (in category 'printing') -----
- printOn: aStream
-
- aStream nextPut: $(.
- time printOn: aStream.
- aStream nextPutAll: ': prog '.
- program printOn: aStream.
- aStream nextPut: $).
- !
Item was removed:
- ----- Method: ProgramChangeEvent>>program (in category 'accessing') -----
- program
-
- ^ program
- !
Item was removed:
- ----- Method: ProgramChangeEvent>>program: (in category 'accessing') -----
- program: midiProgramChange
-
- program := midiProgramChange.
- !
Item was removed:
- ----- Method: ProgramChangeEvent>>program:channel: (in category 'accessing') -----
- program: midiProgramChange channel: midiChannel
-
- program := midiProgramChange.
- channel := midiChannel.
- !
Item was removed:
- ----- Method: Project>>beep (in category '*sound') -----
- beep
- (PluckedSound pitch: 261.625*4 dur: 1 loudness: 0.1) play!
Item was removed:
- AbstractSound subclass: #QueueSound
- instanceVariableNames: 'startTime sounds currentSound done'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !QueueSound commentStamp: 'nice 3/24/2010 07:38' prior: 0!
- I am a queue for sound - give me a bunch of sounds to play and I will play them one at a time in the order that they are received.
-
- Example:
- "Here is a simple example which plays two sounds three times."
- | clink warble queue |
- clink := SampledSound soundNamed: 'clink'.
- warble := SampledSound soundNamed: 'warble'.
- queue := QueueSound new.
- 3 timesRepeat:[
- queue add: clink; add: warble
- ].
- queue play.
-
- Structure:
- startTime Integer -- if present, start playing when startTime <= Time millisecondClockValue
- (schedule the sound to play later)
- sounds SharedQueue -- the synchronized list of sounds.
- currentSound AbstractSound -- the currently active sound
- done Boolean -- am I done playing ?
-
- Other:
- You may want to keep track of the queue's position so that you can feed it at an appropriate rate. To do this in an event driven way, modify or subclass nextSound to notify you when appropriate. You could also poll by checking currentSound, but this is not recommended for most applications.
-
- !
Item was removed:
- ----- Method: QueueSound>>add: (in category 'accessing') -----
- add: aSound
- self sounds nextPut: aSound.
- ^ aSound!
Item was removed:
- ----- Method: QueueSound>>currentSound (in category 'accessing') -----
- currentSound
- ^ currentSound ifNil: [currentSound := self nextSound]!
Item was removed:
- ----- Method: QueueSound>>currentSound: (in category 'accessing') -----
- currentSound: aSound
- currentSound := aSound!
Item was removed:
- ----- Method: QueueSound>>doControl (in category 'sound generation') -----
- doControl
- super doControl.
- self currentSound ifNotNil: [:curSound | curSound doControl]!
Item was removed:
- ----- Method: QueueSound>>done: (in category 'accessing') -----
- done: aBoolean
- done := aBoolean!
Item was removed:
- ----- Method: QueueSound>>initialize (in category 'initialization') -----
- initialize
- super initialize.
- sounds := SharedQueue new.
- done := false.
- startTime := Time millisecondClockValue!
Item was removed:
- ----- Method: QueueSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Play a collection of sounds in sequence."
-
- | finalIndex i remaining count rate |
- self currentSound ifNil: [^ self]. "already done"
- self startTime > Time millisecondClockValue ifTrue: [^ self].
- rate := self samplingRate.
- finalIndex := (startIndex + n) - 1.
- i := startIndex.
- [i <= finalIndex] whileTrue: [
- [
- self currentSound ifNil: [^ self].
- (remaining := self currentSound samplesRemaining) <= 0]
- whileTrue: [self currentSound: self nextSound].
- count := (finalIndex - i) + 1.
- remaining < count ifTrue: [count := remaining].
- self currentSound mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: leftVol rightVol: rightVol.
- i := i + count]!
Item was removed:
- ----- Method: QueueSound>>nextSound (in category 'sound generation') -----
- nextSound
- | answer |
- sounds isEmpty ifTrue: [^ nil].
- answer := sounds next.
- answer reset.
- ^ answer!
Item was removed:
- ----- Method: QueueSound>>reset (in category 'sound generation') -----
- reset
- super reset.
- self currentSound
- ifNil: [self currentSound: self nextSound]
- ifNotNil: [:curSound | curSound reset]!
Item was removed:
- ----- Method: QueueSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
- (done and: [self sounds isEmpty])
- ifTrue: [^ 0]
- ifFalse: [^ 1000000].
- !
Item was removed:
- ----- Method: QueueSound>>sounds (in category 'accessing') -----
- sounds
- ^ sounds!
Item was removed:
- ----- Method: QueueSound>>startTime (in category 'accessing') -----
- startTime
- ^ startTime!
Item was removed:
- ----- Method: QueueSound>>startTime: (in category 'accessing') -----
- startTime: anInteger
- startTime := anInteger!
Item was removed:
- Envelope subclass: #RandomEnvelope
- instanceVariableNames: 'rand lowLimit highLimit delta'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: RandomEnvelope class>>for: (in category 'instance creation') -----
- for: aSelector
- "Answer a random envelope for the given selector."
-
- ^ self new updateSelector: aSelector
- !
Item was removed:
- ----- Method: RandomEnvelope>>centerPitch: (in category 'accessing') -----
- centerPitch: aNumber
- "If this envelope controls pitch, set its scale to the given number. Otherwise, do nothing."
-
- updateSelector = #pitch: ifTrue: [self scale: aNumber].
- !
Item was removed:
- ----- Method: RandomEnvelope>>delta (in category 'accessing') -----
- delta
-
- ^ delta
- !
Item was removed:
- ----- Method: RandomEnvelope>>delta: (in category 'accessing') -----
- delta: aNumber
-
- delta := aNumber.
- !
Item was removed:
- ----- Method: RandomEnvelope>>duration (in category 'envelope compatibility') -----
- duration
-
- ^ 1.0
- !
Item was removed:
- ----- Method: RandomEnvelope>>duration: (in category 'envelope compatibility') -----
- duration: seconds
- "Do nothing."
- !
Item was removed:
- ----- Method: RandomEnvelope>>highLimit (in category 'accessing') -----
- highLimit
-
- ^ highLimit
- !
Item was removed:
- ----- Method: RandomEnvelope>>highLimit: (in category 'accessing') -----
- highLimit: aNumber
-
- highLimit := aNumber.
- !
Item was removed:
- ----- Method: RandomEnvelope>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- rand := Random new.
- lowLimit := 0.994.
- highLimit := 1.006.
- delta := 0.0002.
- currValue := 1.0.
- scale := 1.0.
- !
Item was removed:
- ----- Method: RandomEnvelope>>lowLimit (in category 'accessing') -----
- lowLimit
-
- ^ lowLimit
- !
Item was removed:
- ----- Method: RandomEnvelope>>lowLimit: (in category 'accessing') -----
- lowLimit: aNumber
-
- lowLimit := aNumber.
- !
Item was removed:
- ----- Method: RandomEnvelope>>name (in category 'envelope compatibility') -----
- name
-
- ^ 'random ', updateSelector
- !
Item was removed:
- ----- Method: RandomEnvelope>>points (in category 'envelopeEditor compatibility') -----
- points
-
- | env |
- points ifNil: [
- env := self target envelopes first.
- points := OrderedCollection new.
- points
- add: 0@(self delta * 5 + 0.5);
- add: (env points at: env loopStartIndex)x@(self highLimit -1 * 5 + 0.5);
- add: (env points at: env loopEndIndex)x@(self highLimit -1 * 5 + 0.5);
- add: (env points last)x@(self lowLimit -1 * 5 + 0.5).
- loopStartIndex := 2.
- loopEndIndex := 3.
- ].
- ^points!
Item was removed:
- ----- Method: RandomEnvelope>>setPoints:loopStart:loopEnd: (in category 'envelopeEditor compatibility') -----
- setPoints: pointList loopStart: startIndex loopEnd: endIndex
-
- self delta: pointList first y - 0.5 / 5.
- self highLimit: (pointList at: startIndex) y - 0.5 / 5 + 1.
- self lowLimit: pointList last y - 0.5 / 5 + 1.
- ^super setPoints: pointList loopStart: startIndex loopEnd: endIndex!
Item was removed:
- ----- Method: RandomEnvelope>>sustainEnd: (in category 'envelope compatibility') -----
- sustainEnd: seconds
- "Do nothing."
- !
Item was removed:
- ----- Method: RandomEnvelope>>updateTargetAt: (in category 'applying') -----
- updateTargetAt: mSecs
- "Send my updateSelector to the given target object with the value of this envelope at the given number of milliseconds from its onset. Answer true if the value changed."
-
- | r |
- r := rand next.
- r > 0.5
- ifTrue: [
- currValue := currValue + delta.
- currValue > highLimit ifTrue: [currValue := highLimit]]
- ifFalse: [
- currValue := currValue - delta.
- currValue < lowLimit ifTrue: [currValue := lowLimit]].
- currValue = lastValue ifTrue: [^ false].
- ((target == nil) or: [updateSelector == nil]) ifTrue: [^ false].
- target
- perform: updateSelector
- with: scale * currValue.
- lastValue := currValue.
- ^ true
- !
Item was removed:
- ----- Method: RandomEnvelope>>volume: (in category 'accessing') -----
- volume: aNumber
- "If this envelope controls volume, set its scale to the given number. Otherwise, do nothing."
-
- updateSelector = #volume: ifTrue: [self scale: aNumber].
- !
Item was removed:
- AbstractSound subclass: #RepeatingSound
- instanceVariableNames: 'sound iterationCount iteration samplesPerIteration'
- classVariableNames: 'CarMotorSamples'
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: RepeatingSound class>>carMotorSound (in category 'car motor example') -----
- carMotorSound
- "Return a repeating sound for the sound of a car engine."
- "RepeatingSound carMotorSound play"
-
- ^ self carMotorSound: 10.0!
Item was removed:
- ----- Method: RepeatingSound class>>carMotorSound: (in category 'car motor example') -----
- carMotorSound: speed
- "Return a repeating sound for the sound of a car engine running at the given speed."
- "(RepeatingSound carMotorSound: 2.0) play"
-
- CarMotorSamples ifNil: [self initializeCarMotor].
- ^ RepeatingSound repeatForever:
- ((LoopedSampledSound
- unloopedSamples: CarMotorSamples
- pitch: 20.0
- samplingRate: 22050)
- setPitch: speed dur: 100.0 loudness: 1.0)
- !
Item was removed:
- ----- Method: RepeatingSound class>>initializeCarMotor (in category 'car motor example') -----
- initializeCarMotor
- "Initialize the samples array for the sound of a car engine."
-
- CarMotorSamples := SoundBuffer fromArray: #(
- 36 199 190 508 332 167 253 302 788 884 1233 1145 977 904 991 1371 1361 1495 1253 1346 1696 1454 1631 1784 1752 1826 1389 1234 1202 1152 1188 1000 1048 898 724 937 1145 1537 2023 2079 2371 2156 2098 1855 1843 2208 2126 2218 1664 1457 1389 1454 1481 1458 1661 1400 1548 1499 1949 2055 2130 2220 2038 1904 1750 1993 2114 2272 2418 2101 1976 1791 2161 2690 2958 3013 2888 2798 2792 2875 3207 3627 3732 3842 3791 3836 3964 4082 4351 4550 4755 4746 4851 5180 5507 6100 6491 6533 6133 5394 4627 3886 3133 2209 1073 -368 -1876 -3170 -4067 -4641 -4963 -5049 -4922 -4634 -4147 -3544 -2805 -1962 -1219 -592 -326 -374 -627 -901 -1075 -1159 -1252 -1312 -1444 -1397 -1338 -1142 -748 -541 -350 -314 -265 -143 52 464 653 927 1269 1617 2048 2365 2654 2924 3306 3669 3855 3799 3160 2372 1629 1289 1635 1841 1838 1557 987 630 557 857 1005 868 435 -309 -1083 -1765 -2025 -2055 -2219 -2388 -2409 -2438 -2314 -2002 -1687 -1477 -1533 -1641 -1878 -1885 -1776 -1580 -1005 -525 -164 -84 396 768 1160 1788 2219 2365 1836 14
35 1097 988 1326 1423 2106 2191 1965 1829 1578 1835 1429 1570 1596 1301 1357 1233 1634 2386 2597 3037 3225 3406 3339 3049 2935 2611 2428 2340 2728 2621 2994 2599 2591 3010 3341 3922 3992 3824 2982 2128 1376 1455 1437 2022 1927 1730 1841 1832 2334 2942 3183 3124 3362 3342 3549 3322 3474 3686 4164 4550 4051 3701 2742 2656 3210 4011 4641 4416 3697 2998 3382 3715 3729 3687 3375 3521 3932 4273 4172 3970 3598 3675 4879 5887 6320 5794 4623 4179 4453 5626 6412 6353 5563 4689 4683 5058 5905 6270 6218 6134 5704 5297 4087 2627 1221 -181 -1351 -2616 -4341 -6598 -8702 -9888 -10087 -9286 -8357 -7568 -6878 -6063 -4839 -3540 -2281 -1176 -315 248 409 337 -353 -1326 -2135 -2392 -2324 -2288 -2486 -3272 -3618 -3573 -2804 -1503 -604 267 808 1389 2069 2643 3328 3964 4706 5502 6136 6163 5665 4956 4491 4507 4409 4042 3132 1996 998 330 -116 -475 -877 -1370 -1250 -1048 -851 -740 -1207 -1166 -1040 -395 405 441 342 -281 -763 -799 -774 -447 -319 -190 -120 115 182 91 207 387 959 1462 1811 1767 1335 972 730 979 1
157 1338 1347 807 591 232 417 696 664 1406 1512 2065 2416 2374 2539 2395 2483 2677 2674 2585 2299 1134 320 -336 -65 676 743 538 16 -374 -515 138 463 1043 1533 1786 2332 2258 2566 2663 2961 3599 3498 3518 2952 2309 2045 1667 1571 1504 1213 1118 1029 874 843 710 977 1377 1816 2236 2114 1989 1698 1618 1672 1682 1602 1382 1044 689 364 55 -24 4 322 669 948 1148 1193 1280 1463 1873 2261 2578 2654 2543 2312 1976 1772 1738 1763 1855 1834 1664 1469 1312 1399 1484 1732 1880 2004 2124 2090 2056 2000 2048 2227 2464 2670 2721 2511 2234 2056 2081 2263 2522 2737 2768 2728 2693 2711 2768 2891 3068 3182 3126 2913 2545 2171 1950 1820 1765 1710 1538 1319 1020 764 600 538 607 742 808 710 517 307 162 62 17 -8 -205 -486 -858 -1288 -1581 -1720 -1795 -1834 -1863 -1906 -1966 -1895 -1855 -1651 -1350 -1049 -721 -464 -265 -65 75 189 306 412 472 458 374 222 113 101 178 309 481 568 576 516 497 582 724 844 964 914 774 662 509 472 576 610 572 554 517 605 785 1008 1312 1555 1786 1957 2044 2081 2118 2193 2264 2328 2
335 2277 2205 2098 2002 1981 1982 2017 1972 1912 1788 1611 1519 1428 1393 1367 1209 1045 842 624 564 509 465 398 172 11 -157 -264 -259 -269 -248 -249 -222 -266 -355 -372 -288 -158 -55 1 71 91 102 228 420 619 798 829 930 1012 1047 1210 1359 1531 1676 1702 1787 1809 1729 1668 1653 1721 1808 1793 1747 1616 1485 1476 1516 1751 1961 2029 2057 2006 1955 1893 1904 1960 1967 1975 1934 1827 1814 1749 1809 1947 2037 2098 2067 1970 1754 1627 1667 1759 1904 1890 1819 1747 1644 1698 1746 1834 1959 1922 1887 1864 1712 1734 1770 1895 2029 2062 2153 2132 2203 2206 2202 2194 2075 2019 1889 1923 1930 2090 2250 2335 2372 2209 2085 1902 1805 1826 1843 1804 1761 1605 1580 1680 1713 1825 1904 2097 2269 2373 2384 2235 2351 2445 2530 2610 2560 2618 2511 2445 2374 2111 1959 1760 1602 1474 1208 1021 786 688 654 573 526 409 452 566 694 746 831 914 1008 1043 821 513 214 -45 -242 -453 -723 -898 -1103 -1078 -1081 -1087 -1015 -1073 -869 -884 -720 -555 -329 -24 -63 14 -96 5 260 412 636 623 611 785 788 1001 1025 98
9 1162 1215 1404 1408 1305 1311 1120 1076 956 785 740 371 389 164 202 522 478 770 483 259 250 79 497 987 1288 1453 1283 1350 1436 1441 1804 1861 2059 2156 1969 2142 2148 2384 2652 2470 2383 1883 1739 1618 1475 1523 1134 1167 1031 816 674 274 251 162 301 387 23 -176 -345 -333 -198 -356 -363 -444 -421 -192 -226 -230 -239 -326 10 106 195 132 95 202 79 -68 -222 -45 429 788 954 1256 1426 1521 1704 1729 2053 1867 1581 1434 1367 1554 1386 1221 1165 1253 1571 1394 1425 1390 948 1288 999 1421 1568 1292 1478 1019 1053 591 693 520 302 314 116 847 1340 1792 1883 1582 1474 1821 2140 2486 2651 2167 1728 1380 1345 1811 1993 2052 2325 2231 2148 2271 2450 2831 2866 2908 2721 2623 2252 2025 2393 2667 3015 2817 2668 2588 2540 2736 2761 3275 3232 3252 3168 3112 3284 3138 3458 3716 3876 3928 3824 3928 4040 4330 4923 5226 5205 5183 5172 5510 5926 6225 6306 6020 5433 4448 3261 2118 959 -239 -1741 -3208 -4507 -5623 -6134 -6133 -5617 -4931 -4192 -3378 -2817 -2219 -1588 -817 -110 199 281 -5 -417 -652 -749 -6
79 -890 -1261 -1549 -1905 -1928 -2002 -1885 -1552 -1185 -655 -235 222 793 1424 1992 2599 2940 3081 2982 2695 2667 2771 2919 2980 2662 2146 1537 1215 1217 1374 1337 1061 790 376 250 -97 -111 5 -149 -243 -733 -936 -1395 -1810 -1781 -1762 -1500 -1716 -2039 -2318 -2398 -1907 -1592 -1422 -1900 -2619 -3034 -3024 -2335 -1429 -557 323 1051 1587 2021 2282 2438 2207 1843 1789 1482 1392 1056 742 1220 1294 1464 1641 1731 1847 1291 1682 1970 2097 2253 1624 1474 1312 1312 1873 2315 2523 2486 2323 2385 2924 3638 4341 4431 4045 3644 2945 2939 2935 2867 3411 2886 2731 2211 1405 1001 640 1077 1430 1688 1803 1857 2036 2447 3394 3628 3702 3468 3361 3782 3668 3672 4050 3895 4188 4564 4217 3965 2693 1946 1878 2245 3152 3267 3120 2670 2675 3308 4567 5358 5556 5114 3953 3653 3658 4111 4688 4262 3819 3732 4224 4771 5579 5622 5585 5613 5501 5593 5452 5570 5632 6094 5985 5579 4982 4206 3878 3683 3274 2172 698 -1224 -2821 -3890 -4742 -5518 -6463 -7297 -7730 -8054 -7991 -7508 -6683 -5163 -3562 -2162 -1401 -1000
-650 -255 344 643 475 -347 -1530 -2545 -3189 -3506 -3525 -3563 -3239 -2710 -1975 -1174 -649 117 1250 2603 3929 4750 4920 4876 4692 4897 5263 5455 5008 4285 3535 2650 2480 2198 1908 1831 1412 1060 602 80 -281 -245 -37 518 694 559 449 134 264 395 501 454 294 14 -188 -258 -603 -471 -526 -212 202 413 643 447 674 1151 2015 2779 2830 2783 2349 2213 2223 1805 1467 750 640 762 709 685 202 48 360 1103 1707 1935 1604 992 986 883 1293 1285 840 880 25 72 -201 -568 -194 -266 416 698 748 1106 930 1391 2268 2672 3350 3207 3010 3183 2888 3077 3048 2737 2684 2102 1594 1047 146 -39 -397 -420 -237 -520 -465 -526 -247 398 929 1605 2176 2568 2979 3102 3165 3206 3205 3315 3167 2841 2330 1660 1172 909 881 992 1021 1063 1098 1184 1407 1681 1927 2245 2498 2652 2755 2740 2720 2600 2599 2547 2529 2425 2327 2216 1983 1798 1578 1501 1596 1707 1778 1775 1794 1832 1945 2157 2368 2534 2679 2726 2647 2546 2482 2500 2613 2715 2858 2909 2875 2798 2847 3002 3238 3544 3763 3906 3870 3762 3684 3570 3510 3375 3115 2665
2099 1534 1114 848 744 650 462 329 147 161 282 430 614 681 701 635 505 263 -31 -284 -523 -787 -1040 -1310 -1530 -1694 -1726 -1660 -1541 -1319 -1101 -872 -661 -468 -289 -53 235 439 581 607 542 488 496 442 476 539 528 480 404 353 383 409 514 643 801 911 1039 1099 1060 1002 1008 1079 1079 1088 1043 998 953 947 1077 1232 1417 1630 1737 1807 1861 1947 2139 2352 2521 2494 2388 2251 2163 2142 2183 2246 2312 2333 2215 2167 2080 1954 1856 1767 1725 1685 1560 1366 1157 915 754 677 570 434 268 50 -48 -106 -80 23 -6 3 -105 -143 -106 -86 -10 15 72 129 151 224 269 377 540 615 755 802 841 986 1126 1263 1430 1501 1565 1592 1629 1704 1769 1780 1815 1868 1875 1853 1767 1657 1676 1777 1954 2063 2033 2006 1997 2052 2132 2218 2192 2163 2068 1935 1832 1731 1692 1644 1603 1587 1656 1704 1735 1707 1693 1778 1855 1886 1808 1854 1866 2020 2082 2051 2063 1922 1994 2055 1979 1867 1654 1725 1958 2103 2250 2210 2181 2136 1990 1769 1538 1555 1690 1847 1927 1833 1861 1845 1916 1901 1878 1827 1965 2079 2011 1813 14
42 1294 1314 1438 1527 1471 1351 1346 1433 1541 1742 1882 2055 2187 2137 2094 2026 2216 2547 2788 2910 2700 2476 2276 2271 2219 2140 2106 1948 1839 1563 1271 991 871 785 695 490 237 93 101 302 452 541 637 735 773 731 667 554 479 381 262 -30 -313 -571 -871 -940 -1094 -1156 -946 -946 -789 -822 -1016 -846 -729 -380 -130 -174 -291 -393 -459 -370 -385 -488 -235 -189 -29 66 20 251 506 931 1376 1399 1348 1192 940 1022 839 916 1173 1247 1303 1207 950 888 944 1151 1385 1216 1012 762 741 964 995 1072 1129 1201 1243 1189 1214 1209 1090 1188 1226 962 840 480 309 201 8 -27 -108 19 120 122 175 188 247 298 326 490 659 638 530 299 294 391 561 749 632 677 592 520 445 175 452 195 476 279 54 216 -444 -153 -497 -42 65 -76 89 -307 613 424 736 729 692 1203 923 1051 761 782 993 912 1361 971 671 640 713 1230 870 821 292 243 774 1172 1686 1286 1348 1303 1523 1622 1578 1833 1810 1913 1658 1535 1352 1375 1673 2156 2537 2408 2275 2078 2090 2117 2030 2120 2227 2296 2388 2667 2966 3152 3134 2987 2799 2665 2686 2
666 2584 2637 2572 2631 2836 3106 3325 3066 2882 2869 3046 3325 3369 3339 3398 3350 3293 3457 3587 3759 3999 4191 4413 4437 4477 4519 4628 4905 5061 5239 5014 4922 5179 5616 6008 6053 5515 4650 3634 2615 2101 1403 430 -981 -2592 -4097 -5331 -6002 -6365 -6339 -5996 -5552 -4825 -4058 -3378 -2538 -1678 -858 -70 377 250 -342 -1019 -1354 -1355 -1196 -1361 -1521 -1624 -1862 -1561 -1109 -638 -510 -705 -845 -1026 -585 -35 768 1668 2308 2850 3002 3103 3216 3453 3876 4335 4501 4065 3249 2233 1669 1518 1717 1688 1115 370 -493 -662 -599 -225 85 -153 -466 -954 -1270 -1132 -935 -978 -1481 -2039 -2683 -3353 -3678 -3673 -3362 -2780 -2386 -2281 -2137 -2034 -1498 -801 -239 351 480 608 886 1176 1592 1788 2106 2205 2010 1893 1582 1539 1597 1795 1990 2158 2092 1255 800 1029 1404 1884 2085 1537 1103 919 870 2111 3220 3367 3480 2671 2319 2914 3620 4073 3498 2841 2067 1810 2225 2669 3168 2603 1347 499 729 1563 2063 1953 1175 432 458 1393 2521 3149 3279 2822 2467 2697 3005 3756 4386 4418 4555 3662 3241 3320
3520 3914 4087 3923 2896 2532 1732 1807 2221 2972 3933 3101 2464 1657 1615 2639 3948 4718 5026 4305 3909 3815 3811 4014 3853 4090 4153 4670 4783 4527 4113 4296 4866 5695 6258 6024 5748 5089 5020 5101 4974 4353 3499 2056 779 -738 -2628 -4028 -5515 -6213 -6815 -7376 -7953 -8558 -8565 -7680 -6158 -4573 -3152 -2390 -1579 -792 -128 414 470 360 165 -390 -1164 -2225 -3460 -4085 -4255 -3862 -3277 -2975 -2731 -2390 -1656 -387 1008 2146 3014 3428 3832 4526 4822 4875 4472 3941 3954 3945 3710 2856 1848 931 619 1054 1206 877 318 -270 -412 34 160 399 532 402 655 568 472 246 -92 356 716 776 540 -331 -730 -548 -242 338 202 -72 4 -6 637 885 1005 1330 1619 2174 2350 2069 1709 1412 1476 1747 1558 1230 711 321 398 293 313 92 81 454 659 806 581 346 351 585 870 851 436 -76 -479 -756 -907 -1190 -1414 -1586 -1628 -1483 -1389 -1238 -816 -177 556 1249 1735 2074 2385 2710 3065 3264 3285 3143 2928 2692 2297 1832 1387 1022 955 1088 1101 1028 872 870 1090 1475 1976 2316 2578 2716 2705 2557 2467 2367 2328 2364 2
301 2073 1686 1366 1175 1116 1199 1196 1109 962 920 934 983 1051 1258 1536 1752 1836 1770 1680 1643 1800 1954 2082 2111 1986 1885 1813 1824 1898 2088 2236 2353 2399 2340 2255 2213 2244 2350 2365 2326 2266 2154 2072 2068 2093 2130 2223 2295 2394 2515 2449 2426 2527 2778 3021 3240 3286 3216 3108 3004 3042 3106 3147 2990 2690 2282 1902 1641 1457 1359 1172 825 473 189 106 166 377 569 634 551 403 364 415 437 366 107 -242 -524 -723 -824 -959 -1100 -1264 -1381 -1408 -1252 -1072 -932 -889 -819 -581 -341 -107 56 128 156 158 185 260 284 270 324 376 391 423 449 446 429 521 569 566 584 546 589 624 594 594 584 607 725 876 976 1004 1046 1082 1193 1341 1372 1434 1446 1409 1528 1618 1747 1911 1985 2090 2092 2110 2170 2230 2360 2411 2433 2402 2317 2280 2227 2126 2017 1878 1729 1564 1406 1237 1073 957 906 841 788 706 548 437 429 449 554 653 664 582 500 486 511 519 430 339 318 294 287 265 288 299 429 605 681 822 808 887 950 1042 1240 1348 1547 1638 1752 1787 1765 1864 1949 2025 2058 1990 1921 1818 170
7 1755 1810 2007 2069 2017 1840 1623 1633 1646 1803 1962 2002 1985 1838 1694 1588 1493 1551 1685 1756 1784 1604 1458 1532 1660 1898 1986 1737 1551 1457 1665 1890 2078 2066 2082 2181 2156 2167 2174 2290 2341 2314 2302 2134 2114 2054 2020 2109 1974 1916 1841 1628 1718 1718 1860 1951 1774 1893 1745 1701 1769 1541 1733 1542 1509 1547 1370 1640 1572 1480 1679 1501 1747 1697 1748 1973 1763 1949 1795 2000 2185 2249 2600 2532 2713 2672 2558 2572 2506 2691 2760 2797 2680 2299 1992 1796 1558 1444 1055 663 489 6 -197 -508 -713 -632 -763 -579 -532 -472 -253 -174 -66 75 -39 72 208 312 339 87 16 -170 -198 -166 -227 -270 -498 -495 -406 -544 -569 -766 -656 -500 -344 -121 -161 -67 -60 97 96 47 31 -76 163 173 417 465 257 332 5 48 -14 -135 124 -51 17 -190 -361 -127 -23 352 410 491 632 489 608 746 1100 1463 1473 1668 1380 1289 1319 1575 1979 1935 1824 1385 1265 1351 1528 1675 1429 1018 548 133 -254 -466 -736 -796 -815 -994 -916 -948 -584 -366 -196 -132 -119 -108 -165 12 -235 -107 -353 -349 -579 -765 -9
53 -1235 -888 -764 -286 -769 -804 -787 -508 255 127 169 -177 -373 -111).
- !
Item was removed:
- ----- Method: RepeatingSound class>>repeat:count: (in category 'instance creation') -----
- repeat: aSound count: anInteger
- "Return a RepeatingSound that will repeat the given sound for the given number of iterations."
-
- ^ self new setSound: aSound iterations: anInteger
- !
Item was removed:
- ----- Method: RepeatingSound class>>repeatForever: (in category 'instance creation') -----
- repeatForever: aSound
- "Return a RepeatingSound that will repeat the given sound forever."
-
- ^ self new setSound: aSound iterations: #forever
- !
Item was removed:
- ----- Method: RepeatingSound>>copySound (in category 'copying') -----
- copySound
- "Private!! Support for copying. Copy my component sound."
-
- sound := sound copy.
- !
Item was removed:
- ----- Method: RepeatingSound>>doControl (in category 'sound generation') -----
- doControl
-
- super doControl.
- sound doControl.
- !
Item was removed:
- ----- Method: RepeatingSound>>iterationCount (in category 'accessing') -----
- iterationCount
-
- ^ iterationCount
- !
Item was removed:
- ----- Method: RepeatingSound>>iterationCount: (in category 'accessing') -----
- iterationCount: aNumber
-
- iterationCount := aNumber.
- !
Item was removed:
- ----- Method: RepeatingSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Play a collection of sounds in sequence."
- "(RepeatingSound new
- setSound: FMSound majorScale
- iterations: 2) play"
-
- | i count samplesNeeded |
- iteration <= 0 ifTrue: [^ self].
- i := startIndex.
- samplesNeeded := n.
- [samplesNeeded > 0] whileTrue: [
- count := sound samplesRemaining min: samplesNeeded.
- count = 0 ifTrue: [
- iterationCount == #forever
- ifFalse: [
- iteration := iteration - 1.
- iteration <= 0 ifTrue: [^ self]]. "done"
- sound reset.
- count := sound samplesRemaining min: samplesNeeded.
- count = 0 ifTrue: [^ self]]. "zero length sound"
- sound mixSampleCount: count
- into: aSoundBuffer
- startingAt: i
- leftVol: leftVol * scaledVol // ScaleFactor
- rightVol: rightVol * scaledVol // ScaleFactor.
- i := i + count.
- samplesNeeded := samplesNeeded - count].
- !
Item was removed:
- ----- Method: RepeatingSound>>postCopy (in category 'copying') -----
- postCopy
- "Copy my component sound."
-
- super postCopy.
- self copySound
- !
Item was removed:
- ----- Method: RepeatingSound>>reset (in category 'sound generation') -----
- reset
-
- super reset.
- sound reset.
- samplesPerIteration := sound samplesRemaining.
- iterationCount == #forever
- ifTrue: [iteration := 1]
- ifFalse: [iteration := iterationCount].
- !
Item was removed:
- ----- Method: RepeatingSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
-
- iterationCount == #forever ifTrue: [^ 1000000].
- iteration > 0
- ifTrue: [^ sound samplesRemaining + ((iteration - 1) * samplesPerIteration)]
- ifFalse: [^ 0].
- !
Item was removed:
- ----- Method: RepeatingSound>>setPitch:dur:loudness: (in category 'initialization') -----
- setPitch: p dur: d loudness: l
-
- self error: 'RepeatingSounds do not support playing notes'.
- !
Item was removed:
- ----- Method: RepeatingSound>>setSound:iterations: (in category 'initialization') -----
- setSound: aSound iterations: anIntegerOrSymbol
- "Initialize the receiver to play the given sound the given number of times. If iteration count is the symbol #forever, then repeat indefinitely."
- "(RepeatingSound repeat: AbstractSound scaleTest count: 2) play"
- "(RepeatingSound repeatForever: PluckedSound lowMajorScale) play"
-
- super initialize.
- sound := aSound.
- iterationCount := anIntegerOrSymbol.
- self reset.
- !
Item was removed:
- ----- Method: RepeatingSound>>sound (in category 'accessing') -----
- sound
-
- ^ sound
- !
Item was removed:
- ----- Method: RepeatingSound>>sound: (in category 'accessing') -----
- sound: aSound
-
- sound := aSound.
- !
Item was removed:
- AbstractSound subclass: #RestSound
- instanceVariableNames: 'initialCount count'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: RestSound class>>dur: (in category 'instance creation') -----
- dur: d
- "Return a rest of the given duration."
-
- ^ self new setDur: d
- !
Item was removed:
- ----- Method: RestSound class>>pitch:dur:loudness: (in category 'instance creation') -----
- pitch: p dur: d loudness: l
- "Return a rest of the given duration."
- "Note: This message allows one to silence one or more voices of a multi-voice piece by using RestSound as their instrument."
-
- ^ self new setDur: d
- !
Item was removed:
- ----- Method: RestSound>>duration (in category 'accessing') -----
- duration
- "Answer the duration of this sound in seconds."
-
- ^ initialCount asFloat / self samplingRate
- !
Item was removed:
- ----- Method: RestSound>>duration: (in category 'accessing') -----
- duration: seconds
-
- super duration: seconds.
- count := initialCount := (seconds * self samplingRate) rounded.
- !
Item was removed:
- ----- Method: RestSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Play silence for a given duration."
- "(RestSound dur: 1.0) play"
-
- count := count - n.
- !
Item was removed:
- ----- Method: RestSound>>reset (in category 'sound generation') -----
- reset
-
- super reset.
- count := initialCount.
- !
Item was removed:
- ----- Method: RestSound>>samples (in category 'accessing') -----
- samples
- ^ SoundBuffer newMonoSampleCount: initialCount!
Item was removed:
- ----- Method: RestSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
-
- ^ count
- !
Item was removed:
- ----- Method: RestSound>>setDur: (in category 'initialization') -----
- setDur: d
- "Set rest duration in seconds."
-
- initialCount := (d * self samplingRate asFloat) rounded.
- count := initialCount.
- self reset.
- !
Item was removed:
- AbstractSound subclass: #ReverbSound
- instanceVariableNames: 'sound tapDelays tapGains tapCount bufferSize bufferIndex leftBuffer rightBuffer'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: ReverbSound>>applyReverbTo:startingAt:count: (in category 'private') -----
- applyReverbTo: aSoundBuffer startingAt: startIndex count: n
-
- | delayedLeft delayedRight i tapGain j out |
- <primitive: 'primitiveApplyReverb' module:'SoundGenerationPlugin'>
- <var: #aSoundBuffer declareC: 'short int *aSoundBuffer'>
- <var: #tapDelays declareC: 'int *tapDelays'>
- <var: #tapGains declareC: 'int *tapGains'>
- <var: #leftBuffer declareC: 'short int *leftBuffer'>
- <var: #rightBuffer declareC: 'short int *rightBuffer'>
-
- startIndex to: ((startIndex + n) - 1) do: [:sliceIndex |
- delayedLeft := delayedRight := 0.
- 1 to: tapCount do: [:tapIndex |
- i := bufferIndex - (tapDelays at: tapIndex).
- i < 1 ifTrue: [i := i + bufferSize]. "wrap"
- tapGain := tapGains at: tapIndex.
- delayedLeft := delayedLeft + (tapGain * (leftBuffer at: i)).
- delayedRight := delayedRight + (tapGain * (rightBuffer at: i))].
-
- "left channel"
- j := (2 * sliceIndex) - 1.
- out := (aSoundBuffer at: j) + (delayedLeft // ScaleFactor).
- out > 32767 ifTrue: [out := 32767]. "clipping!!"
- out < -32767 ifTrue: [out := -32767]. "clipping!!"
- aSoundBuffer at: j put: out.
- leftBuffer at: bufferIndex put: out.
-
- "right channel"
- j := j + 1.
- out := (aSoundBuffer at: j) + (delayedRight // ScaleFactor).
- out > 32767 ifTrue: [out := 32767]. "clipping!!"
- out < -32767 ifTrue: [out := -32767]. "clipping!!"
- aSoundBuffer at: j put: out.
- rightBuffer at: bufferIndex put: out.
-
- bufferIndex := (bufferIndex \\ bufferSize) + 1].
- !
Item was removed:
- ----- Method: ReverbSound>>copySound (in category 'copying') -----
- copySound
- "Private!! Support for copying. Copy my component sound."
-
- sound := sound copy.
- leftBuffer := leftBuffer shallowCopy.
- rightBuffer := rightBuffer shallowCopy.
- !
Item was removed:
- ----- Method: ReverbSound>>doControl (in category 'sound generation') -----
- doControl
-
- super doControl.
- sound doControl.
- !
Item was removed:
- ----- Method: ReverbSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Play my sound with reverberation."
-
- sound mixSampleCount: n
- into: aSoundBuffer
- startingAt: startIndex
- leftVol: leftVol
- rightVol: rightVol.
- self applyReverbTo: aSoundBuffer startingAt: startIndex count: n.
- !
Item was removed:
- ----- Method: ReverbSound>>postCopy (in category 'copying') -----
- postCopy
- "Copy my component sound."
-
- super postCopy.
- self copySound
- !
Item was removed:
- ----- Method: ReverbSound>>reset (in category 'sound generation') -----
- reset
-
- super reset.
- sound reset.
- 1 to: bufferSize do: [:i |
- leftBuffer at: i put: 0.
- rightBuffer at: i put: 0].
- !
Item was removed:
- ----- Method: ReverbSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
-
- ^ sound samplesRemaining
- !
Item was removed:
- ----- Method: ReverbSound>>sound (in category 'accessing') -----
- sound
-
- ^ sound
- !
Item was removed:
- ----- Method: ReverbSound>>sound: (in category 'accessing') -----
- sound: aSound
-
- sound := aSound.
- !
Item was removed:
- ----- Method: ReverbSound>>tapDelays:gains: (in category 'accessing') -----
- tapDelays: delayList gains: gainList
- "ReverbSound new tapDelays: #(537 691 1191) gains: #(0.07 0.07 0.07)"
-
- | maxDelay gain d |
- delayList size = gainList size
- ifFalse: [self error: 'tap delay and gains lists must be the same size'].
- tapCount := delayList size.
- tapDelays := Bitmap new: tapCount.
- tapGains := Bitmap new: tapCount.
-
- maxDelay := 0.
- 1 to: tapGains size do: [:i |
- tapDelays at: i put: (delayList at: i) asInteger.
- gain := gainList at: i.
- gain >= 1.0 ifTrue: [self error: 'reverb tap gains must be under 1.0'].
- tapGains at: i put: (gain * ScaleFactor) asInteger.
- d := tapDelays at: i.
- d > maxDelay ifTrue: [maxDelay := d]].
- bufferSize := maxDelay.
- leftBuffer := SoundBuffer newMonoSampleCount: maxDelay.
- rightBuffer := SoundBuffer newMonoSampleCount: maxDelay.
- bufferIndex := 1.
- !
Item was removed:
- Object subclass: #SampledInstrument
- instanceVariableNames: 'sustainedSoft sustainedLoud staccatoSoft staccatoLoud sustainedThreshold loudThreshold'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !SampledInstrument commentStamp: '<historical>' prior: 0!
- I represent a collection of individual notes at different pitches, volumes, and articulations. On request, I can select the best note to use for a given pitch, duration, and volume. I currently only support two volumes, loud and soft, and two articulations, normal and staccato, but I can easily be extended to include more. The main barrier to keeping more variations is simply the memory space (assuming my component notes are sampled sounds).
- !
Item was removed:
- ----- Method: SampledInstrument class>>buildSmallOrchestra (in category 'instance creation') -----
- buildSmallOrchestra
- "Example of how to build a skeleton orchestra that uses less memory (about 14 MBytes)."
- "SampledInstrument buildSmallOrchestra"
-
- | dir |
- AbstractSound unloadSampledTimbres.
- dir := 'Tosh:Not Backed Up:Sample Library:Orchestra'.
- #(clarinet oboe bassoon trombone tympani) do: [:instName |
- SampledInstrument
- readSimpleInstrument: instName
- fromDirectory: dir.
- (AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 1].
- #(flute bass) do: [:instName |
- SampledInstrument
- readSimpleInstrument: instName
- fromDirectory: dir.
- (AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 2].
-
- (AbstractSound soundNamed: 'bass-f') allNotes do: [:n |
- n firstSample: (n findStartPointForThreshold: 2500)].
-
- (AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n |
- n beUnlooped.
- n firstSample: (n findStartPointForThreshold: 0)].
-
- (AbstractSound soundNamed: 'trombone-f') allNotes do: [:n |
- n firstSample: (n findStartPointForThreshold: 1800)].
-
- AbstractSound soundNamed: 'trumpet-f' put: (AbstractSound soundNamed: 'trombone-f').
- AbstractSound soundNamed: 'horn-f' put: (AbstractSound soundNamed: 'trombone-f').
- AbstractSound soundNamed: 'violin-f' put: (AbstractSound soundNamed: 'bass-f').
- AbstractSound soundNamed: 'viola-f' put: (AbstractSound soundNamed: 'bass-f').
- AbstractSound soundNamed: 'cello-f' put: (AbstractSound soundNamed: 'bass-f').
-
- (AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n | n beUnlooped].
-
- !
Item was removed:
- ----- Method: SampledInstrument class>>readLoudAndStaccatoInstrument:fromDirectory: (in category 'instance creation') -----
- readLoudAndStaccatoInstrument: instName fromDirectory: orchestraDir
- "SampledInstrument
- readLoudAndStaccatoInstrument: 'oboe'
- fromDirectory: 'Tosh/Sample Library/Orchestra'"
- | sampleSetDir memBefore memAfter loud short snd |
- sampleSetDir := orchestraDir , FileDirectory slash , instName.
- memBefore := Smalltalk garbageCollect.
- loud := SampledInstrument new readSampleSetFrom: sampleSetDir, ' f'.
- short := SampledInstrument new readSampleSetFrom: sampleSetDir, ' stacc'.
- memAfter := Smalltalk garbageCollect.
- Transcript show:
- instName, ': ', (memBefore - memAfter) printString,
- ' bytes; ', memAfter printString, ' bytes left'; cr.
- AbstractSound soundNamed: instName, '-f&stacc' put:
- (snd := SampledInstrument new
- allSampleSets: loud;
- staccatoLoudAndSoftSampleSet: short).
- "fix slow attacks"
- snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 500)].
-
- AbstractSound soundNamed: instName, '-f' put:
- (snd := SampledInstrument new
- allSampleSets: loud).
- "fix slow attacks"
- snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1000)].!
Item was removed:
- ----- Method: SampledInstrument class>>readPizzInstrument:fromDirectory: (in category 'instance creation') -----
- readPizzInstrument: instName fromDirectory: orchestraDir
- "SampledInstrument
- readPizzInstrument: 'violin'
- fromDirectory: 'Tosh/Sample Library/Orchestra'"
- | sampleSetDir memBefore memAfter sampleSet snd |
- sampleSetDir := orchestraDir , FileDirectory slash , instName , ' pizz'.
- memBefore := Smalltalk garbageCollect.
- sampleSet := SampledInstrument new readSampleSetFrom: sampleSetDir.
- memAfter := Smalltalk garbageCollect.
- Transcript show:
- instName, ': ', (memBefore - memAfter) printString,
- ' bytes; ', memAfter printString, ' bytes left'; cr.
- AbstractSound soundNamed: instName, '-pizz' put:
- (snd := SampledInstrument new allSampleSets: sampleSet).
-
- "fix slow attacks"
- snd allNotes do: [:n |
- n firstSample: (n findStartPointForThreshold: 1000)].
-
- ^ snd!
Item was removed:
- ----- Method: SampledInstrument class>>readSimpleInstrument:fromDirectory: (in category 'instance creation') -----
- readSimpleInstrument: instName fromDirectory: orchestraDir
- "SampledInstrument
- readSimpleInstrument: 'oboe'
- fromDirectory: 'Tosh:Sample Library:Orchestra'"
-
- | sampleSetDir memBefore memAfter sampleSet snd |
- sampleSetDir := orchestraDir, FileDirectory slash, instName, ' f'.
- memBefore := Smalltalk garbageCollect.
- sampleSet := SampledInstrument new readSampleSetFrom: sampleSetDir.
- memAfter := Smalltalk garbageCollect.
- Transcript show:
- instName, ': ', (memBefore - memAfter) printString,
- ' bytes; ', memAfter printString, ' bytes left'; cr.
- AbstractSound soundNamed: instName, '-f' put:
- (snd := SampledInstrument new allSampleSets: sampleSet).
-
- "fix slow attacks"
- snd allNotes do: [:n |
- n firstSample: (n findStartPointForThreshold: 1000)].
-
- ^ snd
- !
Item was removed:
- ----- Method: SampledInstrument>>allNotes (in category 'other') -----
- allNotes
- "Answer a collection containing of all the unique sampled sounds used by this instrument."
-
- | r |
- r := IdentitySet new.
- r addAll: sustainedLoud.
- sustainedSoft ~~ sustainedLoud ifTrue: [r addAll: sustainedSoft].
- staccatoLoud ~~ sustainedLoud ifTrue: [r addAll: staccatoLoud].
- staccatoSoft ~~ staccatoLoud ifTrue: [r addAll: staccatoSoft].
- ^ r asArray sort: [:n1 :n2 | n1 pitch < n2 pitch]
- !
Item was removed:
- ----- Method: SampledInstrument>>allSampleSets: (in category 'accessing') -----
- allSampleSets: sortedNotes
-
- | keyMap |
- keyMap := self midiKeyMapFor: sortedNotes.
- sustainedSoft := keyMap.
- sustainedLoud := keyMap.
- staccatoSoft := keyMap.
- staccatoLoud := keyMap.
- !
Item was removed:
- ----- Method: SampledInstrument>>chooseSamplesForPitch:from: (in category 'other') -----
- chooseSamplesForPitch: pitchInHz from: sortedNotes
- "From the given collection of LoopedSampledSounds, choose the best one to be pitch-shifted to produce the given pitch."
- "Assume: the given collection is sorted in ascending pitch order."
-
- | i lower higher |
- i := 1.
- [(i < sortedNotes size) and: [(sortedNotes at: i) pitch < pitchInHz]]
- whileTrue: [i := i + 1].
- i = 1 ifTrue: [^ sortedNotes at: 1].
- lower := sortedNotes at: i - 1.
- higher := sortedNotes at: i.
- "note: give slight preference for down-shifting a higher-pitched sample set"
- (pitchInHz / lower pitch) < ((0.95 * higher pitch) / pitchInHz)
- ifTrue: [^ lower]
- ifFalse: [^ higher].
- !
Item was removed:
- ----- Method: SampledInstrument>>initialize (in category 'accessing') -----
- initialize
-
- super initialize.
- sustainedThreshold := 0.15.
- loudThreshold := 0.5.
- !
Item was removed:
- ----- Method: SampledInstrument>>loudThreshold (in category 'accessing') -----
- loudThreshold
-
- ^ loudThreshold
- !
Item was removed:
- ----- Method: SampledInstrument>>loudThreshold: (in category 'accessing') -----
- loudThreshold: aNumber
-
- loudThreshold := aNumber asFloat.
- !
Item was removed:
- ----- Method: SampledInstrument>>memorySpace (in category 'other') -----
- memorySpace
- "Answer the number of bytes required to store the samples for this instrument."
-
- | total |
- total := 0.
- self allNotes do: [:n |
- total := total + (n leftSamples monoSampleCount * 2).
- n isStereo ifTrue: [total := total + (n leftSamples monoSampleCount * 2)]].
- ^ total
- !
Item was removed:
- ----- Method: SampledInstrument>>midiKeyMapFor: (in category 'other') -----
- midiKeyMapFor: sortedNotes
- "Return a 128 element array that maps each MIDI key number to the sampled note from the given set with the closests pitch. A precise match isn't necessary because the selected note will be pitch shifted to play at the correct pitch."
-
- ^ (0 to: 127) collect: [:k |
- self
- chooseSamplesForPitch: (AbstractSound pitchForMIDIKey: k)
- from: sortedNotes].
- !
Item was removed:
- ----- Method: SampledInstrument>>playChromaticRunFrom:to: (in category 'other') -----
- playChromaticRunFrom: startPitch to: endPitch
-
- (AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play.
- !
Item was removed:
- ----- Method: SampledInstrument>>pruneNoteList:notesPerOctave: (in category 'other') -----
- pruneNoteList: aNoteList notesPerOctave: notesPerOctave
- "Return a pruned version of the given note list with only the given number of notes per octave. Assume the given notelist is in sorted order."
-
- | r interval lastPitch |
- r := OrderedCollection new: aNoteList size.
- interval := (2.0 raisedTo: (1.0 / notesPerOctave)) * 0.995.
- lastPitch := 0.0.
- aNoteList do: [:n |
- n pitch > (lastPitch * interval) ifTrue: [
- r addLast: n.
- lastPitch := n pitch]].
- ^ r
- !
Item was removed:
- ----- Method: SampledInstrument>>pruneToNotesPerOctave: (in category 'other') -----
- pruneToNotesPerOctave: notesPerOctave
- "Prune all my keymaps to the given number of notes per octave."
-
- sustainedLoud := self midiKeyMapFor:
- (self pruneNoteList: sustainedLoud notesPerOctave: notesPerOctave).
- sustainedSoft := self midiKeyMapFor:
- (self pruneNoteList: sustainedSoft notesPerOctave: notesPerOctave).
- staccatoLoud := self midiKeyMapFor:
- (self pruneNoteList: staccatoLoud notesPerOctave: notesPerOctave).
- staccatoSoft := self midiKeyMapFor:
- (self pruneNoteList: staccatoSoft notesPerOctave: notesPerOctave).
- !
Item was removed:
- ----- Method: SampledInstrument>>pruneToSingleNote: (in category 'other') -----
- pruneToSingleNote: aNote
- "Fill all my keymaps with the given note."
-
- | oneNoteMap |
- oneNoteMap := Array new: 128 withAll: aNote.
- sustainedLoud := oneNoteMap.
- sustainedSoft := oneNoteMap.
- staccatoLoud := oneNoteMap.
- staccatoSoft := oneNoteMap.
- !
Item was removed:
- ----- Method: SampledInstrument>>readSampleSetFrom: (in category 'other') -----
- readSampleSetFrom: dirName
- "Answer a collection of sounds read from AIFF files in the given directory and sorted in ascending pitch order."
-
- | all dir |
- all := OrderedCollection new.
- dir := FileDirectory default on: dirName.
- dir fileNames do: [:n | | fullName snd |
- fullName := dir fullNameFor: n.
- UIManager default
- informUser: 'Reading AIFF file ', n
- during:
- [snd := LoopedSampledSound new
- fromAIFFFileNamed: fullName
- mergeIfStereo: true].
- all add: snd].
- ^ all asArray sort: [:s1 :s2 | s1 pitch < s2 pitch]
- !
Item was removed:
- ----- Method: SampledInstrument>>readSampleSetInfoFrom: (in category 'other') -----
- readSampleSetInfoFrom: dirName
- "MessageTally spyOn: [SampledInstrument new readSampleSetFrom: 'Tosh:Desktop Folder:AAA Squeak2.0 Beta:Organ Samples:Flute8'] timeToRun"
-
- | all dir |
- all := OrderedCollection new.
- dir := FileDirectory default on: dirName.
- dir fileNames do: [:n | | info fullName |
- fullName := dir fullNameFor: n.
- info := AIFFFileReader new readFromFile: fullName
- mergeIfStereo: false
- skipDataChunk: true.
- all add: n -> info].
- ^ all
- !
Item was removed:
- ----- Method: SampledInstrument>>soundForMidiKey:dur:loudness: (in category 'playing') -----
- soundForMidiKey: midiKey dur: d loudness: l
- "Answer an initialized sound object that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)."
-
- | keymap note |
- l >= loudThreshold
- ifTrue: [
- d >= sustainedThreshold
- ifTrue: [keymap := sustainedLoud]
- ifFalse: [keymap := staccatoLoud]]
- ifFalse: [
- d >= sustainedThreshold
- ifTrue: [keymap := sustainedSoft]
- ifFalse: [keymap := staccatoSoft]].
- keymap ifNil: [keymap := sustainedLoud].
- note := (keymap at: midiKey) copy.
- ^ note
- setPitch: (AbstractSound pitchForMIDIKey: midiKey)
- dur: d
- loudness: (l * note gain)
- !
Item was removed:
- ----- Method: SampledInstrument>>soundForPitch:dur:loudness: (in category 'playing') -----
- soundForPitch: pitchNameOrNumber dur: d loudness: l
- "Answer an initialized sound object that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0."
- "Note: Generally, SampledInstruments are expected to be played via MIDI key numbers rather than by pitches, since finding the MIDI key for a given pitch is expensive."
-
- ^ self soundForMidiKey: (AbstractSound midiKeyForPitch: pitchNameOrNumber)
- dur: d
- loudness: l
- !
Item was removed:
- ----- Method: SampledInstrument>>staccatoLoudAndSoftSampleSet: (in category 'accessing') -----
- staccatoLoudAndSoftSampleSet: sortedNotes
-
- staccatoLoud := self midiKeyMapFor: sortedNotes.
- staccatoSoft := staccatoLoud.
- !
Item was removed:
- ----- Method: SampledInstrument>>staccatoLoudSampleSet: (in category 'accessing') -----
- staccatoLoudSampleSet: sortedNotes
-
- staccatoLoud := self midiKeyMapFor: sortedNotes.
- !
Item was removed:
- ----- Method: SampledInstrument>>staccatoSoftSampleSet: (in category 'accessing') -----
- staccatoSoftSampleSet: sortedNotes
-
- staccatoSoft := self midiKeyMapFor: sortedNotes.
- !
Item was removed:
- ----- Method: SampledInstrument>>sustainedLoudSampleSet: (in category 'accessing') -----
- sustainedLoudSampleSet: sortedNotes
-
- sustainedLoud := self midiKeyMapFor: sortedNotes.
- !
Item was removed:
- ----- Method: SampledInstrument>>sustainedSoftSampleSet: (in category 'accessing') -----
- sustainedSoftSampleSet: sortedNotes
-
- sustainedSoft := self midiKeyMapFor: sortedNotes.
- !
Item was removed:
- ----- Method: SampledInstrument>>sustainedThreshold (in category 'accessing') -----
- sustainedThreshold
-
- ^ sustainedThreshold
- !
Item was removed:
- ----- Method: SampledInstrument>>sustainedThreshold: (in category 'accessing') -----
- sustainedThreshold: aNumber
-
- sustainedThreshold := aNumber asFloat.
- !
Item was removed:
- ----- Method: SampledInstrument>>testAtPitch: (in category 'other') -----
- testAtPitch: aPitch
- "SampledInstrument testAtPitch: 'c4'"
-
- | pattern |
- pattern := (#(
- (c4 0.64 100)
- (c4 0.64 200)
- (c4 0.64 400)
- (c4 0.64 600)
- (c4 0.64 800)
- (c4 1.28 1000)
- (c4 1.28 400)
- (c4 0.32 500)
- (c4 0.32 500)
- (c4 0.32 500)
- (c4 0.32 500)
- (c4 0.16 500)
- (c4 0.16 500)
- (c4 0.16 500)
- (c4 0.16 500)
- (c4 0.16 500)
- (c4 0.08 500)
- (c4 0.08 500)
- (c4 0.16 500)
- (c4 0.08 500)
- (c4 0.08 500)
- (c4 0.64 500))
- collect: [:triple | triple copy at: 1 put: aPitch; yourself]).
- (AbstractSound noteSequenceOn: self from: pattern) play.
- !
Item was removed:
- ----- Method: SampledInstrument>>trimAttackOf:threshold: (in category 'other') -----
- trimAttackOf: sampleBuffer threshold: threshold
- "Trim 'silence' off the initial attacks of the given sound buffer."
-
- (sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd |
- snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold).
- snd isStereo ifTrue: [
- snd rightSamples:
- (self trimAttackOf: snd rightSamples threshold: threshold)]].
- !
Item was removed:
- ----- Method: SampledInstrument>>trimAttacks: (in category 'other') -----
- trimAttacks: threshold
- "Trim 'silence' off the initial attacks all my samples."
-
- (sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd |
- snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold).
- snd isStereo ifTrue: [
- snd rightSamples:
- (self trimAttackOf: snd rightSamples threshold: threshold)]].
- !
Item was removed:
- AbstractSound subclass: #SampledSound
- instanceVariableNames: 'initialCount count samples originalSamplingRate samplesSize scaledIndex indexHighBits scaledIncrement'
- classVariableNames: 'CoffeeCupClink DefaultSampleTable IncrementFractionBits IncrementScaleFactor NominalSamplePitch ScaledIndexOverflow SoundLibrary'
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: SampledSound class>>addLibrarySoundNamed:fromAIFFfileNamed: (in category 'sound library') -----
- addLibrarySoundNamed: aString fromAIFFfileNamed: fileName
- "Add a sound from the given AIFF file to the library."
- "SampledSound
- addLibrarySoundNamed: 'shutterClick'
- fromAIFFfileNamed: '7.aif'"
- "Add all .aif files in the current directory to the sound library:
- | fileNames |
- fileNames := FileDirectory default fileNamesMatching: '*.aif'.
- fileNames do: [:fName |
- SampledSound
- addLibrarySoundNamed: (fName copyUpTo: $.)
- fromAIFFfileNamed: fName]"
-
- | snd |
- snd := self fromAIFFfileNamed: fileName.
- self addLibrarySoundNamed: aString
- samples: snd samples
- samplingRate: snd originalSamplingRate.
- !
Item was removed:
- ----- Method: SampledSound class>>addLibrarySoundNamed:samples:samplingRate: (in category 'sound library') -----
- addLibrarySoundNamed: aString samples: sampleData samplingRate: samplesPerSecond
- "Add the given sound to the sound library. The sample data may be either a ByteArray or a SoundBuffer. If the former, it is take to be 8-bit unsigned samples. If the latter, it is taken to be 16 bit signed samples."
-
- SoundLibrary
- at: aString
- put: (Array with: sampleData with: samplesPerSecond).
- !
Item was removed:
- ----- Method: SampledSound class>>assimilateSoundsFrom: (in category 'sound library') -----
- assimilateSoundsFrom: aDictionary
- "assimilate sounds with new keys from the given dictionary"
-
- aDictionary associationsDo:
- [:assoc | (SoundLibrary includesKey: assoc key) ifFalse:
- [SoundLibrary add: assoc]]!
Item was removed:
- ----- Method: SampledSound class>>beep (in category 'instance creation') -----
- beep
- "Beep in the presence of the sound system.
- Not to be used directly - use Beeper class>>beep
- or Beeper class>>beepPrimitive instead."
-
- (self new
- setSamples: self coffeeCupClink
- samplingRate: 12000) play
- !
Item was removed:
- ----- Method: SampledSound class>>coffeeCupClink (in category 'coffee cup clink') -----
- coffeeCupClink
- "Return the samples array for the sound of a spoon being tapped against a coffee cup."
-
- CoffeeCupClink ifNil: [self initializeCoffeeCupClink].
- ^ CoffeeCupClink
- !
Item was removed:
- ----- Method: SampledSound class>>convert8bitSignedFrom:to16Bit: (in category 'utilities') -----
- convert8bitSignedFrom: aByteArray to16Bit: aSoundBuffer
- "Copy the contents of the given array of signed 8-bit samples into the given array of 16-bit signed samples."
-
- | n s |
- <primitive: 'primitiveConvert8BitSigned' module: 'MiscPrimitivePlugin'>
- <var: #aByteArray declareC: 'unsigned char *aByteArray'>
- <var: #aSoundBuffer declareC: 'unsigned short *aSoundBuffer'>
- n := aByteArray size.
- 1 to: n do: [:i |
- s := aByteArray at: i.
- s > 127
- ifTrue: [aSoundBuffer at: i put: ((s - 256) bitShift: 8)]
- ifFalse: [aSoundBuffer at: i put: (s bitShift: 8)]].
- !
Item was removed:
- ----- Method: SampledSound class>>convert8bitSignedTo16Bit: (in category 'utilities') -----
- convert8bitSignedTo16Bit: aByteArray
- "Convert the given array of samples--assumed to be 8-bit signed, linear data--into 16-bit signed samples. Return an array containing the resulting samples. Typically used to read uncompressed AIFF sound data."
-
- | result |
- result := SoundBuffer newMonoSampleCount: aByteArray size.
- self convert8bitSignedFrom: aByteArray to16Bit: result.
- ^ result
- !
Item was removed:
- ----- Method: SampledSound class>>convert8bitUnsignedTo16Bit: (in category 'utilities') -----
- convert8bitUnsignedTo16Bit: anArray
- "Convert the given array of samples--assumed to be 8-bit unsigned, linear data--into 16-bit signed samples. Return an array containing the resulting samples. Typically used to read uncompressed WAVE sound data."
-
- | n samples s |
- n := anArray size.
- samples := SoundBuffer newMonoSampleCount: n.
- 1 to: n do: [:i |
- s := anArray at: i.
- samples at: i put: (s - 128 * 256)].
- ^ samples
- !
Item was removed:
- ----- Method: SampledSound class>>convertBytesTo16BitSamples:mostSignificantByteFirst: (in category 'utilities') -----
- convertBytesTo16BitSamples: aByteArray mostSignificantByteFirst: msbFirst
- "Convert the given ByteArray (with the given byte ordering) into 16-bit sample buffer."
-
- | n data src b1 b2 w |
- n := aByteArray size // 2.
- data := SoundBuffer newMonoSampleCount: n.
- src := 1.
- 1 to: n do: [:i |
- b1 := aByteArray at: src.
- b2 := aByteArray at: src + 1.
- msbFirst
- ifTrue: [w := (b1 bitShift: 8) + b2]
- ifFalse: [w := (b2 bitShift: 8) + b1].
- w > 32767 ifTrue: [w := w - 65536].
- data at: i put: w.
- src := src + 2].
- ^ data
- !
Item was removed:
- ----- Method: SampledSound class>>defaultSampleTable: (in category 'default sound') -----
- defaultSampleTable: anArray
- "Set the sample table to be used as the default waveform for playing a score such as the Bach fugue. Array is assumed to contain monaural signed 16-bit sample values."
-
- DefaultSampleTable := SoundBuffer fromArray: anArray.
- !
Item was removed:
- ----- Method: SampledSound class>>defaultSamples:repeated: (in category 'default sound') -----
- defaultSamples: anArray repeated: n
-
- | data |
- data := WriteStream on: (SoundBuffer newMonoSampleCount: anArray size * n).
- n timesRepeat: [
- anArray do: [:sample | data nextPut: sample truncated]].
- DefaultSampleTable := data contents.
- !
Item was removed:
- ----- Method: SampledSound class>>fileReaderServicesForFile:suffix: (in category 'file reader services') -----
- fileReaderServicesForFile: fullName suffix: suffix
-
- ^ (suffix = 'wav')
- ifTrue: [Array with: self serviceLoadingWav]
- ifFalse: [#()]!
Item was removed:
- ----- Method: SampledSound class>>fromAIFFfileNamed: (in category 'instance creation') -----
- fromAIFFfileNamed: fileName
- "Read a SampledSound from the AIFF file of the given name, merging stereo to mono if necessary."
- "(SampledSound fromAIFFfileNamed: '1.aif') play"
- "| snd |
- FileDirectory default fileNames do: [:n |
- (n endsWith: '.aif')
- ifTrue: [
- snd := SampledSound fromAIFFfileNamed: n.
- snd play.
- SoundPlayer waitUntilDonePlaying: snd]]."
-
- | aiffFileReader |
- aiffFileReader := AIFFFileReader new.
- aiffFileReader readFromFile: fileName
- mergeIfStereo: true
- skipDataChunk: false.
- ^ self
- samples: (aiffFileReader channelData at: 1)
- samplingRate: aiffFileReader samplingRate
- !
Item was removed:
- ----- Method: SampledSound class>>fromDroppedWaveFileNamed: (in category 'file reader services') -----
- fromDroppedWaveFileNamed: fileName
-
- (self fromWaveFileNamed: fileName) explore!
Item was removed:
- ----- Method: SampledSound class>>fromWaveFileNamed: (in category 'instance creation') -----
- fromWaveFileNamed: fileName
- "(SampledSound fromWaveFileNamed: 'c:\windows\media\chimes.wav') play"
- "| snd fd |
- fd := FileDirectory on:'c:\windows\media\'.
- fd fileNames do: [:n |
- (n asLowercase endsWith: '.wav')
- ifTrue: [
- snd := SampledSound fromWaveFileNamed: (fd pathName,n).
- snd play.
- SoundPlayer waitUntilDonePlaying: snd]]."
-
- ^self fromWaveStream: (FileStream oldFileNamed: fileName)
- !
Item was removed:
- ----- Method: SampledSound class>>fromWaveStream: (in category 'instance creation') -----
- fromWaveStream: fileStream
-
- | stream header data type channels samplingRate blockAlign bitsPerSample leftAndRight |
- header := self readWaveChunk: 'fmt ' inRIFF: fileStream.
- data := self readWaveChunk: 'data' inRIFF: fileStream.
- fileStream close.
- stream := ReadStream on: header.
- type := self next16BitWord: false from: stream.
- type = 1 ifFalse: [^ self error:'Unexpected wave format'].
- channels := self next16BitWord: false from: stream.
- (channels < 1 or: [channels > 2])
- ifTrue: [^ self error: 'Unexpected number of wave channels'].
- samplingRate := self next32BitWord: false from: stream.
- stream skip: 4. "skip average bytes per second"
- blockAlign := self next16BitWord: false from: stream.
- bitsPerSample := self next16BitWord: false from: stream.
- (bitsPerSample = 8 or: [bitsPerSample = 16])
- ifFalse: [ "recompute bits per sample"
- bitsPerSample := (blockAlign // channels) * 8].
-
- bitsPerSample = 8
- ifTrue: [data := self convert8bitUnsignedTo16Bit: data]
- ifFalse: [data := self convertBytesTo16BitSamples: data mostSignificantByteFirst: false].
-
- channels = 2 ifTrue: [
- leftAndRight := data splitStereo.
- ^ MixedSound new
- add: (self samples: leftAndRight first samplingRate: samplingRate) pan: 0.0;
- add: (self samples: leftAndRight last samplingRate: samplingRate) pan: 1.0;
- yourself].
-
- ^ self samples: data samplingRate: samplingRate
- !
Item was removed:
- ----- Method: SampledSound class>>initialize (in category 'class initialization') -----
- initialize
- "SampledSound initialize"
-
- IncrementFractionBits := 16.
- IncrementScaleFactor := 2 raisedTo: IncrementFractionBits.
- ScaledIndexOverflow := 2 raisedTo: 29. "handle overflow before needing LargePositiveIntegers"
- self useCoffeeCupClink.
- SoundLibrary ifNil: [SoundLibrary := Dictionary new].
- Beeper setDefault: (self new
- setSamples: self coffeeCupClink
- samplingRate: 12000).
-
- FileServices registerFileReader: self
- !
Item was removed:
- ----- Method: SampledSound class>>initializeCoffeeCupClink (in category 'coffee cup clink') -----
- initializeCoffeeCupClink
- "Initialize the samples array for the sound of a spoon being tapped against a coffee cup."
- "SampledSound initializeCoffeeCupClink"
-
- | samples |
- samples := #(768 1024 -256 2304 -13312 26624 32512 19200 6400 -256 5888 32512 28928 32512 -32768 32512 -32768 18688 26368 -26112 32512 32512 2304 32512 5632 2816 10240 -4608 -1792 32512 32512 -5376 10752 32512 32512 32512 8192 15872 32512 -3584 -32768 -23296 -24832 -32768 -32768 -32768 -2304 32512 32512 -32768 32512 -15360 6400 8448 -18176 -32768 -256 -32768 -29440 9472 20992 17920 32512 32512 -256 32512 -32768 -32768 -23040 -32768 -25088 -32768 -27648 -1536 24320 -32768 32512 20480 27904 22016 16384 -32768 32512 -27648 -32768 -7168 28160 -6400 5376 32512 -256 32512 -7168 -11776 -19456 -27392 -24576 -32768 -24064 -19456 12800 32512 27136 2048 25344 15616 8192 -4608 -28672 -32768 -30464 -2560 17664 256 -8192 8448 32512 27648 -6144 -512 -7424 -18688 7936 -256 -22272 -14080 2048 27648 15616 -12288 -768 5376 3328 5632 3072 -6656 -20480 10240 27136 -10752 -11008 -768 -2048 6144 -7168 -3584 -1024 -7680 19712 26112 1024 -11008 3072 16384 -8960 -14848 -4864 -23808 -11264 12288 8192 7168 4
864 23040 32512 512 -11776 -5632 -16896 -21504 -12800 -6144 -16896 -4352 32512 32512 23296 21760 5632 2816 -9472 -20992 -11264 -29440 -32768 -3584 7680 8448 15360 32512 32512 15616 15104 -2048 -27904 -27904 -25600 -12288 -12032 -13568 17152 22272 15360 30208 28160 7680 -5632 -8192 -16384 -31744 -25856 -10752 -3840 6656 13056 24320 26368 12800 20736 12288 -19200 -20992 -16640 -21504 -17920 -6912 8448 11264 14080 23040 18176 8192 -1024 0 256 -20992 -19712 -4608 -11264 -2048 14080 12032 8192 6912 13056 9216 -5632 -5376 -3840 -6656 -9984 -5632 4864 -3584 -1280 17408 7680 -1280 4096 2816 -1024 -4864 3328 8448 -768 -5888 -2048 5120 0 3072 11008 -7680 -15360 2560 6656 -3840 0 11776 7680 2816 1536 -1280 -3840 -8704 -1536 3584 -9728 -9728 11776 18688 7680 6656 6400 -4864 -3840 -256 -6912 -13312 -11264 2304 9728 1792 3328 18944 18432 6912 6144 -1536 -17664 -14336 -2304 -10496 -15616 -4096 9728 17152 14848 13312 11520 2304 -1024 2560 -8704 -26624 -18688 -256 -256 2816 14080 13824 12544 14080 9
728 -512 -12032 -8960 -3328 -9984 -15872 -5120 8192 3584 10496 20224 7936 4608 6144 1280 -8704 -12800 -7424 -8448 -8960 -3840 7424 13056 8704 13312 13056 -2304 -4864 -768 -7168 -10496 -4608 -1536 -3072 -1280 6144 13312 11008 4864 4864 1536 -8960 -7680 1792 -4864 -7680 2816 5632 3328 2560 5376 7936 3584 -512 512 -4608 -9728 0 9216 768 -4096 7680 7168 256 4608 -768 -8704 -6400 2048 6144 -3072 -3328 6400 9472 3840 -768 1792 -3840 -5120 6144 768 -9984 -4352 5120 9472 6912 2816 1792 1280 768 512 -2816 -9728 -6912 6912 6912 -3328 -768 8448 11776 10752 3328 -6912 -10752 -8704 -1536 0 -6912 -3328 9984 13568 7424 6144 6656 256 0 256 -12032 -17920 -8192 3584 8960 4096 5632 12032 8704 6912 5632 -3584 -10496 -7936 -2048 -9216 -11776 2304 9472 15104 14848 5888 512 -2816 1024 2560 -9984 -13312 -5120 768 1792 768 8448 12032 11264 12800 -256 -11264 -9728 -2304 3072 -4352 -6912 256 2304 5376 9984 8192 2816 1280 3584 -2048 -11008 -8448 -2048 3072 4864 2304 3072 3072 3072 7168 3328 -5376 -4864 512 512
-1792 -1792 1792 5376 5888 5888 512 -5888 -3584 4096 3584 -6400 -4864 4608 3072 3840 5376 1024 768 2816 5888 -768 -12288 -7936 2304 5888 3328 2048 6144 3072 3072 6400 -3328 -7168 256 4096 -512 -9472 -6656 3328 6912 9216 8704 3840 -2560 -256 6656 -2560 -11264 -4608 -768 -1280 1536 3072 4096 5120 9984 11264 1024 -8192 -6144 -1024 -3840 -5632 -512 1024 2304 9728 9728 1280 512 4096 2816 -3584 -9984 -6912 -2304 512 5632 7680 3584 1024 5632 5888 -1280 -3584 -2304 -2560 -1536 -1024 -1792 -512 1536 7680 9984 2048 -2048 2048 3328 -1280 -4096 -3328 -4608 -1280 4352 3328 1280 1792 5120 6912 1024 -2560 0 -768 -1024 1280 -256 -4608 -1280 6400 5120 768 1792 2560 2048 0 -1536 -1280 -2304 1024 5376 2560 -2560 -512 4096 2048 512 768 -1280 -256 2560 2560 -256 -1024 768 3584 1280 -3328 -1536 1792 2816 3328 2304 -256 256 2816 2304 -1280 -3328 -1536 2304 2304 -256 -256 1024 1536 3840 5120 1024 -2048 0 1536 -768 -2560 -1792 256 2304 2048 1536 256 768 5888 6656 256 -3840 -2304 -1280 -1536 256 0 -512 2304
4352 3840 768 0 2304 3072 256 -3072 -2560 -2560 256 4608 2560 256 1536 3072 3072 1792 256 256 512 -256 -768 -1280 -1536 768 4352 2816 -512 768 2560 2560 2304 -256 -1792 -768 768 1792 256 -2304 -256 3328 3840 2304 2304 1536 256 2048 1024 -1536 -1792 -1024 512 256 -512 0 2304 4864 5120 4352 1024 -1280 0 -768 -2816 -2304 -512 1024 2048 2304 2048 3072 3840 2816 2048 -512 -3072 -1792 -1536 -1280 768 1280 1536 2304 2816 2048 1536 2048 1536 1536 -768 -3840 -2048 0 1280 2816 1792 1536 2560 3584 2816 1024 256 -768 -768 -1280 -2816 -768 1792 3328 5120 3072 1280 1536 1792 768 -1024 -1280 -1536 -768 512 256 1536 2560 2560 3328 1280 0 768 1536 768 -256 -512 -1536 -1280 768 1280 2304 2560 2560 2560 1024 -256 -512 0 1280 1536 768 -1280 -512 2048 1536 2048 1280 -256 256 512 768 768 1280 2304 1792 512 -1280 -1024 768 1536 1536 256 -768 1536 3584 3072 1792 -256 -1536 -512 256 -512 -512 768 2048 2048 1792 1280 1280 3072 2816 768 -1024 -2304 -1024 256 256 1280 1792 2304 2816 2304 1280 512 1024 768 -76
8 -1280 -1280 -512 1536 2560 2816 2048 512 1024 1792 1280 768 0 -768 -768 0 256 256 1280 2560 2304 2304 1536 512 512 1024 1280 0 -1792 -1536 -512 1280 3072 2816 1792 512 1024 1536 256 -256 768 768 256 256 -256 512 1280 1280 1536 768 1024 1792 1536 1024 0 256 -512 -256 1024 512 256 768 1792 2304 1280 256 768 1024 1280 1792 768 -768 -768 768 512 256 1024 1792 1536 1280 1536 1792 1280 768 512 -512 -1792 -512 512 768 2304 2816 1792 768 1536 2304 1536 0 -256 -256 -768 -768 256 1536 1536 2304 2048 256 768 2048 2304 1280 0 -256 -1024 -1024 0 1024 1792 2304 2304 1280 512 1280 2048 1280 256 -512 -1792 -1536 256 1536 1792 2048 2048 2048 1536 512 512 768 256 -256 0 -512 -1024 768 2048 2304 2304 1280 1280 1024 1024 1024 0 -512 256 768 0 -256 1536 2304 1792 2304 1280 -512 -256 768 1536 1024 256 512 512 1024 1792 1792 1536 1024 1280 0 -1280 256 2048 2560 2048 1024 -256 -256 1024 1280 1536 1024 0 0 256 768 1792 2304 2048 1280 1024 0 -512 -256 256 1024 1024 512 768 768 1280 2048 1792 1024 768 768 -
256 -1024 0 256 1024 1536 1024 1280 1536 1792 1792 1024 512 512 0 -512 -256 512 768 1280 1280 1024 1280 1792 1792 1280 512 -256 -256 256 512 1280 1024 1280 1280 1024 1024 768 1024 1024 1024 1280 256 256 768 768 1024 512 256 768 1280 2560 2560 1280 512 -256 -512 -256 1024 1536 768 1024 1280 768 1024 1536 1536 1024 256 0 0 0 768 768 512 1280 1536 1280 1280 1280 1280 768 768 256 -256 768 768 256 768 1280 1792 1536 1536 1536 256 512 1024 0 -768 -256 768 512 1024 2048 1536 1024 1536 1536 768 0 0 -256).
-
- CoffeeCupClink := SoundBuffer fromArray: samples.
- !
Item was removed:
- ----- Method: SampledSound class>>next16BitWord:from: (in category 'WAV reading') -----
- next16BitWord: msbFirst from: stream
- "Read a 16-bit positive integer from the input stream."
- "Assume: Stream has at least two bytes left."
-
- | n |
- n := stream next: 2.
- ^msbFirst
- ifTrue:[(n at: 1) * 256 + (n at: 2)]
- ifFalse:[(n at: 2) * 256 + (n at: 1)]
- !
Item was removed:
- ----- Method: SampledSound class>>next32BitWord:from: (in category 'WAV reading') -----
- next32BitWord: msbFirst from: stream
- "Read a 32-bit positive integer from the input stream."
- "Assume: Stream has at least four bytes left."
-
- | n |
- n := stream next: 4.
- ^msbFirst
- ifTrue:[(n at: 1) * 256 + (n at: 2) * 256 + (n at: 3) * 256 + (n at: 4)]
- ifFalse:[(n at: 4) * 256 + (n at: 3) * 256 + (n at: 2) * 256 + (n at: 1)]
- !
Item was removed:
- ----- Method: SampledSound class>>nominalSamplePitch: (in category 'default sound') -----
- nominalSamplePitch: aNumber
- "Record an estimate of the normal pitch of the sampled sound."
-
- NominalSamplePitch := aNumber.
- !
Item was removed:
- ----- Method: SampledSound class>>playSoundNamed: (in category 'sound library') -----
- playSoundNamed: aString
- "Play the sound with given name. Do nothing if there is no sound of that name in the library."
- "SampledSound playSoundNamed: 'croak'"
-
- | snd |
- snd := self soundNamed: aString.
- snd ifNotNil: [snd play].
- ^ snd
- !
Item was removed:
- ----- Method: SampledSound class>>putCoffeeCupClinkInSoundLibrary (in category 'sound library') -----
- putCoffeeCupClinkInSoundLibrary
- "SampledSound putCoffeeCupClinkInSoundLibrary"
-
- self addLibrarySoundNamed: 'clink'
- samples: self coffeeCupClink
- samplingRate: 11025!
Item was removed:
- ----- Method: SampledSound class>>readWaveChunk:inRIFF: (in category 'WAV reading') -----
- readWaveChunk: chunkType inRIFF: stream
- "Search the stream for a format chunk of the given type and return its contents."
-
- | id count |
- stream reset; binary.
- stream skip: 8. "skip 'RIFF' and total length"
- id := (stream next: 4) asString. "contents type"
- id = 'WAVE' ifFalse: [^ '']. "content type must be WAVE"
-
- "search for a chunk of the given type"
- [id := (stream next: 4) asString.
- count := self next32BitWord: false from: stream.
- id = chunkType] whileFalse: [
- "skip this chunk, rounding length up to a word boundary"
- stream skip: (count + 1 bitAnd: 16rFFFFFFFE).
- stream atEnd ifTrue: [^ '']].
-
- ^ stream next: count "return raw chunk data"
- !
Item was removed:
- ----- Method: SampledSound class>>removeSoundNamed: (in category 'sound library') -----
- removeSoundNamed: aString
- "Remove the sound with the given name from the sound library."
-
- SoundLibrary removeKey: aString ifAbsent: [].
- !
Item was removed:
- ----- Method: SampledSound class>>samples:samplingRate: (in category 'instance creation') -----
- samples: anArrayOf16BitSamples samplingRate: samplesPerSecond
- "Return a SampledSound with the given samples array and sampling rate."
-
- ^ self new setSamples: anArrayOf16BitSamples samplingRate: samplesPerSecond
- !
Item was removed:
- ----- Method: SampledSound class>>serviceLoadingWav (in category 'file reader services') -----
- serviceLoadingWav
-
- ^ SimpleServiceEntry
- provider: self
- label: 'load as sound'
- selector: #fromDroppedWaveFileNamed:
- description: 'load the sound'
- buttonLabel: 'load as sound'!
Item was removed:
- ----- Method: SampledSound class>>soundLibrary (in category 'sound library') -----
- soundLibrary
- "Answer the sound library dictionary."
-
- ^ SoundLibrary
- !
Item was removed:
- ----- Method: SampledSound class>>soundNamed: (in category 'sound library') -----
- soundNamed: aString
- "Answer the sound of the given name, or, if there is no sound of that name, put up an informer so stating, and answer nil"
-
- "(SampledSound soundNamed: 'shutterClick') play"
-
- ^ self soundNamed: aString ifAbsent:
- [self inform: aString, ' not found in the Sound Library' translated.
- nil]!
Item was removed:
- ----- Method: SampledSound class>>soundNamed:ifAbsent: (in category 'sound library') -----
- soundNamed: aString ifAbsent: aBlock
- "Answer the sound of the given name, or if there is no sound of that name, answer the result of evaluating aBlock"
- "(SampledSound soundNamed: 'shutterClick') play"
-
- | entry samples compressedSound |
- entry := SoundLibrary
- at: aString
- ifAbsent:
- [^ aBlock value].
- entry ifNil: [^ aBlock value].
- entry second isString
- ifTrue: [compressedSound := Compiler evaluate: entry second.
- compressedSound source: entry first.
- ^ compressedSound asSound]
- ifFalse: [samples := entry at: 1.
- samples class isBytes ifTrue: [samples := self convert8bitSignedTo16Bit: samples].
- ^ self samples: samples samplingRate: (entry at: 2)]
- !
Item was removed:
- ----- Method: SampledSound class>>soundNames (in category 'sound library') -----
- soundNames
- "Answer a list of sound names for the sounds stored in the sound library."
- "SampledSound soundNames asSortedCollection do:
- [:n |
- (n padded: #right to: 10 with: $ ) asParagraph displayAt: Sensor cursorPoint - 32.
- (SampledSound soundNamed: n) ifNotNil:
- [:s| s playAndWaitUntilDone. (Delay forMilliseconds: 250) wait]]"
-
- ^ SoundLibrary keys asArray
- !
Item was removed:
- ----- Method: SampledSound class>>uLawDecode: (in category 'utilities') -----
- uLawDecode: aByteArray
- "Convert the given array of uLaw-encoded 8-bit samples into a SoundBuffer of 16-bit signed samples."
-
- | n out decodingTable |
- n := aByteArray size.
- out := SoundBuffer newMonoSampleCount: n.
- decodingTable := self uLawDecodeTable.
- 1 to: n do: [:i | out at: i put: (decodingTable at: (aByteArray at: i) + 1)].
- ^ out
- !
Item was removed:
- ----- Method: SampledSound class>>uLawDecodeTable (in category 'utilities') -----
- uLawDecodeTable
- "Return a 256 entry table to be used to decode 8-bit uLaw-encoded samples."
- "Details: This table was computed as follows:
- | d encoded lastEncodedPos lastEncodedNeg |
- d := Array new: 256.
- lastEncodedPos := nil.
- lastEncodedNeg := nil.
- 4095 to: 0 by: -1 do: [:s |
- encoded := SampledSound uLawEncodeSample: s.
- lastEncodedPos = encoded
- ifFalse: [
- d at: (encoded + 1) put: (s bitShift: 3).
- lastEncodedPos := encoded].
- encoded := encoded bitOr: 16r80.
- lastEncodedNeg = encoded
- ifFalse: [
- d at: (encoded + 1) put: (s bitShift: 3) negated.
- lastEncodedNeg := encoded]].
- d "
-
- ^ #(32760 31608 30584 29560 28536 27512 26488 25464 24440 23416 22392 21368 20344 19320 18296 17272 16248 15736 15224 14712 14200 13688 13176 12664 12152 11640 11128 10616 10104 9592 9080 8568 8056 7800 7544 7288 7032 6776 6520 6264 6008 5752 5496 5240 4984 4728 4472 4216 3960 3832 3704 3576 3448 3320 3192 3064 2936 2808 2680 2552 2424 2296 2168 2040 1912 1848 1784 1720 1656 1592 1528 1464 1400 1336 1272 1208 1144 1080 1016 952 888 856 824 792 760 728 696 664 632 600 568 536 504 472 440 408 376 360 344 328 312 296 280 264 248 232 216 200 184 168 152 136 120 112 104 96 88 80 72 64 56 48 40 32 24 16 8 0 -32760 -31608 -30584 -29560 -28536 -27512 -26488 -25464 -24440 -23416 -22392 -21368 -20344 -19320 -18296 -17272 -16248 -15736 -15224 -14712 -14200 -13688 -13176 -12664 -12152 -11640 -11128 -10616 -10104 -9592 -9080 -8568 -8056 -7800 -7544 -7288 -7032 -6776 -6520 -6264 -6008 -5752 -5496 -5240 -4984 -4728 -4472 -4216 -3960 -3832 -3704 -3576 -3448 -3320 -3192 -3064 -2936 -2808 -2680 -25
52 -2424 -2296 -2168 -2040 -1912 -1848 -1784 -1720 -1656 -1592 -1528 -1464 -1400 -1336 -1272 -1208 -1144 -1080 -1016 -952 -888 -856 -824 -792 -760 -728 -696 -664 -632 -600 -568 -536 -504 -472 -440 -408 -376 -360 -344 -328 -312 -296 -280 -264 -248 -232 -216 -200 -184 -168 -152 -136 -120 -112 -104 -96 -88 -80 -72 -64 -56 -48 -40 -32 -24 -16 -8 0)
- !
Item was removed:
- ----- Method: SampledSound class>>uLawEncode: (in category 'utilities') -----
- uLawEncode: anArray
- "Convert the given array of 16-bit signed samples into a ByteArray of uLaw-encoded 8-bit samples."
-
- | n out s |
- n := anArray size.
- out := ByteArray new: n.
- 1 to: n do: [:i |
- s := anArray at: i.
- s := s bitShift: -3. "drop 4 least significant bits"
- s < 0
- ifTrue: [s := (self uLawEncodeSample: s negated) bitOr: 16r80]
- ifFalse: [s := (self uLawEncodeSample: s)].
- out at: i put: s].
- ^ out
- !
Item was removed:
- ----- Method: SampledSound class>>uLawEncodeSample: (in category 'utilities') -----
- uLawEncodeSample: s
- "Encode the given 16-bit signed sample using the uLaw 8-bit encoding."
-
- s < 496 ifTrue: [
- s < 112 ifTrue: [
- s < 48 ifTrue: [
- s < 16
- ifTrue: [^ 16r70 bitOr: (15 - s)]
- ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]].
- ^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))].
- s < 240
- ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))]
- ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]].
-
- s < 2032 ifTrue: [
- s < 1008
- ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))]
- ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]].
-
- s < 4080
- ifTrue: [^ 15 - ((s - 2032) bitShift: -7)]
- ifFalse: [^ 0].
- !
Item was removed:
- ----- Method: SampledSound class>>universalSoundKeys (in category 'sound library') -----
- universalSoundKeys
- "Answer a list of the sound-names that are expected to be found in the SoundLibrary of every image."
- ^ {'camera' translatedNoop. 'chirp' translatedNoop. 'chomp' translatedNoop. 'click' translatedNoop. 'clink' translatedNoop. 'coyote' translatedNoop. 'croak' translatedNoop. 'horn' translatedNoop. 'laugh' translatedNoop. 'meow' translatedNoop. 'motor' translatedNoop. 'peaks' translatedNoop. 'scrape' translatedNoop. 'scratch' translatedNoop. 'scritch' translatedNoop. 'silence' translatedNoop. 'splash' translatedNoop. 'warble' translatedNoop.}!
Item was removed:
- ----- Method: SampledSound class>>unusedSoundNameLike: (in category 'sound library') -----
- unusedSoundNameLike: desiredName
- "Pick an unused sound name based on the given string. If necessary, append digits to avoid name conflicts with existing sounds."
- "SampledSound unusedSoundNameLike: 'chirp'"
-
- | newName i |
- newName := desiredName.
- i := 2.
- [SoundLibrary includesKey: newName] whileTrue: [
- newName := desiredName, i printString.
- i := i + 1].
- ^ newName
- !
Item was removed:
- ----- Method: SampledSound class>>useCoffeeCupClink (in category 'default sound') -----
- useCoffeeCupClink
- "Set the sample table to be used as the default waveform to the sound of a coffee cup being tapped with a spoon."
- "SampledSound useCoffeeCupClink bachFugue play"
-
- DefaultSampleTable := self coffeeCupClink.
- NominalSamplePitch := 400.
- !
Item was removed:
- ----- Method: SampledSound>>compressWith: (in category 'accessing') -----
- compressWith: codecClass
- | codec result |
- codec := codecClass new.
- result := codec compressSound: self.
- codec release.
- ^ result!
Item was removed:
- ----- Method: SampledSound>>compressWith:atRate: (in category 'accessing') -----
- compressWith: codecClass atRate: aSamplingRate
- | codec result |
- codec := codecClass new.
- result := codec compressSound: self atRate: aSamplingRate.
- codec release.
- ^ result!
Item was removed:
- ----- Method: SampledSound>>duration (in category 'accessing') -----
- duration
-
- ^ initialCount asFloat / self samplingRate asFloat
- !
Item was removed:
- ----- Method: SampledSound>>duration: (in category 'accessing') -----
- duration: seconds
-
- super duration: seconds.
- count := initialCount := (seconds * self samplingRate) rounded.
- !
Item was removed:
- ----- Method: SampledSound>>endGracefully (in category 'playing') -----
- endGracefully
- "See stopGracefully, which affects initialCOunt, and I don't think it should (di)."
-
- | decayInMs env |
- envelopes isEmpty
- ifTrue: [
- self adjustVolumeTo: 0 overMSecs: 10.
- decayInMs := 10]
- ifFalse: [
- env := envelopes first.
- decayInMs := env attackTime + env decayTime].
- count := decayInMs * self samplingRate // 1000.
- !
Item was removed:
- ----- Method: SampledSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'playing') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Mix the given number of samples with the samples already in the given buffer starting at the given index.
- Assume that the buffer size is at least (index + count) - 1."
-
- | lastIndex outIndex sampleIndex sample i s overflow |
- <primitive:'primitiveMixSampledSound' module: 'SoundGenerationPlugin'>
- <var: #aSoundBuffer type: #'short int *'>
- <var: #samples type: #'short int *'>
-
- lastIndex := startIndex + n - 1.
- outIndex := startIndex. "index of next stereo output sample pair"
- sampleIndex := indexHighBits + (scaledIndex >> IncrementFractionBits).
- [sampleIndex <= samplesSize and: [outIndex <= lastIndex]] whileTrue:
- [sample := (samples at: sampleIndex) * scaledVol // ScaleFactor.
- leftVol > 0 ifTrue:
- [i := 2 * outIndex - 1.
- s := (aSoundBuffer at: i) + (sample * leftVol // ScaleFactor).
- "clip the result!!!!"
- aSoundBuffer at: i put: (s > 32767 ifTrue: [32767] ifFalse: [s < -32767 ifTrue: [-32767] ifFalse: [s]])].
- rightVol > 0 ifTrue:
- [i := 2 * outIndex.
- s := (aSoundBuffer at: i) + (sample * rightVol // ScaleFactor).
- "clip the result!!!!"
- aSoundBuffer at: i put: (s > 32767 ifTrue: [32767] ifFalse: [s < -32767 ifTrue: [-32767] ifFalse: [s]])].
-
- scaledVolIncr ~= 0 ifTrue:
- [scaledVol := scaledVol + scaledVolIncr.
- (scaledVolIncr > 0
- ifTrue: [scaledVol >= scaledVolLimit]
- ifFalse: [scaledVol <= scaledVolLimit])
- ifTrue: "reached the limit; stop incrementing"
- [scaledVol := scaledVolLimit.
- scaledVolIncr := 0]].
-
- scaledIndex := scaledIndex + scaledIncrement.
- "In 64-bits we don't have to worry about scaled indexes overflowing,
- and in the primitive this is guard evaluated at compile time."
- (SmallInteger maxVal <= 16r3FFFFFFF
- and: [scaledIndex >= ScaledIndexOverflow]) ifTrue:
- [overflow := scaledIndex >> IncrementFractionBits.
- indexHighBits := indexHighBits + overflow.
- scaledIndex := scaledIndex - (overflow << IncrementFractionBits)].
-
- sampleIndex := indexHighBits + (scaledIndex >> IncrementFractionBits).
- outIndex := outIndex + 1].
- "But we still have to update indexHighBits and scaledIndex correctly outside the loop..."
- SmallInteger maxVal > 16r3FFFFFFF ifTrue:
- [overflow := scaledIndex >> IncrementFractionBits.
- indexHighBits := indexHighBits + overflow.
- scaledIndex := scaledIndex - (overflow << IncrementFractionBits)].
- count := count - n!
Item was removed:
- ----- Method: SampledSound>>originalSamplingRate (in category 'accessing') -----
- originalSamplingRate
-
- ^ originalSamplingRate
- !
Item was removed:
- ----- Method: SampledSound>>pitch: (in category 'initialization') -----
- pitch: pitchNameOrNumber
-
- | p |
- p := self nameOrNumberToPitch: pitchNameOrNumber.
- originalSamplingRate :=
- ((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger.
- self reset.
- !
Item was removed:
- ----- Method: SampledSound>>playSilentlyUntil: (in category 'playing') -----
- playSilentlyUntil: startTime
- "Used to fast foward to a particular starting time.
- Overridden to be instant for sampled sounds."
-
- "true ifTrue: [^ super playSilentlyUntil: startTime]."
- indexHighBits := (startTime * originalSamplingRate) asInteger.
- scaledIndex := IncrementScaleFactor.
- count := initialCount - (startTime * self samplingRate).
- mSecsSinceStart := (startTime * 1000) asInteger.
-
- !
Item was removed:
- ----- Method: SampledSound>>reset (in category 'playing') -----
- reset
- "Details: The sample index and increment are scaled to allow fractional increments without having to do floating point arithmetic in the inner loop."
-
- super reset.
- scaledIncrement :=
- ((originalSamplingRate asFloat / self samplingRate) * IncrementScaleFactor) rounded.
- count := initialCount.
- scaledIndex := IncrementScaleFactor. "index of the first sample, scaled"
- indexHighBits := 0.
- !
Item was removed:
- ----- Method: SampledSound>>samples (in category 'accessing') -----
- samples
-
- ^ samples
- !
Item was removed:
- ----- Method: SampledSound>>samplesRemaining (in category 'playing') -----
- samplesRemaining
-
- ^ count
- !
Item was removed:
- ----- Method: SampledSound>>setPitch:dur:loudness: (in category 'initialization') -----
- setPitch: pitchNameOrNumber dur: d loudness: vol
- "Used to play scores using the default sample table."
- "(SampledSound pitch: 880.0 dur: 1.5 loudness: 0.6) play"
-
- | p |
- super setPitch: pitchNameOrNumber dur: d loudness: vol.
- p := self nameOrNumberToPitch: pitchNameOrNumber.
- samples := DefaultSampleTable.
- samplesSize := samples size.
- initialCount := (d * self samplingRate asFloat) rounded.
- originalSamplingRate :=
- ((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger.
- self loudness: vol.
- self reset.
- !
Item was removed:
- ----- Method: SampledSound>>setSamples:samplingRate: (in category 'initialization') -----
- setSamples: anArray samplingRate: rate
- "Set my samples array to the given array with the given nominal sampling rate. Altering the rate parameter allows the sampled sound to be played back at different pitches."
- "Note: There are two ways to use sampled sound: (a) you can play them through once (supported by this method) or (b) you can make them the default waveform with which to play a musical score (supported by the class method defaultSampleTable:)."
- "Assume: anArray is either a SoundBuffer or a collection of signed 16-bit sample values."
- "(SampledSound
- samples: SampledSound coffeeCupClink
- samplingRate: 5000) play"
-
- "copy the array into a SoundBuffer if necessary"
- anArray class isWords
- ifTrue: [samples := anArray]
- ifFalse: [samples := SoundBuffer fromArray: anArray].
-
- samplesSize := samples size.
- samplesSize >= SmallInteger maxVal ifTrue: [ "this is unlikely..."
- self error: 'sample count must be under ', SmallInteger maxVal printString].
- originalSamplingRate := rate.
- initialCount := (samplesSize * self samplingRate) // originalSamplingRate.
- self loudness: 1.0.
- self reset.
- !
Item was removed:
- ----- Method: SampledSound>>setScaledIncrement: (in category 'playing') -----
- setScaledIncrement: aNumber
-
- scaledIncrement := (aNumber * IncrementScaleFactor) rounded.
-
- !
Item was removed:
- ----- Method: SampledSound>>stopAfterMSecs: (in category 'playing') -----
- stopAfterMSecs: mSecs
- "Terminate this sound this note after the given number of milliseconds."
-
- count := (mSecs * self samplingRate) // 1000.
- !
Item was changed:
----- Method: SampledSound>>storeSampleCount:bigEndian:on: (in category 'file i/o') -----
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)."
+ | streamDirect reverseBytes |
- | reverseBytes |
self samplingRate ~= originalSamplingRate ifTrue: [
^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream].
"optimization: if sampling rates match, just store my buffer"
+ streamDirect := aBinaryStream isKindOf: StandardFileStream.
+ reverseBytes := (bigEndianFlag xor: Smalltalk isBigEndian) xor: streamDirect not.
- reverseBytes := bigEndianFlag ~= Smalltalk isBigEndian.
reverseBytes ifTrue: [samples reverseEndianness].
+ streamDirect
- (aBinaryStream isKindOf: StandardFileStream)
ifTrue: [ "optimization for files: write sound buffer directly to file"
aBinaryStream next: (samples size // 2) putAll: samples startingAt: 1] "size in words"
ifFalse: [ "for non-file streams:"
1 to: samples monoSampleCount do: [:i | aBinaryStream int16: (samples at: i)]].
reverseBytes ifTrue: [samples reverseEndianness]. "restore to original endianness"
!
Item was removed:
- ----- Method: SampledSound>>volumeForm:from:to:nSamplesPerPixel: (in category 'sound tracks') -----
- volumeForm: height from: start to: stop nSamplesPerPixel: nPerPixel
- "Note: nPerPixel can be Integer or Float for pixel-perfect alignment."
- "In an inspector of a samplesSound...
- self currentWorld addMorph: (ImageMorph new image:
- (self volumeForm: 32 from: 1 to: samples size nSamplesPerPixel: 225))
- "
- | volPlot width max |
- width := stop-start//nPerPixel.
- volPlot := Form extent: width@height.
- (start max: 1) to: (stop min: samples size)-nPerPixel by: nPerPixel do:
- [:i | | sample min vol | min:= max:= 0.
- i asInteger to: (i+nPerPixel-1) asInteger by: 4 do: "by: 4 makes it faster yet looks the same"
- [:j | sample := samples at: j.
- sample < min ifTrue: [min := sample].
- sample > max ifTrue: [max := sample]].
- vol := (max - min) * height // 65536.
- volPlot fillBlack: ((i-start//nPerPixel) @ (height-vol//2) extent: 1@(vol+1))].
- ^ volPlot
-
- !
Item was removed:
- AbstractSound subclass: #ScorePlayer
- instanceVariableNames: 'score instruments overallVolume leftVols rightVols muted rate tempo secsPerTick done repeat ticksSinceStart ticksClockIncr trackEventIndex tempoMapIndex activeSounds activeMIDINotes midiPort midiPlayerProcess durationInTicks'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !ScorePlayer commentStamp: '<historical>' prior: 0!
- This is a real-time player for MIDI scores (i.e., scores read from MIDI files). Score can be played using either the internal sound synthesis or an external MIDI synthesizer on platforms that support MIDI output.
- !
Item was removed:
- ----- Method: ScorePlayer class>>fileReaderServicesForFile:suffix: (in category 'file reader services') -----
- fileReaderServicesForFile: fullName suffix: suffix
-
- ^ (suffix = 'mid') | (suffix = '*')
- ifTrue: [self services]
- ifFalse: [#()]
- !
Item was removed:
- ----- Method: ScorePlayer class>>fromFileNamed: (in category 'instance creation') -----
- fromFileNamed: fileName
-
- ^ self onScore: (MIDIFileReader scoreFromFileNamed: fileName)!
Item was removed:
- ----- Method: ScorePlayer class>>initialize (in category 'class initialization') -----
- initialize
-
- Smalltalk addToShutDownList: self.
- FileServices registerFileReader: self.!
Item was removed:
- ----- Method: ScorePlayer class>>onScore: (in category 'instance creation') -----
- onScore: aMIDIScore
-
- ^ self new onScore: aMIDIScore
- !
Item was removed:
- ----- Method: ScorePlayer class>>playFileNamed: (in category 'instance creation') -----
- playFileNamed: fileName
-
- ^ (MIDISound fromFileNamed: fileName)
- play; yourself!
Item was removed:
- ----- Method: ScorePlayer class>>servicePlayMidiFile (in category 'file reader services') -----
- servicePlayMidiFile
- "Answer a service for opening player on a midi file"
-
- ^ SimpleServiceEntry
- provider: self
- label: 'play MIDI file'
- selector: #playFileNamed:
- description: 'play the MIDI file directly'
- buttonLabel: 'play'!
Item was removed:
- ----- Method: ScorePlayer class>>services (in category 'file reader services') -----
- services
-
- ^ Array with: self servicePlayMidiFile!
Item was removed:
- ----- Method: ScorePlayer class>>shutDown: (in category 'snapshotting') -----
- shutDown: quitting
-
- quitting ifTrue: [
- ScorePlayer allSubInstancesDo: [:ea | [ea stopMIDIPlaying] on: Error do: [] ] ].!
Item was removed:
- ----- Method: ScorePlayer class>>unload (in category 'initialize-release') -----
- unload
-
- FileServices unregisterFileReader: self !
Item was removed:
- ----- Method: ScorePlayer>>adjustVolumeTo:overMSecs: (in category 'volume') -----
- adjustVolumeTo: vol overMSecs: mSecs
- | normalizedVolume incr block |
- normalizedVolume := (vol asFloat min: 1.0) max: 0.0.
- incr := (self overallVolume - normalizedVolume) / mSecs * 50.0.
- block := normalizedVolume > 0.0
- ifTrue: [
- [[(normalizedVolume - self overallVolume) abs > 0.01] whileTrue: [self overallVolume: self overallVolume - incr. (Delay forMilliseconds: 50) wait]]]
- ifFalse: [
- [[self overallVolume > 0.0] whileTrue: [self overallVolume: self overallVolume - incr. (Delay forMilliseconds: 50) wait]. self pause]].
- block fork
- !
Item was removed:
- ----- Method: ScorePlayer>>closeMIDIPort (in category 'midi output') -----
- closeMIDIPort
- "Stop using MIDI for output. Music will be played using the built-in sound synthesis."
-
- self pause.
- midiPort := nil.
- !
Item was removed:
- ----- Method: ScorePlayer>>copySounds (in category 'copying') -----
- copySounds
- "Private!! Support for copying."
-
- instruments := instruments copy.
- leftVols := leftVols copy.
- rightVols := rightVols copy.
- muted := muted copy.
- self reset.
- !
Item was removed:
- ----- Method: ScorePlayer>>disableReverb: (in category 'operating') -----
- disableReverb: aBoolean
-
- aBoolean
- ifTrue: [SoundPlayer stopReverb]
- ifFalse: [SoundPlayer startReverb].
- !
Item was removed:
- ----- Method: ScorePlayer>>doControl (in category 'sound generation') -----
- doControl
-
- super doControl.
- 1 to: activeSounds size do: [:i | (activeSounds at: i) first doControl].
- ticksSinceStart := ticksSinceStart + ticksClockIncr.
- self processAllAtTick: ticksSinceStart asInteger.
- !
Item was removed:
- ----- Method: ScorePlayer>>duration (in category 'accessing') -----
- duration
- "Answer the duration in seconds of my MIDI score when played at the current rate. Take tempo changes into account."
-
- | totalSecs currentTempo lastTempoChangeTick |
- totalSecs := 0.0.
- currentTempo := 120.0. "quarter notes per minute"
- lastTempoChangeTick := 0.
- score tempoMap ifNotNil: [
- score tempoMap do: [:tempoEvt |
- "accumulate time up to this tempo change event"
- secsPerTick := 60.0 / (currentTempo * rate * score ticksPerQuarterNote).
- totalSecs := totalSecs + (secsPerTick * (tempoEvt time - lastTempoChangeTick)).
-
- "set the new tempo"
- currentTempo := (120.0 * (500000.0 / tempoEvt tempo)) roundTo: 0.01.
- lastTempoChangeTick := tempoEvt time]].
-
- "add remaining time through end of score"
- secsPerTick := 60.0 / (currentTempo * rate * score ticksPerQuarterNote).
- totalSecs := totalSecs + (secsPerTick * (score durationInTicks - lastTempoChangeTick)).
- ^ totalSecs
- !
Item was removed:
- ----- Method: ScorePlayer>>durationInTicks (in category 'accessing') -----
- durationInTicks
-
- durationInTicks == nil ifTrue: [^ 1000].
- ^ durationInTicks!
Item was removed:
- ----- Method: ScorePlayer>>infoForTrack: (in category 'accessing') -----
- infoForTrack: i
- "Return the info string for the given track."
- "Note: MIDI files follow varying conventions on their use of comment strings. Often, the first string in the track suggests the role of that track in the score, such as 'flute 1' or 'soprano'."
-
- ^ score trackInfo at: i
- !
Item was removed:
- ----- Method: ScorePlayer>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- score := MIDIScore new initialize.
- instruments := Array new.
- overallVolume := 0.5.
- leftVols := Array new.
- rightVols := Array new.
- muted := Array new.
- rate := 1.0.
- repeat := false.
- durationInTicks := 100.!
Item was removed:
- ----- Method: ScorePlayer>>instrumentForTrack: (in category 'accessing') -----
- instrumentForTrack: trackIndex
-
- ^ instruments at: trackIndex
- !
Item was removed:
- ----- Method: ScorePlayer>>instrumentForTrack:put: (in category 'accessing') -----
- instrumentForTrack: trackIndex put: aSoundProto
-
- trackIndex > instruments size ifTrue: [^ self].
- instruments at: trackIndex put: aSoundProto.
- !
Item was removed:
- ----- Method: ScorePlayer>>isDone (in category 'sound generation') -----
- isDone
-
- | track |
- activeSounds size > 0 ifTrue: [^ false].
- activeMIDINotes size > 0 ifTrue: [^ false].
- 1 to: score tracks size do: [:i |
- track := score tracks at: i.
- (trackEventIndex at: i) <= track size ifTrue: [^ false]].
- (trackEventIndex last) <= score ambientTrack size ifTrue: [^ false].
- ^ true
- !
Item was removed:
- ----- Method: ScorePlayer>>isPlaying (in category 'sound generation') -----
- isPlaying
- ^ SoundPlayer isPlaying: self!
Item was removed:
- ----- Method: ScorePlayer>>isStereo (in category 'accessing') -----
- isStereo
-
- ^ true
- !
Item was removed:
- ----- Method: ScorePlayer>>jumpToTick: (in category 'sound generation') -----
- jumpToTick: startTick
-
-
- self reset.
- self processTempoMapAtTick: startTick.
- self skipNoteEventsThruTick: startTick.
- self skipAmbientEventsThruTick: startTick.
- ticksSinceStart := startTick.
- !
Item was removed:
- ----- Method: ScorePlayer>>midiPlayLoop (in category 'midi output') -----
- midiPlayLoop
-
- | mSecsPerStep tStart mSecs |
- mSecsPerStep := 5.
- [done] whileFalse: [
- tStart := Time millisecondClockValue.
- self processAllAtTick: ticksSinceStart asInteger.
- (Delay forMilliseconds: mSecsPerStep) wait.
- mSecs := Time millisecondClockValue - tStart.
- mSecs < 0 ifTrue: [mSecs := mSecsPerStep]. "clock wrap"
- ticksSinceStart := ticksSinceStart + (mSecs asFloat / (1000.0 * secsPerTick))].
- !
Item was removed:
- ----- Method: ScorePlayer>>midiPort (in category 'accessing') -----
- midiPort
-
- ^ midiPort
- !
Item was removed:
- ----- Method: ScorePlayer>>millisecondsSinceStart (in category 'accessing') -----
- millisecondsSinceStart
- "Answer the approximate number of milliseconds of real time since the beginning of the score. Since this calculation uses the current tempo, which can change throughout the piece, it is safer to use ticksSinceStart for synchronization."
-
- ^ (secsPerTick * ticksSinceStart * 1000) asInteger
- !
Item was removed:
- ----- Method: ScorePlayer>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Play a number of sounds concurrently. The level of each sound can be set independently for the left and right channels."
-
- | myLeftVol myRightVol someSoundIsDone pair snd trk left right |
- myLeftVol := (leftVol * overallVolume) asInteger.
- myRightVol := (rightVol * overallVolume) asInteger.
- someSoundIsDone := false.
- 1 to: activeSounds size do: [:i |
- pair := activeSounds at: i.
- snd := pair at: 1.
- trk := pair at: 2.
- left := (myLeftVol * (leftVols at: trk)) // ScaleFactor.
- right := (myRightVol * (rightVols at: trk)) // ScaleFactor.
- snd samplesRemaining > 0
- ifTrue: [
- snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right]
- ifFalse: [someSoundIsDone := true]].
-
- someSoundIsDone ifTrue: [
- activeSounds := activeSounds select: [:p | p first samplesRemaining > 0]].
- !
Item was removed:
- ----- Method: ScorePlayer>>mutedForTrack: (in category 'accessing') -----
- mutedForTrack: trackIndex
-
- ^ muted at: trackIndex
- !
Item was removed:
- ----- Method: ScorePlayer>>mutedForTrack:put: (in category 'accessing') -----
- mutedForTrack: trackIndex put: aBoolean
-
- trackIndex > muted size ifTrue: [^ self].
- muted at: trackIndex put: aBoolean.
- aBoolean ifFalse: [^ self].
-
- "silence any currently sounding notes for this track"
- activeSounds do: [:pair |
- pair last = trackIndex ifTrue: [activeSounds remove: pair ifAbsent: []]].
- midiPort ifNotNil: [
- activeMIDINotes do: [:pair |
- pair last = trackIndex ifTrue: [
- pair first endNoteOnMidiPort: midiPort.
- activeMIDINotes remove: pair ifAbsent: []]]].
- !
Item was removed:
- ----- Method: ScorePlayer>>mutedState (in category 'accessing') -----
- mutedState
-
- ^ muted
- !
Item was removed:
- ----- Method: ScorePlayer>>onScore: (in category 'initialization') -----
- onScore: aMIDIScore
-
- | trackCount totalVol incr curr pan |
- score := aMIDIScore.
- trackCount := score tracks size.
- durationInTicks := score durationInTicks.
- instruments := (1 to: trackCount) collect: [:i | FMSound oboe1].
- leftVols := Array new: trackCount.
- rightVols := Array new: trackCount.
- muted := Array new: trackCount withAll: false.
- rate := 1.0.
- repeat := false.
- tempo := 120.0.
-
- trackCount = 0 ifTrue: [^ self].
- 1 to: trackCount do: [:i |
- leftVols at: i put: ScaleFactor // 4.
- rightVols at: i put: ScaleFactor // 4].
-
- "distribute inital panning of tracks left-to-right"
- totalVol := 1.0.
- incr := totalVol / (((trackCount // 2) + 1) * 2).
- curr := 0.
- 1 to: trackCount do: [:t |
- t even
- ifTrue: [pan := curr]
- ifFalse: [
- curr := curr + incr.
- pan := totalVol - curr].
- self panForTrack: t put: pan].
-
- !
Item was removed:
- ----- Method: ScorePlayer>>openMIDIPort (in category 'midi output') -----
- openMIDIPort
-
- midiPort := SimpleMIDIPort openDefault.!
Item was removed:
- ----- Method: ScorePlayer>>openMIDIPort: (in category 'midi output') -----
- openMIDIPort: portNum
- "Open the given MIDI port. Music will be played as MIDI commands to the given MIDI port."
-
- midiPort := SimpleMIDIPort openOnPortNumber: portNum.
- !
Item was removed:
- ----- Method: ScorePlayer>>overallVolume (in category 'accessing') -----
- overallVolume
-
- ^ overallVolume
- !
Item was removed:
- ----- Method: ScorePlayer>>overallVolume: (in category 'accessing') -----
- overallVolume: aNumber
- "Set the overally playback volume to a value between 0.0 (off) and 1.0 (full blast)."
-
- overallVolume := (aNumber asFloat min: 1.0) max: 0.0.
-
- !
Item was removed:
- ----- Method: ScorePlayer>>panForTrack: (in category 'accessing') -----
- panForTrack: i
-
- | left right fullVol pan |
- left := leftVols at: i.
- right := rightVols at: i.
- left = right ifTrue: [^ 0.5]. "centered"
- fullVol := left max: right.
- left < fullVol
- ifTrue: [pan := left asFloat / (2.0 * fullVol)]
- ifFalse: [pan := 1.0 - (right asFloat / (2.0 * fullVol))].
- ^ pan roundTo: 0.001
-
- !
Item was removed:
- ----- Method: ScorePlayer>>panForTrack:put: (in category 'accessing') -----
- panForTrack: trackIndex put: aNumber
- "Set the left-right pan for this track to a value in the range [0.0..1.0], where 0.0 means full-left."
-
- | fullVol pan left right |
- trackIndex > leftVols size ifTrue: [^ self].
- fullVol := (leftVols at: trackIndex) max: (rightVols at: trackIndex).
- pan := (aNumber asFloat min: 1.0) max: 0.0.
- pan <= 0.5
- ifTrue: [ "attenuate right channel"
- left := fullVol.
- right := 2.0 * pan * fullVol]
- ifFalse: [ "attenuate left channel"
- left := 2.0 * (1.0 - pan) * fullVol.
- right := fullVol].
- rightVols at: trackIndex put: right asInteger.
- leftVols at: trackIndex put: left asInteger.
- !
Item was removed:
- ----- Method: ScorePlayer>>pause (in category 'operating') -----
- pause
- "Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning."
-
- score pauseFrom: self.
- super pause.
- activeSounds := activeSounds species new.
- midiPort ifNotNil: [self stopMIDIPlaying].
- !
Item was removed:
- ----- Method: ScorePlayer>>positionInScore (in category 'accessing') -----
- positionInScore
-
- ^ self ticksSinceStart asFloat / (self durationInTicks max: 1)!
Item was removed:
- ----- Method: ScorePlayer>>positionInScore: (in category 'accessing') -----
- positionInScore: pos
-
- self isPlaying ifTrue: [^ self "ignore rude intrusion"].
- ticksSinceStart := pos * durationInTicks.
- done := false.
-
- !
Item was removed:
- ----- Method: ScorePlayer>>postCopy (in category 'copying') -----
- postCopy
- "Copy my component sounds."
-
- super postCopy.
- self copySounds
- !
Item was removed:
- ----- Method: ScorePlayer>>processAllAtTick: (in category 'sound generation') -----
- processAllAtTick: scoreTick
-
- self processTempoMapAtTick: scoreTick.
- midiPort
- ifNil: [self processNoteEventsAtTick: scoreTick]
- ifNotNil: [self processMIDIEventsAtTick: scoreTick].
- self processAmbientEventsAtTick: scoreTick.
- self isDone ifTrue: [
- repeat
- ifTrue: [self reset]
- ifFalse: [done := true]].
- !
Item was removed:
- ----- Method: ScorePlayer>>processAmbientEventsAtTick: (in category 'sound generation') -----
- processAmbientEventsAtTick: scoreTick
- "Process ambient events through the given tick."
-
- | i evt |
- i := trackEventIndex at: trackEventIndex size.
- [evt := score ambientEventAfter: i ticks: scoreTick.
- evt ~~ nil] whileTrue: [
- i := i + 1.
- evt occurAtTime: scoreTick inScorePlayer: self atIndex: i inEventTrack: score ambientTrack secsPerTick: secsPerTick].
- trackEventIndex at: trackEventIndex size put: i.
- !
Item was removed:
- ----- Method: ScorePlayer>>processMIDIEventsAtTick: (in category 'midi output') -----
- processMIDIEventsAtTick: scoreTick
- "Process note events through the given score tick using MIDI."
-
- | j evt |
- 1 to: score tracks size do: [:i |
- j := trackEventIndex at: i.
- [evt := score eventForTrack: i after: j ticks: scoreTick.
- evt ~~ nil] whileTrue: [
- evt isNoteEvent
- ifTrue: [
- (muted at: i) ifFalse: [
- evt startNoteOnMidiPort: midiPort.
- activeMIDINotes add: (Array with: evt with: i)]]
- ifFalse: [evt outputOnMidiPort: midiPort].
- j := j + 1.
- trackEventIndex at: i put: j]].
- self turnOffActiveMIDINotesAt: scoreTick.
- !
Item was removed:
- ----- Method: ScorePlayer>>processNoteEventsAtTick: (in category 'sound generation') -----
- processNoteEventsAtTick: scoreTick
- "Process note events through the given score tick using internal Squeak sound synthesis."
-
- | instr j evt snd |
- 1 to: score tracks size do: [:i |
- instr := instruments at: i.
- j := trackEventIndex at: i.
- [evt := score eventForTrack: i after: j ticks: scoreTick.
- evt ~~ nil] whileTrue: [
- (evt isNoteEvent and: [(muted at: i) not]) ifTrue: [
- snd := instr
- soundForMidiKey: evt midiKey
- dur: secsPerTick * evt duration
- loudness: evt velocity asFloat / 127.0.
- activeSounds add: (Array with: snd with: i)].
- j := j + 1.
- trackEventIndex at: i put: j]].
- !
Item was removed:
- ----- Method: ScorePlayer>>processTempoMapAtTick: (in category 'sound generation') -----
- processTempoMapAtTick: scoreTick
- "Process tempo changes through the given score tick."
-
- | map tempoChanged |
- map := score tempoMap.
- map ifNil: [^ self].
- tempoChanged := false.
- [(tempoMapIndex <= map size) and:
- [(map at: tempoMapIndex) time <= scoreTick]] whileTrue: [
- tempoChanged := true.
- tempoMapIndex := tempoMapIndex + 1].
-
- tempoChanged ifTrue: [
- tempo := (120.0 * (500000.0 / (map at: tempoMapIndex - 1) tempo)) roundTo: 0.01.
- self tempoOrRateChanged].
-
- !
Item was removed:
- ----- Method: ScorePlayer>>rate (in category 'accessing') -----
- rate
-
- ^ rate
- !
Item was removed:
- ----- Method: ScorePlayer>>rate: (in category 'accessing') -----
- rate: aNumber
- "Set the playback rate. For example, a rate of 2.0 will playback at twice normal speed."
-
- rate := aNumber asFloat.
- self tempoOrRateChanged.
- !
Item was removed:
- ----- Method: ScorePlayer>>repeat (in category 'accessing') -----
- repeat
- "Return true if this player will repeat when it gets to the end of the score, false otherwise."
-
- ^ repeat
- !
Item was removed:
- ----- Method: ScorePlayer>>repeat: (in category 'accessing') -----
- repeat: aBoolean
- "Turn repeat mode on or off."
-
- repeat := aBoolean.
- !
Item was removed:
- ----- Method: ScorePlayer>>reset (in category 'sound generation') -----
- reset
-
- super reset.
- tempo := 120.0.
- self tempoOrRateChanged.
- done := false.
- ticksSinceStart := 0.
- "one index for each sound track, plus one for the ambient track..."
- trackEventIndex := Array new: score tracks size+1 withAll: 1.
- tempoMapIndex := 1.
- activeSounds := OrderedCollection new.
- activeMIDINotes := OrderedCollection new.
- score resetFrom: self.
- overallVolume ifNil: [overallVolume := 0.5].
- !
Item was removed:
- ----- Method: ScorePlayer>>resumePlaying (in category 'operating') -----
- resumePlaying
- "Resume playing. Start over if done."
-
- done ifTrue: [self reset].
- self jumpToTick: ticksSinceStart. "Play up to here in case we got scrolled to new position."
- score resumeFrom: self.
- midiPort
- ifNil: [super resumePlaying] "let the sound player drive sound generation"
- ifNotNil: [self startMIDIPlaying]. "start a process to drive MIDI output"
- !
Item was removed:
- ----- Method: ScorePlayer>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
-
- done
- ifTrue: [^ 0]
- ifFalse: [^ 1000000].
- !
Item was removed:
- ----- Method: ScorePlayer>>score (in category 'accessing') -----
- score
-
- ^ score
- !
Item was removed:
- ----- Method: ScorePlayer>>secsPerTick (in category 'accessing') -----
- secsPerTick
-
- ^ secsPerTick!
Item was removed:
- ----- Method: ScorePlayer>>settingsString (in category 'accessing') -----
- settingsString
-
- | s |
- s := WriteStream on: (String new: 1000).
- s nextPutAll: 'player'; cr.
- s tab; nextPutAll: 'rate: ', self rate printString, ';'; cr.
- s tab; nextPutAll: 'overallVolume: ', self overallVolume printString, ';'; cr.
- 1 to: self trackCount do: [:t |
- s tab; nextPutAll: 'instrumentForTrack: ', t printString,
- ' put: (AbstractSound soundNamed: #default);'; cr.
- s tab; nextPutAll: 'mutedForTrack: ', t printString,
- ' put: ', (self mutedForTrack: t) printString, ';'; cr.
- s tab; nextPutAll: 'volumeForTrack: ', t printString,
- ' put: ', (self volumeForTrack: t) printString, ';'; cr.
- s tab; nextPutAll: 'panForTrack: ', t printString,
- ' put: ', (self panForTrack: t) printString, ';'; cr].
- s tab; nextPutAll: 'repeat: ', self repeat printString, '.'; cr.
- ^ s contents
- !
Item was removed:
- ----- Method: ScorePlayer>>skipAmbientEventsThruTick: (in category 'sound generation') -----
- skipAmbientEventsThruTick: startTick
- "Skip ambient events through the given score tick."
-
- score ambientTrack withIndexDo:
- [:evt :i | evt time > startTick ifTrue:
- [^ trackEventIndex at: trackEventIndex size put: i]].
- !
Item was removed:
- ----- Method: ScorePlayer>>skipNoteEventsThruTick: (in category 'sound generation') -----
- skipNoteEventsThruTick: startTick
- "Skip note events through the given score tick using internal Squeak sound synthesis."
-
- | j evt |
- 1 to: score tracks size do: [:i |
- j := trackEventIndex at: i.
- [evt := score eventForTrack: i after: j ticks: startTick.
- evt == nil] whileFalse: [
- evt isNoteEvent
- ifTrue: [
- (((evt time + evt duration) > startTick) and: [(muted at: i) not]) ifTrue: [
- self startNote: evt forStartTick: startTick trackIndex: i]]
- ifFalse: [
- midiPort == nil ifFalse: [evt outputOnMidiPort: midiPort]].
- j := j + 1].
- trackEventIndex at: i put: j].
- !
Item was removed:
- ----- Method: ScorePlayer>>startMIDIPlaying (in category 'midi output') -----
- startMIDIPlaying
- "Start up a process to play this score via MIDI."
-
- midiPort ensureOpen.
- midiPlayerProcess ifNotNil: [midiPlayerProcess terminate].
- midiPlayerProcess := [self midiPlayLoop] newProcess.
- midiPlayerProcess
- name: 'Score Player (', self score printString, ')';
- priority: Processor userInterruptPriority;
- resume.
- !
Item was removed:
- ----- Method: ScorePlayer>>startNote:forStartTick:trackIndex: (in category 'sound generation') -----
- startNote: noteEvent forStartTick: startTick trackIndex: trackIndex
- "Prepare a note to begin playing at the given tick. Used to start playing at an arbitrary point in the score. Handle both MIDI and built-in synthesis cases."
-
- | snd |
- midiPort
- ifNil: [
- snd := (instruments at: trackIndex)
- soundForMidiKey: noteEvent midiKey
- dur: secsPerTick * (noteEvent endTime - startTick)
- loudness: noteEvent velocity asFloat / 127.0.
- activeSounds add: (Array with: snd with: trackIndex)]
- ifNotNil: [
- noteEvent startNoteOnMidiPort: midiPort.
- activeMIDINotes add: (Array with: noteEvent with: trackIndex)].
- !
Item was removed:
- ----- Method: ScorePlayer>>stopMIDIPlaying (in category 'midi output') -----
- stopMIDIPlaying
- "Terminate the MIDI player process and turn off any active notes."
-
- midiPlayerProcess ifNotNil: [midiPlayerProcess terminate].
- midiPlayerProcess := nil.
- activeMIDINotes do: [:pair | pair first endNoteOnMidiPort: midiPort].
- activeMIDINotes := activeMIDINotes species new.
- !
Item was removed:
- ----- Method: ScorePlayer>>tempo (in category 'accessing') -----
- tempo
- "Return the current tempo in beats (quarter notes) per minute. The tempo at any given moment is defined by the score and cannot be changed by the client. To change the playback speed, the client may change the rate parameter."
-
- ^ tempo
- !
Item was removed:
- ----- Method: ScorePlayer>>tempoOrRateChanged (in category 'operating') -----
- tempoOrRateChanged
- "This method should be called after changing the tempo or rate."
-
- secsPerTick := 60.0 / (tempo * rate * score ticksPerQuarterNote).
- ticksClockIncr := (1.0 / self controlRate) / secsPerTick.
- !
Item was removed:
- ----- Method: ScorePlayer>>ticksForMSecs: (in category 'accessing') -----
- ticksForMSecs: mSecs
-
- ^ (mSecs asFloat / (1000.0 * secsPerTick)) rounded
- !
Item was removed:
- ----- Method: ScorePlayer>>ticksSinceStart (in category 'accessing') -----
- ticksSinceStart
- "Answer the number of score ticks that have elapsed since this piece started playing. The duration of a tick is determined by the MIDI score."
-
- ^ ticksSinceStart
- !
Item was removed:
- ----- Method: ScorePlayer>>ticksSinceStart: (in category 'accessing') -----
- ticksSinceStart: newTicks
- "Adjust ticks to folow, eg, piano roll autoscrolling"
-
- self isPlaying ifFalse: [ticksSinceStart := newTicks]
- !
Item was removed:
- ----- Method: ScorePlayer>>trackCount (in category 'accessing') -----
- trackCount
-
- ^ score tracks size
- !
Item was removed:
- ----- Method: ScorePlayer>>turnOffActiveMIDINotesAt: (in category 'midi output') -----
- turnOffActiveMIDINotesAt: scoreTick
- "Turn off any active MIDI notes that should be turned off at the given score tick."
-
- | someNoteEnded |
- midiPort ifNil: [^ self].
- someNoteEnded := false.
- activeMIDINotes do: [:pair | | evt |
- evt := pair first.
- evt endTime <= scoreTick ifTrue: [
- evt endNoteOnMidiPort: midiPort.
- someNoteEnded := true]].
-
- someNoteEnded ifTrue: [
- activeMIDINotes := activeMIDINotes select: [:p | p first endTime > scoreTick]].
- !
Item was removed:
- ----- Method: ScorePlayer>>updateDuration (in category 'initialization') -----
- updateDuration
-
- durationInTicks := score durationInTicks.
- !
Item was removed:
- ----- Method: ScorePlayer>>volumeForTrack: (in category 'accessing') -----
- volumeForTrack: i
-
- | vol |
- vol := (leftVols at: i) max: (rightVols at: i).
- ^ (vol asFloat / ScaleFactor) roundTo: 0.0001
- !
Item was removed:
- ----- Method: ScorePlayer>>volumeForTrack:put: (in category 'accessing') -----
- volumeForTrack: trackIndex put: aNumber
-
- | newVol oldLeft oldRight oldFullVol left right |
- trackIndex > leftVols size ifTrue: [^ self].
- newVol := ((aNumber asFloat max: 0.0) min: 1.0) * ScaleFactor.
- oldLeft := leftVols at: trackIndex.
- oldRight := rightVols at: trackIndex.
- oldFullVol := oldLeft max: oldRight.
- oldFullVol = 0 ifTrue: [oldFullVol := 1.0].
- oldLeft < oldFullVol
- ifTrue: [
- left := newVol * oldLeft / oldFullVol.
- right := newVol]
- ifFalse: [
- left := newVol.
- right := newVol * oldRight / oldFullVol].
- leftVols at: trackIndex put: left asInteger.
- rightVols at: trackIndex put: right asInteger.
- !
Item was removed:
- AbstractSound subclass: #SequentialSound
- instanceVariableNames: 'sounds currentIndex'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: SequentialSound>>, (in category 'composition') -----
- , aSound
- "Return the concatenation of the receiver and the argument sound."
-
- ^ self add: aSound
- !
Item was removed:
- ----- Method: SequentialSound>>add: (in category 'composition') -----
- add: aSound
-
- sounds := sounds copyWith: aSound.
- ^aSound
- !
Item was removed:
- ----- Method: SequentialSound>>compressWith: (in category 'composition') -----
- compressWith: codecClass
- ^ self copy transformSounds: [:s | s compressWith: codecClass]!
Item was removed:
- ----- Method: SequentialSound>>compressWith:atRate: (in category 'composition') -----
- compressWith: codecClass atRate: aSamplingRate
- ^ self copy transformSounds: [:s | s compressWith: codecClass atRate: aSamplingRate]!
Item was removed:
- ----- Method: SequentialSound>>copySounds (in category 'copying') -----
- copySounds
- "Private!! Support for copying. Copy my component sounds."
-
- sounds := sounds collect: [:s | s copy].
- !
Item was removed:
- ----- Method: SequentialSound>>doControl (in category 'sound generation') -----
- doControl
-
- super doControl.
- currentIndex > 0
- ifTrue: [(sounds at: currentIndex) doControl].
- !
Item was removed:
- ----- Method: SequentialSound>>duration (in category 'accessing') -----
- duration
- "Answer the duration of this sound in seconds."
-
- "7 dec 2000 - handle compressed sounds. better way??"
-
- ^sounds inject: 0 into: [:totalDuration :snd | totalDuration + snd asSound duration]!
Item was removed:
- ----- Method: SequentialSound>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- sounds := Array new.
- currentIndex := 0.
- !
Item was removed:
- ----- Method: SequentialSound>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'sound generation') -----
- mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
- "Play a collection of sounds in sequence."
- "PluckedSound chromaticScale play"
-
- | finalIndex i snd remaining count leftScaledVol rightScaledVol |
- currentIndex = 0 ifTrue: [^ self]. "already done"
-
- leftScaledVol := leftVol * scaledVol / ScaleFactor asFloat.
- rightScaledVol := rightVol * scaledVol / ScaleFactor asFloat.
-
- finalIndex := (startIndex + n) - 1.
- i := startIndex.
- [i <= finalIndex] whileTrue: [
- snd := (sounds at: currentIndex).
- [(remaining := snd samplesRemaining) <= 0] whileTrue: [
- "find next undone sound"
- currentIndex < sounds size
- ifTrue: [
- currentIndex := currentIndex + 1.
- snd := (sounds at: currentIndex)]
- ifFalse: [
- currentIndex := 0.
- ^ self]]. "no more sounds"
- count := (finalIndex - i) + 1.
- remaining < count ifTrue: [count := remaining].
- snd mixSampleCount: count into: aSoundBuffer startingAt: i
- leftVol: leftScaledVol
- rightVol: rightScaledVol.
- i := i + count].
- !
Item was removed:
- ----- Method: SequentialSound>>postCopy (in category 'copying') -----
- postCopy
- "Copy my component sounds."
-
- super postCopy.
- self copySounds
- !
Item was removed:
- ----- Method: SequentialSound>>pruneFinishedSounds (in category 'composition') -----
- pruneFinishedSounds
- "Remove any sounds that have been completely played."
-
- | newSnds |
- (currentIndex > 1 and: [currentIndex < sounds size]) ifFalse: [^ self].
- newSnds := sounds copyFrom: currentIndex to: sounds size.
- currentIndex := 1.
- sounds := newSnds.
- !
Item was removed:
- ----- Method: SequentialSound>>removeFirstCompleteSoundOrNil (in category 'composition') -----
- removeFirstCompleteSoundOrNil
- "Remove the first sound if it has been completely recorded."
-
- | firstSound |
-
- sounds size > 0 ifFalse: [^ nil].
- firstSound := sounds first.
- sounds := sounds copyFrom: 2 to: sounds size.
- ^firstSound
- !
Item was removed:
- ----- Method: SequentialSound>>reset (in category 'sound generation') -----
- reset
-
- super reset.
- sounds do: [:snd | snd reset].
- sounds size > 0 ifTrue: [currentIndex := 1].
- !
Item was removed:
- ----- Method: SequentialSound>>samplesRemaining (in category 'sound generation') -----
- samplesRemaining
-
- currentIndex = 0
- ifTrue: [^ 0]
- ifFalse: [^ 1000000].
- !
Item was removed:
- ----- Method: SequentialSound>>sounds (in category 'accessing') -----
- sounds
-
- ^ sounds
- !
Item was removed:
- ----- Method: SequentialSound>>transformSounds: (in category 'copying') -----
- transformSounds: tfmBlock
- "Private!! Support for copying. Copy my component sounds."
-
- sounds := sounds collect: tfmBlock
- !
Item was removed:
- Object subclass: #SimpleMIDIPort
- instanceVariableNames: 'portNumber accessSema lastCommandByteOut'
- classVariableNames: 'DefaultPortNumber InterfaceClockRate UseMIDIDeviceForOutput'
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !SimpleMIDIPort commentStamp: '<historical>' prior: 0!
- This is a first cut at a simple MIDI output port.
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>anyPortNumFromUser (in category 'utilities') -----
- anyPortNumFromUser
-
- ^ UIManager default
- chooseFrom: ((0 to: self primPortCount - 1) collect:[:i| self portDescription: i])
- values: (0 to: self primPortCount - 1)
- title: 'MIDI port for default usage:' translated
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>askForDefault (in category 'utilities') -----
- askForDefault
- "self askForDefault"
-
- self anyPortNumFromUser ifNotNil: [:num |
- DefaultPortNumber := num].!
Item was removed:
- ----- Method: SimpleMIDIPort class>>closeAllPorts (in category 'utilities') -----
- closeAllPorts
- "Close all MIDI ports."
- "SimpleMIDIPort closeAllPorts"
-
- | lastPortNum |
- lastPortNum := self primPortCount - 1.
- 0 to: lastPortNum do: [:portNum | self basicNew primMIDIClosePort: portNum].
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>examplePlayNoteNamedVelocityOnChannel (in category 'examples') -----
- examplePlayNoteNamedVelocityOnChannel
- "self examplePlayNoteNamedVelocityOnChannel"
-
- |aPort|
- aPort:= self openOnPortNumber: 0.
- #('Bottle Blow' 'Shakuhachi' 'Whistle' 'Ocarina' 'Lead 1 (square)' 'Lead 2 (sawtooth)' 'Lead 3 (caliope lead)' 'Lead 4 (chiff lead)' 'Lead 5 (charang)' 'Lead 6 (voice)' 'Lead 7 (fifths)' 'Lead 8 (brass + lead)' 'Pad 1 (new age)' 'Pad 2 (warm)' 'Pad 3 (polysynth)' 'Pad 4 (choir)' 'Pad 5 (bowed)' 'Pad 6 (metallic)' 'Pad 7 (halo)' 'Pad 8 (sweep)' 'FX 1 (rain)' 'FX 2 (soundtrack)' 'FX 3 (crystal)' 'FX 4 (atmosphere)' 'FX 5 (brightness)' 'FX 6 (goblins)' 'FX 7 (echoes)' 'FX 8 (sci-fi)' 'Sitar' 'Banjo' 'Shamisen' 'Koto' 'Kalimba' 'Bagpipe' 'Fiddle' 'Shanai' 'Tinkle Bell' 'Agogo' 'Steel Drums' 'Woodblock' 'Taiko Drum' 'Melodic Tom' 'Synth Drum' 'Reverse Cymbal' 'Guitar Fret Noise' 'Breath Noise' 'Seashore' 'Bird Tweet' 'Telephone Ring' 'Helicopter' 'Applause' 'Gunshot' ) do: [:anInstrumentName |
- [aPort useInstrument: anInstrumentName onChannel: 0.
- aPort playNoteNamed: 'c4' onChannel: 0.
- (Delay forMilliseconds: 250) wait.
- aPort stopNoteNamed: 'c4' onChannel: 0] ensure: [aPort close]]!
Item was removed:
- ----- Method: SimpleMIDIPort class>>initialize (in category 'class initialization') -----
- initialize
- "SimpleMIDIPort initialize"
-
- InterfaceClockRate := 1000000.
- DefaultPortNumber := 0.
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>inputPortNumFromUser (in category 'utilities') -----
- inputPortNumFromUser
- "Prompt the user for a MIDI input port. Answer a port number, or nil if the user does not select a port or if MIDI is not supported on this platform."
- "SimpleMIDIPort inputPortNumFromUser"
-
- | portCount dir portList |
- portCount := self primPortCount.
- portCount = 0 ifTrue: [^ nil].
- portList := OrderedCollection new.
- 0 to: portCount - 1 do:[:i |
- dir := self primPortDirectionalityOf: i.
- (dir = 1) | (dir = 3) ifTrue:[portList add: i]].
- ^UIManager default
- chooseFrom: (portList collect:[:i| self portDescription: i])
- values: portList
- title: 'MIDI port for input:' translated
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>midiInstruments (in category 'utilities') -----
- midiInstruments
- "self midiInstruments"
- ^ #('Acoustic Grand Piano' 'Bright Acoustic Piano' 'Electric Grand Piano' 'Honky-tonk Piano' 'Rhodes Piano' 'Chorused Piano' 'Harpsichord' 'Clavinet' 'Celesta' 'Glockenspiel' 'Music box' 'Vibraphone' 'Marimba' 'Xylophone' 'Tubular Bells' 'Dulcimer' 'Hammond Organ' 'Percussive Organ' 'Rock Organ' 'Church Organ' 'Reed Organ' 'Accordian' 'Harmonica' 'Tango Accordian' 'Acoustic Guitar (nylon)' 'Acoustic Guitar (steel)' 'Electric Guitar (jazz)' 'Electric Guitar (clean)' 'Electric Guitar (muted)' 'Overdriven Guitar' 'Distortion Guitar' 'Guitar Harmonics' 'Acoustic Bass' 'Electric Bass (finger)' 'Electric Bass (pick)' 'Fretless Bass' 'Slap Bass 1' 'Slap Bass 2' 'Synth Bass 1' 'Synth Bass 2' 'Violin' 'Viola' 'Cello' 'Contrabass' 'Tremolo Strings' 'Pizzicato Strings' 'Orchestral Harp' 'Timpani' 'String Ensemble 1' 'String Ensemble 2' 'Synth Strings 1' 'Synth Strings 2' 'Choir Aahs' 'Voice Oohs' 'Synth Voice' 'Orchestra Hit' 'Trumpet' 'Trombone' 'Tuba' 'Muted Trumpet' 'French Horn' 'Brass S
ection' 'Synth Brass 1' 'Synth Brass 2' 'Soprano Sax' 'Alto Sax' 'Tenor Sax' 'Baritone Sax' 'Oboe' 'English Horn' 'Bassoon' 'Clarinet' 'Piccolo' 'Flute' 'Recorder' 'Pan Flute' 'Bottle Blow' 'Shakuhachi' 'Whistle' 'Ocarina' 'Lead 1 (square)' 'Lead 2 (sawtooth)' 'Lead 3 (caliope lead)' 'Lead 4 (chiff lead)' 'Lead 5 (charang)' 'Lead 6 (voice)' 'Lead 7 (fifths)' 'Lead 8 (brass + lead)' 'Pad 1 (new age)' 'Pad 2 (warm)' 'Pad 3 (polysynth)' 'Pad 4 (choir)' 'Pad 5 (bowed)' 'Pad 6 (metallic)' 'Pad 7 (halo)' 'Pad 8 (sweep)' 'FX 1 (rain)' 'FX 2 (soundtrack)' 'FX 3 (crystal)' 'FX 4 (atmosphere)' 'FX 5 (brightness)' 'FX 6 (goblins)' 'FX 7 (echoes)' 'FX 8 (sci-fi)' 'Sitar' 'Banjo' 'Shamisen' 'Koto' 'Kalimba' 'Bagpipe' 'Fiddle' 'Shanai' 'Tinkle Bell' 'Agogo' 'Steel Drums' 'Woodblock' 'Taiko Drum' 'Melodic Tom' 'Synth Drum' 'Reverse Cymbal' 'Guitar Fret Noise' 'Breath Noise' 'Seashore' 'Bird Tweet' 'Telephone Ring' 'Helicopter' 'Applause' 'Gunshot' )!
Item was removed:
- ----- Method: SimpleMIDIPort class>>midiIsSupported (in category 'utilities') -----
- midiIsSupported
- "Answer true if this platform supports MIDI."
-
- ^ self primPortCount > 0
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>openDefault (in category 'instance creation') -----
- openDefault
- "Answer a new instance of me opened on the default MIDI port."
-
- ^ self openOnPortNumber: DefaultPortNumber
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>openOnPortNumber: (in category 'instance creation') -----
- openOnPortNumber: portNum
- "Answer a new instance of me for the given MIDI port number."
- "Details: All clients of a particular MIDI port should share the same instance of me. This allows accesses to the port to be serialized and shared port-related state state to be maintained."
-
- SimpleMIDIPort allSubInstancesDo: [:p |
- p portNumber = portNum ifTrue: [
- "share the existing port object for this port number"
- ^ p]].
-
- ^ super new openOnPortNumber: portNum
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>outputPortNumFromUser (in category 'utilities') -----
- outputPortNumFromUser
- "Prompt the user for a MIDI output port. Answer a port number, or nil if the user does not select a port or if MIDI is not supported on this platform."
- "SimpleMIDIPort outputPortNumFromUser"
-
- | portCount dir portList |
- portCount := self primPortCount.
- portCount = 0 ifTrue: [^ nil].
- portList := OrderedCollection new.
- 0 to: portCount - 1 do:[:i |
- dir := self primPortDirectionalityOf: i.
- (dir = 2) | (dir = 3) ifTrue:[portList add: i]].
- ^UIManager default
- chooseFrom: (portList collect:[:i| self portDescription: i])
- values: portList
- title: 'MIDI port for output:' translated.
-
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>percussionInstruments (in category 'utilities') -----
- percussionInstruments
- "self percussionInstruments"
- ^ #('Bottle Blow' 'Shakuhachi' 'Whistle' 'Ocarina' 'Lead 1 (square)' 'Lead 2 (sawtooth)' 'Lead 3 (caliope lead)' 'Lead 4 (chiff lead)' 'Lead 5 (charang)' 'Lead 6 (voice)' 'Lead 7 (fifths)' 'Lead 8 (brass + lead)' 'Pad 1 (new age)' 'Pad 2 (warm)' 'Pad 3 (polysynth)' 'Pad 4 (choir)' 'Pad 5 (bowed)' 'Pad 6 (metallic)' 'Pad 7 (halo)' 'Pad 8 (sweep)' 'FX 1 (rain)' 'FX 2 (soundtrack)' 'FX 3 (crystal)' 'FX 4 (atmosphere)' 'FX 5 (brightness)' 'FX 6 (goblins)' 'FX 7 (echoes)' 'FX 8 (sci-fi)' 'Sitar' 'Banjo' 'Shamisen' 'Koto' 'Kalimba' 'Bagpipe' 'Fiddle' 'Shanai' 'Tinkle Bell' 'Agogo' 'Steel Drums' 'Woodblock' 'Taiko Drum' 'Melodic Tom' 'Synth Drum' 'Reverse Cymbal' 'Guitar Fret Noise' 'Breath Noise' 'Seashore' 'Bird Tweet' 'Telephone Ring' 'Helicopter' 'Applause' 'Gunshot' )!
Item was removed:
- ----- Method: SimpleMIDIPort class>>portDescription: (in category 'utilities') -----
- portDescription: portNum
- "Answer a string indicating the directionality of the given MIDI port."
- "(0 to: SimpleMIDIPort primPortCount - 1) collect:
- [:i | SimpleMIDIPort portDescription: i]"
-
- | portName dir |
- portName := (self primPortNameOf: portNum) convertFromSystemString.
- dir := self primPortDirectionalityOf: portNum.
- dir = 1 ifTrue: [^ portName, ' (in)'].
- dir = 2 ifTrue: [^ portName, ' (out)'].
- dir = 3 ifTrue: [^ portName, ' (in/out)'].
- ^ self error: 'unknown MIDI port directionality'
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>primPortCount (in category 'primitives') -----
- primPortCount
- "Answer the number of MIDI ports supported by this platform, or zero if this primitive is not implemented."
-
- <primitive: 'primitiveMIDIGetPortCount' module: 'MIDIPlugin'>
- ^ 0
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>primPortDirectionalityOf: (in category 'primitives') -----
- primPortDirectionalityOf: portNum
- "Answer the platform-specific name for the given MIDI port."
-
- <primitive: 'primitiveMIDIGetPortDirectionality' module: 'MIDIPlugin'>
- self primitiveFailed.
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>primPortNameOf: (in category 'primitives') -----
- primPortNameOf: portNum
- "Answer the platform-specific name for the given MIDI port."
-
- <primitive: 'primitiveMIDIGetPortName' module: 'MIDIPlugin'>
- self primitiveFailed.
- !
Item was removed:
- ----- Method: SimpleMIDIPort class>>useMIDIDeviceForOutput (in category 'preferences') -----
- useMIDIDeviceForOutput
-
- <preference: 'Use MIDI device for output'
- category: #media
- description: 'If true, will try to open a native MIDI device when playing MIDI scores.'
- type: #Boolean>
- ^ UseMIDIDeviceForOutput ifNil: [false]!
Item was removed:
- ----- Method: SimpleMIDIPort class>>useMIDIDeviceForOutput: (in category 'preferences') -----
- useMIDIDeviceForOutput: boolean
-
- UseMIDIDeviceForOutput := boolean.!
Item was removed:
- ----- Method: SimpleMIDIPort>>bufferTimeStampFrom: (in category 'input') -----
- bufferTimeStampFrom: aByteArray
- "Return the timestamp from the given MIDI input buffer. Assume the given buffer is at least 4 bytes long."
-
- ^ ((aByteArray at: 1) bitShift: 24) +
- ((aByteArray at: 2) bitShift: 16) +
- ((aByteArray at: 3) bitShift: 8) +
- (aByteArray at: 4)
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>close (in category 'open/close') -----
- close
- "Close this MIDI port."
-
- portNumber ifNotNil: [self primMIDIClosePort: portNumber].
- accessSema := nil.
- lastCommandByteOut := nil.
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>ensureOpen (in category 'open/close') -----
- ensureOpen
- "Make sure this MIDI port is open. It is good to call this before starting to use a port in case an intervening image save/restore has caused the underlying hardware port to get closed."
-
- portNumber ifNil: [^ self error: 'Use "openOn:" to open a MIDI port initially'].
- self primMIDIClosePort: portNumber.
- self primMIDIOpenPort: portNumber readSemaIndex: 0 interfaceClockRate: InterfaceClockRate.
- accessSema := Semaphore forMutualExclusion.
- lastCommandByteOut := Array new: 16 withAll: 0. "clear running status"
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>flushInput (in category 'input') -----
- flushInput
- "Read any lingering MIDI data from this port's input buffer."
-
- | buf |
- buf := ByteArray new: 1000.
- [(self readInto: buf) > 0] whileTrue.
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>midiCmd:channel:byte: (in category 'output') -----
- midiCmd: cmd channel: channel byte: dataByte
- "Immediately output the given MIDI command with the given channel and argument byte to this MIDI port. Assume that the port is open."
-
- accessSema critical: [
- self primMIDIWritePort: portNumber
- from: (ByteArray
- with: (cmd bitOr: channel)
- with: dataByte)
- at: 0].
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>midiCmd:channel:byte:byte: (in category 'output') -----
- midiCmd: cmd channel: channel byte: dataByte1 byte: dataByte2
- "Immediately output the given MIDI command with the given channel and argument bytes to this MIDI port. Assume that the port is open."
-
- accessSema critical: [
- self primMIDIWritePort: portNumber
- from: (ByteArray
- with: (cmd bitOr: channel)
- with: dataByte1
- with: dataByte2)
- at: 0].
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>midiOutput: (in category 'output') -----
- midiOutput: aByteArray
- "Output the given bytes to this MIDI port immediately. Assume that the port is open."
-
- accessSema critical: [
- self primMIDIWritePort: portNumber from: aByteArray at: 0].
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>openOnPortNumber: (in category 'open/close') -----
- openOnPortNumber: portNum
- "Open this MIDI port on the given port number."
-
- self close.
- portNumber := portNum.
- accessSema := Semaphore forMutualExclusion.
- self ensureOpen.
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>playNote:onChannel: (in category 'primitives') -----
- playNote: aNote onChannel: aChannel
- self playNote: aNote velocity: 64 onChannel: aChannel!
Item was removed:
- ----- Method: SimpleMIDIPort>>playNote:velocity:onChannel: (in category 'primitives') -----
- playNote: aNote velocity: aVel onChannel: aChannel
- self midiCmd: 144 channel: aChannel byte: aNote byte: aVel!
Item was removed:
- ----- Method: SimpleMIDIPort>>playNoteNamed:onChannel: (in category 'primitives') -----
- playNoteNamed: aNotename onChannel: aChannel
- self playNoteNamed: aNotename velocity: 64 onChannel: aChannel!
Item was removed:
- ----- Method: SimpleMIDIPort>>playNoteNamed:velocity:onChannel: (in category 'primitives') -----
- playNoteNamed: aNotename velocity: aVel onChannel: aChannel
- self playNote: (AbstractSound midiKeyForPitch: aNotename) velocity: aVel onChannel: aChannel
-
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>portNumber (in category 'open/close') -----
- portNumber
- "Answer my port number."
-
- ^ portNumber
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>primMIDIClosePort: (in category 'primitives') -----
- primMIDIClosePort: portNum
- "Close the given MIDI port. Don't fail if port is already closed."
-
- <primitive: 'primitiveMIDIClosePort' module: 'MIDIPlugin'>
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>primMIDIOpenPort:readSemaIndex:interfaceClockRate: (in category 'primitives') -----
- primMIDIOpenPort: portNum readSemaIndex: readSemaIndex interfaceClockRate: interfaceClockRate
- "Open the given MIDI port. If non-zero, readSemaIndex specifies the index in the external objects array of a semaphore to be signalled when incoming MIDI data is available. Not all platforms support signalling the read semaphore. InterfaceClockRate specifies the clock rate of the external MIDI interface adaptor on Macintosh computers; it is ignored on other platforms."
-
- <primitive: 'primitiveMIDIOpenPort' module: 'MIDIPlugin'>
- self primitiveFailed.
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>primMIDIReadPort:into: (in category 'primitives') -----
- primMIDIReadPort: portNum into: byteArray
- "Read any available MIDI data into the given buffer (up to the size of the buffer) and answer the number of bytes read."
-
- <primitive: 'primitiveMIDIRead' module: 'MIDIPlugin'>
- self primitiveFailed.
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>primMIDIWritePort:from:at: (in category 'primitives') -----
- primMIDIWritePort: portNum from: byteArray at: midiClockValue
- "Queue the given data to be sent through the given MIDI port at the given time. If midiClockValue is zero, send the data immediately."
-
- <primitive: 'primitiveMIDIWrite' module: 'MIDIPlugin'>
- self primitiveFailed.
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>readInto: (in category 'input') -----
- readInto: aByteArray
- "Read any data from this port into the given buffer."
-
- ^ self primMIDIReadPort: portNumber into: aByteArray
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>stopNote:onChannel: (in category 'primitives') -----
- stopNote: aNote onChannel: aChannel
- self stopNote: aNote velocity: 64 onChannel: aChannel!
Item was removed:
- ----- Method: SimpleMIDIPort>>stopNote:velocity:onChannel: (in category 'primitives') -----
- stopNote: aNote velocity: aVel onChannel: aChannel
- self midiCmd: 128 channel: aChannel byte: aNote byte: aVel!
Item was removed:
- ----- Method: SimpleMIDIPort>>stopNoteNamed:onChannel: (in category 'primitives') -----
- stopNoteNamed: aNotename onChannel: aChannel
- self stopNoteNamed: aNotename velocity: 64 onChannel: aChannel!
Item was removed:
- ----- Method: SimpleMIDIPort>>stopNoteNamed:velocity:onChannel: (in category 'primitives') -----
- stopNoteNamed: aNotename velocity: aVel onChannel: aChannel
- self stopNote: (AbstractSound midiKeyForPitch: aNotename) velocity: aVel onChannel: aChannel
- !
Item was removed:
- ----- Method: SimpleMIDIPort>>useInstrument:onChannel: (in category 'open/close') -----
- useInstrument: aName onChannel: aChannel
- self useInstrumentNumber: (self class midiInstruments indexOf: aName)-1 onChannel: aChannel!
Item was removed:
- ----- Method: SimpleMIDIPort>>useInstrumentNumber:onChannel: (in category 'open/close') -----
- useInstrumentNumber: aNumber onChannel: aChannel
- self ensureOpen.
- self midiCmd: 192 channel: aChannel byte: aNumber !
Item was removed:
- ArrayedCollection variableWordSubclass: #SoundBuffer
- instanceVariableNames: ''
- classVariableNames: 'SineTable'
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !SoundBuffer commentStamp: '<historical>' prior: 0!
- SoundBuffers store 16 bit unsigned quantities. !
Item was removed:
- ----- Method: SoundBuffer class>>averageEvery:from:upTo: (in category 'instance creation') -----
- averageEvery: nSamples from: anotherBuffer upTo: inCount
-
- ^(self newMonoSampleCount: inCount // nSamples)
- averageEvery: nSamples
- from: anotherBuffer
- upTo: inCount!
Item was removed:
- ----- Method: SoundBuffer class>>fromArray: (in category 'instance creation') -----
- fromArray: anArray
- "Return a new SoundBuffer whose contents are copied from the given Array or ByteArray."
-
- | new |
- new := SoundBuffer newMonoSampleCount: anArray size.
- 1 to: anArray size do: [:i | new at: i put: (anArray at: i)].
- ^ new
- !
Item was removed:
- ----- Method: SoundBuffer class>>fromByteArray: (in category 'instance creation') -----
- fromByteArray: aByteArray
- "Convert the given ByteArray (stored with the most significant byte first) into 16-bit sample buffer."
-
- | n buf src w |
- n := aByteArray size // 2.
- buf := SoundBuffer newMonoSampleCount: n.
- src := 1.
- 1 to: n do: [:i |
- w := ((aByteArray at: src) bitShift: 8) + (aByteArray at: src + 1).
- w > 32767 ifTrue: [w := w - 65536].
- buf at: i put: w.
- src := src + 2].
- ^ buf
- !
Item was removed:
- ----- Method: SoundBuffer class>>initialize (in category 'class initialization') -----
- initialize
- "Build a sine wave table."
- "SoundBuffer initialize"
-
- | tableSize radiansPerStep peak |
- tableSize := 4000.
- SineTable := self newMonoSampleCount: tableSize.
- radiansPerStep := (2.0 * Float pi) / tableSize asFloat.
- peak := ((1 bitShift: 15) - 1) asFloat. "range is +/- (2^15 - 1)"
- 1 to: tableSize do: [:i |
- SineTable at: i put: (peak * (radiansPerStep * (i - 1)) sin) rounded].
- !
Item was removed:
- ----- Method: SoundBuffer class>>new: (in category 'instance creation') -----
- new: anInteger
- "See the comment in newMonoSampleCount:. To avoid confusion, it is best to create new instances using newMonoSampleCount: or newStereoSampleCount:."
-
- ^ self newMonoSampleCount: anInteger
- !
Item was removed:
- ----- Method: SoundBuffer class>>newMonoSampleCount: (in category 'instance creation') -----
- newMonoSampleCount: anInteger
- "Return a SoundBuffer large enough to hold the given number of monaural samples (i.e., 16-bit words)."
- "Details: The size is rounded up to an even number, since the underlying representation is in terms of 32-bit words."
-
- ^ self basicNew: (anInteger + 1) // 2
- !
Item was removed:
- ----- Method: SoundBuffer class>>newStereoSampleCount: (in category 'instance creation') -----
- newStereoSampleCount: anInteger
- "Return a SoundBuffer large enough to hold the given number of stereo slices. A stereo 'slice' consists of two 16-bit samples, one for each channel."
-
- ^ self basicNew: anInteger
- !
Item was removed:
- ----- Method: SoundBuffer class>>sineTable (in category 'class initialization') -----
- sineTable
- "Answer a SoundBuffer containing one complete cycle of a sine wave."
-
- ^ SineTable
- !
Item was removed:
- ----- Method: SoundBuffer class>>startUp (in category 'objects from disk') -----
- startUp
- "Check if the word order has changed from the last save."
-
- | la |
- la := ShortIntegerArray classPool at: #LastSaveOrder.
- ((la at: 2) = 42 and: [(la at: 1) = 13])
- ifTrue: [^self swapHalves]. "Reverse the two 16-bit halves."
- "Another reversal happened automatically which reversed the bytes."
- !
Item was removed:
- ----- Method: SoundBuffer class>>startUpFrom: (in category 'objects from disk') -----
- startUpFrom: endiannessHasToBeFixed
- "In this case, do we need to swap word halves when reading this segment?"
-
- ^endiannessHasToBeFixed
- ifTrue: [Message selector: #swapHalves "will be run on each instance"]
- ifFalse: [nil]!
Item was removed:
- ----- Method: SoundBuffer>>asByteArray (in category 'utilities') -----
- asByteArray
- "Answer a ByteArray containing my sample data serialized in most-significant byte first order."
-
- | sampleCount bytes dst s |
- sampleCount := self monoSampleCount.
- bytes := ByteArray new: 2 * sampleCount.
- dst := 0.
- 1 to: sampleCount do: [:src |
- s := self at: src.
- bytes at: (dst := dst + 1) put: ((s bitShift: -8) bitAnd: 255).
- bytes at: (dst := dst + 1) put: (s bitAnd: 255)].
- ^ bytes
-
- !
Item was removed:
- ----- Method: SoundBuffer>>at: (in category 'primitives') -----
- at: index
- "Return the 16-bit integer value at the given index of the receiver."
-
- <primitive: 143>
- index isInteger ifTrue: [self errorSubscriptBounds: index].
- index isNumber ifTrue: [^ self at: index truncated].
- self errorNonIntegerIndex.
- !
Item was removed:
- ----- Method: SoundBuffer>>at:put: (in category 'primitives') -----
- at: index put: value
- "Store the given 16-bit integer at the given index in the receiver."
-
- <primitive: 144>
- index isInteger
- ifTrue: [
- (index >= 1 and: [index <= self size])
- ifTrue: [self errorImproperStore]
- ifFalse: [self errorSubscriptBounds: index]].
- index isNumber ifTrue: [^ self at: index truncated put: value].
- self errorNonIntegerIndex.
- !
Item was removed:
- ----- Method: SoundBuffer>>averageEvery:from:upTo: (in category 'utilities') -----
- averageEvery: nSamples from: anotherBuffer upTo: inCount
-
- | fromIndex sum |
-
- fromIndex := 1.
- 1 to: inCount // nSamples do: [ :i |
- sum := 0.
- nSamples timesRepeat: [
- sum := sum + (anotherBuffer at: fromIndex).
- fromIndex := fromIndex + 1.
- ].
- self at: i put: sum // nSamples.
- ].
- !
Item was removed:
- ----- Method: SoundBuffer>>bytesPerElement (in category 'accessing') -----
- bytesPerElement
- "Number of bytes in each item. This multiplied by (self size)*8 gives the number of bits stored."
- ^ 2!
Item was removed:
- ----- Method: SoundBuffer>>downSampledLowPassFiltering: (in category 'utilities') -----
- downSampledLowPassFiltering: doFiltering
- "Answer a new SoundBuffer half the size of the receiver consisting of every other sample. If doFiltering is true, a simple low-pass filter is applied to avoid aliasing of high frequencies. Assume that receiver is monophonic."
- "Details: The simple low-pass filter in the current implementation could be improved, at some additional cost."
-
- | n resultBuf j |
- n := self monoSampleCount.
- resultBuf := SoundBuffer newMonoSampleCount: n // 2.
- j := 0.
- doFiltering
- ifTrue: [
- 1 to: n by: 2 do: [:i |
- resultBuf at: (j := j + 1) put:
- (((self at: i) + (self at: i + 1)) bitShift: -1)]]
- ifFalse: [
- 1 to: n by: 2 do: [:i |
- resultBuf at: (j := j + 1) put: (self at: i)]].
-
- ^ resultBuf!
Item was removed:
- ----- Method: SoundBuffer>>extractLeftChannel (in category 'utilities') -----
- extractLeftChannel
- "Answer a new SoundBuffer half the size of the receiver consisting of only the left channel of the receiver, which is assumed to contain stereo sound data."
-
- | n resultBuf j |
- n := self monoSampleCount.
- resultBuf := SoundBuffer newMonoSampleCount: n // 2.
- j := 0.
- 1 to: n by: 2 do: [:i | resultBuf at: (j := j + 1) put: (self at: i)].
- ^ resultBuf!
Item was removed:
- ----- Method: SoundBuffer>>extractRightChannel (in category 'utilities') -----
- extractRightChannel
- "Answer a new SoundBuffer half the size of the receiver consisting of only the right channel of the receiver, which is assumed to contain stereo sound data."
-
- | n resultBuf j |
- n := self monoSampleCount.
- resultBuf := SoundBuffer newMonoSampleCount: n // 2.
- j := 0.
- 2 to: n by: 2 do: [:i | resultBuf at: (j := j + 1) put: (self at: i)].
- ^ resultBuf!
Item was removed:
- ----- Method: SoundBuffer>>indexOfFirstSampleOver: (in category 'utilities') -----
- indexOfFirstSampleOver: threshold
- "Return the index of the first sample whose absolute value is over the given threshold value. Return an index one greater than my size if no sample is over the threshold."
-
- 1 to: self size do: [:i |
- (self at: i) abs > threshold ifTrue: [^ i]].
- ^ self size + 1!
Item was removed:
- ----- Method: SoundBuffer>>indexOfLastSampleOver: (in category 'utilities') -----
- indexOfLastSampleOver: threshold
- "Return the index of the last sample whose absolute value is over the given threshold value. Return zero if no sample is over the threshold."
-
- self size to: 1 by: -1 do: [:i |
- (self at: i) abs > threshold ifTrue: [^ i]].
- ^ 0
- !
Item was removed:
- ----- Method: SoundBuffer>>lowPassFiltered (in category 'utilities') -----
- lowPassFiltered
- "Answer a simple low-pass filtered copy of this buffer. Assume it is monophonic."
-
- | sz out last this |
- sz := self monoSampleCount.
- out := self shallowCopy.
- last := self at: 1.
- 2 to: sz do: [:i |
- this := self at: i.
- out at: i put: (this + last) // 2.
- last := this].
- ^ out
- !
Item was removed:
- ----- Method: SoundBuffer>>mergeStereo (in category 'utilities') -----
- mergeStereo
- "Answer a new SoundBuffer half the size of the receiver that mixes the left and right stereo channels of the receiver, which is assumed to contain stereo sound data."
-
- | n resultBuf j |
- n := self monoSampleCount.
- resultBuf := SoundBuffer newMonoSampleCount: n // 2.
- j := 0.
- 1 to: n by: 2 do: [:i | resultBuf at: (j := j + 1) put: (((self at: i) + (self at: i + 1)) // 2)].
- ^ resultBuf
- !
Item was removed:
- ----- Method: SoundBuffer>>monoSampleCount (in category 'accessing') -----
- monoSampleCount
- "Return the number of monaural 16-bit samples that fit into this SoundBuffer."
-
- ^ super size * 2
- !
Item was removed:
- ----- Method: SoundBuffer>>normalized: (in category 'utilities') -----
- normalized: percentOfFullVolume
- "Increase my amplitudes so that the highest peak is the given percent of full volume. For example 's normalized: 50' would normalize to half of full volume."
-
- | peak s mult |
- peak := 0.
- 1 to: self size do: [:i |
- s := (self at: i) abs.
- s > peak ifTrue: [peak := s]].
- mult := (32767.0 * percentOfFullVolume) / (100.0 * peak).
- 1 to: self size do: [:i | self at: i put: (mult * (self at: i)) asInteger].
- !
Item was removed:
- ----- Method: SoundBuffer>>primFill: (in category 'primitives') -----
- primFill: aPositiveInteger
- "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."
- "Note: Since 16-bit word arrays are not built into the virtual machine, this primitive fills by 32-bit words."
-
- <primitive: 145>
- self errorImproperStore.
- !
Item was removed:
- ----- Method: SoundBuffer>>restoreEndianness (in category 'objects from disk') -----
- restoreEndianness
- "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian.
- Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap."
-
- | hack blt |
- Smalltalk isLittleEndian ifTrue: [
- "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: 1.
- blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1"
- blt sourceX: 1; destX: 0; copyBits.
- blt sourceX: 0; destX: 1; copyBits.
- blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3"
- blt sourceX: 3; destX: 2; copyBits.
- blt sourceX: 2; destX: 3; copyBits].
-
- !
Item was removed:
- ----- Method: SoundBuffer>>reverseEndianness (in category 'objects from disk') -----
- reverseEndianness
- "Swap the bytes of each 16-bit word, using a fast BitBlt hack."
-
- | hack blt |
- 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: 1.
- blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1"
- blt sourceX: 1; destX: 0; copyBits.
- blt sourceX: 0; destX: 1; copyBits.
- blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3"
- blt sourceX: 3; destX: 2; copyBits.
- blt sourceX: 2; destX: 3; copyBits.
- !
Item was removed:
- ----- Method: SoundBuffer>>saveAsAIFFFileSamplingRate:on: (in category 'utilities') -----
- saveAsAIFFFileSamplingRate: rate on: aBinaryStream
- "Store this mono sound buffer in AIFF file format with the given sampling rate on the given stream."
-
- | sampleCount s swapBytes |
- sampleCount := self monoSampleCount.
- aBinaryStream nextPutAll: 'FORM' asByteArray.
- aBinaryStream nextInt32Put: (2 * sampleCount) + ((7 * 4) + 18).
- aBinaryStream nextPutAll: 'AIFF' asByteArray.
- aBinaryStream nextPutAll: 'COMM' asByteArray.
- aBinaryStream nextInt32Put: 18.
- aBinaryStream nextNumber: 2 put: 1. "channels"
- aBinaryStream nextInt32Put: sampleCount.
- aBinaryStream nextNumber: 2 put: 16. "bits/sample"
- self storeExtendedFloat: rate on: aBinaryStream.
- aBinaryStream nextPutAll: 'SSND' asByteArray.
- aBinaryStream nextInt32Put: (2 * sampleCount) + 8.
- aBinaryStream nextInt32Put: 0.
- aBinaryStream nextInt32Put: 0.
-
- (aBinaryStream isKindOf: StandardFileStream) ifTrue: [
- "optimization: write sound buffer directly to file"
- swapBytes := Smalltalk isLittleEndian.
- swapBytes ifTrue: [self reverseEndianness]. "make big endian"
- aBinaryStream next: (self size // 2) putAll: self startingAt: 1. "size in words"
- swapBytes ifTrue: [self reverseEndianness]. "revert to little endian"
- ^ self].
-
- 1 to: sampleCount do: [:i |
- s := self at: i.
- aBinaryStream nextPut: ((s bitShift: -8) bitAnd: 16rFF).
- aBinaryStream nextPut: (s bitAnd: 16rFF)].
- !
Item was removed:
- ----- Method: SoundBuffer>>size (in category 'accessing') -----
- size
- "Return the number of 16-bit sound samples that fit in this sound buffer. To avoid confusion, it is better to get the size of SoundBuffer using monoSampleCount or stereoSampleCount."
-
- ^ self monoSampleCount
- !
Item was removed:
- ----- Method: SoundBuffer>>splitStereo (in category 'utilities') -----
- splitStereo
- "Answer an array of two SoundBuffers half the size of the receiver consisting of the left and right channels of the receiver (which is assumed to contain stereo sound data)."
-
- | n leftBuf rightBuf leftIndex rightIndex |
- n := self monoSampleCount.
- leftBuf := SoundBuffer newMonoSampleCount: n // 2.
- rightBuf := SoundBuffer newMonoSampleCount: n // 2.
- leftIndex := rightIndex := 0.
- 1 to: n by: 2 do: [:i |
- leftBuf at: (leftIndex := leftIndex + 1) put: (self at: i).
- rightBuf at: (rightIndex := rightIndex + 1) put: (self at: i + 1)].
- ^ Array with: leftBuf with: rightBuf
- !
Item was removed:
- ----- Method: SoundBuffer>>stereoSampleCount (in category 'accessing') -----
- stereoSampleCount
- "Return the number of stereo slices that fit into this SoundBuffer. A stereo 'slice' consists of two 16-bit samples, one for each channel."
-
- ^ super size
- !
Item was removed:
- ----- Method: SoundBuffer>>storeExtendedFloat:on: (in category 'utilities') -----
- storeExtendedFloat: aNumber on: aBinaryStream
- "Store an Apple extended-precision 80-bit floating point number on the given stream."
- "Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do."
-
- | n isNeg exp mantissa |
- n := aNumber asFloat.
- isNeg := false.
- n < 0.0 ifTrue: [
- n := 0.0 - n.
- isNeg := true].
- exp := (n log: 2.0) ceiling.
- mantissa := (n * (2 raisedTo: 64 - exp)) truncated.
- exp := exp + 16r4000 - 2. "not sure why the -2 is needed..."
- isNeg ifTrue: [exp := exp bitOr: 16r8000]. "set sign bit"
- aBinaryStream nextPut: ((exp bitShift: -8) bitAnd: 16rFF).
- aBinaryStream nextPut: (exp bitAnd: 16rFF).
- 8 to: 1 by: -1 do: [:i | aBinaryStream nextPut: (mantissa digitAt: i)].!
Item was removed:
- ----- Method: SoundBuffer>>trimmedThreshold: (in category 'utilities') -----
- trimmedThreshold: threshold
-
- | start end |
- start := self indexOfFirstSampleOver: threshold.
- end := self indexOfLastSampleOver: threshold.
- start > end ifTrue: [^ SoundBuffer new].
- start := (start - 200) max: 1.
- end := (end + 200) min: self size.
- ^ self copyFrom: start to: end
- !
Item was removed:
- ----- Method: SoundBuffer>>writeOnGZIPByteStream: (in category 'objects from disk') -----
- writeOnGZIPByteStream: aStream
-
- aStream nextPutAllWordArray: self!
Item was removed:
- Object subclass: #SoundCodec
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !SoundCodec commentStamp: '<historical>' prior: 0!
- I am an abstract class that describes the protocol for sound codecs. Each codec (the name stems from "COder/DECoder") describes a particular algorithm for compressing and decompressing sound data. Most sound codecs are called 'lossy' because they lose information; the decompressed sound data is not exactly the same as the original data.
- !
Item was removed:
- ----- Method: SoundCodec>>bytesPerEncodedFrame (in category 'subclass responsibilities') -----
- bytesPerEncodedFrame
- "Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size."
-
- self subclassResponsibility.
- !
Item was removed:
- ----- Method: SoundCodec>>compressAndDecompress: (in category 'compress/decompress') -----
- compressAndDecompress: aSound
- "Compress and decompress the given sound. Useful for testing."
- "(MuLawCodec new compressAndDecompress: (SampledSound soundNamed: 'camera')) play"
-
- ^ (self compressSound: aSound) asSound
- !
Item was removed:
- ----- Method: SoundCodec>>compressSound: (in category 'compress/decompress') -----
- compressSound: aSound
- "Compress the entirety of the given sound with this codec. Answer a CompressedSoundData."
-
- | compressed channels |
- compressed := CompressedSoundData new
- codecName: self class name;
- soundClassName: aSound class name.
- (aSound isKindOf: SampledSound) ifTrue: [
- channels := Array new: 1.
- channels at: 1 put: (self encodeSoundBuffer: aSound samples).
- compressed
- channels: channels;
- samplingRate: aSound originalSamplingRate;
- firstSample: 1;
- loopEnd: aSound samples size;
- loopLength: 0.0;
- perceivedPitch: 100.0;
- gain: aSound loudness.
- ^ compressed].
- (aSound isKindOf: LoopedSampledSound) ifTrue: [
- aSound isStereo
- ifTrue: [
- channels := Array new: 2.
- channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples).
- channels at: 2 put: (self encodeSoundBuffer: aSound rightSamples)]
- ifFalse: [
- channels := Array new: 1.
- channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples)].
- compressed
- channels: channels;
- samplingRate: aSound originalSamplingRate;
- firstSample: aSound firstSample;
- loopEnd: aSound loopEnd;
- loopLength: aSound loopLength;
- perceivedPitch: aSound perceivedPitch;
- gain: aSound gain.
- ^ compressed].
- self error: 'you can only compress sampled sounds'.
- !
Item was removed:
- ----- Method: SoundCodec>>compressSound:atRate: (in category 'compress/decompress') -----
- compressSound: aSound atRate: desiredSampleRate
- "Compress the entirety of the given sound with this codec. Answer a CompressedSoundData."
-
- | compressed channels samples newRate ratio buffer |
-
- compressed := CompressedSoundData new
- codecName: self class name;
- soundClassName: aSound class name.
- (aSound isKindOf: SampledSound) ifTrue: [
- (desiredSampleRate isNil or:
- [(ratio := aSound originalSamplingRate // desiredSampleRate) <= 1]) ifTrue: [
- samples := aSound samples.
- newRate := aSound originalSamplingRate.
- ] ifFalse: [
- buffer := aSound samples.
- samples := SoundBuffer
- averageEvery: ratio
- from: buffer
- upTo: buffer monoSampleCount.
- newRate := aSound originalSamplingRate / ratio.
- ].
-
- channels := Array new: 1.
- channels at: 1 put: (self encodeSoundBuffer: samples).
- compressed
- channels: channels;
- samplingRate: newRate;
- firstSample: 1;
- loopEnd: samples size;
- loopLength: 0.0;
- perceivedPitch: 100.0;
- gain: aSound loudness.
- ^ compressed].
- (aSound isKindOf: LoopedSampledSound) ifTrue: [
- aSound isStereo
- ifTrue: [
- channels := Array new: 2.
- channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples).
- channels at: 2 put: (self encodeSoundBuffer: aSound rightSamples)]
- ifFalse: [
- channels := Array new: 1.
- channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples)].
- compressed
- channels: channels;
- samplingRate: aSound originalSamplingRate;
- firstSample: aSound firstSample;
- loopEnd: aSound loopEnd;
- loopLength: aSound loopLength;
- perceivedPitch: aSound perceivedPitch;
- gain: aSound gain.
- ^ compressed].
- self error: 'you can only compress sampled sounds'.
- !
Item was removed:
- ----- Method: SoundCodec>>decodeCompressedData: (in category 'private') -----
- decodeCompressedData: aByteArray
- "Decode the entirety of the given encoded data buffer with this codec. Answer a monophonic SoundBuffer containing the uncompressed samples."
-
- | frameCount result increments |
- frameCount := self frameCount: aByteArray.
- result := SoundBuffer newMonoSampleCount: frameCount * self samplesPerFrame.
- self reset.
- increments := self decodeFrames: frameCount from: aByteArray at: 1 into: result at: 1.
- ((increments first = aByteArray size) and: [increments last = result size]) ifFalse: [
- self error: 'implementation problem; increment sizes should match buffer sizes'].
- ^ result
- !
Item was removed:
- ----- Method: SoundCodec>>decodeFrames:from:at:into:at: (in category 'subclass responsibilities') -----
- decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
- "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
- "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."
-
- self subclassResponsibility.
- !
Item was removed:
- ----- Method: SoundCodec>>decompressSound: (in category 'compress/decompress') -----
- decompressSound: aCompressedSound
- "Decompress the entirety of the given compressed sound with this codec and answer the resulting sound."
-
- | channels sound |
- channels := aCompressedSound channels
- collect: [:compressed | self decodeCompressedData: compressed].
- 'SampledSound' = aCompressedSound soundClassName ifTrue: [
- sound := SampledSound
- samples: channels first
- samplingRate: (aCompressedSound samplingRate).
- sound loudness: aCompressedSound gain.
- ^ sound].
- 'LoopedSampledSound' = aCompressedSound soundClassName ifTrue: [
- aCompressedSound loopLength = 0
- ifTrue: [
- sound := LoopedSampledSound
- unloopedSamples: channels first
- pitch: aCompressedSound perceivedPitch
- samplingRate: aCompressedSound samplingRate]
- ifFalse: [
- sound := LoopedSampledSound
- samples: channels first
- loopEnd: aCompressedSound loopEnd
- loopLength: aCompressedSound loopLength
- pitch: aCompressedSound perceivedPitch
- samplingRate: aCompressedSound samplingRate].
- channels size > 1 ifTrue: [sound rightSamples: channels last].
- sound
- firstSample: aCompressedSound firstSample;
- gain: aCompressedSound gain.
- sound
- setPitch: 100.0
- dur: (channels first size / aCompressedSound samplingRate)
- loudness: 1.0.
- ^ sound].
- self error: 'unknown sound class'.
- !
Item was removed:
- ----- Method: SoundCodec>>encodeFrames:from:at:into:at: (in category 'subclass responsibilities') -----
- encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
- "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
- "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."
-
- self subclassResponsibility.
- !
Item was removed:
- ----- Method: SoundCodec>>encodeSoundBuffer: (in category 'private') -----
- encodeSoundBuffer: aSoundBuffer
- "Encode the entirety of the given monophonic SoundBuffer with this codec. Answer a ByteArray containing the compressed sound data."
-
- | codeFrameSize frameSize fullFrameCount lastFrameSamples result increments finalFrame i lastIncs |
- frameSize := self samplesPerFrame.
- fullFrameCount := aSoundBuffer monoSampleCount // frameSize.
- lastFrameSamples := aSoundBuffer monoSampleCount - (fullFrameCount * frameSize).
- codeFrameSize := self bytesPerEncodedFrame.
- codeFrameSize = 0 ifTrue:
- ["Allow room for 1 byte per sample for variable-length compression"
- codeFrameSize := frameSize].
- lastFrameSamples > 0
- ifTrue: [result := ByteArray new: (fullFrameCount + 1) * codeFrameSize]
- ifFalse: [result := ByteArray new: fullFrameCount * codeFrameSize].
- self reset.
- increments := self encodeFrames: fullFrameCount from: aSoundBuffer at: 1 into: result at: 1.
- lastFrameSamples > 0 ifTrue: [
- finalFrame := SoundBuffer newMonoSampleCount: frameSize.
- i := fullFrameCount * frameSize.
- 1 to: lastFrameSamples do: [:j |
- finalFrame at: j put: (aSoundBuffer at: (i := i + 1))].
- lastIncs := self encodeFrames: 1 from: finalFrame at: 1 into: result at: 1 + increments second.
- increments := Array with: increments first + lastIncs first
- with: increments second + lastIncs second].
- increments second < result size
- ifTrue: [^ result copyFrom: 1 to: increments second]
- ifFalse: [^ result]
- !
Item was removed:
- ----- Method: SoundCodec>>frameCount: (in category 'private') -----
- frameCount: aByteArray
- "Compute the frame count for this byteArray. This default computation will have to be overridden by codecs with variable frame sizes."
-
- | codeFrameSize |
- codeFrameSize := self bytesPerEncodedFrame.
- (aByteArray size \\ codeFrameSize) = 0 ifFalse:
- [self error: 'encoded buffer is not an even multiple of the encoded frame size'].
- ^ aByteArray size // codeFrameSize!
Item was removed:
- ----- Method: SoundCodec>>reset (in category 'subclass responsibilities') -----
- reset
- "Reset my encoding and decoding state. Optional. This default implementation does nothing."
- !
Item was removed:
- ----- Method: SoundCodec>>samplesPerFrame (in category 'subclass responsibilities') -----
- samplesPerFrame
- "Answer the number of sound samples per compression frame."
-
- self subclassResponsibility.
- !
Item was removed:
- SoundRecorder subclass: #SoundInputStream
- instanceVariableNames: 'bufferSize mutex'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !SoundInputStream commentStamp: '<historical>' prior: 0!
- This subclass of SoundRecorder supports real-time processing of incoming sound data. The sound input process queues raw sound buffers, allowing them to be read and processed by the client as they become available. A semaphore is used to synchronize between the record process and the client process. Since sound data is buffered, the client process may lag behind the input process without losing data.
- !
Item was removed:
- ----- Method: SoundInputStream>>allocateBuffer (in category 'private') -----
- allocateBuffer
- "Allocate a new buffer and reset nextIndex. This message is sent by the sound input process."
-
- currentBuffer := SoundBuffer newMonoSampleCount: bufferSize.
- nextIndex := 1.
- !
Item was removed:
- ----- Method: SoundInputStream>>bufferCount (in category 'accessing') -----
- bufferCount
- "Answer the number of sound buffers that have been queued."
-
- mutex ifNil: [^ 0]. "not recording"
- ^mutex critical: [recordedBuffers size].
- !
Item was removed:
- ----- Method: SoundInputStream>>bufferSize (in category 'accessing') -----
- bufferSize
-
- ^ bufferSize
- !
Item was removed:
- ----- Method: SoundInputStream>>bufferSize: (in category 'accessing') -----
- bufferSize: aNumber
- "Set the sound buffer size. Buffers of this size will be queued for the client to process."
-
- bufferSize := aNumber truncated.
- !
Item was removed:
- ----- Method: SoundInputStream>>emitBuffer: (in category 'private') -----
- emitBuffer: buffer
- "Queue a buffer for later processing. This message is sent by the sound input process."
-
- mutex critical: [recordedBuffers addLast: buffer].
- !
Item was removed:
- ----- Method: SoundInputStream>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
- bufferSize := 1024.
- mutex := nil.
- !
Item was removed:
- ----- Method: SoundInputStream>>isRecording (in category 'accessing') -----
- isRecording
- "Answer true if the sound input process is running."
-
- ^ recordProcess ~~ nil
- !
Item was removed:
- ----- Method: SoundInputStream>>nextBufferOrNil (in category 'accessing') -----
- nextBufferOrNil
- "Answer the next input buffer or nil if no buffer is available."
-
- mutex ifNil: [^ nil]. "not recording"
- ^mutex critical: [
- recordedBuffers size > 0
- ifTrue: [recordedBuffers removeFirst]
- ifFalse: [nil]].
- !
Item was removed:
- ----- Method: SoundInputStream>>startRecording (in category 'recording controls') -----
- startRecording
- "Start the sound input process."
-
- recordProcess ifNotNil: [self stopRecording].
- recordedBuffers := OrderedCollection new: 100.
- mutex := Semaphore forMutualExclusion.
- super startRecording.
- paused := false.
- !
Item was removed:
- ----- Method: SoundInputStream>>stopRecording (in category 'recording controls') -----
- stopRecording
- "Turn off the sound input process and close the driver."
-
- super stopRecording.
- recordedBuffers := nil.
- mutex := nil.
- !
Item was removed:
- Object subclass: #SoundPlayer
- instanceVariableNames: ''
- classVariableNames: 'ActiveSounds Buffer BufferIndex BufferMSecs LastBuffer PlayerProcess PlayerSemaphore ReadyForBuffer ReverbState SamplingRate SoundJustStarted SoundSupported SoundsShouldStartQuick SoundsStopWhenDone Stereo UseReadySemaphore UseReverb'
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: SoundPlayer class>>boinkPitch:dur:loudness:waveTable:pan: (in category 'primitive test') -----
- boinkPitch: p dur: d loudness: l waveTable: waveTable pan: pan
- "Play a decaying note on the given stream using the given wave table. Used for testing only."
-
- | decay tableSize amplitude increment cycles i |
- decay := 0.96.
- tableSize := waveTable size.
- amplitude := l asInteger min: 1000.
- increment := ((p asFloat * tableSize asFloat) / SamplingRate asFloat) asInteger.
- increment := (increment max: 1) min: (tableSize // 2).
- cycles := (d * SamplingRate asFloat) asInteger.
-
- i := 1.
- 1 to: cycles do: [:cycle |
- (cycle \\ 100) = 0
- ifTrue: [amplitude := (decay * amplitude asFloat) asInteger].
- i := (((i - 1) + increment) \\ tableSize) + 1.
- self playTestSample: (amplitude * (waveTable at: i)) // 1000 pan: pan].
- !
Item was removed:
- ----- Method: SoundPlayer class>>boinkScale (in category 'primitive test') -----
- boinkScale
- "Tests the sound output primitives by playing a scale."
- "SoundPlayer boinkScale"
-
- | sineTable pan |
- self shutDown: true.
- SamplingRate := 11025.
- Stereo := true.
- sineTable := self sineTable: 1000.
- Buffer := SoundBuffer newStereoSampleCount: 1000.
- BufferIndex := 1.
- self primSoundStartBufferSize: Buffer stereoSampleCount
- rate: SamplingRate
- stereo: Stereo.
- pan := 0.
- #(261.626 293.665 329.628 349.229 391.996 440.001 493.884 523.252) do: [:p |
- self boinkPitch: p dur: 0.3 loudness: 300 waveTable: sineTable pan: pan.
- pan := pan + 125].
-
- self boinkPitch: 261.626 dur: 1.0 loudness: 300 waveTable: sineTable pan: 500.
- self primSoundStop.
- self shutDown: true.
- SoundPlayer initialize. "reset sampling rate, buffer size, and stereo flag"
- !
Item was removed:
- ----- Method: SoundPlayer class>>bufferMSecs (in category 'accessing') -----
- bufferMSecs
-
- ^ BufferMSecs
- !
Item was removed:
- ----- Method: SoundPlayer class>>canStartPlayer (in category 'playing') -----
- canStartPlayer
- "Some platforms do no support simultaneous record and play. If this is one of those platforms, return false if there is a running SoundRecorder."
-
- ^SoundRecorder canRecordWhilePlaying
- or: [ SoundRecorder anyActive not]
-
- !
Item was removed:
- ----- Method: SoundPlayer class>>defaultQuickStartForPlatform (in category 'preferences') -----
- defaultQuickStartForPlatform
-
- ^ Smalltalk os platformName = 'Mac OS'.
- !
Item was removed:
- ----- Method: SoundPlayer class>>defaultStopSoundForPlatform (in category 'preferences') -----
- defaultStopSoundForPlatform
-
- ^(Smalltalk os platformName = 'Mac OS') not
- !
Item was removed:
- ----- Method: SoundPlayer class>>initialize (in category 'initialization') -----
- initialize
- "SoundPlayer initialize; shutDown; startUp"
- "Details: BufferMSecs represents a tradeoff between latency and quality. If BufferMSecs is too low, the sound will not play smoothly, especially during long-running primitives such as large BitBlts. If BufferMSecs is too high, there will be a long time lag between when a sound buffer is submitted to be played and when that sound is actually heard. BufferMSecs is typically in the range 50-200."
-
- SamplingRate := 22050.
- BufferMSecs := 120.
- Stereo := true.
- UseReverb ifNil: [UseReverb := true].
- !
Item was removed:
- ----- Method: SoundPlayer class>>isAllSilence:size: (in category 'private') -----
- isAllSilence: buffer size: count
- "return true if the buffer is all silence after reverb has ended"
- | value |
- value := buffer at: 1.
- 2 to: count do:[:i| (buffer at: i) = value ifFalse:[^false]].
- ^true!
Item was removed:
- ----- Method: SoundPlayer class>>isPlaying: (in category 'playing') -----
- isPlaying: aSound
- ^ ActiveSounds includes: aSound!
Item was removed:
- ----- Method: SoundPlayer class>>isReverbOn (in category 'player process') -----
- isReverbOn
-
- ^ ReverbState ~~ nil
- !
Item was removed:
- ----- Method: SoundPlayer class>>lastPlayBuffer (in category 'player process') -----
- lastPlayBuffer
- ^LastBuffer!
Item was removed:
- ----- Method: SoundPlayer class>>oldStylePlayLoop (in category 'player process') -----
- oldStylePlayLoop
- "This version of the play loop is used if the VM does not yet support sound primitives that signal a semaphore when a sound buffer becomes available."
-
- | bytesPerSlice count |
- bytesPerSlice := Stereo ifTrue: [4] ifFalse: [2].
- [
- [(count := self primSoundAvailableBytes // bytesPerSlice) > 100]
- whileFalse: [(Delay forMilliseconds: 1) wait].
-
- count := count min: Buffer stereoSampleCount.
- PlayerSemaphore critical: [
- ActiveSounds := ActiveSounds select: [:snd | snd samplesRemaining > 0].
- ActiveSounds do: [:snd |
- snd ~~ SoundJustStarted ifTrue: [
- snd playSampleCount: count into: Buffer startingAt: 1]].
- ReverbState == nil ifFalse: [
- ReverbState applyReverbTo: Buffer startingAt: 1 count: count].
- self primSoundPlaySamples: count from: Buffer startingAt: 1.
- Buffer primFill: 0.
- SoundJustStarted := nil]] repeat
- !
Item was removed:
- ----- Method: SoundPlayer class>>pauseSound: (in category 'playing') -----
- pauseSound: aSound
- "Stop playing the given sound. Playing can be resumed from this point later."
-
- PlayerSemaphore critical: [
- ActiveSounds remove: aSound ifAbsent: []].
- !
Item was removed:
- ----- Method: SoundPlayer class>>playLoop (in category 'player process') -----
- playLoop
- "The sound player process loop."
- | bytesPerSlice count willStop mayStop |
- mayStop := self stopSoundWhenDone.
- bytesPerSlice := Stereo ifTrue: [4] ifFalse: [2].
- [
- [(count := self primSoundAvailableBytes // bytesPerSlice) > 100]
- whileFalse: [ReadyForBuffer wait].
-
- count := count min: Buffer stereoSampleCount.
- PlayerSemaphore critical: [
- ActiveSounds := ActiveSounds select: [:snd | snd samplesRemaining > 0].
- ActiveSounds do: [:snd |
- snd ~~ SoundJustStarted ifTrue: [
- snd playSampleCount: count into: Buffer startingAt: 1]].
- ReverbState == nil ifFalse: [
- ReverbState applyReverbTo: Buffer startingAt: 1 count: count].
- self primSoundPlaySamples: count from: Buffer startingAt: 1.
- willStop := mayStop and:[
- (ActiveSounds size = 0) and:[
- self isAllSilence: Buffer size: count]].
- LastBuffer ifNotNil:[
- LastBuffer replaceFrom: 1 to: LastBuffer size with: Buffer startingAt: 1.
- ].
- willStop
- ifTrue:[self shutDown: true. PlayerProcess := nil]
- ifFalse:[Buffer primFill: 0].
- SoundJustStarted := nil].
- willStop ifTrue:[^self] ] repeat
- !
Item was removed:
- ----- Method: SoundPlayer class>>playSound: (in category 'playing') -----
- playSound: aSound
- "Reset and start playing the given sound from its beginning."
-
- aSound reset.
- aSound samplesRemaining = 0 ifTrue:[^self].
- self resumePlaying: aSound.
- !
Item was removed:
- ----- Method: SoundPlayer class>>playTestSample:pan: (in category 'primitive test') -----
- playTestSample: s pan: pan
- "Append the given sample in the range [-32767..32767] to the output buffer, playing the output buffer when it is full. Used for testing only."
-
- | sample leftSample |
- BufferIndex >= Buffer size
- ifTrue: [
- "current buffer is full; play it"
- [self primSoundAvailableBytes > 0]
- whileFalse. "wait for space to be available"
- self primSoundPlaySamples: Buffer stereoSampleCount from: Buffer startingAt: 1.
- Buffer primFill: 0.
- BufferIndex := 1].
-
- sample := s.
- sample > 32767 ifTrue: [ sample := 32767 ].
- sample < -32767 ifTrue: [ sample := -32767 ].
-
- Stereo
- ifTrue: [
- leftSample := (sample * pan) // 1000.
- Buffer at: BufferIndex put: sample - leftSample.
- Buffer at: BufferIndex + 1 put: leftSample]
- ifFalse: [
- Buffer at: BufferIndex + 1 put: sample].
- BufferIndex := BufferIndex + 2.
- !
Item was removed:
- ----- Method: SoundPlayer class>>playerProcess (in category 'player process') -----
- playerProcess
- ^PlayerProcess!
Item was removed:
- ----- Method: SoundPlayer class>>primGetDefaultSoundPlayer (in category 'private') -----
- primGetDefaultSoundPlayer
- "Answer the name of the default output device."
- <primitive: 'primitiveGetDefaultSoundPlayer' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primGetDefaultSoundRecorder (in category 'private') -----
- primGetDefaultSoundRecorder
- "Answer the name of the default input device."
- <primitive: 'primitiveGetDefaultSoundRecorder' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primGetNumberOfSoundPlayerDevices (in category 'private') -----
- primGetNumberOfSoundPlayerDevices
- "Answer the number of output devices."
- <primitive: 'primitiveGetNumberOfSoundPlayerDevices' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primGetNumberOfSoundRecorderDevices (in category 'private') -----
- primGetNumberOfSoundRecorderDevices
- "Answer the number of input devices."
- <primitive: 'primitiveGetNumberOfSoundRecorderDevices' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primGetSoundPlayerDeviceName: (in category 'private') -----
- primGetSoundPlayerDeviceName: n
- "Answer the name of the n'th output device."
- <primitive: 'primitiveGetSoundPlayerDeviceName' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primGetSoundRecorderDeviceName: (in category 'private') -----
- primGetSoundRecorderDeviceName: n
- "Answer the name of the n'th input device."
- <primitive: 'primitiveGetSoundRecorderDeviceName' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primSetDefaultSoundPlayer: (in category 'private') -----
- primSetDefaultSoundPlayer: deviceName
- "Set the default output device by supplying its name."
- <primitive: 'primitiveSetDefaultSoundPlayer' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primSetDefaultSoundRecorder: (in category 'private') -----
- primSetDefaultSoundRecorder: deviceName
- "Set the default input device by supplying its name."
- <primitive: 'primitiveSetDefaultSoundRecorder' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundAvailableBytes (in category 'private') -----
- primSoundAvailableBytes
- "Answer the number of bytes of available space in the sound output buffer."
- "Note: Squeak always uses buffers containing 4-bytes per sample (2 channels at 2 bytes per channel) regardless of the state of the Stereo flag."
-
- <primitive: 'primitiveSoundAvailableSpace' module: 'SoundPlugin' error: ec>
- ^ self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundEnableAEC: (in category 'private') -----
- primSoundEnableAEC: aBooleanInteger
- "Enable or disable acoustic echo-cancellation (AEC). aBooleanInteger should be 0 for false, and 1 for true."
- <primitive: 'primitiveSoundEnableAEC' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundGetRecordLevel (in category 'private') -----
- primSoundGetRecordLevel
- "Answer sound as array of doubles left then right channel, range is 0.0 to 1.0 but may be overdriven"
- <primitive: 'primitiveSoundGetRecordLevel' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundGetVolume (in category 'private') -----
- primSoundGetVolume
- "Answer sound as an array of doubles left then right channel, range is 0.0 to 1.0 but may be overdriven"
- <primitive: 'primitiveSoundGetVolume' module: 'SoundPlugin' error: ec>
- ^Array with: 1.0 with: 1.0!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundInsertSamples:from:samplesOfLeadTime: (in category 'private') -----
- primSoundInsertSamples: count from: aSoundBuffer samplesOfLeadTime: anInteger
- "Mix the given number of sample frames from the given sound buffer into the queue of samples that has already been submitted to the sound driver. This primitive is used to start a sound playing with minimum latency, even if large sound output buffers are being used to ensure smooth sound output. Answers the number of samples consumed, or zero if the primitive is not implemented or fails."
-
- <primitive: 'primitiveSoundInsertSamples' module: 'SoundPlugin' error: ec>
- ^ 0!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundPlaySamples:from:startingAt: (in category 'private') -----
- primSoundPlaySamples: count from: aSampleBuffer startingAt: index
- "Copy count frames (pairs) of stereo sound samples into the current sound
- output buffer from the given sample buffer starting at the given index."
-
- <primitive: 'primitiveSoundPlaySamples' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed
- !
Item was removed:
- ----- Method: SoundPlayer class>>primSoundSetVolumeLeft:volumeRight: (in category 'private') -----
- primSoundSetVolumeLeft: aLeftVolume volumeRight: aRightVolume
- "Set sound pass in float 0.0-1.0 for left and right channel, with possible 2.0 or higher to overdrive sound channel "
- <primitive: 'primitiveSoundSetLeftVolume' module: 'SoundPlugin' error: ec>
- ^self!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundStartBufferSize:rate:stereo: (in category 'private') -----
- primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag
- "Start double-buffered sound output with the given buffer size and sampling rate. This version has been superceded by primitive 171 (primSoundStartBufferSize:rate:stereo:semaIndex:)."
- "ar 12/5/1998 Turn off the sound if not supported"
- <primitive: 'primitiveSoundStart' module: 'SoundPlugin' error: ec>
- SoundSupported := false!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundStartBufferSize:rate:stereo:semaIndex: (in category 'private') -----
- primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag semaIndex: anInteger
- "Start double-buffered sound output with the given buffer size and sampling rate. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled when the sound driver is ready to accept another buffer of samples."
- "Details: If this primitive fails, this method tries to use the older version instead."
-
- <primitive: 'primitiveSoundStartWithSemaphore' module: 'SoundPlugin' error: ec>
- UseReadySemaphore := false.
- self primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundStop (in category 'private') -----
- primSoundStop
- "Stop double-buffered sound output. Must not raise an error because it is used inside error handling and at system shutdown"
-
- <primitive: 'primitiveSoundStop' module: 'SoundPlugin' error: ec>
- ^self!
Item was removed:
- ----- Method: SoundPlayer class>>primSoundSupportsAEC (in category 'private') -----
- primSoundSupportsAEC
- "Answer if the plugin supports echo-cancellation on this OS/hardware."
- <primitive: 'primitiveSoundSupportsAEC' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundPlayer class>>resumePlaying: (in category 'playing') -----
- resumePlaying: aSound
- "Start playing the given sound without resetting it; it will resume playing from where it last stopped."
- "Implementation detail: On virtual machines that don't support the quickstart primitive, you may need to edit this method to pass false to resumePlaying:quickStart:."
-
- self resumePlaying: aSound quickStart: true.
- !
Item was removed:
- ----- Method: SoundPlayer class>>resumePlaying:quickStart: (in category 'playing') -----
- resumePlaying: aSound quickStart: quickStart
- "Start playing the given sound without resetting it; it will resume playing from where it last stopped. If quickStart is true, then try to start playing the given sound immediately."
-
- | doQuickStart |
- SoundService soundEnabled ifFalse: [^ self].
- doQuickStart := quickStart.
- self soundQuickStart ifFalse: [doQuickStart := false].
- PlayerProcess == nil ifTrue: [
- self canStartPlayer ifFalse: [^ self].
- ^self startUpWithSound: aSound].
-
- PlayerSemaphore critical: [
- (ActiveSounds includes: aSound)
- ifTrue: [doQuickStart := false]
- ifFalse: [doQuickStart ifFalse: [ActiveSounds add: aSound]].
- PlayerProcess name: 'Sound Player (', ActiveSounds size asString, ')'].
-
- "quick-start the given sound, unless the sound player has just started"
- doQuickStart ifTrue: [self startPlayingImmediately: aSound].
- !
Item was removed:
- ----- Method: SoundPlayer class>>reverbState (in category 'accessing') -----
- reverbState
-
- ^ ReverbState!
Item was removed:
- ----- Method: SoundPlayer class>>samplingRate (in category 'accessing') -----
- samplingRate
-
- ^ SamplingRate!
Item was removed:
- ----- Method: SoundPlayer class>>setVolumeLeft:volumeRight: (in category 'accessing') -----
- setVolumeLeft: aLeftVolume volumeRight: aRightVolume
- "Set sound pass in float 0.0-1.0 for left and right channel, with possible 2.0 or higher to overdrive sound channel "
- self primSoundSetVolumeLeft: aLeftVolume volumeRight: aRightVolume!
Item was removed:
- ----- Method: SoundPlayer class>>shutDown: (in category 'snapshotting') -----
- shutDown: quitting
- "Stop player process, for example before snapshotting."
-
- quitting ifTrue:
- [self stopPlayerProcess: false.
- ReverbState := nil]!
Item was removed:
- ----- Method: SoundPlayer class>>sineTable: (in category 'primitive test') -----
- sineTable: size
- "Compute a sine table of the given size. Used for testing only."
-
- | radiansPerStep table |
- table := Array new: size.
- radiansPerStep := (2.0 * Float pi) / table size asFloat.
- 1 to: table size do: [:i |
- table at: i put:
- (32767.0 * (radiansPerStep * i) sin) asInteger].
-
- ^ table
- !
Item was removed:
- ----- Method: SoundPlayer class>>soundPluginActive (in category 'private') -----
- soundPluginActive
- "Answer quickly if the SoundPlugin is actually active."
- "self soundPluginActive"
- ^SoundSupported
- and: [(self class compiledMethodAt: (UseReadySemaphore
- ifTrue: [#primSoundStartBufferSize:rate:stereo:semaIndex:]
- ifFalse: [#primSoundStartBufferSize:rate:stereo:])) isLinkedNamedPrimitive]!
Item was removed:
- ----- Method: SoundPlayer class>>soundQuickStart (in category 'preferences') -----
- soundQuickStart
- <preference: 'Quickstart Sounds'
- category: 'media'
- description: 'If true, attempt to start playing sounds immediately rather than waiting for the next chance to fill the sound bufffers"'
- type: #Boolean>
-
- ^SoundsShouldStartQuick ifNil: [self defaultQuickStartForPlatform]!
Item was removed:
- ----- Method: SoundPlayer class>>soundQuickStart: (in category 'preferences') -----
- soundQuickStart: aBoolean
-
-
- SoundsShouldStartQuick := aBoolean!
Item was removed:
- ----- Method: SoundPlayer class>>soundVolume (in category 'accessing') -----
- soundVolume
- "Return sound as array of doubles left then right channel, range is 0.0 to 1.0 but may be overdriven"
- ^self primSoundGetVolume!
Item was removed:
- ----- Method: SoundPlayer class>>startPlayerProcessBufferSize:rate:stereo: (in category 'player process') -----
- startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag
- "Start the sound player process. Terminate the old process, if any."
- "SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false"
- ^self startPlayerProcessBufferSize: bufferSize
- rate: samplesPerSecond
- stereo: stereoFlag
- sound: nil!
Item was removed:
- ----- Method: SoundPlayer class>>startPlayerProcessBufferSize:rate:stereo:sound: (in category 'player process') -----
- startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag sound: aSound
- "Start the sound player process. Terminate the old process, if any."
- "SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false"
-
- self stopPlayerProcess: true.
- aSound ifNotNil: "stopPlayerProcess: ensures ActiveSounds are empty..."
- [ActiveSounds add: aSound].
- Buffer := SoundBuffer newStereoSampleCount: (bufferSize // 4) * 4.
- LastBuffer ifNotNil:
- [LastBuffer := SoundBuffer basicNew: Buffer basicSize].
- PlayerSemaphore := Semaphore forMutualExclusion.
- SamplingRate := samplesPerSecond.
- Stereo := stereoFlag.
- SoundSupported := true. "Assume so"
- UseReadySemaphore := true. "set to false if ready semaphore not supported by VM"
- Smalltalk newExternalSemaphoreDo: [ :semaphore :index |
- ReadyForBuffer := semaphore.
- self primSoundStartBufferSize: Buffer stereoSampleCount
- rate: samplesPerSecond
- stereo: Stereo
- semaIndex: index ].
- "Check if sound start prim was successful"
- SoundSupported ifFalse:[
- Smalltalk unregisterExternalObject: ReadyForBuffer.
- ReadyForBuffer := nil.
- ^self ].
- UseReadySemaphore
- ifTrue: [PlayerProcess := [SoundPlayer playLoop] newProcess]
- ifFalse: [PlayerProcess := [SoundPlayer oldStylePlayLoop] newProcess].
- UseReverb ifTrue: [self startReverb].
-
- PlayerProcess
- name: 'Sound Player (', ActiveSounds size asString, ')';
- priority: Processor userInterruptPriority;
- resume!
Item was removed:
- ----- Method: SoundPlayer class>>startPlayingImmediately: (in category 'private') -----
- startPlayingImmediately: aSound
- "Private!! Start playing the given sound as soon as possible by mixing it into the sound output buffers of the underlying sound driver."
-
- | totalSamples buf |
- "first, fill a double-size buffer with samples"
- "Note: The code below assumes that totalSamples contains two
- buffers worth of samples, and the insertSamples primitive is
- expected to consume at least one buffer's worth of these
- samples. The remaining samples are guaranteed to fit into
- a single buffer."
- totalSamples := Buffer stereoSampleCount * 2. "two buffer's worth"
- buf := SoundBuffer newStereoSampleCount: totalSamples.
- aSound playSampleCount: totalSamples into: buf startingAt: 1.
- ReverbState == nil ifFalse: [
- ReverbState applyReverbTo: buf startingAt: 1 count: totalSamples].
-
- PlayerSemaphore critical: [ | n src leftover rest |
- "insert as many samples as possible into the sound driver's buffers"
- n := self primSoundInsertSamples: totalSamples
- from: buf
- samplesOfLeadTime: 1024.
- n > 0 ifTrue:[
- leftover := totalSamples - n.
-
- "copy the remainder of buf into Buffer"
- "Note: the following loop iterates over 16-bit words, not two-word stereo slices"
- "assert: 0 < leftover <= Buffer stereoSampleCount"
- src := 2 * n.
- 1 to: 2 * leftover do:
- [:dst | Buffer at: dst put: (buf at: (src := src + 1))].
-
- "generate enough additional samples to finish filling Buffer"
- rest := Buffer stereoSampleCount - leftover.
- aSound playSampleCount: rest into: Buffer startingAt: leftover + 1.
- ReverbState == nil ifFalse: [
- ReverbState applyReverbTo: Buffer startingAt: leftover + 1 count: rest].
-
- "record the fact that this sound has already been played into Buffer so that we don't process it again this time around"
- SoundJustStarted := aSound.
- ] ifFalse:[
- "quick start failed; reset the sound so we start over"
- aSound reset.
- ].
- ActiveSounds add: aSound].
- !
Item was removed:
- ----- Method: SoundPlayer class>>startReverb (in category 'player process') -----
- startReverb
- "Start a delay-line style reverb with the given tap delays and gains. Tap delays are given in samples and should be prime integers; the following comment gives an expression that generates primes."
- "Integer primesUpTo: 22050"
-
- UseReverb := true.
- ReverbState := ReverbSound new
- tapDelays: #(1601 7919) gains: #(0.12 0.07).
- !
Item was removed:
- ----- Method: SoundPlayer class>>startUp (in category 'snapshotting') -----
- startUp
- "Start up the player process."
-
- SoundPlayer initialize.
- SoundPlayer
- startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000
- rate: SamplingRate
- stereo: Stereo.
- !
Item was removed:
- ----- Method: SoundPlayer class>>startUpWithSound: (in category 'snapshotting') -----
- startUpWithSound: aSound
- "Start up the player process."
-
- SoundPlayer initialize.
- SoundPlayer
- startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000
- rate: SamplingRate
- stereo: Stereo
- sound: aSound.
- !
Item was removed:
- ----- Method: SoundPlayer class>>stereo (in category 'accessing') -----
- stereo
-
- ^ Stereo
- !
Item was removed:
- ----- Method: SoundPlayer class>>stopPlayerProcess: (in category 'player process') -----
- stopPlayerProcess: hardStop
- "Stop the sound player process."
- "SoundPlayer stopPlayerProcess"
-
- PlayerProcess ifNotNil:
- [PlayerProcess ~~ Processor activeProcess ifTrue:
- [PlayerProcess terminate].
- PlayerProcess := nil].
- (hardStop or: [self soundPluginActive]) ifTrue: [self primSoundStop].
- ActiveSounds isEmpty ifFalse:
- [ActiveSounds := OrderedCollection new].
- Buffer := nil.
- PlayerSemaphore isEmpty ifFalse:
- [PlayerSemaphore := Semaphore forMutualExclusion].
- ReadyForBuffer ifNotNil:
- [Smalltalk unregisterExternalObject: ReadyForBuffer.
- ReadyForBuffer := nil]!
Item was removed:
- ----- Method: SoundPlayer class>>stopPlayingAll (in category 'playing') -----
- stopPlayingAll
- "Stop playing all sounds."
-
- PlayerSemaphore critical: [
- ActiveSounds := ActiveSounds species new].
- !
Item was removed:
- ----- Method: SoundPlayer class>>stopReverb (in category 'player process') -----
- stopReverb
-
- UseReverb := false.
- ReverbState := nil.
- !
Item was removed:
- ----- Method: SoundPlayer class>>stopSoundWhenDone (in category 'preferences') -----
- stopSoundWhenDone
- <preference: 'Stop sounds when done'
- category: 'media'
- description: 'If true, the sound player is shut down after playing finished'
- type: #Boolean>
-
- ^SoundsStopWhenDone ifNil: [self defaultStopSoundForPlatform]!
Item was removed:
- ----- Method: SoundPlayer class>>stopSoundWhenDone: (in category 'preferences') -----
- stopSoundWhenDone: aBoolean
-
- SoundsStopWhenDone := aBoolean!
Item was removed:
- ----- Method: SoundPlayer class>>useLastBuffer (in category 'initialization') -----
- useLastBuffer
- ^LastBuffer notNil!
Item was removed:
- ----- Method: SoundPlayer class>>useLastBuffer: (in category 'initialization') -----
- useLastBuffer: aBool
- Buffer ifNil:[^self].
- aBool
- ifTrue:[LastBuffer := SoundBuffer basicNew: Buffer basicSize]
- ifFalse:[LastBuffer := nil] !
Item was removed:
- ----- Method: SoundPlayer class>>useShortBuffer (in category 'initialization') -----
- useShortBuffer
- "Experimental support for real-time MIDI input. This only works on platforms whose hardware allows very short buffer sizes. It has been tested on a Macintosh Powerbook G3."
- "SoundPlayer useShortBuffer"
-
- self shutDown: true.
- BufferMSecs := 15.
- SoundPlayer
- startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000
- rate: SamplingRate
- stereo: Stereo.
- !
Item was removed:
- ----- Method: SoundPlayer class>>waitUntilDonePlaying: (in category 'playing') -----
- waitUntilDonePlaying: aSound
- "Wait until the given sound is no longer playing."
-
- [PlayerSemaphore critical: [ActiveSounds includes: aSound]]
- whileTrue: [(Delay forMilliseconds: 100) wait].
- !
Item was removed:
- ----- Method: SoundPlayer>>startUp (in category 'system startup') -----
- startUp
-
- SoundPlayer soundQuickStart: SoundPlayer defaultQuickStartForPlatform.
- SoundPlayer stopSoundWhenDone: SoundPlayer defaultStopSoundForPlatform.!
Item was removed:
- Object subclass: #SoundRecorder
- instanceVariableNames: 'stereo samplingRate recordLevel recordedBuffers recordedSound recordProcess bufferAvailableSema paused meteringBuffer meterLevel soundPlaying currentBuffer nextIndex codec desiredSampleRate'
- classVariableNames: 'CanRecordWhilePlaying RecorderActive'
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: SoundRecorder class>>anyActive (in category 'accessing') -----
- anyActive
- "Return true if any sound recorder is actively recording"
- ^RecorderActive == true!
Item was removed:
- ----- Method: SoundRecorder class>>canRecordWhilePlaying (in category 'accessing') -----
- canRecordWhilePlaying
- "Return true if this platform supports simultaneous sound recording and playback."
- <preference: 'Record while playing'
- category: 'media'
- description: 'If true, recording and playing sounds concurrently is permitted (platform dependent)'
- type: #Boolean>
- ^CanRecordWhilePlaying ifNil: [false].
- !
Item was removed:
- ----- Method: SoundRecorder class>>canRecordWhilePlaying: (in category 'accessing') -----
- canRecordWhilePlaying: aBoolean
-
- CanRecordWhilePlaying := aBoolean
- !
Item was removed:
- ----- Method: SoundRecorder>>allocateBuffer (in category 'private') -----
- allocateBuffer
- "Allocate a new buffer and reset nextIndex."
-
- | bufferTime |
- bufferTime := stereo "Buffer time = 1/2 second"
- ifTrue: [self samplingRate asInteger]
- ifFalse: [self samplingRate asInteger // 2].
- currentBuffer := SoundBuffer newMonoSampleCount:
- "Multiple of samplesPerFrame that is approx. bufferTime long"
- (bufferTime truncateTo: self samplesPerFrame).
- nextIndex := 1.
- !
Item was removed:
- ----- Method: SoundRecorder>>clearRecordedSound (in category 'recording controls') -----
- clearRecordedSound
- "Clear the sound recorded thus far. Go into pause mode if currently recording."
-
- paused := true.
- recordedSound := SequentialSound new.
- self allocateBuffer.
- !
Item was removed:
- ----- Method: SoundRecorder>>codec: (in category 'accessing') -----
- codec: aSoundCodec
-
- codec := aSoundCodec!
Item was removed:
- ----- Method: SoundRecorder>>condensedSamples (in category 'results') -----
- condensedSamples
- "Return a single SoundBuffer that is the contatenation of all my recorded buffers."
-
- | sz newBuf i |
- recordedBuffers := recordedSound sounds collect: [:snd | snd samples].
- recordedBuffers isEmpty ifTrue: [^ SoundBuffer new: 0].
- recordedBuffers size = 1 ifTrue: [^ recordedBuffers first copy].
- sz := recordedBuffers inject: 0 into: [:tot :buff | tot + buff size].
- newBuf := SoundBuffer newMonoSampleCount: sz.
- i := 1.
- recordedBuffers do: [:b |
- 1 to: b size do: [:j |
- newBuf at: i put: (b at: j).
- i := i + 1]].
- recordedBuffers := nil.
- ^ newBuf
- !
Item was removed:
- ----- Method: SoundRecorder>>condensedStereoSound (in category 'results') -----
- condensedStereoSound
- "Decompose my buffers into left and right channels and return a mixed sound consisting of the those two channels. This may be take a while, since the data must be copied into new buffers."
-
- | sz leftBuf rightBuf leftI rightI left |
- sz := recordedBuffers inject: 0 into: [:tot :buff | tot + buff size].
- leftBuf := SoundBuffer newMonoSampleCount: (sz + 1) // 2.
- rightBuf := SoundBuffer newMonoSampleCount: (sz + 1) // 2.
- leftI := rightI := 1.
- left := true.
- recordedBuffers do: [:b |
- 1 to: b size do: [:j |
- left
- ifTrue: [leftBuf at: leftI put: (b at: j). leftI := leftI + 1. left := false]
- ifFalse: [rightBuf at: rightI put: (b at: j). rightI := rightI + 1. left := true]]].
- ^ MixedSound new
- add: (SampledSound new setSamples: leftBuf samplingRate: samplingRate) pan: 0.0;
- add: (SampledSound new setSamples: rightBuf samplingRate: samplingRate) pan: 1.0
- !
Item was removed:
- ----- Method: SoundRecorder>>copyFrom:to:normalize:dcOffset: (in category 'trimming') -----
- copyFrom: startPlace to: endPlace normalize: nFactor dcOffset: dcOffset
- "Return a new SoundBuffer containing the samples in the given range."
-
- | startBufIndex startSampleIndex endBufIndex endSampleIndex
- count resultBuf j buf firstInBuf n |
- startBufIndex := startPlace at: 1.
- startSampleIndex := startPlace at: 2.
- endBufIndex := endPlace at: 1.
- endSampleIndex := endPlace at: 2.
-
- startBufIndex = endBufIndex
- ifTrue: [count := endSampleIndex + 1 - startSampleIndex]
- ifFalse: [
- count := ((recordedBuffers at: startBufIndex) size + 1 - startSampleIndex). "first buffer"
- count := count + endSampleIndex. "last buffer"
- startBufIndex + 1 to: endBufIndex - 1 do:
- [:i | count := count + (recordedBuffers at: i) size]]. "middle buffers"
- resultBuf := SoundBuffer newMonoSampleCount: count.
-
- j := 1. "next destination index in resultBuf"
- startBufIndex to: endBufIndex do: [:i |
- buf := recordedBuffers at: i.
- firstInBuf := 1.
- n := buf size.
- i = startBufIndex ifTrue: [
- n := (recordedBuffers at: startBufIndex) size + 1 - startSampleIndex.
- firstInBuf := startSampleIndex].
- i = endBufIndex ifTrue: [
- i = startBufIndex
- ifTrue: [n := endSampleIndex + 1 - startSampleIndex]
- ifFalse: [n := endSampleIndex]].
- self copyTo: resultBuf from: j to: (j + n - 1)
- from: buf startingAt: firstInBuf
- normalize: nFactor dcOffset: dcOffset.
- j := j + n].
- ^ resultBuf
- !
Item was removed:
- ----- Method: SoundRecorder>>copyTo:from:to:from:startingAt:normalize:dcOffset: (in category 'trimming') -----
- copyTo: resultBuf from: startIndex to: endIndex from: buf startingAt: firstInBuf normalize: nFactor dcOffset: dcOffset
- "Copy samples from buf to resultBuf removing the DC offset and normalizing their volume in the process."
-
- | indexOffset |
- indexOffset := firstInBuf - startIndex.
- startIndex to: endIndex do: [:i |
- resultBuf at: i put: (((buf at: (i + indexOffset)) - dcOffset) * nFactor) // 1000].
- !
Item was removed:
- ----- Method: SoundRecorder>>desiredSampleRate: (in category 'accessing') -----
- desiredSampleRate: newRate
-
- "use of this method indicates a strong desire for the specified rate, even if
- the OS/hardware are not cooperative"
-
- desiredSampleRate := samplingRate := newRate "Best are 44100 22050 11025"
- !
Item was removed:
- ----- Method: SoundRecorder>>emitBuffer: (in category 'private') -----
- emitBuffer: buffer
- | sound ratio |
-
- "since some sound recording devices cannot (or will not) record below a certain sample rate,
- trim the samples down if the user really wanted fewer samples"
-
- sound := (desiredSampleRate isNil or: [(ratio := samplingRate // desiredSampleRate) <= 1])
- ifTrue: [SampledSound new setSamples: buffer samplingRate: samplingRate]
- ifFalse:
- [| resultBuf |
- resultBuf := SoundBuffer
- averageEvery: ratio
- from: buffer
- upTo: buffer monoSampleCount.
- SampledSound new setSamples: resultBuf samplingRate: samplingRate / ratio].
- recordedSound ifNil:
- [recordedSound := SequentialSound new].
- recordedSound add: (codec ifNil: [sound] ifNotNil: [codec compressSound: sound])!
Item was removed:
- ----- Method: SoundRecorder>>emitPartialBuffer (in category 'private') -----
- emitPartialBuffer
- | s |
- s := self samplesPerFrame.
- self emitBuffer: (currentBuffer copyFrom: 1 to: ((nextIndex-1) +( s-1) truncateTo: s))!
Item was removed:
- ----- Method: SoundRecorder>>endPlace (in category 'trimming') -----
- endPlace
-
- ^ Array with: recordedBuffers size with: recordedBuffers last size!
Item was removed:
- ----- Method: SoundRecorder>>firstSampleOverThreshold:dcOffset:startingAt: (in category 'trimming') -----
- firstSampleOverThreshold: threshold dcOffset: dcOffset startingAt: startPlace
- "Beginning at startPlace, this routine will return the first place at which a sample exceeds the given threshold."
-
- | buf s iStart jStart nThreshold |
- nThreshold := threshold negated.
- iStart := startPlace first.
- jStart := startPlace second.
- iStart to: recordedBuffers size do:
- [:i | buf := recordedBuffers at: i.
- jStart to: buf size do:
- [:j | s := (buf at: j) - dcOffset.
- (s < nThreshold or: [s > threshold]) ifTrue:
- ["found a sample over threshold"
- ^ Array with: i with: j]].
- jStart := 1].
- ^ self endPlace!
Item was removed:
- ----- Method: SoundRecorder>>hasRecordedSound (in category 'recording controls') -----
- hasRecordedSound
- "Answer whether the receiver currently has any recorded sound"
-
- ^ self recordedSound notNil!
Item was removed:
- ----- Method: SoundRecorder>>initialize (in category 'initialization') -----
- initialize
- "SoundRecorder new"
-
- super initialize.
- stereo := false.
- samplingRate := 11025.
- recordLevel := 0.5.
- self initializeRecordingState.
- !
Item was removed:
- ----- Method: SoundRecorder>>initializeRecordingState (in category 'initialization') -----
- initializeRecordingState
-
- recordProcess := nil.
- bufferAvailableSema := nil.
- paused := true.
- meteringBuffer := nil.
- meterLevel := 0.
- soundPlaying := nil.
- currentBuffer := nil.
- nextIndex := 1.
- !
Item was removed:
- ----- Method: SoundRecorder>>isActive (in category 'accessing') -----
- isActive
- "Return true if I have a recordProcess running."
-
- ^ recordProcess ~~ nil
- !
Item was removed:
- ----- Method: SoundRecorder>>isPaused (in category 'accessing') -----
- isPaused
- "Return true if recording is paused."
-
- ^ paused
- !
Item was removed:
- ----- Method: SoundRecorder>>meterFrom:count:in: (in category 'private') -----
- meterFrom: start count: count in: buffer
- "Update the meter level with the maximum signal level in the given range of the given buffer."
-
- | max sample min |
- count = 0 ifTrue: [^self]. "no new samples"
- max := min := 0.
- start to: start + count - 1 do:
- [:i |
- sample := buffer at: i.
- sample > max
- ifTrue: [max := sample]
- ifFalse:
- [sample < min ifTrue: [min := sample]]].
- meterLevel := max max: min negated!
Item was removed:
- ----- Method: SoundRecorder>>meterLevel (in category 'accessing') -----
- meterLevel
- "Return the meter level, an integer in the range [0..100] where zero is silence and 100 represents the maximum signal level possible without clipping."
-
- ^ (100 * meterLevel) // 32768
- !
Item was removed:
- ----- Method: SoundRecorder>>normalizeFactorFor:min:max:dcOffset: (in category 'trimming') -----
- normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset
- "Return a normalization factor for the range of sample values and DC offset. A normalization factor is a fixed-point number that will be divided by 1000 after multiplication with each sample value."
-
- | peak factor |
- peak := (max - dcOffset) max: (min - dcOffset) negated.
- peak = 0 ifTrue: [^ 1000].
- factor := (32767.0 * percentOfMaxVolume) / (100.0 * peak).
- ^ (factor * 1000.0) asInteger
- !
Item was removed:
- ----- Method: SoundRecorder>>pause (in category 'recording controls') -----
- pause
- "Go into pause mode. The record level continues to be updated, but no sound is recorded."
-
- paused := true.
- ((currentBuffer ~~ nil) and: [nextIndex > 1])
- ifTrue: [self emitPartialBuffer.
- self allocateBuffer].
-
- soundPlaying ifNotNil: [
- soundPlaying pause.
- soundPlaying := nil].
- "Note: there can be problems if canRecordWhilePlaying is true. Recorders which only pause will inhibit other recorders from recording. I chose to make #stopPlaying unconditional in a subclass. The same might be appropriate here at the expense of making recorders resumable"
-
- self class canRecordWhilePlaying ifFalse: [self stopRecording].!
Item was removed:
- ----- Method: SoundRecorder>>place:plus: (in category 'trimming') -----
- place: startPlace plus: nSamples
- "Return the place that is nSamples (may be negative) beyond thisPlace."
-
- | i j remaining buf |
- i := startPlace first.
- j := startPlace second.
- nSamples >= 0
- ifTrue: [remaining := nSamples.
- [buf := recordedBuffers at: i.
- (j + remaining) <= buf size ifTrue: [^ Array with: i with: j + remaining].
- i < recordedBuffers size]
- whileTrue: [remaining := remaining - (buf size - j + 1).
- i := i+1. j := 1].
- ^ self endPlace]
- ifFalse: [remaining := nSamples negated.
- [buf := recordedBuffers at: i.
- (j - remaining) >= 1 ifTrue: [^ Array with: i with: j - remaining].
- i > 1]
- whileTrue: [remaining := remaining - j.
- i := i-1. j := (recordedBuffers at: i) size].
- ^ #(1 1)]!
Item was removed:
- ----- Method: SoundRecorder>>playback (in category 'recording controls') -----
- playback
- "Playback the sound that has been recorded."
-
- self pause.
- soundPlaying := self recordedSound.
- soundPlaying play.
- !
Item was removed:
- ----- Method: SoundRecorder>>primGetActualRecordingSampleRate (in category 'primitives') -----
- primGetActualRecordingSampleRate
- "Answer the actual sample rate being used for recording. This primitive fails unless sound recording is currently in progress."
-
- <primitive: 'primitiveSoundGetRecordingSampleRate' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundRecorder>>primRecordSamplesInto:startingAt: (in category 'primitives') -----
- primRecordSamplesInto: aWordArray startingAt: index
- "Record a sequence of 16-bit sound samples into the given array starting at the given sample index. Answer the number of samples recorded, which may be zero if no samples are currently available."
-
- <primitive: 'primitiveSoundRecordSamples' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundRecorder>>primSetRecordLevel: (in category 'primitives') -----
- primSetRecordLevel: anInteger
- "Set the desired recording level to the given value in the range 0-1000, where 0 is the lowest recording level and 1000 is the maximum. Do nothing if the sound input hardware does not support changing the recording level."
-
- <primitive: 'primitiveSoundSetRecordLevel' module: 'SoundPlugin' error: ec>
- ^self primitiveFailed!
Item was removed:
- ----- Method: SoundRecorder>>primStartRecordingDesiredSampleRate:stereo:semaIndex: (in category 'primitives') -----
- primStartRecordingDesiredSampleRate: samplesPerSec stereo: stereoFlag semaIndex: anInteger
- "Start sound recording with the given stereo setting. Use a sampling rate as close to the desired rate as the underlying platform will support. If the given semaphore index is > 0, it is taken to be the index of a Semaphore in the external objects array to be signalled every time a recording buffer is filled.
- We do *not* raise a primitiveFailed error here since this prim is called insdied a critical blcok and that often makes things painful. The only really likely case where this prim fails is a linux machine with no sound input hardware (a Raspberry Pi for example). See the startRecording method for how the failure is handled"
-
- <primitive: 'primitiveSoundStartRecording' module: 'SoundPlugin'>
- "self primitiveFailed"
- !
Item was removed:
- ----- Method: SoundRecorder>>primStopRecording (in category 'primitives') -----
- primStopRecording
- "Stop sound recording. Does nothing if recording is not currently in progress. Do not fail if plugin is not available"
-
- <primitive: 'primitiveSoundStopRecording' module: 'SoundPlugin'>!
Item was removed:
- ----- Method: SoundRecorder>>recordLevel (in category 'accessing') -----
- recordLevel
-
- ^ recordLevel
- !
Item was removed:
- ----- Method: SoundRecorder>>recordLevel: (in category 'accessing') -----
- recordLevel: level
- "Set the desired recording level to the given value in the range 0.0 to 1.0, where 0.0 is the lowest recording level and 1.0 is the maximum. Do nothing if the sound input hardware does not support changing the recording level."
- "Details: On the Macintosh, the lowest possible record level attenuates the input signal, but does not silence it entirely."
-
- recordLevel := (level asFloat min: 1.0) max: 0.0.
- recordProcess ifNotNil: [
- self primSetRecordLevel: (1000.0 * recordLevel) asInteger].
- !
Item was removed:
- ----- Method: SoundRecorder>>recordLoop (in category 'private') -----
- recordLoop
- "Record process loop that records samples."
-
- | n sampleCount linuxWorkaroundBlock |
-
- n := 0.
- linuxWorkaroundBlock := Smalltalk os platformName = 'unix'
- ifTrue: [ [ (Delay forMilliseconds: 20) wait ] ]
- ifFalse: [ nil ].
- [
- n = 0 ifTrue: [bufferAvailableSema wait].
- paused
- ifTrue: [
- n := self primRecordSamplesInto: meteringBuffer startingAt: 1.
- self meterFrom: 1 count: n in: meteringBuffer]
- ifFalse: [
- n := self primRecordSamplesInto: currentBuffer startingAt: nextIndex.
- self meterFrom: nextIndex count: n in: currentBuffer.
- nextIndex := nextIndex + n.
- stereo
- ifTrue: [sampleCount := currentBuffer stereoSampleCount]
- ifFalse: [sampleCount := currentBuffer monoSampleCount].
- nextIndex > sampleCount
- ifTrue: [
- self emitBuffer: currentBuffer.
- self allocateBuffer]].
-
- "workaround for OSS emulation on top on ALSA (on Linux environments)"
- linuxWorkaroundBlock ifNotNil: [ linuxWorkaroundBlock value ] ] repeat
- !
Item was removed:
- ----- Method: SoundRecorder>>recordedSound (in category 'results') -----
- recordedSound
- "Return the sound that was recorded."
-
- ^ recordedSound
- !
Item was removed:
- ----- Method: SoundRecorder>>resumeRecording (in category 'recording controls') -----
- resumeRecording
- "Continue recording from the point at which it was last paused."
-
- self flag: #bob.
- "Note: If canRecordWhilePlaying is true, then recordings may never get started (at least by this method). One possibility, used in a subclass, is to make the #startPlaying unconditional. Another would be to use #startPlaying instead of #resumePlaying in appropriate cases"
-
- self class canRecordWhilePlaying ifFalse: [self startRecording].
- paused := false.
- !
Item was removed:
- ----- Method: SoundRecorder>>samplesPerFrame (in category 'private') -----
- samplesPerFrame
- "Can be overridden to quantize buffer size for, eg, fixed-frame codecs"
-
- codec == nil
- ifTrue: [^ 1]
- ifFalse: [^ codec samplesPerFrame]!
Item was removed:
- ----- Method: SoundRecorder>>samplingRate (in category 'accessing') -----
- samplingRate
-
- ^ samplingRate
- !
Item was removed:
- ----- Method: SoundRecorder>>samplingRate: (in category 'accessing') -----
- samplingRate: newRate
-
- samplingRate := newRate "Best are 44100 22050 11025"
- !
Item was removed:
- ----- Method: SoundRecorder>>scanForEndThreshold:dcOffset:minLull:startingAt: (in category 'trimming') -----
- scanForEndThreshold: threshold dcOffset: dcOffset minLull: lull startingAt: startPlace
- "Beginning at startPlace, this routine will find the last sound that exceeds threshold, such that if you look lull samples later you will not find another sound over threshold within the following block of lull samples.
- Return the place that is lull samples beyond to that last sound.
- If no end of sound is found, return endPlace."
-
- | buf s iStart jStart nThreshold n |
- nThreshold := threshold negated.
- iStart := startPlace first.
- jStart := startPlace second.
- n := 0.
- iStart to: recordedBuffers size do:
- [:i | buf := recordedBuffers at: i.
- jStart to: buf size do:
- [:j | s := (buf at: j) - dcOffset.
- (s < nThreshold or: [s > threshold])
- ifTrue: ["found a sample over threshold"
- n := 0]
- ifFalse: ["still not over threshold"
- n := n + 1.
- n >= lull ifTrue: [^ Array with: i with: j]]].
- jStart := 1].
- ^ self endPlace!
Item was removed:
- ----- Method: SoundRecorder>>scanForStartThreshold:dcOffset:minDur:startingAt: (in category 'trimming') -----
- scanForStartThreshold: threshold dcOffset: dcOffset minDur: duration startingAt: startPlace
- "Beginning at startPlace, this routine will find the first sound that exceeds threshold, such that if you look duration samples later you will find another sound over threshold within the following block of duration samples.
- Return the place that is duration samples prior to that first sound.
- If no sound is found, return endPlace."
-
- | soundPlace lookPlace nextSoundPlace thirdPlace |
- soundPlace := self firstSampleOverThreshold: threshold dcOffset: dcOffset
- startingAt: startPlace.
- [soundPlace = self endPlace ifTrue: [^ soundPlace].
- "Found a sound -- look duration later"
- lookPlace := self place: soundPlace plus: duration.
- nextSoundPlace := self firstSampleOverThreshold: threshold dcOffset: dcOffset
- startingAt: lookPlace.
- thirdPlace := self place: lookPlace plus: duration.
- nextSoundPlace first < thirdPlace first
- or: [nextSoundPlace first = thirdPlace first
- and: [nextSoundPlace second < thirdPlace second]]]
- whileFalse: [soundPlace := nextSoundPlace].
-
- "Yes, there is sound in the next interval as well"
- ^ self place: soundPlace plus: 0-duration
- !
Item was removed:
- ----- Method: SoundRecorder>>segmentsAbove:normalizedVolume: (in category 'trimming') -----
- segmentsAbove: threshold normalizedVolume: percentOfMaxVolume
- "Break the current recording up into a sequence of sound segments separated by silences."
-
- | dcOffset firstPlace endPlace resultBuf nFactor lastPlace segments gapSize minDur minLull soundSize restSize max min sum totalSamples |
- stereo ifTrue: [self error: 'stereo trimming is not yet supported'].
- paused ifFalse: [self error: 'must stop recording before trimming'].
- (recordedSound == nil or: [recordedSound sounds isEmpty]) ifTrue:[^ self].
- "Reconstruct buffers so old trimming code will work"
- recordedBuffers := recordedSound sounds collect: [:snd | snd samples].
- soundSize := restSize := 0.
-
- max := min := sum := totalSamples := 0.
- recordedBuffers do: [:buf | | bufSize s |
- bufSize := buf size.
- totalSamples := totalSamples + buf size.
- 1 to: bufSize do: [:i |
- s := buf at: i.
- s > max ifTrue: [max := s].
- s < min ifTrue: [min := s].
- sum := sum + s]].
- dcOffset := sum // totalSamples.
-
- minDur := (samplingRate/20.0) asInteger. " 1/20 second "
- minLull := (samplingRate/4.0) asInteger. " 1/2 second "
- segments := SequentialSound new.
- endPlace := self endPlace.
- lastPlace := #(1 1).
- [firstPlace := self scanForStartThreshold: threshold
- dcOffset: dcOffset
- minDur: minDur
- startingAt: lastPlace.
- firstPlace = endPlace]
- whileFalse:
- [firstPlace = lastPlace ifFalse:
- ["Add a silence equal to the gap size"
- "Wasteful but simple way to get gap size..."
- gapSize := (self copyFrom: lastPlace to: firstPlace
- normalize: 1000 dcOffset: dcOffset) size - 2.
- "... -2 makes up for overlap of one sample on either end"
- segments add: (RestSound dur: gapSize asFloat / samplingRate).
- restSize := restSize + gapSize.
- "Transcript cr; print: firstPlace; space; print: lastPlace; space; print: gapSize; space; show: 'gap'."
- ].
- lastPlace := self scanForEndThreshold: threshold
- dcOffset: dcOffset
- minLull: minLull + minDur
- startingAt: firstPlace.
- "Allow room for lead time of next sound"
- lastPlace := self place: lastPlace plus: minDur negated.
- nFactor := self normalizeFactorFor: percentOfMaxVolume
- min: min max: max dcOffset: dcOffset.
- resultBuf := self copyFrom: firstPlace to: lastPlace
- normalize: nFactor dcOffset: dcOffset.
- soundSize := soundSize + resultBuf size.
- "Transcript cr; print: firstPlace; space; print: lastPlace; space; print: resultBuf size; space; show: 'sound'."
- segments add: (codec == nil
- ifTrue: [SampledSound new setSamples: resultBuf samplingRate: samplingRate]
- ifFalse: [codec compressSound: (SampledSound new setSamples: resultBuf samplingRate: samplingRate)])].
-
- "Final gap for consistency"
- gapSize := (self copyFrom: lastPlace to: self endPlace
- normalize: 1000 dcOffset: dcOffset) size - 1.
- segments add: (RestSound dur: gapSize asFloat / samplingRate).
- restSize := restSize + gapSize.
- self inform: (soundSize+restSize/samplingRate printShowingMaxDecimalPlaces: 1) , ' secs reduced to ' , (soundSize/samplingRate printShowingMaxDecimalPlaces: 1).
- recordedBuffers := nil.
- ^ segments!
Item was removed:
- ----- Method: SoundRecorder>>soundSegments (in category 'results') -----
- soundSegments
-
- ^ self segmentsAbove: 1000 normalizedVolume: 80.0
- !
Item was removed:
- ----- Method: SoundRecorder>>startRecording (in category 'recording controls') -----
- startRecording
- "Turn on the sound input driver and start the recording process. Initially, recording is paused.
- If the primStartRecordingDesiredSampleRate:... fails it almost certainly means we have no usable
- sound input device. Rather than having the prim raise a failure error we let it quietly do nothing
- (since I hate trying to debug errors inside a critical block) and check the actual sampling rate later.
- If the sampling rate is 0 we know the startup failed and raise an application level Signal to let any
- user code know about the problem.
- You might think we should also use the stopRecording message to close things down cleanly but
- that simply results in astorm of attempts to start recording so it is simpler to let it be deluded. An
- attempts to start recording will repeat the test and thereby handle any plug-in hardware etc."
-
- recordLevel ifNil: [recordLevel := 0.5]. "lazy initialization"
- self class canRecordWhilePlaying ifFalse: [SoundPlayer shutDown: true].
- recordProcess ifNotNil: [self stopRecording].
- paused := true.
- meteringBuffer := SoundBuffer newMonoSampleCount: 1024.
- meterLevel := 0.
- self allocateBuffer.
- Smalltalk newExternalSemaphoreDo: [ :semaphore :index |
- bufferAvailableSema := semaphore.
- self primStartRecordingDesiredSampleRate: samplingRate asInteger
- stereo: stereo
- semaIndex: index ].
- RecorderActive := true.
- samplingRate := self primGetActualRecordingSampleRate.
- samplingRate = 0 ifTrue: [ Warning signal: 'SoundRecorder: unable to connect to sound input device'].
- self primSetRecordLevel: (1000.0 * recordLevel) asInteger.
- recordProcess := [self recordLoop] newProcess.
- recordProcess priority: Processor userInterruptPriority.
- recordProcess resume!
Item was removed:
- ----- Method: SoundRecorder>>stopRecording (in category 'recording controls') -----
- stopRecording
- "Stop the recording process and turn of the sound input driver."
-
- recordProcess ifNotNil: [recordProcess terminate].
- recordProcess := nil.
- self primStopRecording.
- RecorderActive := false.
- Smalltalk unregisterExternalObject: bufferAvailableSema.
- ((currentBuffer ~~ nil) and: [nextIndex > 1])
- ifTrue: [self emitPartialBuffer].
- codec ifNotNil: [codec reset].
- self initializeRecordingState.
- !
Item was removed:
- ----- Method: SoundRecorder>>suppressSilence (in category 'trimming') -----
- suppressSilence
-
- recordedSound := self soundSegments!
Item was removed:
- ----- Method: SoundRecorder>>trim:normalizedVolume: (in category 'trimming') -----
- trim: threshold normalizedVolume: percentOfMaxVolume
- "Remove the leading and trailing parts of this recording that are below the given threshold. Remove any DC offset and scale the recording so that its peaks are the given percent of the maximum volume."
-
- | dcOffset startPlace endPlace resultBuf nFactor max min sum totalSamples |
- stereo ifTrue: [self error: 'stereo trimming is not yet supported'].
- paused ifFalse: [self error: 'must stop recording before trimming'].
- recordedBuffers := recordedSound sounds collect: [:snd | snd samples].
- recordedBuffers isEmpty ifTrue: [^ self].
-
- max := min := sum := totalSamples := 0.
- recordedBuffers do: [:buf | | bufSize s |
- bufSize := buf size.
- totalSamples := totalSamples + buf size.
- 1 to: bufSize do: [:i |
- s := buf at: i.
- s > max ifTrue: [max := s].
- s < min ifTrue: [min := s].
- sum := sum + s]].
- dcOffset := sum // totalSamples.
-
- "a place is an array of <buffer index><index of sample in buffer>"
- startPlace := self scanForStartThreshold: threshold
- dcOffset: dcOffset
- minDur: (samplingRate/60.0) asInteger "at least 1/60th of a second"
- startingAt: #(1 1).
- startPlace = self endPlace ifTrue:
- ["no samples above threshold"
- recordedBuffers := nil. ^ self].
-
- endPlace := self scanForEndThreshold: threshold
- dcOffset: dcOffset
- minLull: (samplingRate/5) asInteger
- startingAt: startPlace.
- nFactor := self normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset.
- resultBuf := self copyFrom: startPlace to: endPlace normalize: nFactor dcOffset: dcOffset.
- recordedSound := SampledSound new setSamples: resultBuf samplingRate: samplingRate.
- recordedBuffers := nil
- !
Item was removed:
- ----- Method: SoundRecorder>>verifyExistenceOfRecordedSound (in category 'recording controls') -----
- verifyExistenceOfRecordedSound
- "If the receiver has a recorded sound, answer true; if not, put up an informer and answer false"
-
- ^ self recordedSound
- ifNotNil:
- [true]
- ifNil:
- [self inform: 'please record a sound first' translated.
- false]!
Item was removed:
- AbstractSound subclass: #StreamingMonoSound
- instanceVariableNames: 'stream volume repeat headerStart audioDataStart streamSamplingRate totalSamples codec mixer leftoverSamples lastBufferMSecs mutex'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !StreamingMonoSound commentStamp: '<historical>' prior: 0!
- I implement a streaming player for monophonic Sun (.au) and AIFF (.aif) audio files.
- Example of use:
- (StreamingMonoSound onFileNamed: 'song.aif') play.
- !
Item was removed:
- ----- Method: StreamingMonoSound class>>onFileNamed: (in category 'instance creation') -----
- onFileNamed: fileName
- "Answer an instance of me for playing the file with the given name."
-
- | f |
- f := FileDirectory default readOnlyFileNamed: fileName.
- f ifNil: [^ self error: 'could not open ', fileName].
- ^ self new initStream: f headerStart: 0
- !
Item was removed:
- ----- Method: StreamingMonoSound class>>onFileNamed:headerStart: (in category 'instance creation') -----
- onFileNamed: fileName headerStart: anInteger
- "Answer an instance of me for playing audio data starting at the given position in the file with the given name."
-
- | f |
- f := FileDirectory default readOnlyFileNamed: fileName.
- f ifNil: [^ self error: 'could not open ', fileName].
- ^ self new initStream: f headerStart: anInteger
- !
Item was removed:
- ----- Method: StreamingMonoSound>>closeFile (in category 'other') -----
- closeFile
- "Close my stream, if it responds to close."
-
- stream ifNotNil: [
- (stream respondsTo: #close) ifTrue: [stream close]].
- mixer := nil.
- codec := nil.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>createMixer (in category 'private') -----
- createMixer
- "Create a mixed sound consisting of sampled sounds with one sound buffer's worth of samples."
-
- | snd |
- mixer := MixedSound new.
- snd := SampledSound
- samples: (SoundBuffer newMonoSampleCount: 2) "buffer size will be adjusted dynamically"
- samplingRate: streamSamplingRate.
- mixer add: snd pan: 0.5 volume: volume.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>currentSampleIndex (in category 'private') -----
- currentSampleIndex
- "Answer the index of the current sample."
-
- | bytePosition frameIndex |
- bytePosition := stream position - audioDataStart.
- codec
- ifNil: [^ bytePosition // 2]
- ifNotNil: [
- frameIndex := bytePosition // codec bytesPerEncodedFrame.
- ^ (frameIndex * codec samplesPerFrame) - leftoverSamples monoSampleCount].
- !
Item was removed:
- ----- Method: StreamingMonoSound>>duration (in category 'accessing') -----
- duration
- "Answer the duration of this sound in seconds."
-
- ^ totalSamples asFloat / streamSamplingRate
- !
Item was removed:
- ----- Method: StreamingMonoSound>>extractFrom:to: (in category 'other') -----
- extractFrom: startSecs to: endSecs
- "Extract a portion of this sound between the given start and end times. The current implementation only works if the sound is uncompressed."
-
- | emptySound first last sampleCount byteStream sndBuf |
- codec ifNotNil: [^ self error: 'only works on uncompressed sounds'].
- emptySound := SampledSound samples: SoundBuffer new samplingRate: streamSamplingRate.
- first := (startSecs * streamSamplingRate) truncated max: 0.
- last := ((endSecs * streamSamplingRate) truncated min: totalSamples) - 1.
- first >= last ifTrue: [^ emptySound].
- codec ifNotNil: [self error: 'extracting from compressed sounds is not supported'].
- sampleCount := last + 1 - first.
- stream position: audioDataStart + (2 * first).
- byteStream := ReadStream on: (stream next: 2 * sampleCount).
- sndBuf := SoundBuffer newMonoSampleCount: sampleCount.
- 1 to: sampleCount do: [:i | sndBuf at: i put: byteStream int16].
- ^ SampledSound samples: sndBuf samplingRate: streamSamplingRate
- !
Item was removed:
- ----- Method: StreamingMonoSound>>initStream:headerStart: (in category 'initialization') -----
- initStream: aStream headerStart: anInteger
- "Initialize for streaming from the given stream. The audio file header starts at the given stream position."
-
- stream := aStream.
- volume := 1.0.
- repeat := false.
- headerStart := anInteger.
- self reset.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>loadBuffer:compressedSampleCount: (in category 'private') -----
- loadBuffer: aSoundBuffer compressedSampleCount: sampleCount
- "Load the given sound buffer from the compressed sample stream."
- "Details: Most codecs decode in multi-sample units called 'frames'. Since the requested sampleCount is typically not an even multiple of the frame size, we need to deal with partial frames. The unused samples from a partial frame are retained until the next call to this method."
-
- | n samplesNeeded frameCount encodedBytes r decodedCount buf j |
- "first, use any leftover samples"
- n := self loadFromLeftovers: aSoundBuffer sampleCount: sampleCount.
- samplesNeeded := sampleCount - n.
- samplesNeeded <= 0 ifTrue: [^ self].
-
- "decode an integral number of full compression frames"
- frameCount := samplesNeeded // codec samplesPerFrame.
- encodedBytes := stream next: (frameCount * codec bytesPerEncodedFrame).
- r := codec decodeFrames: frameCount from: encodedBytes at: 1 into: aSoundBuffer at: n + 1.
- decodedCount := r last.
- decodedCount >= samplesNeeded ifTrue: [^ self].
-
- "decode one last compression frame to finish filling the buffer"
- buf := SoundBuffer newMonoSampleCount: codec samplesPerFrame.
- encodedBytes := stream next: codec bytesPerEncodedFrame.
- codec decodeFrames: 1 from: encodedBytes at: 1 into: buf at: 1.
- j := 0.
- (n + decodedCount + 1) to: sampleCount do: [:i |
- aSoundBuffer at: i put: (buf at: (j := j + 1))].
-
- "save the leftover samples"
- leftoverSamples := buf copyFrom: (j + 1) to: buf monoSampleCount.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>loadBuffer:uncompressedSampleCount: (in category 'private') -----
- loadBuffer: aSoundBuffer uncompressedSampleCount: sampleCount
- "Load the given sound buffer from the uncompressed sample stream."
-
- "read directly into the sample buffer; count is in 32-bit words"
- stream next: sampleCount // 2 into: aSoundBuffer startingAt: 1.
- aSoundBuffer restoreEndianness.
-
- "read the final sample if sampleCount is odd:"
- sampleCount odd ifTrue: [aSoundBuffer at: sampleCount put: stream int16].
- !
Item was removed:
- ----- Method: StreamingMonoSound>>loadBuffersForSampleCount: (in category 'private') -----
- loadBuffersForSampleCount: count
- "Load the sound buffers from the stream."
-
- | snd buf sampleCount |
- snd := mixer sounds first.
- buf := snd samples.
- buf monoSampleCount = count ifFalse: [
- buf := SoundBuffer newMonoSampleCount: count.
- snd setSamples: buf samplingRate: streamSamplingRate].
- sampleCount := count min: (totalSamples - self currentSampleIndex).
- sampleCount < count ifTrue: [buf primFill: 0].
-
- codec
- ifNil: [self loadBuffer: buf uncompressedSampleCount: sampleCount]
- ifNotNil: [self loadBuffer: buf compressedSampleCount: sampleCount].
-
- mixer reset.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>loadFromLeftovers:sampleCount: (in category 'private') -----
- loadFromLeftovers: aSoundBuffer sampleCount: sampleCount
- "Load the given sound buffer from the samples leftover from the last frame. Answer the number of samples loaded, which typically is less than sampleCount."
-
- | leftoverCount n |
- leftoverCount := leftoverSamples monoSampleCount.
- leftoverCount = 0 ifTrue: [^ 0].
-
- n := leftoverCount min: sampleCount.
- 1 to: n do: [:i | aSoundBuffer at: i put: (leftoverSamples at: i)].
- n < sampleCount
- ifTrue: [leftoverSamples := SoundBuffer new]
- ifFalse: [leftoverSamples := leftoverSamples copyFrom: n + 1 to: leftoverSamples size].
- ^ n
- !
Item was removed:
- ----- Method: StreamingMonoSound>>millisecondsSinceStart (in category 'playing') -----
- millisecondsSinceStart
- "Answer the number of milliseconds of this sound started playing."
-
- | mSecs |
- (stream isNil or: [stream closed]) ifTrue: [^ 0].
- mSecs := self currentSampleIndex * 1000 // streamSamplingRate.
- (self isPlaying and: [lastBufferMSecs > 0]) ifTrue: [
- "adjust mSecs by the milliseconds since the last buffer"
- mutex critical: [
- mSecs := self currentSampleIndex * 1000 // streamSamplingRate.
- mSecs := mSecs + ((Time millisecondClockValue - lastBufferMSecs) max: 0)]].
- ^ mSecs + 350 - (2 * SoundPlayer bufferMSecs)
- !
Item was removed:
- ----- Method: StreamingMonoSound>>playSampleCount:into:startingAt: (in category 'playing') -----
- playSampleCount: n into: aSoundBuffer startingAt: startIndex
- "Mix the next n samples of this sound into the given buffer starting at the given index"
-
- self repeat ifTrue: [ "loop if necessary"
- (totalSamples - self currentSampleIndex) < n ifTrue: [self startOver]].
-
- mutex critical: [
- lastBufferMSecs := Time millisecondClockValue.
- self loadBuffersForSampleCount: (n * streamSamplingRate) // SoundPlayer samplingRate.
- mixer playSampleCount: n into: aSoundBuffer startingAt: startIndex].
- !
Item was removed:
- ----- Method: StreamingMonoSound>>positionCodecTo: (in category 'private') -----
- positionCodecTo: desiredSampleIndex
- "Position to the closest frame before the given sample index when using a codec. If using the ADPCM codec, try to ensure that it is in sync with the compressed sample stream."
-
- | desiredFrameIndex desiredPosition tmpStream tmpCodec byteBuf bufFrames sampleBuf frameCount n startOffset |
- (codec isKindOf: ADPCMCodec) ifFalse: [
- "stateless codecs (or relatively stateless ones, like GSM: just jump to frame boundary"
- desiredFrameIndex := desiredSampleIndex // codec samplesPerFrame.
- stream position: audioDataStart + (desiredFrameIndex * codec bytesPerEncodedFrame).
- codec reset.
- ^ self].
-
- "compute the desired stream position"
- desiredFrameIndex := desiredSampleIndex // codec samplesPerFrame.
- desiredPosition := audioDataStart + (desiredFrameIndex * codec bytesPerEncodedFrame).
-
- "copy stream and codec"
- (stream isKindOf: FileStream)
- ifTrue: [tmpStream := (FileStream readOnlyFileNamed: stream name) binary]
- ifFalse: [tmpStream := stream deepCopy].
- tmpCodec := codec copy reset.
-
- "reset the codec and start back about 30 seconds to try to get codec in sync"
- startOffset := ((desiredFrameIndex - 80000) max: 0) * codec bytesPerEncodedFrame.
- tmpStream position: audioDataStart + startOffset.
-
- "decode forward to the desired position"
- byteBuf := ByteArray new: (32000 roundTo: codec bytesPerEncodedFrame).
- bufFrames := byteBuf size // codec bytesPerEncodedFrame.
- sampleBuf := SoundBuffer newMonoSampleCount: bufFrames * codec samplesPerFrame.
- frameCount := (desiredPosition - tmpStream position) // codec bytesPerEncodedFrame.
- [frameCount > 0] whileTrue: [
- n := bufFrames min: frameCount.
- tmpStream next: n * codec bytesPerEncodedFrame into: byteBuf startingAt: 1.
- tmpCodec decodeFrames: n from: byteBuf at: 1 into: sampleBuf at: 1.
- frameCount := frameCount - n].
-
- codec := tmpCodec.
- stream position: tmpStream position.
- (tmpStream isKindOf: FileStream) ifTrue: [tmpStream close].!
Item was removed:
- ----- Method: StreamingMonoSound>>readAIFFHeader (in category 'private') -----
- readAIFFHeader
- "Read an AIFF file header from stream."
-
- | aiffReader |
- aiffReader := AIFFFileReader new.
- aiffReader readFromStream: stream mergeIfStereo: false skipDataChunk: true.
- aiffReader channelCount = 1 ifFalse: [self error: 'not monophonic'].
- aiffReader bitsPerSample = 16 ifFalse: [self error: 'not 16-bit'].
-
- audioDataStart := headerStart + aiffReader channelDataOffset.
- streamSamplingRate := aiffReader samplingRate.
- totalSamples := aiffReader frameCount min: (stream size - audioDataStart) // 2.
- codec := nil.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>readHeader (in category 'private') -----
- readHeader
- "Read the sound file header from my stream."
-
- | id |
- stream position: headerStart.
- id := (stream next: 4) asString.
- stream position: headerStart.
- id = '.snd' ifTrue: [^ self readSunAudioHeader].
- id = 'FORM' ifTrue: [^ self readAIFFHeader].
- self error: 'unrecognized sound file format'.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>readSunAudioHeader (in category 'private') -----
- readSunAudioHeader
- "Read a Sun audio file header from my stream."
-
- | id headerBytes dataBytes format channelCount |
- id := (stream next: 4) asString.
- headerBytes := stream uint32. "header bytes"
- dataBytes := stream uint32.
- format := stream uint32.
- streamSamplingRate := stream uint32.
- channelCount := stream uint32.
-
- id = '.snd' ifFalse: [self error: 'not Sun audio format'].
- dataBytes := dataBytes min: (stream size - headerBytes).
- channelCount = 1 ifFalse: [self error: 'not monophonic'].
- audioDataStart := headerStart + headerBytes.
- codec := nil.
- format = 1 ifTrue: [ "8-bit u-LAW"
- codec := MuLawCodec new.
- totalSamples := dataBytes.
- ^ self].
- format = 3 ifTrue: [ "16-bit linear"
- totalSamples := dataBytes // 2.
- ^ self].
- format = 23 ifTrue: [ "ADPCM-4 bit (CCITT G.721)"
- codec := ADPCMCodec new
- initializeForBitsPerSample: 4 samplesPerFrame: 0.
- totalSamples := (dataBytes // 4) * 8.
- ^ self].
- format = 25 ifTrue: [ "ADPCM-3 bit (CCITT G.723)"
- codec := ADPCMCodec new
- initializeForBitsPerSample: 3 samplesPerFrame: 0.
- totalSamples := (dataBytes // 3) * 8.
- ^ self].
- format = 26 ifTrue: [ "ADPCM-5 bit (CCITT G.723)"
- codec := ADPCMCodec new
- initializeForBitsPerSample: 5 samplesPerFrame: 0.
- totalSamples := (dataBytes // 5) * 8.
- ^ self].
- format = 610 ifTrue: [ "GSM 06.10 (this format was added by Squeak)"
- codec := GSMCodec new.
- totalSamples := (dataBytes // 33) * 160.
- ^ self].
- self error: 'unsupported Sun audio format ', format printString
- !
Item was removed:
- ----- Method: StreamingMonoSound>>repeat (in category 'accessing') -----
- repeat
- "Answer the repeat flag."
-
- ^ repeat
- !
Item was removed:
- ----- Method: StreamingMonoSound>>repeat: (in category 'accessing') -----
- repeat: aBoolean
- "Set the repeat flag. If true, this sound will loop back to the beginning when it gets to the end."
-
- repeat := aBoolean.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>reset (in category 'playing') -----
- reset
-
- super reset.
- self startOver.
- self createMixer.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>samplesRemaining (in category 'playing') -----
- samplesRemaining
- "Answer the number of samples remaining to be played."
-
- | result |
- (stream isNil or: [stream closed]) ifTrue: [^ 0].
- self repeat ifTrue: [^ 1000000].
- result := (totalSamples - self currentSampleIndex) max: 0.
- result <= 0 ifTrue: [self closeFile].
- ^ result
- !
Item was removed:
- ----- Method: StreamingMonoSound>>saveAsFileNamed:compressionType: (in category 'converting') -----
- saveAsFileNamed: newFileName compressionType: compressionTypeString
- "Store this sound in a new file with the given name using the given compression type. Useful for converting between compression formats."
-
- | outFile |
- outFile := (FileStream newFileNamed: newFileName) binary.
- self storeSunAudioOn: outFile compressionType: compressionTypeString.
- outFile close.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>soundPosition (in category 'accessing') -----
- soundPosition
- "Answer the relative position of sound playback as a number between 0.0 and 1.0."
-
- (stream isNil or: [stream closed]) ifTrue: [^ 0.0].
- ^ self currentSampleIndex asFloat / totalSamples
- !
Item was removed:
- ----- Method: StreamingMonoSound>>soundPosition: (in category 'accessing') -----
- soundPosition: fraction
- "Jump to the position the given fraction through the sound file. The argument is a number between 0.0 and 1.0."
-
- | desiredSampleIndex |
- (stream isNil or: [stream closed]) ifTrue: [^ self].
- desiredSampleIndex := ((totalSamples * fraction) truncated max: 0) min: totalSamples.
- codec
- ifNil: [stream position: audioDataStart + (desiredSampleIndex * 2)]
- ifNotNil: [self positionCodecTo: desiredSampleIndex].
- leftoverSamples := SoundBuffer new.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>startOver (in category 'private') -----
- startOver
- "Jump back to the first sample."
-
- stream reopen; binary.
- self readHeader.
- stream position: audioDataStart.
- leftoverSamples := SoundBuffer new.
- lastBufferMSecs := 0.
- mutex := Semaphore forMutualExclusion.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>storeSunAudioOn:compressionType: (in category 'converting') -----
- storeSunAudioOn: aBinaryStream compressionType: compressionName
- "Store myself on the given stream as a monophonic sound compressed with the given type of compression. The sampling rate is reduced to 22050 samples/second if it is higher."
-
- | fmt inBufSize samplesPerFrame outCodec compressed outSamplingRate audioWriter |
- self pause; reset. "stop playing and return to beginning"
-
- fmt := SunAudioFileWriter formatCodeForCompressionType: compressionName.
- inBufSize := 64000.
- samplesPerFrame := 1.
- outCodec := SunAudioFileWriter codecForFormatCode: fmt.
- outCodec ifNotNil: [
- samplesPerFrame := outCodec samplesPerFrame.
- inBufSize := inBufSize roundUpTo: (2 * samplesPerFrame).
- compressed := ByteArray new:
- (inBufSize // samplesPerFrame) * outCodec bytesPerEncodedFrame].
- outSamplingRate := streamSamplingRate.
- streamSamplingRate > 22050 ifTrue: [
- streamSamplingRate = 44100 ifFalse: [self error: 'unexpected MP3 sampling rate'].
- outSamplingRate := 22050].
-
- "write audio header"
- audioWriter := SunAudioFileWriter onStream: aBinaryStream.
- audioWriter writeHeaderSamplingRate: outSamplingRate format: fmt.
-
- "convert and write sound data"
- 'Storing audio...'
- displayProgressFrom: 0 to: totalSamples during: [:bar | | outBuf counts inBuf samplesRemaining byteCount |
- samplesRemaining := totalSamples.
- [samplesRemaining > 0] whileTrue: [
- bar value: totalSamples - samplesRemaining.
- self loadBuffersForSampleCount: (inBufSize min: samplesRemaining).
- inBuf := mixer sounds first samples.
- outSamplingRate < streamSamplingRate
- ifTrue: [outBuf := inBuf downSampledLowPassFiltering: true]
- ifFalse: [outBuf := inBuf].
- outCodec
- ifNil: [audioWriter appendSamples: outBuf]
- ifNotNil: [
- counts := outCodec
- encodeFrames: (outBuf size // samplesPerFrame)
- from: outBuf at: 1
- into: compressed at: 1.
- byteCount := counts last.
- byteCount = compressed size
- ifTrue: [audioWriter appendBytes: compressed]
- ifFalse: [audioWriter appendBytes: (compressed copyFrom: 1 to: byteCount)]].
- samplesRemaining := samplesRemaining - inBuf monoSampleCount]].
-
- "update audio header"
- audioWriter updateHeaderDataSize.
- !
Item was removed:
- ----- Method: StreamingMonoSound>>streamSamplingRate (in category 'accessing') -----
- streamSamplingRate
- "Answer the sampling rate of the MP3 stream."
-
- ^ streamSamplingRate
- !
Item was removed:
- ----- Method: StreamingMonoSound>>volume (in category 'accessing') -----
- volume
- "Answer my volume."
-
- ^ volume
- !
Item was removed:
- ----- Method: StreamingMonoSound>>volume: (in category 'accessing') -----
- volume: aNumber
- "Set my volume to the given number between 0.0 and 1.0."
-
- volume := aNumber.
- self createMixer.
- !
Item was removed:
- ----- Method: String>>asSound (in category '*sound-synthesis') -----
- asSound
- "Return a sound. Either from the sound library via SampleSound or
- else the Beeper default"
- ^ SampledSound
- soundNamed: self
- ifAbsent: [Beeper default]!
Item was removed:
- Object subclass: #SunAudioFileWriter
- instanceVariableNames: 'stream headerStart'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !SunAudioFileWriter commentStamp: '<historical>' prior: 0!
- I encode monophonic sampled sounds in Sun audio (.au) file format. Sun audio files have a very simple format but can store both compressed and uncompressed sample data. I can write this format either directly into a file or onto any writable binary stream.
- !
Item was removed:
- ----- Method: SunAudioFileWriter class>>codecForFormatCode: (in category 'sound storing') -----
- codecForFormatCode: formatCode
- "Answer the codec for the given Sun audio file format number."
-
- formatCode = 1 ifTrue: [^ MuLawCodec new].
- formatCode = 3 ifTrue: [^ nil]. "uncompressed"
- formatCode = 23 ifTrue: [^ ADPCMCodec newBitsPerSample: 4].
- formatCode = 25 ifTrue: [^ ADPCMCodec newBitsPerSample: 3].
- formatCode = 26 ifTrue: [^ ADPCMCodec newBitsPerSample: 5].
- formatCode = 610 ifTrue: [^ GSMCodec new].
- self error: 'unsupported Sun audio format'
- !
Item was removed:
- ----- Method: SunAudioFileWriter class>>formatCodeForCompressionType: (in category 'sound storing') -----
- formatCodeForCompressionType: aString
- "Answer the Sun audio file format number for the given compression type name."
-
- | lowercase |
- lowercase := aString asLowercase.
- 'mulaw' = lowercase ifTrue: [^ 1].
- 'none' = lowercase ifTrue: [^ 3].
- 'adpcm3' = lowercase ifTrue: [^ 25].
- 'adpcm4' = lowercase ifTrue: [^ 23].
- 'adpcm5' = lowercase ifTrue: [^ 26].
- 'gsm' = lowercase ifTrue: [^ 610].
- self error: 'unknown compression style'
- !
Item was removed:
- ----- Method: SunAudioFileWriter class>>onFileNamed: (in category 'instance creation') -----
- onFileNamed: fileName
- "Answer an instance of me on a newly created file with the given name."
-
- | file |
- file := (FileStream newFileNamed: fileName) binary.
- ^ self new setStream: file
- !
Item was removed:
- ----- Method: SunAudioFileWriter class>>onStream: (in category 'instance creation') -----
- onStream: aBinaryStream
- "Answer an instance of me on the given binary stream."
-
- ^ self new setStream: aBinaryStream
- !
Item was removed:
- ----- Method: SunAudioFileWriter class>>storeSampledSound:onFileNamed:compressionType: (in category 'sound storing') -----
- storeSampledSound: aSampledSound onFileNamed: fileName compressionType: aString
- "Store the samples of the given sampled sound on a file with the given name using the given type of compression. See formatCodeForCompressionType: for the list of compression types."
-
- | fmt codec f compressed |
- fmt := self formatCodeForCompressionType: aString.
- codec := self codecForFormatCode: fmt.
- f := self onFileNamed: fileName.
- f writeHeaderSamplingRate: aSampledSound originalSamplingRate format: fmt.
- codec
- ifNil: [f appendSamples: aSampledSound samples]
- ifNotNil: [
- compressed := codec encodeSoundBuffer: aSampledSound samples.
- f appendBytes: compressed].
- f closeFile.
- !
Item was removed:
- ----- Method: SunAudioFileWriter>>appendBytes: (in category 'other') -----
- appendBytes: aByteArray
- "Append the given sample data to my stream."
-
- stream nextPutAll: aByteArray.
- !
Item was removed:
- ----- Method: SunAudioFileWriter>>appendSamples: (in category 'other') -----
- appendSamples: aSoundBuffer
- "Append the given SoundBuffer to my stream."
-
- | swapBytes s |
- (stream isKindOf: StandardFileStream) ifTrue: [
- "optimization: write sound buffer directly to file"
- swapBytes := Smalltalk isLittleEndian.
- swapBytes ifTrue: [aSoundBuffer reverseEndianness]. "make big endian"
- stream next: (aSoundBuffer size // 2) putAll: aSoundBuffer startingAt: 1. "size in words"
- swapBytes ifTrue: [aSoundBuffer reverseEndianness]. "revert to little endian"
- ^ self].
-
- "for non-file streams:"
- s := WriteStream on: (ByteArray new: 2 * aSoundBuffer monoSampleCount).
- 1 to: aSoundBuffer monoSampleCount do: [:i | s int16: (aSoundBuffer at: i)].
- self appendBytes: s contents.
- !
Item was removed:
- ----- Method: SunAudioFileWriter>>closeFile (in category 'other') -----
- closeFile
- "Update the Sun audio file header to reflect the final size of the sound data. If my stream is a file stream, close it and, on a Macintosh, set the file type and creator to that used by SoundApp for Sun Audio files. (This does nothing on other platforms.)"
-
- self ensureOpen.
- self updateHeaderDataSize.
- (stream isKindOf: StandardFileStream) ifTrue: [
- stream close.
- FileDirectory default setMacFileNamed: stream name type: 'ULAW' creator: 'SCPL'].
- !
Item was removed:
- ----- Method: SunAudioFileWriter>>ensureOpen (in category 'other') -----
- ensureOpen
- "Ensure that my stream is open."
-
- stream closed ifTrue: [stream reopen; binary].
- !
Item was removed:
- ----- Method: SunAudioFileWriter>>setStream: (in category 'initialization') -----
- setStream: aBinaryStream
- "Initialize myself for writing on the given stream."
-
- stream := aBinaryStream.
- headerStart := aBinaryStream position.
- !
Item was removed:
- ----- Method: SunAudioFileWriter>>updateHeaderDataSize (in category 'other') -----
- updateHeaderDataSize
- "Update the Sun audio file header to reflect the final size of the sound data."
-
- | byteCount |
- byteCount := stream position - (headerStart + 24).
- stream position: headerStart + 8.
- stream uint32: byteCount.
- !
Item was removed:
- ----- Method: SunAudioFileWriter>>writeHeaderSamplingRate: (in category 'other') -----
- writeHeaderSamplingRate: samplingRate
- "Write a Sun audio file header for 16-bit linear format."
-
- self writeHeaderSamplingRate: samplingRate format: 3.
- !
Item was removed:
- ----- Method: SunAudioFileWriter>>writeHeaderSamplingRate:format: (in category 'other') -----
- writeHeaderSamplingRate: samplingRate format: audioFormat
- "Write a Sun audio file header for the given sampling rate and format. Currently, only monophonic files are supported."
-
- self ensureOpen.
- stream position: headerStart.
- stream nextPutAll: '.snd' asByteArray.
- stream uint32: 24. "header size in bytes"
- stream uint32: 0. "sample data size in bytes; fill in later"
- stream uint32: audioFormat.
- stream uint32: samplingRate truncated.
- stream uint32: 1. "channel count"
- !
Item was removed:
- AbstractScoreEvent subclass: #TempoEvent
- instanceVariableNames: 'tempo'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Scores'!
-
- !TempoEvent commentStamp: '<historical>' prior: 0!
- Represents a tempo change in a MIDI score.
- !
Item was removed:
- ----- Method: TempoEvent class>>time:tempo: (in category 'instance creation') -----
- time: aTime tempo: aTempo
-
- ^ self new
- time: aTime;
- tempo: aTempo;
- yourself!
Item was removed:
- ----- Method: TempoEvent>>isTempoEvent (in category 'classification') -----
- isTempoEvent
-
- ^ true
- !
Item was removed:
- ----- Method: TempoEvent>>printOn: (in category 'printing') -----
- printOn: aStream
-
- aStream nextPut: $(.
- time printOn: aStream.
- aStream nextPutAll: ': tempo '.
- aStream nextPutAll: (120.0 * (500000.0 / tempo) printShowingMaxDecimalPlaces: 2).
- aStream nextPut: $).
- !
Item was removed:
- ----- Method: TempoEvent>>tempo (in category 'accessing') -----
- tempo
-
- ^ tempo
- !
Item was removed:
- ----- Method: TempoEvent>>tempo: (in category 'accessing') -----
- tempo: anInteger
-
- tempo := anInteger.
- !
Item was removed:
- FMSound subclass: #UnloadedSound
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !UnloadedSound commentStamp: '<historical>' prior: 0!
- Instances of me, which are really just FMSounds, are used placeholders for sounds that have been unloaded from this image but which may be re-loaded later.
- !
Item was removed:
- ----- Method: UnloadedSound class>>default (in category 'instruments') -----
- default
- "UnloadedSound default play"
-
- | snd p |
- snd := super new modulation: 1 ratio: 1.
- p := OrderedCollection new.
- p add: 0(a)0.0; add: 10(a)1.0; add: 100(a)1.0; add: 120(a)0.0.
- snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3).
- ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5
- !
Item was removed:
- Envelope subclass: #VolumeEnvelope
- instanceVariableNames: 'currentVol targetVol mSecsForChange'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
Item was removed:
- ----- Method: VolumeEnvelope>>computeSlopeAtMSecs: (in category 'private') -----
- computeSlopeAtMSecs: mSecs
- "Private!! Find the next inflection point of this envelope and compute its target volume and the number of milliseconds until the inflection point is reached."
-
- | t i |
- ((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [ "decay phase"
- t := (points at: loopEndIndex) x + (mSecs - loopEndMSecs).
- i := self indexOfPointAfterMSecs: t startingAt: loopEndIndex.
- i == nil ifTrue: [ "past end"
- targetVol := points last y * decayScale.
- mSecsForChange := 0.
- nextRecomputeTime := mSecs + 1000000.
- ^ self].
- targetVol := (points at: i) y * decayScale.
- mSecsForChange := (((points at: i) x - t) min: (endMSecs - mSecs)) max: 4.
- nextRecomputeTime := mSecs + mSecsForChange.
- ^ self].
-
- mSecs < loopStartMSecs ifTrue: [ "attack phase"
- i := self indexOfPointAfterMSecs: mSecs startingAt: 1.
- targetVol := (points at: i) y.
- mSecsForChange := ((points at: i) x - mSecs) max: 4.
- nextRecomputeTime := mSecs + mSecsForChange.
- ((loopEndMSecs ~~ nil) and: [nextRecomputeTime > loopEndMSecs])
- ifTrue: [nextRecomputeTime := loopEndMSecs].
- ^ self].
-
- "sustain and loop phase"
- noChangesDuringLoop ifTrue: [
- targetVol := (points at: loopEndIndex) y.
- mSecsForChange := 10.
- loopEndMSecs == nil
- ifTrue: [nextRecomputeTime := mSecs + 10] "unknown end time"
- ifFalse: [nextRecomputeTime := loopEndMSecs].
- ^ self].
-
- loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y]. "looping on a single point"
- t := loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs).
- i := self indexOfPointAfterMSecs: t startingAt: loopStartIndex.
- targetVol := (points at: i) y.
- mSecsForChange := ((points at: i) x - t) max: 4.
- nextRecomputeTime := (mSecs + mSecsForChange) min: loopEndMSecs.
- !
Item was removed:
- ----- Method: VolumeEnvelope>>reset (in category 'applying') -----
- reset
- "Reset the state for this envelope."
-
- super reset.
- target initialVolume: points first y * scale.
- nextRecomputeTime := 0.
- !
Item was removed:
- ----- Method: VolumeEnvelope>>updateSelector (in category 'accessing') -----
- updateSelector
- "Needed by the envelope editor."
-
- ^ #volume:
- !
Item was removed:
- ----- Method: VolumeEnvelope>>updateTargetAt: (in category 'applying') -----
- updateTargetAt: mSecs
- "Update the volume envelope slope and limit for my target. Answer false."
-
- mSecs < nextRecomputeTime ifTrue: [^ false].
- self computeSlopeAtMSecs: mSecs.
- mSecsForChange < 5 ifTrue: [mSecsForChange := 5]. "don't change instantly to avoid clicks"
- target adjustVolumeTo: targetVol * scale overMSecs: mSecsForChange.
- ^ false
- !
Item was removed:
- ----- Method: VolumeEnvelope>>volume: (in category 'accessing') -----
- volume: aNumber
- "Set the maximum volume of a volume-controlling envelope."
-
- scale := aNumber asFloat.
- !
Item was removed:
- SoundCodec subclass: #WaveletCodec
- instanceVariableNames: 'fwt samplesPerFrame nLevels alpha beta'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Sound-Synthesis'!
-
- !WaveletCodec commentStamp: '<historical>' prior: 0!
- The Wavelet codec performs a wavelet transform on the original data. It then achieves its compression by thresholding the transformed data, converting all values below a given magnitude to zero, and then run-coding the resulting data. The run-coding provides automatic variable compression depending on the parameters chosen.
-
- As is, this codec achieves reasonable reproduction at 10:1 compression, although the quality from the GSMCodec is definitely better. I feel that the quality would be comparable if uLaw scaling were introduced prior to thresholding.
-
- The nice thing about using wavelets is there are numerous factors to play with for better performance:
- nLevels - the "order" of the transform performed
- alpha and beta - these specify the wavelet shape (some are better for speech)
- the actual threshold used
- By simply changing these parameters, one can easily vary the compression achieved from 5:1 to 50:1, and listen to the quality at each step.
-
- The specific format for an encoded buffer is as follows:
- 4 bytes: frameCount.
- 4 bytes: samplesPerFrame.
- 4 bytes: nLevels.
- 4 bytes: alpha asIEEE32BitWord.
- 4 bytes: beta asIEEE32BitWord.
- frameCount occurrences of...
- 2 bytes: frameSize in bytes, not including these 2
- may be = 0 for complete silence, meaning no scale even.
- 4 bytes: scale asIEEE32BitWord.
- A series of 1- or 2-byte values encoded as follows:
- 0-111: a run of N+1 consecutive 0's;
- 112-127: a run of (N-112)*256 + nextByte + 1 consecutive 0's;
- 128-255: a 15-bit signed value = (N*256 + nextByte) - 32768 - 16384.!
Item was removed:
- ----- Method: WaveletCodec>>bytesPerEncodedFrame (in category 'subclass responsibilities') -----
- bytesPerEncodedFrame
- "Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size."
-
- ^ 0
- !
Item was removed:
- ----- Method: WaveletCodec>>decodeFrames:from:at:into:at: (in category 'subclass responsibilities') -----
- decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex
- "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced."
- "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."
-
- | frameBase coeffArray scale i c nullCount samples sourceFrameEnd frameSize inStream val |
- inStream := ReadStream on: srcByteArray from: srcIndex to: srcByteArray size.
- "frameCount := " inStream nextNumber: 4.
- samplesPerFrame := inStream nextNumber: 4.
- nLevels := inStream nextNumber: 4.
- alpha := Float fromIEEE32Bit: (inStream nextNumber: 4).
- beta := Float fromIEEE32Bit: (inStream nextNumber: 4).
- fwt ifNil:
- ["NOTE: This should read parameters from the encoded data"
- fwt := FWT new.
- fwt nSamples: samplesPerFrame nLevels: nLevels.
- fwt setAlpha: alpha beta: beta].
- frameBase := dstIndex.
- coeffArray := fwt coeffs. "A copy that we can modify"
-
- 1 to: frameCount do:
- [:frame |
-
- "Decode the scale for this frame"
- frameSize := inStream nextNumber: 2.
- sourceFrameEnd := frameSize + inStream position.
- scale := Float fromIEEE32Bit: (inStream nextNumber: 4).
-
- "Expand run-coded samples to scaled float values."
- i := 5.
- [i <= coeffArray size]
- whileTrue:
- [c := inStream next.
- c < 128
- ifTrue: [nullCount := c < 112
- ifTrue: [c + 1]
- ifFalse: [(c-112)*256 + inStream next + 1].
- i to: i + nullCount - 1 do: [:j | coeffArray at: j put: 0.0].
- i := i + nullCount]
- ifFalse: [val := (c*256 + inStream next) - 32768 - 16384.
- coeffArray at: i put: val * scale.
- i := i + 1]].
-
- "Copy float values into the wavelet sample array"
- fwt coeffs: coeffArray.
-
- "Compute the transform"
- fwt transformForward: false.
-
- "Determine the scale for this frame"
- samples := fwt samples.
- samples size = samplesPerFrame ifFalse: [self error: 'frame size error'].
- 1 to: samples size do:
- [:j | dstSoundBuffer at: frameBase + j - 1 put: (samples at: j) asInteger].
-
- inStream position = sourceFrameEnd ifFalse: [self error: 'frame size error'].
- frameBase := frameBase + samplesPerFrame].
-
- ^ Array with: inStream position + 1 - srcIndex
- with: frameBase - dstIndex!
Item was removed:
- ----- Method: WaveletCodec>>encodeFrames:from:at:into:at: (in category 'subclass responsibilities') -----
- encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex
- "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced."
- "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers."
-
- | frameBase coeffs maxVal minVal c scale nullCount frameI outFrameSize threshold "sm" outStream cMin val |
- threshold := 2000.
- fwt ifNil:
- [samplesPerFrame := self samplesPerFrame.
- nLevels := 8.
- "Here are some sample mother wavelets, with the compression achieved on a
- sample of my voice at a threshold of 2000:
- compression achieved "
- alpha := 0.0. beta := 0.0. "12.1"
- alpha := 1.72. beta := 1.51. "14.0"
- alpha := -1.86. beta := -1.53. "14.4"
- alpha := 1.28. beta := -0.86. "15.9"
- alpha := -1.15. beta := 0.69. "16.0"
- fwt := FWT new.
- fwt nSamples: samplesPerFrame nLevels: nLevels.
- fwt setAlpha: alpha beta: beta].
-
- (outStream := WriteStream on: dstByteArray from: dstIndex to: dstByteArray size)
- nextNumber: 4 put: frameCount;
- nextNumber: 4 put: samplesPerFrame;
- nextNumber: 4 put: nLevels;
- nextNumber: 4 put: alpha asIEEE32BitWord;
- nextNumber: 4 put: beta asIEEE32BitWord.
- frameBase := srcIndex.
- 1 to: frameCount do:
- [:frame |
-
- "Copy float values into the wavelet sample array"
- fwt samples: ((frameBase to: frameBase + samplesPerFrame-1)
- collect: [:i | (srcSoundBuffer at: i) asFloat]).
-
- "Compute the transform"
- fwt transformForward: true.
-
- frameI := outStream position+1. "Reserve space for frame size"
- outStream nextNumber: 2 put: 0.
-
- "Determine and output the scale for this frame"
- coeffs := fwt coeffs.
- maxVal := 0.0. minVal := 0.0.
- 5 to: coeffs size do:
- [:i | c := coeffs at: i.
- c > maxVal ifTrue: [maxVal := c].
- c < minVal ifTrue: [minVal := c]].
- scale := (maxVal max: minVal negated) / 16000.0. "Will scale all to -16k..16k: 15 bits"
- outStream nextNumber: 4 put: scale asIEEE32BitWord.
-
- "Copy scaled values, with run-coded sequences of 0's, to destByteArray"
- nullCount := 0.
- cMin := threshold / scale.
- 5 to: coeffs size do:
- [:i | c := (coeffs at: i) / scale.
- c abs < cMin
- ifTrue: ["Below threshold -- count nulls."
- nullCount := nullCount + 1]
- ifFalse: ["Above threshold -- emit prior null count and this sample."
- nullCount > 0 ifTrue:
- [nullCount <= 112
- ifTrue: [outStream nextNumber: 1 put: nullCount-1]
- ifFalse: [outStream nextNumber: 2 put: (112*256) + nullCount-1].
- nullCount := 0].
- val := c asInteger + 16384 + 32768. "Map -16k..16k into 32k..64k"
- outStream nextNumber: 2 put: val]].
-
- nullCount > 0 ifTrue:
- [nullCount <= 112
- ifTrue: [outStream nextNumber: 1 put: nullCount-1]
- ifFalse: [outStream nextNumber: 2 put: (112*256) + nullCount-1]].
- outFrameSize := outStream position+1 - frameI - 2. "Write frame size back at the beginning"
- (WriteStream on: dstByteArray from: frameI to: dstByteArray size)
- nextNumber: 2 put: outFrameSize.
- frameBase := frameBase + samplesPerFrame].
-
- "fbs: disabled because it induces a Sound -> Morphic dependency. It might still be useful as a debugging aid."
- "This displays a temporary indication of compression achieved"
- "sm := TextMorph new contents: (((frameBase - srcIndex) *2.0 / (outStream position+1 - dstIndex) truncateTo: 0.1) printString , ' : 1') asText allBold.
- sm position: Sensor cursorPoint + (-20@30).
- ActiveWorld addMorph: sm.
- World doOneCycleNow.
- sm delete."
-
- outStream position > dstByteArray size ifTrue:
- ["The calling routine only provides buffer space for compression of 2:1 or better. If you are just testing things, you can increase it to, eg, codeFrameSize := frameSize*3, which would be sufficient for a threshold of 0 (lossless conversion)."
- self error: 'Buffer overrun'].
-
- ^ Array with: frameBase - srcIndex
- with: outStream position+1 - dstIndex!
Item was removed:
- ----- Method: WaveletCodec>>frameCount: (in category 'subclass responsibilities') -----
- frameCount: aByteArray
- "Compute the frame count for this byteArray. This default computation will have to be overridden by codecs with variable frame sizes."
-
- ^ (ReadStream on: aByteArray) nextNumber: 4.
- !
Item was removed:
- ----- Method: WaveletCodec>>samplesPerFrame (in category 'subclass responsibilities') -----
- samplesPerFrame
- "Answer the number of sound samples per compression frame."
-
- ^ 4096
- !
1
0
Christoph Thiede uploaded a new version of Sound to project The Trunk:
http://source.squeak.org/trunk/Sound-ct.94.mcz
==================== Summary ====================
Name: Sound-ct.94
Author: ct
Time: 12 October 2023, 7:04:09.945818 pm
UUID: 6f15da49-9689-7148-9b86-e9f11ac8db27
Ancestors: Sound-tpr.93
Merges and revises Sound-mad.90, which fixes endianness issues for storing SampledSounds analogously to Sound-ct.71.
Revision: Also fixes this issue for LoopedSampledSound. Extracts AbstractSound>>#storeSamples:count:bigEndian:on:.
Note: I had to move Sound-mad.90 to the treated inbox because it snapshot only contained the patched version.
=============== Diff against Sound-tpr.93 ===============
Item was added:
+ ----- Method: AbstractSound>>storeSamples:count:bigEndian:on: (in category 'file i/o') -----
+ storeSamples: samples count: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream
+
+ | reverseBytes streamDirect |
+ streamDirect := aBinaryStream isKindOf: StandardFileStream.
+ reverseBytes := (bigEndianFlag xor: Smalltalk isBigEndian) xor: streamDirect not.
+ reverseBytes ifTrue: [samples reverseEndianness].
+ streamDirect
+ ifTrue: "optimization for files: write sound buffer directly to file"
+ [aBinaryStream next: (samples size // 2 min: samplesToStore // 2) putAll: samples startingAt: 1] "size in words"
+ ifFalse: "for non-file streams:"
+ [1 to: (samples monoSampleCount min: samplesToStore) do: [:i | aBinaryStream int16: (samples at: i)]].
+ reverseBytes ifTrue: [samples reverseEndianness]. "restore to original endianness"!
Item was changed:
----- Method: LoopedSampledSound>>storeSampleCount:bigEndian:on: (in category 'file i/o') -----
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."
- "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)."
+ (self isStereo or: [scaledIndexIncr ~= LoopIndexScaleFactor]) ifTrue: [
- | reverseBytes |
- (self isStereo or: [self samplingRate ~= originalSamplingRate]) ifTrue: [
^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream].
"optimization: if I'm not stereo and sampling rates match, just store my buffer"
+ ^ self storeSamples: leftSamples count: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream!
- reverseBytes := bigEndianFlag ~= Smalltalk isBigEndian.
- reverseBytes ifTrue: [leftSamples reverseEndianness].
- (aBinaryStream isKindOf: StandardFileStream)
- ifTrue: [ "optimization for files: write sound buffer directly to file"
- aBinaryStream next: (leftSamples size // 2) putAll: leftSamples startingAt: 1] "size in words"
- ifFalse: [ "for non-file streams:"
- 1 to: leftSamples monoSampleCount do: [:i | aBinaryStream int16: (leftSamples at: i)]].
- reverseBytes ifTrue: [leftSamples reverseEndianness]. "restore to original endianness"
- !
Item was changed:
----- Method: SampledSound>>storeSampleCount:bigEndian:on: (in category 'file i/o') -----
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)."
- | reverseBytes |
self samplingRate ~= originalSamplingRate ifTrue: [
^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream].
+
-
"optimization: if sampling rates match, just store my buffer"
+ ^ self storeSamples: samples count: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream!
- reverseBytes := bigEndianFlag ~= Smalltalk isBigEndian.
- reverseBytes ifTrue: [samples reverseEndianness].
- (aBinaryStream isKindOf: StandardFileStream)
- ifTrue: [ "optimization for files: write sound buffer directly to file"
- aBinaryStream next: (samples size // 2) putAll: samples startingAt: 1] "size in words"
- ifFalse: [ "for non-file streams:"
- 1 to: samples monoSampleCount do: [:i | aBinaryStream int16: (samples at: i)]].
- reverseBytes ifTrue: [samples reverseEndianness]. "restore to original endianness"
- !
1
0
Christoph Thiede uploaded a new version of Tests to project The Trunk:
http://source.squeak.org/trunk/Tests-ct.499.mcz
==================== Summary ====================
Name: Tests-ct.499
Author: ct
Time: 12 October 2023, 7:04:04.688818 pm
UUID: e65e949e-a834-7547-8ff0-6cbddc859574
Ancestors: Tests-mt.498
Complements Sound-ct.94 (fixes endianness issues for storing sounds).
=============== Diff against Tests-mt.498 ===============
Item was added:
+ ----- Method: SoundTest>>testStoreLoopedSamples (in category 'tests') -----
+ testStoreLoopedSamples
+
+ self testStoreSamplesFor:
+ (RepeatingSound carMotorSound: 20.0 "optimized case") sound.
+ self testStoreSamplesFor:
+ (RepeatingSound carMotorSound: 10.0) sound.!
Item was added:
+ ----- Method: SoundTest>>testStorePluckedSamples (in category 'tests') -----
+ testStorePluckedSamples
+
+ self testStoreSamplesFor: PluckedSound default.!
Item was changed:
----- Method: SoundTest>>testStoreSamples (in category 'tests') -----
testStoreSamples
+ self testStoreSamplesFor:
+ (SampledSound
+ samples: SampledSound coffeeCupClink
+ samplingRate: SoundPlayer samplingRate).!
- | sound fileName arrayBytes fileBytes |
- sound := PluckedSound default.
- fileName := 'tempPluck.wav'.
-
- "Write to file"
- fileBytes := [
- sound storeWAVOnFileNamed: fileName.
- FileStream oldFileNamed: fileName do: [:stream |
- stream binary contents]] ensure: [
- FileDirectory default deleteFileNamed: fileName].
-
- "Write to array"
- arrayBytes := ByteArray streamContents: [:stream |
- sound storeWAVSamplesOn: stream].
-
- "Compare"
- self assert: fileBytes equals: arrayBytes.!
Item was added:
+ ----- Method: SoundTest>>testStoreSamplesFor: (in category 'tests') -----
+ testStoreSamplesFor: aSound
+
+ | fileName arrayBytes fileBytes |
+ fileName := '{1}.wav' format: {self selector}.
+
+ "Write to file"
+ fileBytes :=
+ [aSound storeWAVOnFileNamed: fileName.
+ FileStream oldFileNamed: fileName do: [:stream |
+ stream binary contents]] ensure:
+ [FileDirectory default deleteFileNamed: fileName].
+
+ "Write to array"
+ arrayBytes := ByteArray streamContents: [:stream |
+ aSound storeWAVSamplesOn: stream].
+
+ "Compare"
+ self assert: fileBytes equals: arrayBytes.!
1
0
Marcel Taeumel uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-ct.935.mcz
==================== Summary ====================
Name: Tools-ct.935
Author: ct
Time: 20 January 2020, 4:31:15.448972 pm
UUID: 00d7a637-e3ae-dd42-abaf-8aa2523cf17e
Ancestors: Tools-mt.929
MessageTrace: Improves display of parent/child messages by using unified message labels everywhere.
=============== Diff against Tools-mt.929 ===============
Item was changed:
----- Method: MessageSet>>initializeMessageList: (in category 'private') -----
initializeMessageList: anArray
"Initialize my messageList from the given list of MethodReference or string objects. NB: special handling for uniclasses.
Do /not/ replace the elements of anArray if they are already MethodReferences, so as to allow users to construct richer systems, such as differencers between existing and edited versions of code."
messageList := OrderedCollection new.
anArray do:
[:each | each isMethodReference
ifTrue: [messageList addLast: each]
ifFalse:
[ MessageSet
parse: each
toClassAndSelector:
[ : class : sel | class ifNotNil: [ messageList addLast: (MethodReference class: class selector: sel) ] ] ] ].
"Unify labels if wanted."
self class useUnifiedMessageLabels ifTrue:
[ messageList withIndexDo:
+ [ : each : index |
+ each stringVersion: (self indentionPrefixOfSize: (self indentionsIn: each stringVersion)) , (self unifiedMessageLabelFor: each) ] ].
- [ : each : index | | cls |
- cls := each actualClass.
- each stringVersion:
- (self indentionPrefixOfSize: (self indentionsIn: each stringVersion))
- , (cls
- ifNil: [each asString]
- ifNotNil:
- [cls isUniClass
- ifTrue: [cls typicalInstanceName, ' ', each selector]
- ifFalse:
- [ cls name , ' ' , each selector , ' {'
- , ((cls organization categoryOfElement: each selector) ifNil: ['']) , '}'
- , ' {', cls category, '}' ] ]) ] ].
messageListIndex := messageList isEmpty ifTrue: [0] ifFalse: [1].
contents := String empty!
Item was added:
+ ----- Method: MessageSet>>unifiedMessageLabelFor: (in category 'private') -----
+ unifiedMessageLabelFor: aMethodReference
+
+ | class selector |
+ class := aMethodReference actualClass.
+ selector := aMethodReference selector.
+ class ifNil: [^ aMethodReference asString].
+ class isUniClass
+ ifTrue: [^ class typicalInstanceName, ' ', selector].
+ ^ '{1} {2} \{{3}\} \{{4}\}' format: {
+ class.
+ selector.
+ class organization categoryOfElement: selector.
+ class category }!
Item was changed:
----- Method: MessageTrace>>addChildMessages:autoSelectString: (in category 'building') -----
addChildMessages: methodReferences autoSelectString: aString
| currentIndentionLevel addables selectables selectableString newAnchor |
selectableString := aString keywords
ifEmpty: [ String empty ]
ifNotEmptyDo: [ : keywords |
"we can probably do something more precise here; perhaps recombining the extracted keywords into a single selector? Then again all usages of this method seem to already enforce use of a selector"
aString ].
[ (messageListIndex between: 1 and: autoSelectStrings size) ]
whileFalse: [ autoSelectStrings add: selectableString ].
currentIndentionLevel := self currentIndentionLevel.
"Don't add mulitple copies of the same method, if a method is already in the list we will merely select it."
addables := methodReferences reject: [ : each | messageList includes: each ].
addables do:
[ : each |
+ each stringVersion: (self indentionPrefixOfSize: currentIndentionLevel + 1)
+ , (self class useUnifiedMessageLabels
+ ifTrue: [self unifiedMessageLabelFor: each]
+ ifFalse: [each asStringOrText]).
- each stringVersion: (self indentionPrefixOfSize: currentIndentionLevel + 1) , each asStringOrText.
messageList
add: each
afterIndex: self messageListIndex.
autoSelectStrings
add: nil
afterIndex: self messageListIndex.
messageSelections
add: false
afterIndex: self messageListIndex ].
selectables :=
addables copy
addAll: (methodReferences select: [ : each | messageList includes: each ]) ;
yourself.
self deselectAll.
anchorIndex := nil.
selectables do:
[ : each |
self
messageAt: (newAnchor := messageList indexOf: each)
beSelected: true.
anchorIndex ifNil: [ anchorIndex := newAnchor ] ].
self changed: #messageList.
"Select the first child method."
self messageListIndex:
(selectables size > 0
ifTrue: [ messageList indexOf: selectables last ]
ifFalse: [ messageList ifEmpty: [ 0 ] ifNotEmpty: [ 1 ] ])!
Item was changed:
----- Method: MessageTrace>>addParentMessages:autoSelectString: (in category 'building') -----
addParentMessages: methodReferences autoSelectString: aString
| currentIndentionLevel addables selectables |
addables := methodReferences reject: [ : each | messageList includes: each ].
"we may need to process aString here in a similar manner to that in #addChildMessages:autoSelectString:"
selectables := addables copy
addAll: (methodReferences select: [ : each | messageList includes: each ]) ;
yourself.
currentIndentionLevel := self currentIndentionLevel.
(currentIndentionLevel = 0 and: [ addables notEmpty ]) ifTrue:
[ self indentEverything.
currentIndentionLevel := 1 ].
addables do:
[ : each |
+ each stringVersion: (self indentionPrefixOfSize: currentIndentionLevel - 1)
+ , (self class useUnifiedMessageLabels
+ ifTrue: [self unifiedMessageLabelFor: each]
+ ifFalse: [each asStringOrText]).
- each stringVersion: (self indentionPrefixOfSize: currentIndentionLevel - 1) , each asStringOrText.
messageList
add: each
afterIndex: self messageListIndex - 1.
autoSelectStrings
add: aString
afterIndex: self messageListIndex - 1.
messageSelections
add: false
afterIndex: self messageListIndex - 1 ].
self deselectAll.
selectables do:
[ : each | | messageIndex |
messageIndex := messageList indexOf: each.
self
messageAt: messageIndex
beSelected: true.
autoSelectStrings
at: messageIndex
put: aString ].
self changed: #messageList.
anchorIndex := messageListIndex.
selectables size > 0 ifTrue:
[ self messageListIndex: (messageList indexOf: selectables first) ]!
1
0
Marcel Taeumel uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-ct.1032.mcz
==================== Summary ====================
Name: Tools-ct.1032
Author: ct
Time: 10 March 2021, 6:51:33.356304 pm
UUID: 897e4ea2-3740-6a45-a054-d7da65105568
Ancestors: Tools-mt.1030
In the Message Names tool, show definition, comment, and hierarchy for class hits. In particular helpful to find out efficiently whether a selector belongs to a binding or to an actual class.
=============== Diff against Tools-mt.1030 ===============
Item was changed:
----- Method: MessageNames>>computeMessageList (in category 'search') -----
computeMessageList
+ | selector |
+ selectorListIndex = 0 ifTrue: [^ #()].
+
+ selector := selectorList at: selectorListIndex.
+ ^ (selector first isUppercase ifTrue: [Smalltalk classNamed: selector])
+ ifNotNil: [:class |
+ class := Smalltalk classNamed: selector.
+ #(Definition Comment Hierarchy) collect: [:sel |
+ MethodReference class: class selector: sel] ]
+ ifNil: [self systemNavigation allImplementorsOf: selector]!
- ^ selectorListIndex = 0
- ifTrue: [#()]
- ifFalse: [self systemNavigation
- allImplementorsOf: (selectorList at: selectorListIndex)]!
Item was changed:
----- Method: MessageNames>>selectedMessageName (in category 'message list') -----
selectedMessageName
selectorList basicSize = 0 ifTrue: [^ nil]. "Deals with selectorList nil or empty"
+ ^super selectedMessageName ifNil: [
+ "only message name selected"
+ selectorList at: (selectorListIndex max: 1) ifAbsent: [nil] "If no selection we can still find a selector"]!
- ^selectorList at: (selectorListIndex max: 1) ifAbsent: [nil] "If no selection we can still find a selector"!
Item was changed:
----- Method: MessageSet>>aboutToStyle: (in category 'code pane') -----
+ aboutToStyle: aStyler
+ "This is a notification that aStyler is about to re-style its text.
+ Set the classOrMetaClass in aStyler, so that identifiers will be resolved correctly.
- aboutToStyle: aPluggableShoutMorphOrView
- "This is a notification that aPluggableShoutMorphOrView is about to re-style its text.
- Set the classOrMetaClass in aPluggableShoutMorphOrView, so that identifiers
- will be resolved correctly.
Answer true to allow styling to proceed, or false to veto the styling"
| selectedMessageName showingMethod |
self showingSource ifFalse: [^false].
selectedMessageName := self selectedMessageName.
showingMethod := (#(Comment Definition Hierarchy) includes: selectedMessageName) not.
+ aStyler parseAMethod: showingMethod.
"Hack!! setting classOrMetaClass: to nil allows doit or class definition colouring."
+ aStyler classOrMetaClass: (showingMethod ifTrue: [self selectedClassOrMetaClass]).
- aPluggableShoutMorphOrView classOrMetaClass: (showingMethod ifTrue: [self selectedClassOrMetaClass]).
^(#(Comment Hierarchy) includes: selectedMessageName) not!
Item was changed:
----- Method: MessageSet>>selectedMessage (in category 'message list') -----
selectedMessage
"Answer the source method for the currently selected message."
-
self setClassAndSelectorIn: [:class :selector | | source |
class ifNil: [^ 'Class vanished'].
selector first isUppercase ifTrue:
[selector == #Comment ifTrue:
+ ["currentCompiledMethod := class organization commentRemoteStr."
- [currentCompiledMethod := class organization commentRemoteStr.
^ class comment].
selector == #Definition ifTrue:
[^ class definition].
selector == #Hierarchy ifTrue: [^ class printHierarchy]].
source := class sourceMethodAt: selector ifAbsent:
[currentCompiledMethod := nil.
^ 'Missing'].
self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].
currentCompiledMethod := class compiledMethodAt: selector ifAbsent: [nil].
self showingDocumentation ifTrue: [^ self commentContents].
source := self sourceStringPrettifiedAndDiffed.
^ source asText makeSelectorBoldIn: class]!
1
0
Marcel Taeumel uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-xw.1147.mcz
==================== Summary ====================
Name: Tools-xw.1147
Author: xw
Time: 3 May 2022, 4:52:28.265125 pm
UUID: 2c748e92-f991-c745-96d5-c5f8b1d2ec71
Ancestors: Tools-tpr.1146
Set text converter while writing files in FileList, to be consistent with reading
=============== Diff against Tools-tpr.1146 ===============
Item was changed:
----- Method: FileList>>put: (in category 'private') -----
put: aText
"Private - put the supplied text onto the file"
| ff newName contentTypeLabel |
brevityState == #fullFile ifTrue:
[ff := directory newFileNamed: self fullName.
+ self setDefaultEncoderFor: ff.
Cursor write showWhile: [ff nextPutAll: aText asString; close].
(directory = ff directory and: [fileName = ff localName])
ifTrue: [contents := aText asString]
ifFalse: "user changed the directory and/or renamed the file"
[self clearUserEditFlag.
directory ~= ff directory ifTrue:
[self directory: ff directory.
self changed: #rootDirectoryList; changed: #selectedPath].
self updateFileList.
contents := aText asString.
newName := ff localName.
listIndex := list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName].
listIndex > 0 ifTrue: [fileName := newName].
brevityState := #needToGetBrief.
self changed: #fileListIndex].
self changed: #relabel.
^ true "accepted"].
listIndex = 0 ifTrue:
[self inform: 'No fileName is selected' translated.
^ false "failed"].
contentTypeLabel := 'These contents' translated.
brevityState = #briefFile ifTrue: [contentTypeLabel := 'Abbreviated contents' translated].
brevityState = #briefHex ifTrue: [contentTypeLabel := 'Abbreviated contents' translated].
brevityState = #fullHex ifTrue: [contentTypeLabel := 'Hexadecimal contents' translated].
brevityState = #FileList ifTrue: [contentTypeLabel := 'Directory contents' translated].
self inform: ('{1} cannot
meaningfully be saved at present.' translated format: {'Abbreviated contents' translated}).
^ false "failed"
!
1
0
Marcel Taeumel uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-kfr.1161.mcz
==================== Summary ====================
Name: Tools-kfr.1161
Author: kfr
Time: 4 June 2022, 8:13:54.520458 pm
UUID: 8880e2ae-b1d5-ad46-8d3b-27d99549220a
Ancestors: Tools-ct.1160
Open a HelpBrowser with TextLink.
Example:
TerseGuideHelp Help
Select text, press Alt+5 (CMD on Mac) and select 'Link to help on class'
(A link of this format: 'My Link<TerseGuideHelp Help>' will hide the part between < & > )
Dependent on Collections-kfr.1011
=============== Diff against Tools-ct.1160 ===============
Item was changed:
----- Method: Model>>addItem: (in category '*Tools') -----
addItem: classAndMethod
"Open a browser directly on the given class and method
Model new addItem: 'Model addItem:'
Model new addItem: 'Model>>addItem:'
"
self flag: #mref. "classAndMethod is a String"
MessageSet
parse: classAndMethod
toClassAndSelector: [ :class :sel |
class ifNil: [^self].
sel = #Comment ifTrue: [^ Browser fullOnClassComment: class].
sel = #Definition ifTrue: [^ Browser newOnClass: class].
sel = #Hierarchy ifTrue: [^ HierarchyBrowser fullOnClass: class].
+ sel = #Help ifTrue: [^HelpBrowser openOn: class].
Browser newOnClass: class selector: sel
]
!
1
0
Marcel Taeumel uploaded a new version of Tools to project The Trunk:
http://source.squeak.org/trunk/Tools-eem.1168.mcz
==================== Summary ====================
Name: Tools-eem.1168
Author: eem
Time: 13 July 2022, 4:29:53.654209 pm
UUID: 3ce13884-de6d-4e9d-8ada-6eca4fd59835
Ancestors: Tools-eem.1167
Refactor selectMethodsForThisClass & selectSuchThat: so that any of selectMethodsForThisClass, selectMethodsForExtantClasses, & selectContentsMatching can extend selections via the shift key.
=============== Diff against Tools-eem.1167 ===============
Item was removed:
- (PackageInfo named: 'Tools') preamble: '(Workspace instVarNames includes: #windowTitle)
- ifFalse: [Workspace addInstVarName: #windowTitle].
- (Workspace instVarNames includes: #fileDirectory)
- ifFalse: [Workspace addInstVarName: #fileDirectory].
- (Workspace instVarNames includes: #fileLineEndConvention)
- ifFalse: [Workspace addInstVarName: #fileLineEndConvention].
-
- Workspace allInstancesDo: [:workspace |
- workspace instVarNamed: #windowTitle
- put: (workspace valueOfProperty: #windowTitle).
- workspace instVarNamed: #fileDirectory
- put: (workspace valueOfProperty: #fileDirectory).
- workspace instVarNamed: #fileLineEndConvention
- put: (workspace valueOfProperty: #fileLineConversion)].
- '!
Item was removed:
- SystemOrganization addCategory: #'Tools-ArchiveViewer'!
- SystemOrganization addCategory: #'Tools-Base'!
- SystemOrganization addCategory: #'Tools-Browser'!
- SystemOrganization addCategory: #'Tools-Changes'!
- SystemOrganization addCategory: #'Tools-Debugger'!
- SystemOrganization addCategory: #'Tools-Explorer'!
- SystemOrganization addCategory: #'Tools-File Contents Browser'!
- SystemOrganization addCategory: #'Tools-FileList'!
- SystemOrganization addCategory: #'Tools-Inspector'!
- SystemOrganization addCategory: #'Tools-Menus'!
- SystemOrganization addCategory: #'Tools-MethodFinder'!
- SystemOrganization addCategory: #'Tools-Process Browser'!
Item was removed:
- ----- Method: AbstractFont>>browseAllGlyphs (in category '*Tools-Browsing') -----
- browseAllGlyphs
- "Browse glyphs for all printable characters/code-points in the receiver."
-
- ^ self browseGlyphsFrom: self minCodePoint to: self maxCodePoint!
Item was removed:
- ----- Method: AbstractFont>>browseAllGlyphsByCategory (in category '*Tools-Browsing') -----
- browseAllGlyphsByCategory
- "Browse glyphs for all printable characters/code-points in the receiver."
-
- ^ self
- browseGlyphsByCategoryOf: ((self minCodePoint max: 32 "space"+1) to: self maxCodePoint)
- select: [:char | self hasGlyphOf: char]!
Item was removed:
- ----- Method: AbstractFont>>browseAllGlyphsScaledToDisplay (in category '*Tools-Browsing') -----
- browseAllGlyphsScaledToDisplay
- "Browse all glyphs from the receiver's fontFamily in the system's default #pointSize."
-
- (self asPointSize: TextStyle defaultFont pointSize) browseAllGlyphs.
-
- "(self textStyle fontOfPointSize: TextStyle defaultFont pointSize) browseAllGlyphs."!
Item was removed:
- ----- Method: AbstractFont>>browseAllSymbols (in category '*Tools-Browsing') -----
- browseAllSymbols
- "This is a variation of #browseAllGlyphs that is optimized to show all available glyphs in a single run, even though their code points may be scattered all over the Unicode range. See #browseAllSymbolsByCategory."
-
- "self isSymbolFont ifFalse: [self notify: 'This is not a symbol font: ', self familyName]."
-
- ^ self
- browseGlyphsOf: (((self minCodePoint max: 16r1000) to: self maxCodePoint) select: [:ea | self hasGlyphForCode: ea])
- label: 'All symbols in ', self familyName!
Item was removed:
- ----- Method: AbstractFont>>browseAllSymbolsByCategory (in category '*Tools-Browsing') -----
- browseAllSymbolsByCategory
-
- self isSymbolFont ifFalse: [self notify: 'This is not a symbol font: ', self familyName].
- ^ self browseAllGlyphsByCategory!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsByCategoryOf: (in category '*Tools-Browsing') -----
- browseGlyphsByCategoryOf: someCodePointsOrCharacters
-
- self browseGlyphsByCategoryOf: someCodePointsOrCharacters label: nil.!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsByCategoryOf:label: (in category '*Tools-Browsing') -----
- browseGlyphsByCategoryOf: someCodePointsOrCharacters label: label
-
- self
- browseGlyphsByCategoryOf: someCodePointsOrCharacters
- select: [:char | true]
- label: label!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsByCategoryOf:select: (in category '*Tools-Browsing') -----
- browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock
-
- self browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock label: nil.!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsByCategoryOf:select:label: (in category '*Tools-Browsing') -----
- browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil
- "Like #browseGlyphsOf:... but group the code points by Unicode category."
-
- | sortedCodePoints contents isRange tmp separatorBlock |
- isRange := isRange := someCodePointsOrCharacters isInterval and: [someCodePointsOrCharacters increment = 1].
-
- separatorBlock := [:codePoints :category |
- (('\{1}\\' withCRs asText
- format: { Unicode generalCategoryLabels at: category+1 ifAbsent: ['n/a'] })
- addAttribute: (TextFontReference toFont: TextStyle defaultFixedFont);
- addAttribute: (PluggableTextAttribute evalBlock: [self browseGlyphsByCategoryOf: codePoints select: aBlock label: aLabelOrNil]);
- yourself) ].
-
- sortedCodePoints := (someCodePointsOrCharacters
- collect: [:ea | ea isCharacter ifTrue: [ea charCode] ifFalse: [ea] ]
- thenSelect: [:ea | aBlock value: (Unicode value: ea)])
- sorted: [:a :b | | ca cb | (ca := (Unicode generalCategoryOf: a) ifNil: [0]) < (cb := (Unicode generalCategoryOf: b) ifNil: [0])
- or: [ca = cb and: [a < b]]].
-
- "Header"
- contents := (('Family name: {1}{6}\ Emphasis: {2}\ Point size: {3} ({4}ppi {5}px{7})\' withCRs asText format: { self familyName asText addAttribute: (PluggableTextAttribute evalBlock: [self explore]); yourself. [self emphasisString] on: Error do: [self subfamilyName]. self pointSize. self pixelsPerInch. self height. isRange ifTrue: [''] ifFalse: [' (selected code points)']. (self isTTCFont and: [(tmp := self extraGlyphScale) ~= 1]) ifFalse: [''] ifTrue: [' ', (tmp * 100) rounded asString, '%'] }) addAttribute: (TextFontReference toFont: TextStyle defaultFixedFont); yourself).
-
- String streamContents: [:s | | priorCategory currentCodePoints |
- currentCodePoints := OrderedCollection new.
- sortedCodePoints withIndexDo: [:codePoint :index |
- | char category |
- char := Unicode value: codePoint.
- category := Unicode generalCategoryOf: codePoint.
- priorCategory ifNil: [priorCategory := category].
- category = priorCategory ifTrue: [
- currentCodePoints add: codePoint.
- s nextPut: char].
- (category ~= priorCategory or: [index = sortedCodePoints size])
- ifTrue: [
- contents := contents, (separatorBlock value: currentCodePoints value: priorCategory).
- contents := contents, ((s cr; contents) asText addAttribute: (TextFontReference toFont: self); yourself).
- currentCodePoints := OrderedCollection new.
- s reset.
- currentCodePoints add: codePoint.
- s nextPut: char].
- (self widthOf: char) = 0 ifTrue: [s nextPut: Character nbsp; nextPut: Character nbsp].
- priorCategory := category]].
-
- contents editWithLabel: (aLabelOrNil ifNil: [self printString]).!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsFrom:to: (in category '*Tools-Browsing') -----
- browseGlyphsFrom: firstCodePoint to: lastCodePoint
- "Split range in sub-ranges whenever the receiver has no glyph for a certain code point or when that glyph is not visible. Start with at least a printable character after #space to avoid line breaks in the editor. Note that non-breaking space an similar are skipped as well."
-
- ^ self
- browseGlyphsOf:
- ((firstCodePoint max: (self minCodePoint max: 32 "space" +1))
- to: (lastCodePoint min: self maxCodePoint))
- select: [:char | self hasGlyphOf: char]!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsFrom:to:select: (in category '*Tools-Browsing') -----
- browseGlyphsFrom: firstCodePoint to: lastCodePoint select: aBlock
-
- self
- browseGlyphsOf: (firstCodePoint to: lastCodePoint)
- select: aBlock.!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsOf: (in category '*Tools-Browsing') -----
- browseGlyphsOf: someCodePointsOrCharacters
-
- self browseGlyphsOf: someCodePointsOrCharacters label: nil.!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsOf:label: (in category '*Tools-Browsing') -----
- browseGlyphsOf: someCodePointsOrCharacters label: label
- "Browse a collection of non-sequential code points or characters. For ranges use #browseGlyphsFrom:to: to then split into sub-ranges via prediate.
-
- self browseGlyphsOf: 'Hello'
- "
-
- self
- browseGlyphsOf: someCodePointsOrCharacters
- select: [:char | true]
- label: label!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsOf:select: (in category '*Tools-Browsing') -----
- browseGlyphsOf: someCodePointsOrCharacters select: aBlock
-
- self browseGlyphsOf: someCodePointsOrCharacters select: aBlock label: nil.!
Item was removed:
- ----- Method: AbstractFont>>browseGlyphsOf:select:label: (in category '*Tools-Browsing') -----
- browseGlyphsOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil
- "Browse all glyphs in the given collection of code points or characters. Split range in sub-ranges whenever the receiver has no glyph for a certain code point. DO NOT translate user-facing text because this is a debugging tool so that text should only use ASCII."
-
- | contents isRange tmp separatorBlock |
- isRange := someCodePointsOrCharacters isInterval and: [someCodePointsOrCharacters increment = 1].
-
- separatorBlock := [:currentRange |
- (('\16r{1} to: 16r{2}\\' withCRs asText
- format: { currentRange first printStringBase: 16 length: 6 padded: true. currentRange last printStringBase: 16 length: 6 padded: true })
- addAttribute: (TextFontReference toFont: TextStyle defaultFixedFont);
- addAttribute: (PluggableTextAttribute evalBlock: [self browseGlyphsFrom: currentRange first to: currentRange last select: aBlock]);
- yourself)].
-
- "Header"
- contents := (('Family name: {1}{6}\ Emphasis: {2}\ Point size: {3} ({4}ppi {5}px{7})\' withCRs asText format: { self familyName asText addAttribute: (PluggableTextAttribute evalBlock: [self explore]); yourself. [self emphasisString] on: Error do: [self subfamilyName]. self pointSize. self pixelsPerInch. self height. isRange ifTrue: [''] ifFalse: [' (selected code points)']. (self isTTCFont and: [(tmp := self extraGlyphScale) ~= 1]) ifFalse: [''] ifTrue: [' ', (tmp * 100) rounded asString, '%'] }) addAttribute: (TextFontReference toFont: TextStyle defaultFixedFont); yourself).
-
- String streamContents: [:s | | first last |
- last := someCodePointsOrCharacters last.
- someCodePointsOrCharacters withIndexDo: [:codePointOrChar :index |
- | current char valid |
- current := codePointOrChar isCharacter ifTrue: [codePointOrChar charCode] ifFalse: [codePointOrChar].
- char := Unicode value: current.
- (valid := (aBlock value: char))
- ifTrue: [
- s position = 0 ifTrue: [first := current].
- s nextPut: char.
- (self widthOf: char) = 0 ifTrue: [s nextPut: Character nbsp; nextPut: Character nbsp] ].
- (valid not or: [index = someCodePointsOrCharacters size])
- ifTrue: [s position = 0 ifFalse: [
- isRange ifFalse: [contents := contents, String cr] ifTrue: [ | currentRange |
- currentRange := first to: (index = someCodePointsOrCharacters size ifTrue: [last] ifFalse: [current-1]).
- contents := contents, (separatorBlock value: currentRange)].
- contents := contents, ((s cr; contents) asText addAttribute: (TextFontReference toFont: self); yourself).
- s reset]] ]].
-
- contents editWithLabel: (aLabelOrNil ifNil: [self printString]).!
Item was removed:
- SystemWindow subclass: #ArchiveViewer
- instanceVariableNames: 'archive fileName memberIndex viewAllContents'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-ArchiveViewer'!
-
- !ArchiveViewer commentStamp: '<historical>' prior: 0!
- This is a viewer window that allows editing and viewing of Zip archives.!
Item was removed:
- ----- Method: ArchiveViewer class>>addFileToNewZip: (in category 'instance creation') -----
- 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
- !
Item was removed:
- ----- Method: ArchiveViewer class>>deleteTemporaryDirectory (in category 'class initialization') -----
- deleteTemporaryDirectory
- "
- ArchiveViewer deleteTemporaryDirectory
- "
-
- | dir |
- (dir := self temporaryDirectory) exists ifTrue: [ dir recursiveDelete ].!
Item was removed:
- ----- Method: ArchiveViewer class>>descriptionForPartsBin (in category 'parts bin') -----
- descriptionForPartsBin
-
- ^ self partName: 'Zip Tool' translatedNoop
- categories: {'Tools' translated}
- documentation: 'A viewer and editor for Zip archive files' translatedNoop
- !
Item was removed:
- ----- Method: ArchiveViewer class>>extractAllFrom: (in category 'file list services') -----
- extractAllFrom: aFileName
- (self new) fileName: aFileName; extractAll!
Item was removed:
- ----- Method: ArchiveViewer class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') -----
- fileReaderServicesForFile: fullName suffix: suffix
-
- | services |
- services := OrderedCollection new.
- services add: self serviceAddToNewZip.
- ({'zip'.'sar'.'pr'. 'mcz'. '*'} includes: suffix)
- ifTrue: [services add: self serviceOpenInZipViewer.
- services add: self serviceExtractAll].
- ^ services!
Item was removed:
- ----- Method: ArchiveViewer class>>initialize (in category 'class initialization') -----
- initialize
- "ArchiveViewer initialize"
-
- FileServices registerFileReader: self.
- Smalltalk addToShutDownList: self.!
Item was removed:
- ----- Method: ArchiveViewer class>>open (in category 'instance creation') -----
- open
- ^(self new) createWindow; openInWorld.!
Item was removed:
- ----- Method: ArchiveViewer class>>openOn: (in category 'instance creation') -----
- openOn: aFileName
- | newMe |
- newMe := self new.
- newMe createWindow; fileName: aFileName; openInWorld.
- ^newMe!
Item was removed:
- ----- Method: ArchiveViewer class>>serviceAddToNewZip (in category 'file list services') -----
- serviceAddToNewZip
- "Answer a service for adding the file to a new zip"
-
- ^ FileModifyingSimpleServiceEntry
- provider: self
- label: 'add file to new zip' translatedNoop
- selector: #addFileToNewZip:
- description: 'add file to new zip' translatedNoop
- buttonLabel: 'to new zip' translatedNoop!
Item was removed:
- ----- Method: ArchiveViewer class>>serviceExtractAll (in category 'file list services') -----
- serviceExtractAll
- "Answer a service for opening in a zip viewer"
-
- ^ FileModifyingSimpleServiceEntry
- provider: self
- label: 'extract all to...' translatedNoop
- selector: #extractAllFrom:
- description: 'extract all files to a user-specified directory' translatedNoop
- buttonLabel: 'extract all' translatedNoop!
Item was removed:
- ----- Method: ArchiveViewer class>>serviceOpenInZipViewer (in category 'class initialization') -----
- serviceOpenInZipViewer
- "Answer a service for opening in a zip viewer"
-
- ^ SimpleServiceEntry
- provider: self
- label: 'open in zip viewer' translatedNoop
- selector: #openOn:
- description: 'open in zip viewer' translatedNoop
- buttonLabel: 'open zip' translatedNoop!
Item was removed:
- ----- Method: ArchiveViewer class>>services (in category 'fileIn/Out') -----
- services
-
- ^ Array
- with: self serviceAddToNewZip
- with: self serviceOpenInZipViewer
-
-
- !
Item was removed:
- ----- Method: ArchiveViewer class>>shutDown: (in category 'class initialization') -----
- shutDown: quitting
- quitting ifTrue: [ self deleteTemporaryDirectory ].!
Item was removed:
- ----- Method: ArchiveViewer class>>temporaryDirectory (in category 'fileIn/Out') -----
- temporaryDirectory
- "Answer a directory to use for unpacking files for the file list services."
- ^FileDirectory default directoryNamed: '.archiveViewerTemp'!
Item was removed:
- ----- Method: ArchiveViewer class>>unload (in category 'initialize-release') -----
- unload
-
- FileServices unregisterFileReader: self !
Item was removed:
- ----- Method: ArchiveViewer>>addDirectory (in category 'member operations') -----
- addDirectory
- | directory |
- self canAddMember ifFalse: [ ^self ].
- directory := UIManager default chooseDirectory.
- directory
- ifNil: [^ self].
-
- archive addTree: directory removingFirstCharacters: directory pathName size + 1.
- self memberIndex: 0.
- self changed: #memberList.!
Item was removed:
- ----- Method: ArchiveViewer>>addMember (in category 'member operations') -----
- addMember
- | local fName |
- self canAddMember ifFalse: [ ^self ].
- fName := UIManager default chooseFileMatching: '*' .
- fName ifNil: [ ^self ].
-
- local := FileDirectory localNameFor: fName.
- (archive addFile: fName as: local)
- desiredCompressionMethod: ZipArchive compressionDeflated.
- self memberIndex: self members size.
- self changed: #memberList.!
Item was removed:
- ----- Method: ArchiveViewer>>addMemberFromClipboard (in category 'member operations') -----
- addMemberFromClipboard
- | string newName |
- self canAddMember ifFalse: [ ^self ].
- string := Clipboard clipboardText asString.
- newName := UIManager default
- 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.
- ]
- !
Item was removed:
- ----- Method: ArchiveViewer>>archive (in category 'accessing') -----
- archive
- ^archive!
Item was removed:
- ----- Method: ArchiveViewer>>archive: (in category 'initialization') -----
- archive: aZipArchive
- archive := aZipArchive.
- self model: aZipArchive.
- self setLabel: 'New Zip Archive'.
- self memberIndex: 0.
- self changed: #memberList!
Item was removed:
- ----- Method: ArchiveViewer>>briefContents (in category 'initialization') -----
- 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
- !
Item was removed:
- ----- Method: ArchiveViewer>>buildWindowMenu (in category 'menu') -----
- 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.!
Item was removed:
- ----- Method: ArchiveViewer>>buttonColor (in category 'initialization') -----
- buttonColor
- ^self defaultBackgroundColor darker!
Item was removed:
- ----- Method: ArchiveViewer>>buttonOffColor (in category 'initialization') -----
- buttonOffColor
- ^self defaultBackgroundColor darker!
Item was removed:
- ----- Method: ArchiveViewer>>buttonOnColor (in category 'initialization') -----
- buttonOnColor
- ^self defaultBackgroundColor!
Item was removed:
- ----- Method: ArchiveViewer>>canAddMember (in category 'member operations') -----
- canAddMember
- ^archive notNil!
Item was removed:
- ----- Method: ArchiveViewer>>canCreateNewArchive (in category 'archive operations') -----
- canCreateNewArchive
- ^true!
Item was removed:
- ----- Method: ArchiveViewer>>canDeleteMember (in category 'member operations') -----
- canDeleteMember
- ^memberIndex > 0!
Item was removed:
- ----- Method: ArchiveViewer>>canExtractAll (in category 'archive operations') -----
- canExtractAll
- ^self members notEmpty!
Item was removed:
- ----- Method: ArchiveViewer>>canExtractMember (in category 'member operations') -----
- canExtractMember
- ^memberIndex > 0!
Item was removed:
- ----- Method: ArchiveViewer>>canOpenNewArchive (in category 'archive operations') -----
- canOpenNewArchive
- ^true!
Item was removed:
- ----- Method: ArchiveViewer>>canRenameMember (in category 'member operations') -----
- canRenameMember
- ^memberIndex > 0!
Item was removed:
- ----- Method: ArchiveViewer>>canSaveArchive (in category 'archive operations') -----
- canSaveArchive
- ^archive notNil!
Item was removed:
- ----- Method: ArchiveViewer>>canViewAllContents (in category 'member operations') -----
- canViewAllContents
- ^memberIndex > 0 and: [ viewAllContents not ]!
Item was removed:
- ----- Method: ArchiveViewer>>changeViewAllContents (in category 'member operations') -----
- changeViewAllContents
-
- (viewAllContents not and: [ self selectedMember notNil and: [ self selectedMember uncompressedSize > 50000 ]])
- ifTrue: [ (self 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!
Item was removed:
- ----- Method: ArchiveViewer>>commentArchive (in category 'archive operations') -----
- commentArchive
- | newName |
- archive ifNil: [ ^self ].
- newName := UIManager default
- request: 'New comment for archive:'
- initialAnswer: archive zipFileComment.
- archive zipFileComment: newName.!
Item was removed:
- ----- Method: ArchiveViewer>>commentMember (in category 'member operations') -----
- commentMember
- | newName |
- newName := UIManager default
- request: 'New comment for member:'
- initialAnswer: self selectedMember fileComment.
- self selectedMember fileComment: newName.!
Item was removed:
- ----- Method: ArchiveViewer>>contents (in category 'initialization') -----
- 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 ]!
Item was removed:
- ----- Method: ArchiveViewer>>contents: (in category 'initialization') -----
- contents: aText
- self shouldNotImplement.!
Item was removed:
- ----- Method: ArchiveViewer>>createButtonBar (in category 'initialization') -----
- createButtonBar
- | bar |
-
- bar := AlignmentMorph newRow.
- bar
- color: self defaultBackgroundColor;
- rubberBandCells: false;
- vResizing: #shrinkWrap;
- cellGap: 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' #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 clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('add dir ' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('extract member' #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' #canViewAllContents #changeViewAll
Contents 'Toggle the view of all the selected member''s contents'))
- do:
- [:arr |
- | button |
- (button := PluggableButtonMorph
- on: self
- getState: arr second
- action: arr third)
- vResizing: #spaceFill;
- hResizing: #spaceFill;
- onColor: self buttonOnColor offColor: self buttonOffColor;
- label: arr first withCRs;
- setBalloonText: arr fourth.
- bar addMorphBack: button].
- ^bar!
Item was removed:
- ----- Method: ArchiveViewer>>createListHeadingUsingFont: (in category 'initialization') -----
- createListHeadingUsingFont: font
- | sm |
- sm := StringMorph contents: ' order uncomp comp CRC-32 date time file name'.
- font ifNotNil: [ sm font: font ].
- ^(AlignmentMorph newColumn)
- color: self defaultBackgroundColor;
- addMorph: sm;
- yourself.!
Item was removed:
- ----- Method: ArchiveViewer>>createNewArchive (in category 'archive operations') -----
- createNewArchive
- self setLabel: '(new archive)'.
- archive := ZipArchive new.
- self memberIndex: 0.
- self changed: #memberList.!
Item was removed:
- ----- Method: ArchiveViewer>>createWindow (in category 'initialization') -----
- createWindow
- | list heading font text buttonBar |
-
- font := (TextStyle named: #DefaultFixedTextStyle)
- ifNotNil: [ :ts | ts fontArray first].
-
- buttonBar := self createButtonBar.
- self addMorph: buttonBar
- fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0(a)0.0) offsets: (0@0 corner: 0@34)).
-
- 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(a)0.0) offsets: (0@34 corner: 0@44)).
-
- (list := PluggableListMorph new)
- on: self list: #memberList
- selected: #memberIndex changeSelected: #memberIndex:
- menu: #memberMenu:shifted: keystroke: nil.
- list color: self defaultBackgroundColor.
-
- font ifNotNil: [list font: font].
- self addMorph: list
- fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0(a)0.8) offsets: (0@50 corner: 0@0)).
-
- text := PluggableTextMorph on: self
- text: #contents accept: nil
- readSelection: nil menu: nil.
- self addMorph: text
- frame: (0(a)0.8 corner: 1.0(a)1.0).
- text lock.
-
- self setLabel: 'Ned''s Zip Viewer'!
Item was removed:
- ----- Method: ArchiveViewer>>defaultBackgroundColor (in category 'accessing') -----
- defaultBackgroundColor
-
- ^ Color veryVeryLightGray!
Item was removed:
- ----- Method: ArchiveViewer>>defaultColor (in category 'accessing') -----
- defaultColor
-
- ^ Color veryVeryLightGray!
Item was removed:
- ----- Method: ArchiveViewer>>deleteMember (in category 'member operations') -----
- deleteMember
- self canDeleteMember ifFalse: [ ^self ].
- archive removeMember: self selectedMember.
- self memberIndex: 0.
- self changed: #memberList.
- !
Item was removed:
- ----- Method: ArchiveViewer>>directory (in category 'accessing') -----
- directory
- "For compatibility with file list."
- ^self error: 'should use readOnlyStream instead!!'!
Item was removed:
- ----- Method: ArchiveViewer>>displayLineFor: (in category 'member list') -----
- displayLineFor: aMember
- | stream dateTime index |
- index := self archive members indexOf: aMember.
- stream := WriteStream on: (String new: 60).
- dateTime := Time dateAndTimeFromSeconds: aMember lastModTime.
- stream
- nextPutAll: (index printString padded: #left to: 4 with: $ );
- space;
- nextPutAll: (aMember uncompressedSize printString padded: #left to: 8 with: $ );
- space; 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; space.
- dateTime second print24: true showSeconds: false on: stream.
- stream space; space;
- nextPutAll: (aMember fileName ).
- ^stream contents!
Item was removed:
- ----- Method: ArchiveViewer>>downMember (in category 'member order') -----
- downMember
- | temp |
- temp := (self archive members) at: memberIndex.
- self archive members at: memberIndex put: (self archive members at: memberIndex + 1).
- self archive members at: (memberIndex +1) put: temp.
- self memberIndex: 0.
- self changed: #memberList.!
Item was removed:
- ----- Method: ArchiveViewer>>extractAll (in category 'archive operations') -----
- extractAll
- | directory |
-
- self canExtractAll ifFalse: [^ self].
- directory := UIManager default chooseDirectory.
- directory
- ifNil: [^ self].
-
- UIManager default informUserDuring: [:bar| archive extractAllTo: directory informing: bar].
-
-
- !
Item was removed:
- ----- Method: ArchiveViewer>>extractAllPossibleInDirectory: (in category 'archive operations') -----
- 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?'.
- ^self confirm: str contents.
- ].
- ^true.
- !
Item was removed:
- ----- Method: ArchiveViewer>>extractDirectoriesIntoDirectory: (in category 'archive operations') -----
- extractDirectoriesIntoDirectory: directory
- (self members select: [:ea | ea isDirectory])
- do: [:ea | ea extractInDirectory: directory]!
Item was removed:
- ----- Method: ArchiveViewer>>extractFilesIntoDirectory: (in category 'archive operations') -----
- extractFilesIntoDirectory: directory
- (self members reject: [:ea | ea isDirectory])
- do: [:ea | ea extractInDirectory: directory]!
Item was removed:
- ----- Method: ArchiveViewer>>extractMember (in category 'member operations') -----
- extractMember
- "Extract the member after prompting for a filename.
- Answer the filename, or nil if error."
-
- | name |
- self canExtractMember ifFalse: [ ^nil ].
- name := FileSaverDialog openOn: FileDirectory default.
- name ifNil: [ ^nil ].
- (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!
Item was removed:
- ----- Method: ArchiveViewer>>fileName (in category 'accessing') -----
- fileName
- ^fileName!
Item was removed:
- ----- Method: ArchiveViewer>>fileName: (in category 'initialization') -----
- fileName: aString
- archive := ZipArchive new readFrom: aString.
- self setLabel: aString.
- self memberIndex: 0.
- self changed: #memberList!
Item was removed:
- ----- Method: ArchiveViewer>>fullName (in category 'accessing') -----
- 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!
Item was removed:
- ----- Method: ArchiveViewer>>highlightMemberList:with: (in category 'member list') -----
- highlightMemberList: list with: morphList
- (morphList at: self memberIndex) color: Color red!
Item was removed:
- ----- Method: ArchiveViewer>>initialize (in category 'initialization') -----
- initialize
- super initialize.
- memberIndex := 0.
- viewAllContents := false.
- !
Item was removed:
- ----- Method: ArchiveViewer>>initializeToStandAlone (in category 'parts bin') -----
- initializeToStandAlone
- self initialize createWindow.!
Item was removed:
- ----- Method: ArchiveViewer>>inspectMember (in category 'member operations') -----
- inspectMember
- self selectedMember inspect!
Item was removed:
- ----- Method: ArchiveViewer>>memberIndex (in category 'member list') -----
- memberIndex
- ^memberIndex!
Item was removed:
- ----- Method: ArchiveViewer>>memberIndex: (in category 'member list') -----
- memberIndex: n
- memberIndex := n.
- viewAllContents := false.
- self changed: #memberIndex.
- self changed: #contents.!
Item was removed:
- ----- Method: ArchiveViewer>>memberList (in category 'member list') -----
- memberList
- ^ self members collect: [ :ea | self displayLineFor: ea ]!
Item was removed:
- ----- Method: ArchiveViewer>>memberMenu:shifted: (in category 'member list') -----
- memberMenu: menu shifted: shifted
- | services |
-
- menu
- add: 'Comment archive' target: self selector: #commentArchive;
- balloonTextForLastItem: 'Add a comment for the entire archive'.
-
- self selectedMember ifNotNil: [ :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;
- add: 'member go up in order ' target: self selector: #upMember;
- add: 'member go down in order ' target: self selector: #downMember;
- add: 'select member order ' target: self selector: #toIndexPlace;
- addLine.
- services := FileServices itemsForFile: member fileName.
- menu addServices2: services for: self extraLines: #().
- ].
-
-
- ^menu!
Item was removed:
- ----- Method: ArchiveViewer>>members (in category 'accessing') -----
- members
- ^archive ifNil: [ #() asOrderedCollection ]
- ifNotNil: [ archive members asOrderedCollection ]!
Item was removed:
- ----- Method: ArchiveViewer>>openNewArchive (in category 'archive operations') -----
- openNewArchive
- | result |
- result := UIManager default chooseFileMatching: '*' .
- result ifNil: [ ^self ].
- self fileName: result
- !
Item was removed:
- ----- Method: ArchiveViewer>>perform:orSendTo: (in category 'message handling') -----
- perform: selector orSendTo: otherTarget
- ^ self perform: selector!
Item was removed:
- ----- Method: ArchiveViewer>>readOnlyStream (in category 'accessing') -----
- readOnlyStream
- "Answer a read-only stream on the selected member.
- For the various stream-reading services."
-
- ^self selectedMember ifNotNil: [ :mem | mem contentStream ascii ]!
Item was removed:
- ----- Method: ArchiveViewer>>renameMember (in category 'member operations') -----
- renameMember
- | newName |
- self canRenameMember ifFalse: [ ^self ].
- newName := UIManager default
- request: 'New name for member:'
- initialAnswer: self selectedMember fileName.
- newName notEmpty ifTrue: [
- self selectedMember fileName: newName.
- self changed: #memberList
- ]!
Item was removed:
- ----- Method: ArchiveViewer>>saveArchive (in category 'archive operations') -----
- saveArchive
- | result name |
-
- name := FileDirectory localNameFor: labelString .
- self canSaveArchive ifFalse: [ ^self ].
- result := UIManager default
- saveFilenameRequest: 'Save this zip to'
- initialAnswer: name.
- result ifNil: [ ^self ].
-
- (archive canWriteToFileNamed: result)
- 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: result ] on: Error do: [ :ex | self inform: ex description. ].
- self setLabel: name asString.
- self changed: #memberList "in case CRC's and compressed sizes got set"!
Item was removed:
- ----- Method: ArchiveViewer>>selectedMember (in category 'accessing') -----
- selectedMember
- ^memberIndex
- ifNil: [ nil ]
- ifNotNil: [ self members at: memberIndex ifAbsent: [ ] ]!
Item was removed:
- ----- Method: ArchiveViewer>>stream: (in category 'initialization') -----
- stream: aStream
- archive := ZipArchive new readFrom: aStream.
- self setLabel: aStream fullName.
- self memberIndex: 0.
- self changed: #memberList!
Item was removed:
- ----- Method: ArchiveViewer>>toIndexPlace (in category 'member order') -----
- toIndexPlace
- | index max temp |
- max := self archive members size.
- index :=0.
- [index := (UIManager default
- request: 'To which index '
- initialAnswer: '1') asInteger.
- index between: 1 and: max] whileFalse.
- temp := (self archive members) at: memberIndex.
- self archive members at: memberIndex put: (self archive members at: index).
- self archive members at: index put: temp.
- self memberIndex: 0.
- self changed: #memberList.!
Item was removed:
- ----- Method: ArchiveViewer>>upMember (in category 'member order') -----
- upMember
- | temp |
- temp := (self archive members) at: memberIndex.
- self archive members at: memberIndex put: (self archive members at: memberIndex -1).
- self archive members at: (memberIndex -1) put: temp.
- self memberIndex: 0.
- self changed: #memberList.!
Item was removed:
- ----- Method: ArchiveViewer>>windowIsClosing (in category 'initialization') -----
- windowIsClosing
- archive ifNotNil: [ archive close ].!
Item was removed:
- ----- Method: ArchiveViewer>>writePrependingFile (in category 'archive operations') -----
- writePrependingFile
- | result name prependedName |
- self canSaveArchive ifFalse: [ ^self ].
- name := FileSaverDialog openOn: FileDirectory default initialFilename: 'archive.zip' label: 'Choose location to save archive' translated.
- name ifNil: [ ^self ].
- (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' translated.
- ^self ].
- result := FileSaverDialog openOn: FileDirectory default initialFilename: 'archive.zip' label: 'Prepended File:' translated.
- 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"!
Item was removed:
- ----- Method: ArrayedCollection>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Array'!
Item was removed:
- ----- Method: Bag>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
-
- ^ BagInspector!
Item was removed:
- DictionaryInspector subclass: #BagInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !BagInspector commentStamp: 'mt 4/2/2020 10:32' prior: 0!
- I am an inspector for bags. I specialize the inspector for dictionaries because I expose the internal dictionary all bags use.!
Item was removed:
- ----- Method: BagInspector>>addElement: (in category 'menu commands') -----
- addElement: anObject
-
- self object add: anObject.
- self updateFields.
- self selectElementAt: anObject.!
Item was removed:
- ----- Method: BagInspector>>elementGetterAt: (in category 'private') -----
- elementGetterAt: element
- "Return a way to access the number of occurrences in the bag for the given element."
-
- ^ [:bag | (bag instVarNamed: #contents) at: element]!
Item was removed:
- ----- Method: BagInspector>>elementIndices (in category 'initialization') -----
- elementIndices
-
- ^ [ (object instVarNamed: #contents) keysInOrder ] ifError: [
- "Can occur when debugging Bag new"
- Array empty ].!
Item was removed:
- ----- Method: BagInspector>>elementSetterAt: (in category 'private') -----
- elementSetterAt: element
- "Change the number of occurrences for the given element."
-
- ^ [:bag :count | (bag instVarNamed: #contents) at: element put: count]!
Item was removed:
- ----- Method: BagInspector>>isBindingSelected (in category 'bindings') -----
- isBindingSelected
-
- ^ false!
Item was removed:
- ----- Method: BagInspector>>removeSelectedElement (in category 'menu commands') -----
- removeSelectedElement
-
- self object remove: self selectedKey.!
Item was removed:
- Inspector subclass: #BasicInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !BasicInspector commentStamp: 'mt 3/30/2020 14:38' prior: 0!
- I am an Inspector that sends as few messages as possible to collect information about the inspected object. For example, use me to inspect proxies, which are typically subclasses of ProtoObject and hence understand only little messages but make heay use of #doesNotUnderstand:.!
Item was removed:
- ----- Method: BasicInspector class>>openOn:withLabel: (in category 'as yet unclassified') -----
- openOn: anObject withLabel: label
- "Ignore label."
-
- ^ ToolBuilder open: (self on: anObject)!
Item was removed:
- ----- Method: BasicInspector>>basicObjectPrintString (in category 'initialization') -----
- basicObjectPrintString
-
- ^ 'a {1}({2})' format: {thisContext objectClass: object. object identityHash}!
Item was removed:
- ----- Method: BasicInspector>>fieldObjectClass (in category 'fields') -----
- fieldObjectClass
-
- ^ (self newFieldForType: #proto key: #class)
- name: 'class'; emphasizeName;
- valueGetter: [:object | thisContext objectClass: object];
- valueGetterExpression: 'thisContext objectClass: self';
- yourself!
Item was removed:
- ----- Method: BasicInspector>>fieldObjectSize (in category 'fields') -----
- fieldObjectSize
-
- ^ (self newFieldForType: #proto key: #size)
- name: 'size'; emphasizeName;
- valueGetter: [:object | thisContext objectSize: object];
- valueGetterExpression: 'thisContext objectSize: self';
- yourself!
Item was removed:
- ----- Method: BasicInspector>>fieldSelf (in category 'fields') -----
- fieldSelf
-
- ^ (self newFieldForType: #self key: #self)
- name: 'self'; emphasizeName;
- valueGetter: [:obj | self basicObjectPrintString]; printValueAsIs;
- valueGetterExpression: 'self';
- valueSetter: [:obj :value | self object: value]; "Switch to another object-under-inspection."
- yourself!
Item was removed:
- ----- Method: BasicInspector>>inspect: (in category 'initialization') -----
- inspect: anObject
- "We don't want to change the inspector class. Only set anObject as the inspectee."
- self object: anObject!
Item was removed:
- ----- Method: BasicInspector>>labelString (in category 'initialization') -----
- labelString
-
- ^ '{1} {2}{3}' format: {
- '[basic]' translated.
- self basicObjectPrintString.
- (self object isReadOnlyObject
- ifTrue: [' (read-only)' translated]
- ifFalse: [''])}!
Item was removed:
- ----- Method: BasicInspector>>objectOkToClose (in category 'user interface - window') -----
- objectOkToClose
- "No extra interaction with the object in the basic inspector:"
-
- ^ true!
Item was removed:
- ----- Method: BasicInspector>>streamBaseFieldsOn: (in category 'fields - streaming') -----
- streamBaseFieldsOn: aStream
-
- aStream
- nextPut: self fieldSelf;
- nextPut: self fieldObjectClass;
- nextPut: self fieldObjectSize.!
Item was removed:
- ----- Method: BasicInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') -----
- streamIndexedVariablesOn: aStream
- "Truncate indexed variables if there are too many of them."
-
- self
- streamOn: aStream
- truncate: (1 to: (thisContext objectSize: self object))
- collectFields: [:index |
- (self newFieldForType: #indexed key: index)
- name: index asString;
- valueGetter: [:object | thisContext object: object basicAt: index];
- valueGetterExpression: ('thisContext object: {1} basicAt: {2}' format: { 'self'. index });
- valueSetter: [:object :value | thisContext object: object basicAt: index put: value];
- yourself]!
Item was removed:
- ----- Method: BasicInspector>>streamInstanceVariablesOn: (in category 'fields - streaming') -----
- streamInstanceVariablesOn: aStream
-
- | attributesForInstVars |
- attributesForInstVars := (UserInterfaceTheme current get: #instVar for: #SHTextStylerST80) ifNil: [#()].
-
- (thisContext objectClass: self object) allInstVarNames withIndexDo: [:name :index |
- aStream nextPut: ((self newFieldForType: #instVar key: name)
- name: name; styleName: attributesForInstVars;
- valueGetter: [:obj | thisContext object: obj instVarAt: index];
- valueGetterExpression: ('thisContext object: {1} instVarAt: {2}' format: { 'self'. index });
- valueSetter: [:obj :value | thisContext object: obj instVarAt: index put: value];
- yourself)].!
Item was removed:
- ----- Method: Behavior>>browse (in category '*Tools-Browsing') -----
- browse
- ^ToolSet browseClass: self!
Item was removed:
- ----- Method: Behavior>>createGetterFor: (in category '*Tools-Browser-accessors') -----
- createGetterFor: aName
-
- | code |
- code := '{1}\\ ^ {1}' withCRs format: {aName}.
- self compile: code classified: #accessing notifying: nil.!
Item was removed:
- ----- Method: Behavior>>createInstVarAccessors (in category '*Tools-Browser-accessors') -----
- createInstVarAccessors
- "Create getters and setters for all inst vars defined here,
- except do NOT clobber or override any selectors already understood by me"
-
- self instVarNames
- collect: [:each | each asSymbol]
- thenDo: [:instVar |
- (self canUnderstand: instVar) ifFalse: [self createGetterFor: instVar].
- (self canUnderstand: instVar asSimpleSetter) ifFalse: [self createSetterFor: instVar]].
-
- !
Item was removed:
- ----- Method: Behavior>>createSetterFor: (in category '*Tools-Browser-accessors') -----
- createSetterFor: aName
-
- | code |
- code := '{1}: anObject\\ {2}{1} := anObject.' withCRs
- format: {aName. self settersReturnValue ifTrue: ['^ '] ifFalse: ['']}.
- self compile: code classified: #accessing notifying: nil.!
Item was removed:
- ----- Method: Behavior>>inspectAllInstances (in category '*Tools-accessing instances and variables') -----
- 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)!
Item was removed:
- ----- Method: Behavior>>inspectSubInstances (in category '*Tools-accessing instances and variables') -----
- 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')!
Item was removed:
- ----- Method: Behavior>>settersReturnValue (in category '*Tools-Browser-accessors') -----
- settersReturnValue
- "Determine whether the browser's createInstVarAccessors code will generate
- setters that answer self (the default here) or the value set. Classes that want
- to answer the value set (e.g. VMStructType) override."
-
- ^ false!
Item was removed:
- ----- Method: Behavior>>toolIcon (in category '*Tools-icons') -----
- toolIcon
- "Tools can annotate me with an icon identified by the symbol this method returns.
- Defaults to no icon"
- ^ #blank!
Item was removed:
- ----- Method: Behavior>>toolIconSelector: (in category '*Tools-icons') -----
- toolIconSelector: aSymbol
- "Tools can annotate the method identified by aSymbol with an icon identified by the symbol this method returns.
- We customize this for, eg, overriden methods or methods with breaks.
- Defaults to no icon"
-
- self methodDictionary at: aSymbol ifPresent: [ :method |
- method hasBreakpoint ifTrue: [^ #breakpoint].
- method selectorsDo: [:messageSelector |
- (#(halt halt: haltIfNil haltIf: haltOnce haltOnce: haltOnCount: halt:onCount: break) includes: messageSelector)
- ifTrue: [^ #breakpoint].
- (#(flag: needsWork notYetImplemented) includes: messageSelector)
- ifTrue: [^ #flag].
- (#(shouldBeImplemented subclassResponsibility) includes: messageSelector)
- ifTrue: [
- (self isSelectorOverridden: aSymbol)
- ifTrue: [^ #abstract]
- ifFalse: [^ #notOverridden]].
- messageSelector == #shouldNotImplement
- ifTrue: [^ #no]].
- method hasReportableSlip ifTrue: [^ #breakpoint]].
-
- (self isSelectorOverride: aSymbol)
- ifTrue: [
- (self isSelectorOverridden: aSymbol)
- ifTrue: [ ^ #arrowUpAndDown ]
- ifFalse: [ ^ #arrowUp ] ]
- ifFalse: [
- (self isSelectorOverridden: aSymbol)
- ifTrue: [^ #arrowDown ]].
-
- self methodDictionary at: aSymbol ifPresent: [ :method |
- (method primitive ~= 0 and: [method isQuick not])
- ifTrue: [^ #primitive]].
-
-
- ^ #blank!
Item was removed:
- ----- Method: Bitset>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
-
- ^ BitsetInspector!
Item was removed:
- CollectionInspector subclass: #BitsetInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !BitsetInspector commentStamp: 'mt 4/22/2020 08:13' prior: 0!
- I am an inspector for bit sets. I display bits with zero based indexing corresponding to the bit numbering conventions of a bit field.!
Item was removed:
- ----- Method: BitsetInspector>>addElement: (in category 'menu - commands') -----
- addElement: anInteger
- "Flip the specified bit to 1 and select it. Note that there is no need to #updateFields here because of the bitset's semantics for #add:."
-
- self object add: anInteger.
- self selectElementAt: anInteger.!
Item was removed:
- ----- Method: BitsetInspector>>elementIndices (in category 'private') -----
- elementIndices
-
- ^ 0 to: self objectSize - 1!
Item was removed:
- ----- Method: BitsetInspector>>fieldSize (in category 'fields') -----
- fieldSize
-
- ^ (self newFieldForType: #misc key: #size)
- name: 'num 1 bits' translated; emphasizeName;
- valueGetter: [:bitset | bitset size];
- yourself!
Item was removed:
- ----- Method: BitsetInspector>>objectSize (in category 'private') -----
- objectSize
-
- ^ self object capacity!
Item was removed:
- ----- Method: BitsetInspector>>removeSelectedElement (in category 'menu - commands') -----
- removeSelectedElement
- "Flip the selected bit back to 0."
-
- self selectedField setValueFor: self to: 0.!
Item was removed:
- ----- Method: BitsetInspector>>streamBaseFieldsOn: (in category 'fields - streaming') -----
- streamBaseFieldsOn: aStream
-
- super streamBaseFieldsOn: aStream.
- aStream nextPut: self fieldSize.!
Item was removed:
- ----- Method: BlockClosure>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
-
- ^ BlockClosureInspector!
Item was removed:
- ----- Method: BlockClosure>>timeProfile (in category '*Tools') -----
- timeProfile
-
- ^TimeProfileBrowser onBlock: self!
Item was removed:
- Inspector subclass: #BlockClosureInspector
- instanceVariableNames: 'debuggerMap tempVarNames instVarNames'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
Item was removed:
- ----- Method: BlockClosureInspector>>bindingOf: (in category 'evaluation') -----
- bindingOf: aString
- " See commentary in #doItReceiver. Yes, we cannot evalute the closured bindings by name in the code pane. But we can browse and change the bindings through their inspector fields.
-
- self object method literalsDo: [:literal |
- (literal isVariableBinding and: [literal key = aString])
- ifTrue: [^ literal]].
- "
-
- ^ super bindingOf: aString!
Item was removed:
- ----- Method: BlockClosureInspector>>debuggerMap (in category 'private') -----
- debuggerMap
-
- ^ debuggerMap ifNil: [debuggerMap := self object method debuggerMap]!
Item was removed:
- ----- Method: BlockClosureInspector>>doItReceiver (in category 'evaluation') -----
- doItReceiver
- "Overwritten for documentation only. We cannot expose the closured 'self' here because users expect the closure to be the #doItReceiver so that 'self value' can be used to evaluate the block. We can, however, configure the styler to at least style #fieldSource correctly. See #updateStyler:requestor: and #hasBindingOf:.
-
- Note that you can always debug-it the expression 'self value' to the evaluate parts of the closure."
-
- ^ super doItReceiver!
Item was removed:
- ----- Method: BlockClosureInspector>>fieldSource (in category 'fields') -----
- fieldSource
-
- ^ (self newFieldForType: #code key: #source)
- name: 'source code' translated; emphasizeName;
- valueGetter: [:blockClosure | '"{1}"\{2}' withCRs format: {blockClosure outerContext. blockClosure decompile decompileString}]; printValueAsIs;
- shouldStyleValue: true;
- yourself!
Item was removed:
- ----- Method: BlockClosureInspector>>hasBindingOf: (in category 'user interface - styling') -----
- hasBindingOf: aString
-
- self object method literalsDo: [:literal |
- (literal isVariableBinding and: [literal key = aString])
- ifTrue: [^ true]].
-
- (self tempVarNames includes: aString) ifTrue: [^ true].
- (self instVarNames includes: aString) ifTrue: [^ true].
-
- ^ false!
Item was removed:
- ----- Method: BlockClosureInspector>>instVarNames (in category 'private') -----
- instVarNames
-
- ^ instVarNames ifNil: [instVarNames := (self object receiver perform: #class "avoid inlining; support proxies") allInstVarNames]!
Item was removed:
- ----- Method: BlockClosureInspector>>replaceSelectionValue: (in category 'selection') -----
- replaceSelectionValue: anObject
-
- | success |
- (success := super replaceSelectionValue: anObject) ifTrue: [
- self selectedField key = #receiver
- ifTrue: [instVarNames := nil]].
- ^ success!
Item was removed:
- ----- Method: BlockClosureInspector>>streamBaseFieldsOn: (in category 'fields - streaming') -----
- streamBaseFieldsOn: aStream
-
- super streamBaseFieldsOn: aStream.
- aStream nextPut: self fieldSource.!
Item was removed:
- ----- Method: BlockClosureInspector>>streamBindingsOn: (in category 'fields - streaming') -----
- streamBindingsOn: aStream
-
- | compiledCode instNames tempNames |
- self flag: #decompile. "mt: Use #to: and #do: instead of #to:do: to avoid inlining to preserve bindings in enumeration block for later decompilation. See InspectorField."
-
- (1 to: (instNames := self instVarNames) size) do: [:index |
- aStream nextPut: ((self newFieldForType: #instVar key: index)
- name: ('[[[{1}]]]' format: {instNames at: index});
- valueGetter: [:closure | closure receiver instVarAt: index];
- valueSetter: [:closure :value | closure receiver instVarAt: index put: value];
- yourself)].
-
- tempNames := self tempVarNames.
- "No need to show closured bindings from outerContext. The important temps are already covered in the indexed fields below."
- (1 to: tempNames size - self object basicSize) do: [:index |
- aStream nextPut: ((self newFieldForType: #tempVar key: index)
- name: ('[[{1}]]' format: {tempNames at: index});
- valueGetter: [:closure | closure outerContext tempAt: index];
- valueSetter: [:closure :value | closure outerContext tempAt: index put: value];
- yourself)].
-
- (1 to: (compiledCode := self object method) numLiterals) do: [:index |
- | literal |
- literal := compiledCode literalAt: index.
- literal isVariableBinding ifTrue: [
- aStream nextPut: ((self newFieldForType: #tempVar key: index)
- name: ('[{1}]' format: {literal key});
- valueGetter: [:closure | (closure method literalAt: index) value];
- valueSetter: [:closure :value | (closure method literalAt: index) value: value];
- yourself)]].
-
- (1 to: self object basicSize) do: [:index |
- aStream nextPut: ((self newFieldForType: #tempVar key: index)
- name: ('[{1}]' format: {tempNames at: index + tempNames size - self object basicSize});
- valueGetter: [:closure | closure basicAt: index];
- valueSetter: [:closure :value | closure basicAt: index put: value];
- yourself)].
-
-
- "See commentary in #doItReceiver. No need to expose the closured 'self' here because there is already the #receiver instVar.
-
- fieldReceiver
- ^ (self newFieldForType: #tempVar key: #receiver)
- name: '[self]';
- valueGetter: [:obj | obj receiver];
- valueSetter: [:obj :value | obj receiver: value];
- yourself
- "!
Item was removed:
- ----- Method: BlockClosureInspector>>streamInstanceVariablesOn: (in category 'fields - streaming') -----
- streamInstanceVariablesOn: aStream
- "Add (closured) bindings to the list."
-
- super streamInstanceVariablesOn: aStream.
- self streamBindingsOn: aStream.!
Item was removed:
- ----- Method: BlockClosureInspector>>tempVarNames (in category 'private') -----
- tempVarNames
-
- ^ tempVarNames ifNil: [tempVarNames := self debuggerMap tempNamesForContext: self object outerContext]!
Item was removed:
- ----- Method: BlockClosureInspector>>updateStyler:requestor: (in category 'user interface - styling') -----
- updateStyler: aStyler requestor: anObject
- "Overwritten to let the receiver behave like a Workspace to be asked for #hasBindingOf:."
-
- super updateStyler: aStyler requestor: anObject.
- aStyler workspace: self.!
Item was removed:
- ----- Method: Boolean>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Boolean'!
Item was removed:
- CodeHolder subclass: #Browser
- instanceVariableNames: 'environment systemOrganizer classOrganizer metaClassOrganizer editSelection metaClassIndicated selectedSystemCategory selectedClassName selectedMessageName selectedMessageCategoryName classDefinition metaClassDefinition'
- classVariableNames: 'ListClassesHierarchically RecentClasses ShowClassIcons ShowMessageIcons SortMessageCategoriesAlphabetically'
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !Browser commentStamp: 'cwp 12/27/2012 11:09' prior: 0!
- I represent a query path into the class descriptions, the software of the system.!
Item was removed:
- ----- Method: Browser class>>canUseMultiWindowBrowsers (in category 'preferences') -----
- canUseMultiWindowBrowsers
- ^true!
Item was removed:
- ----- Method: Browser class>>cleanUp (in category 'class initialization') -----
- cleanUp
- "Flush caches"
-
- self initialize.!
Item was removed:
- ----- Method: Browser class>>fullOnCategory: (in category 'instance creation') -----
- fullOnCategory: aCategory
- "Open a new full browser set to the system category."
-
- ^ self new
- selectSystemCategory: aCategory asSymbol;
- buildAndOpenFullBrowser!
Item was removed:
- ----- Method: Browser class>>fullOnClass: (in category 'instance creation') -----
- fullOnClass: aClass
- "Open a new full browser set to class."
- "Browser fullOnClass: Browser"
-
- ^ self new
- setClass: aClass;
- buildAndOpenFullBrowser!
Item was removed:
- ----- Method: Browser class>>fullOnClass:category: (in category 'instance creation') -----
- fullOnClass: aClass category: category
- "Open a new full browser set to class and message category."
- "Browser fullOnClass: Browser category: 'controls' "
-
- ^ self new
- setClass: aClass;
- selectMessageCategoryNamed: category;
- buildAndOpenFullBrowser!
Item was removed:
- ----- Method: Browser class>>fullOnClass:selector: (in category 'instance creation') -----
- fullOnClass: aClass selector: aSelector
- "Open a new full browser set to the class and selector."
- "Browser fullOnClass: Browser selector: #defaultWindowColor"
-
- ^ self new
- setClass: aClass selector: aSelector;
- buildAndOpenFullBrowser!
Item was removed:
- ----- Method: Browser class>>fullOnClassComment: (in category 'instance creation') -----
- fullOnClassComment: aClass
-
- ^ self new
- setClass: aClass;
- editComment;
- buildAndOpenFullBrowser!
Item was removed:
- ----- Method: Browser class>>fullOnEnvironment: (in category 'instance creation') -----
- fullOnEnvironment: anEnvironment
-
- ^ self new
- selectEnvironment: anEnvironment;
- buildAndOpenFullBrowser!
Item was removed:
- ----- Method: Browser class>>initialize (in category 'class initialization') -----
- initialize
- "Browser initialize"
-
- RecentClasses := OrderedCollection new.
- self
- registerInFlapsRegistry;
- registerInAppRegistry !
Item was removed:
- ----- Method: Browser class>>listClassesHierarchically (in category 'preferences') -----
- listClassesHierarchically
- <preference: 'List classes hierarchically'
- category: 'browsing'
- description: 'When enabled, the class list in the browser is arranged and indented with regard to the class hierarchy.'
- type: #Boolean>
- ^ListClassesHierarchically ifNil: [false]
- !
Item was removed:
- ----- Method: Browser class>>listClassesHierarchically: (in category 'preferences') -----
- listClassesHierarchically: aBool
-
- ListClassesHierarchically := aBool!
Item was removed:
- ----- Method: Browser class>>new (in category 'instance creation') -----
- new
-
- ^super new systemOrganizer: SystemOrganization!
Item was removed:
- ----- Method: Browser class>>newOnCategory: (in category 'instance creation') -----
- newOnCategory: aCategory
- "Open a new browser on this category"
-
- "Browser newOnCategory: 'Tools-Browser'"
-
- ^self newOnCategory: aCategory label: 'Classes in category ', aCategory
- !
Item was removed:
- ----- Method: Browser class>>newOnCategory:editString:label: (in category 'instance creation') -----
- newOnCategory: aCategory editString: aString label: aLabel
- "Open a new browser on this category (testing first for existence) with aString pre-selected in the code pane.
- We have to be a bit sneaky to do the string insertion since it cannot be handled until after the actual browser is built and opened"
-
- "Browser newOnCategory: 'Tools-Browser' editString: 'test string edit setup' label: 'Testing category browser with set edit string'"
-
- | newBrowser |
- newBrowser := self newOnCategory: aCategory label: aLabel.
- aString ifNotNil:[newBrowser changed: #editString with: aString].
- ^ newBrowser
-
- !
Item was removed:
- ----- Method: Browser class>>newOnCategory:label: (in category 'instance creation') -----
- newOnCategory: aCategory label: aLabel
- "Open a new browser on this category (testing first for existence)."
-
- "Browser newOnCategory: 'Tools-Browser' label: 'Testing category browser'"
-
- | newBrowser newCat |
- newBrowser := self new.
- newCat := aCategory asSymbol.
- (newBrowser systemCategoryList includes: newCat)
- ifTrue: [ newBrowser selectSystemCategory: newCat ]
- ifFalse: [ ^ self inform: 'No such category' ].
-
- newBrowser buildAndOpenCategoryBrowserLabel: aLabel.
- ^ newBrowser
-
- !
Item was removed:
- ----- Method: Browser class>>newOnClass: (in category 'instance creation') -----
- newOnClass: aClass
- "Open a new class browser on this class."
- ^ self newOnClass: aClass label: 'Class Browser: ', aClass name!
Item was removed:
- ----- Method: Browser class>>newOnClass:editString:label: (in category 'instance creation') -----
- newOnClass: aClass editString: aString label: aLabel
- "Open a new class browser on this class with aString pre-selected in the code pane.
- We have to be a bit sneaky to do the string insertion since it cannot be handled until after the actual browser is built and opened"
- "Browser newOnClass: Browser editString: 'test string edit setup' label: 'Testing category browser with set edit string'"
- | newBrowser|
-
- newBrowser := self newOnClass: aClass label: aLabel.
- newBrowser editSelection: #newMessage.
- aString ifNotNil:[newBrowser changed: #editString with: aString].
- ^ newBrowser
- !
Item was removed:
- ----- Method: Browser class>>newOnClass:label: (in category 'instance creation') -----
- newOnClass: aClass label: aLabel
- "Open a new class browser on this class and set the label."
- "Browser newOnClass: Browser label: 'A specific label that I want'"
- | newBrowser |
-
- newBrowser := self new.
- newBrowser setClass: aClass.
- ^ newBrowser buildAndOpenClassBrowserLabel: aLabel
- !
Item was removed:
- ----- Method: Browser class>>newOnClass:messageCategory: (in category 'instance creation') -----
- newOnClass: aClass messageCategory: aCategory
-
- ^ self newOnClass: aClass messageCategory: aCategory editString: nil label: 'Message Category Browser (' , aClass name, ')'.!
Item was removed:
- ----- Method: Browser class>>newOnClass:messageCategory:editString:label: (in category 'instance creation') -----
- newOnClass: aClass messageCategory: aCategory editString: aString label: aLabel
- "Open a new message protocol browser on this class & protocol with aString pre-selected in the code pane.
- We have to be a bit sneaky to do the string insertion since it cannot be handled until after the actual browser is built and opened"
-
- ^self newOnClass: aClass messageCategory: aCategory selector: nil editString: aString label: aLabel!
Item was removed:
- ----- Method: Browser class>>newOnClass:messageCategory:selector:editString:label: (in category 'instance creation') -----
- newOnClass: aClass messageCategory: aCategory selector: aSelector editString: aString label: aLabel
- "Open a new message protocol browser on this class & protocol with aString pre-selected in the code pane.
- We have to be a bit sneaky to do the string insertion since it cannot be handled until after the actual browser is built and opened"
- "Browser newOnClass: Browser messageCategory: 'controls' selector: #decorateButtons editString: 'test string edit setup' label: 'Testing class browser with set edit string'"
- | newBrowser|
-
- newBrowser := self new.
- "setting up a new browser for a specific class, category and selector requires this order of messages
- since the #selectMessageCategoryNamed: carefully nils the chosen selector; thus we can't use
- the more obvious seeming #setClass:selector: method"
- newBrowser
- setClass: aClass;
- selectMessageCategoryNamed: aCategory;
- selectMessageNamed: aSelector;
- editSelection: #editMessage.
-
- newBrowser buildAndOpenMessageCategoryBrowserLabel: 'Message Category Browser (' , aClass name, ')'.
- aString ifNotNil:[newBrowser changed: #editString with: aString].
- ^newBrowser!
Item was removed:
- ----- Method: Browser class>>newOnClass:selector: (in category 'instance creation') -----
- newOnClass: aClass selector: aSymbol
- "Open a new class browser on this class."
- "Browser newOnClass: Browser selector: #decorateButtons"
- | newBrowser |
-
- newBrowser := self new.
- newBrowser setClass: aClass selector: aSymbol.
- ^ newBrowser buildAndOpenClassBrowserLabel: 'Class Browser: ', aClass name
- !
Item was removed:
- ----- Method: Browser class>>open (in category 'instance creation') -----
- open
- ^self openBrowser
-
- !
Item was removed:
- ----- Method: Browser class>>openBrowser (in category 'instance creation') -----
- openBrowser
- "Open a standard system browser with the generic category/class/protocol/message lists"
- "Browser openBrowser"
-
- ^ self new buildAndOpenFullBrowser
-
- !
Item was removed:
- ----- Method: Browser class>>prototypicalToolWindow (in category 'instance creation') -----
- prototypicalToolWindow
- "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
-
- ^ ToolBuilder default build: self !
Item was removed:
- ----- Method: Browser class>>registerInAppRegistry (in category 'class initialization') -----
- registerInAppRegistry
- "Register the receiver in the SystemBrowser AppRegistry"
- SystemBrowser register: self.!
Item was removed:
- ----- Method: Browser class>>registerInFlapsRegistry (in category 'class initialization') -----
- registerInFlapsRegistry
- "Register the receiver in the system's flaps registry"
- self environment
- at: #Flaps
- ifPresent: [:cl | cl registerQuad: {#Browser. #prototypicalToolWindow. 'Browser' translatedNoop. 'A Browser is a tool that allows you to view all the code of all the classes in the system' translatedNoop}
- forFlapNamed: 'Tools']!
Item was removed:
- ----- Method: Browser class>>showClassIcons (in category 'preferences') -----
- showClassIcons
- <preference: 'Show class icons'
- category: 'browsing'
- description: 'When enabled, the class list will show icons for some standard types such as Morph and Magnitude.'
- type: #Boolean>
- ^ShowClassIcons ifNil: [true]
- !
Item was removed:
- ----- Method: Browser class>>showClassIcons: (in category 'preferences') -----
- showClassIcons: aBoolean
- ShowClassIcons := aBoolean.!
Item was removed:
- ----- Method: Browser class>>showMessageIcons (in category 'preferences') -----
- showMessageIcons
- <preference: 'Show message icons'
- category: 'browsing'
- description: 'When enabled, the message list will show icons for flags, overrides, etc.'
- type: #Boolean>
- ^ShowMessageIcons ifNil: [true]
- !
Item was removed:
- ----- Method: Browser class>>showMessageIcons: (in category 'preferences') -----
- showMessageIcons: aBoolean
-
- ShowMessageIcons := aBoolean.!
Item was removed:
- ----- Method: Browser class>>sortMessageCategoriesAlphabetically (in category 'preferences') -----
- sortMessageCategoriesAlphabetically
-
- <preference: 'Sort Message Categories Alphabetically'
- categoryList: #(browsing Tools)
- description: 'When enabled, the message category list in the browser is ordered by alphabet. No need to ''alphabetize'' this list manually via the context menu.'
- type: #Boolean>
-
- ^ SortMessageCategoriesAlphabetically ifNil: [false]
- !
Item was removed:
- ----- Method: Browser class>>sortMessageCategoriesAlphabetically: (in category 'preferences') -----
- sortMessageCategoriesAlphabetically: aBoolean
-
- SortMessageCategoriesAlphabetically := aBoolean.
- !
Item was removed:
- ----- Method: Browser class>>systemOrganizer: (in category 'instance creation') -----
- systemOrganizer: anOrganizer
-
- ^(super new)
- systemOrganizer: anOrganizer;
- yourself!
Item was removed:
- ----- Method: Browser class>>unload (in category 'class initialization') -----
- unload
- "Unload the receiver from global registries"
-
- self environment at: #Flaps ifPresent: [:cl |
- cl unregisterQuadsWithReceiver: self].
- SystemBrowser unregister: self.!
Item was removed:
- ----- Method: Browser>>aboutToStyle: (in category 'code pane') -----
- aboutToStyle: aStyler
- "This is a notification that aStyler is about to re-style its text.
- Set the classOrMetaClass in aStyler, so that identifiers
- will be resolved correctly.
- Answer true to allow styling to proceed, or false to veto the styling"
- | type |
-
- self isModeStyleable ifFalse: [^false].
- type := self editSelection.
- (#(newMessage editMessage editClass newClass) includes: type) ifFalse:[^false].
- aStyler classOrMetaClass: ((type = #editClass or: [type = #newClass]) ifFalse:[self selectedClassOrMetaClass]).
- ^true!
Item was removed:
- ----- Method: Browser>>addAllMethodsToCurrentChangeSet (in category 'class functions') -----
- 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 selectorsDo:
- [:sel |
- ChangeSet current adoptSelector: sel forClass: aClass].
- self changed: #annotation]
- !
Item was removed:
- ----- Method: Browser>>addCategory (in category 'message category functions') -----
- addCategory
- "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection"
- | labels reject lines newName oldCategory |
- self okToChange ifFalse: [^ self].
- self hasClassSelected ifFalse: [^ self].
- labels := OrderedCollection new.
- reject := Set new.
- reject
- addAll: self selectedClassOrMetaClass organization categories;
- add: ClassOrganizer nullCategory;
- add: ClassOrganizer default.
- lines := OrderedCollection new.
- self selectedClassOrMetaClass allSuperclasses do: [:cls | | cats |
- cls = Object ifFalse: [
- cats := cls organization categories reject:
- [:cat | reject includes: cat].
- cats isEmpty ifFalse: [
- lines add: labels size.
- labels addAll: cats sort.
- reject addAll: cats]]].
- (newName := UIManager default
- chooseFromOrAddTo: labels
- lines: lines
- title: 'Add Category') ifNil: [^ self].
- newName isEmpty
- ifTrue: [^ self]
- ifFalse: [newName := newName asSymbol].
- oldCategory := self selectedMessageCategoryName.
- self classOrMetaClassOrganizer
- addCategory: newName
- before: (self hasMessageCategorySelected
- ifFalse: [nil]
- ifTrue: [self selectedMessageCategoryName]).
- self changed: #messageCategoryList.
- self selectMessageCategoryNamed: newName.
- self changed: #messageCategoryList.
- !
Item was removed:
- ----- Method: Browser>>addExtraShiftedItemsTo: (in category 'message list') -----
- addExtraShiftedItemsTo: aMenu
- "The shifted selector-list menu is being built; some menu items are appropriate only for certain kinds of browsers, and this gives a hook for them to be added as approrpiate. If any is added here, a line should be added first -- browse reimplementors of this message for examples."
- !
Item was removed:
- ----- Method: Browser>>addModelItemsToWindowMenu: (in category 'user interface') -----
- addModelItemsToWindowMenu: aMenu
- "Add model-related items to the window menu"
- super addModelItemsToWindowMenu: aMenu.
- SystemBrowser addRegistryMenuItemsTo: aMenu inAccountOf: self.!
Item was removed:
- ----- Method: Browser>>addSpecialMenu: (in category 'traits') -----
- addSpecialMenu: aMenu
- aMenu addList: #(
- -
- ('new class' newClass)
- ('new trait' newTrait)
- -).
- self selectedClass notNil ifTrue: [
- aMenu addList: #(
- ('add trait' addTrait)
- -) ].
- aMenu addList: #(-).
- ^ aMenu!
Item was removed:
- ----- Method: Browser>>addSystemCategory (in category 'system category functions') -----
- addSystemCategory
- "Prompt for a new category name and add it before the
- current selection, or at the end if no current selection"
- | oldSelection newName |
- self okToChange ifFalse: [^ self].
- oldSelection := self selectedSystemCategory.
- newName := self
- request: 'Please type new category name'
- initialAnswer: 'Category-Name'.
- newName isEmpty
- ifTrue: [^ self]
- ifFalse: [newName := newName asSymbol].
- systemOrganizer
- addCategory: newName
- before: self selectedSystemCategory.
- self selectSystemCategory:
- (oldSelection isNil
- ifTrue: [ self systemCategoryList last ]
- ifFalse: [ oldSelection ]).
- self changed: #systemCategoryList.!
Item was removed:
- ----- Method: Browser>>addTrait (in category 'traits') -----
- addTrait
- | input trait |
- input := UIManager default request: 'add trait'.
- input isEmptyOrNil ifFalse: [
- trait := self environment classNamed: input.
- (trait isNil or: [trait isTrait not]) ifTrue: [
- ^self inform: 'Input invalid. ' , input , ' does not exist or is not a trait'].
- self selectedClass setTraitComposition: self selectedClass traitComposition asTraitComposition + trait.
- self contentsChanged].
- !
Item was removed:
- ----- Method: Browser>>alphabetizeMessageCategories (in category 'message category functions') -----
- alphabetizeMessageCategories
- | oldMessageCategory oldMethod |
- oldMessageCategory := selectedMessageCategoryName.
- oldMethod := selectedMessageName.
- self hasClassSelected ifFalse: [^ false].
- self okToChange ifFalse: [^ false].
- self classOrMetaClassOrganizer sortCategories.
- self clearUserEditFlag.
- self editClass.
- self selectClassNamed: selectedClassName.
- self selectMessageCategoryNamed: oldMessageCategory.
- self selectMessageNamed: oldMethod.
- ^ true!
Item was removed:
- ----- Method: Browser>>alphabetizeSystemCategories (in category 'system category functions') -----
- alphabetizeSystemCategories
-
- self okToChange ifFalse: [^ false].
- systemOrganizer sortCategories.
- self selectSystemCategory: nil.
- self changed: #systemCategoryList.
- !
Item was removed:
- ----- Method: Browser>>annotation (in category 'annotation') -----
- 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!
Item was removed:
- ----- Method: Browser>>annotation: (in category 'annotation') -----
- annotation: aText
- "The user accepted aText in our annotation pane"
- | theClass |
- (theClass := self selectedClass) ifNil: [^false].
- self editSelection == #editClass
- ifTrue: [
- self stripNaggingAttributeFromComment: aText.
- theClass comment: aText stamp: Utilities changeStamp.
- self changed: #classCommentText.
- ^ true].
- ^ false
- !
Item was removed:
- ----- Method: Browser>>annotationForClassCommentFor: (in category 'class comment pane') -----
- annotationForClassCommentFor: aClass
- "Provide a line of content for an annotation pane, given that the receiver is pointing at the class comment of the given class."
- | aStamp |
- aStamp := classOrganizer commentStamp.
- ^ aStamp
- ifNil:
- [self selectedClassName, ' has no class comment']
- ifNotNil:
- ['class comment for ', self selectedClassName,
- (aStamp = '<historical>'
- ifFalse:
- [' - ', aStamp]
- ifTrue:
- [''])]!
Item was removed:
- ----- Method: Browser>>annotationForClassDefinitionFor: (in category 'class comment pane') -----
- 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."
- ^self classCommentText!
Item was removed:
- ----- Method: Browser>>arrowKey:from: (in category 'multi-window support') -----
- arrowKey: aChar from: view
- "Intercept Apple-Digit to select panes"
- | index |
- (aChar isDigit
- and: [self multiWindowState notNil]) ifTrue:
- [index := aChar asciiValue - $0 asciiValue.
- index = 0 ifTrue: [index := 10].
- ^index <= self multiWindowState models size
- ifTrue: [self multiWindowState selectWindowIndex: index]
- ifFalse: [self changed: #flash]].
- ^super arrowKey: aChar from: view
- !
Item was removed:
- ----- Method: Browser>>browseAllClasses (in category 'system category functions') -----
- browseAllClasses
- "Create and schedule a new browser on all classes alphabetically."
-
- ^ClassListBrowser newOnAllClasses!
Item was removed:
- ----- Method: Browser>>browseAllCommentsForClass (in category 'message functions') -----
- browseAllCommentsForClass
- "Opens a HelpBrowser on the class"
-
- | myClass |
- myClass := self selectedClass ifNil: [ ^self ].
- myClass isTrait ifTrue: [ ^self ].
- myClass openHelpBrowser model showTopicNamed: myClass name.!
Item was removed:
- ----- Method: Browser>>browseClassHierarchy (in category 'multi-window support') -----
- browseClassHierarchy
- "Overridden to consider multi-window state and hierarchy browser."
-
- | behavior newBrowser |
- (behavior := self selectedClassOrMetaClass) isNil ifTrue:
- [^self].
-
- (self isPackage "PackageBrowser panes can't support a hierarchy browser; not sure why."
- or: [self multiWindowState isNil]) ifTrue:
- [^super browseClassHierarchy].
-
- newBrowser := HierarchyBrowser new
- setClass: behavior;
- selectMessageCategoryNamed: self selectedMessageCategoryName;
- selectMessageNamed: self selectedMessageName;
- editSelection: editSelection;
- yourself.
-
- self multiWindowState addWindow: newBrowser!
Item was removed:
- ----- Method: Browser>>browsePackage (in category 'system category functions') -----
- browsePackage
-
- ^ self selectedPackage
- ifNil: [self informUnknownPackage]
- ifNotNil: [:package | package browse].!
Item was removed:
- ----- Method: Browser>>browsePackageDependencies (in category 'system category functions') -----
- browsePackageDependencies
-
- ^ self selectedPackage
- ifNil: [self informUnknownPackage]
- ifNotNil: [:package | DependencyBrowser openOnPackage: package].!
Item was removed:
- ----- Method: Browser>>browsePackageDependenciesInverted (in category 'system category functions') -----
- browsePackageDependenciesInverted
-
- ^ self selectedPackage
- ifNil: [self informUnknownPackage]
- ifNotNil: [:package | DependencyBrowser openInvertedOnPackage: package].!
Item was removed:
- ----- Method: Browser>>browsePackageExtensions (in category 'system category functions') -----
- browsePackageExtensions
-
- ^ self selectedPackage
- ifNil: [self informUnknownPackage]
- ifNotNil: [:package | self systemNavigation browseAllExtensionMethodsOfPackage: package]!
Item was removed:
- ----- Method: Browser>>browsePackageExtensionsLocalTo (in category 'system category functions') -----
- browsePackageExtensionsLocalTo
-
- ^ self selectedPackage
- ifNil: [self informUnknownPackage]
- ifNotNil: [:package |
- self systemNavigation
- browseAllExtensionMethodsOfPackage: package
- localTo: self selectedSystemCategory].!
Item was removed:
- ----- Method: Browser>>buildAndOpenCategoryBrowser (in category 'toolbuilder') -----
- buildAndOpenCategoryBrowser
- "assemble the spec for a system category browser, build it and open it - use the default label"
-
- ^self buildAndOpenCategoryBrowserLabel: nil
- !
Item was removed:
- ----- Method: Browser>>buildAndOpenCategoryBrowserLabel: (in category 'toolbuilder') -----
- buildAndOpenCategoryBrowserLabel: aLabelString
- "assemble the spec for a system category browser, build it and open it"
-
- | builder windowSpec |
- builder := ToolBuilder default.
-
- windowSpec := self buildCategoryBrowserWith: builder.
- aLabelString ifNotNil:[:str| windowSpec label: str].
-
- builder open: windowSpec.
-
- ^self
- !
Item was removed:
- ----- Method: Browser>>buildAndOpenClassBrowserLabel: (in category 'toolbuilder') -----
- buildAndOpenClassBrowserLabel: aLabelString
- "assemble the spec for a class browser, build it and open it"
-
- | builder max windowSpec catPaneHeight|
- builder := ToolBuilder default.
- catPaneHeight := builder listHeight.
- max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4].
-
- windowSpec :=self buildWindowWith: builder specs: {
- (self topConstantHeightFrame: catPaneHeight fromLeft: 0 width: 0.5) -> [self buildClassListSingletonWith: builder].
- (self frameOffsetFromTop: catPaneHeight fromLeft: 0 width: 0.5 bottomFraction: max) -> [self buildMessageCategoryListWith: builder].
- (self topConstantHeightFrame: catPaneHeight fromLeft: 0.5 width: 0.5) -> [self buildSwitchesWith: builder].
- (self frameOffsetFromTop: catPaneHeight fromLeft: 0.5 width: 0.5 bottomFraction: max) -> [self buildMessageListWith: builder].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
- self setMultiWindowFor:windowSpec.
- windowSpec label: aLabelString.
-
- builder open: windowSpec.
-
- ^self
- !
Item was removed:
- ----- Method: Browser>>buildAndOpenFullBrowser (in category 'toolbuilder') -----
- buildAndOpenFullBrowser
- "assemble the spec for a full system browser, build it and open it"
-
- | builder window |
- builder := ToolBuilder default.
-
- "the build-but-don't-open phase is factored out to support the prototypicalToolWindow facility"
- window := self buildDefaultBrowserWith: builder.
- builder open: window.!
Item was removed:
- ----- Method: Browser>>buildAndOpenMessageCategoryBrowserLabel: (in category 'toolbuilder') -----
- buildAndOpenMessageCategoryBrowserLabel: aLabelString
- "assemble the spec for a messasge category browser, build it and open it"
-
- | builder max windowSpec catPaneHeight |
- builder := ToolBuilder default.
- catPaneHeight := builder listHeight.
- max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4].
-
- windowSpec :=self buildWindowWith: builder specs: {
- (LayoutFrame fractions: (0@0 corner: 1.0@0) offsets: (0@0 corner: 0@catPaneHeight)) -> [self buildMessageListCatSingletonWith: builder].
- (LayoutFrame fractions: (0.0(a)0.0 corner: 1.0@max) offsets: (0@ catPaneHeight corner: 0@0)) -> [self buildMessageListWith: builder].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
- self setMultiWindowFor:windowSpec.
- windowSpec label: aLabelString.
-
- builder open: windowSpec.
-
- ^self
- !
Item was removed:
- ----- Method: Browser>>buildCategoryBrowserWith: (in category 'toolbuilder') -----
- buildCategoryBrowserWith: builder
- "assemble the spec for a system category browser, build it and return it"
-
- | max windowSpec catPaneHeight|
- catPaneHeight := builder listHeight.
- max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4].
-
- windowSpec := self buildWindowWith: builder specs: {
- (LayoutFrame fractions: (0@0 corner: 1.0@0) offsets: (0@0 corner: 0@catPaneHeight)) -> [self buildSystemCatListSingletonWith: builder].
- ((self classListFrame: max fromTop: 0 fromLeft: 0 width: 0.333)
- topOffset: catPaneHeight) -> [self buildClassListWith: builder].
- (self switchesFrame: max fromLeft: 0 width: 0.333) -> [self buildSwitchesWith: builder].
- (LayoutFrame fractions: (0.333@0 corner: 0.666@max) offsets: (0@catPaneHeight corner: 0@0)) -> [self buildMessageCategoryListWith: builder].
- (LayoutFrame fractions: (0.666@0 corner: 1@max) offsets: (0@catPaneHeight corner: 0@0)) -> [self buildMessageListWith: builder].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
- self setMultiWindowFor:windowSpec.
-
- ^builder build: windowSpec
- !
Item was removed:
- ----- Method: Browser>>buildClassListSingletonWith: (in category 'toolbuilder') -----
- buildClassListSingletonWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #classListSingleton;
- getIndex: #indexIsOne;
- setIndex: #indexIsOne:;
- menu: #classListMenu:shifted:;
- keyPress: #classListKey:from:;
- hScrollBarPolicy: #never;
- vScrollBarPolicy: #never;
- minimumHeight: 0.
- ^listSpec
- !
Item was removed:
- ----- Method: Browser>>buildClassListWith: (in category 'toolbuilder') -----
- buildClassListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #classList;
- list: #classList;
- getIndex: #classListIndex;
- setIndex: #classListIndex:;
- icon: #classIconAt:;
- menu: #classListMenu:shifted:;
- keyPress: #classListKey:from:.
- SystemBrowser browseWithDragNDrop ifTrue: [
- listSpec
- dragItem: #dragFromClassList:;
- dragType: #dragTypeForClassListAt:].
-
- ^listSpec
- !
Item was removed:
- ----- Method: Browser>>buildDefaultBrowserWith: (in category 'toolbuilder') -----
- buildDefaultBrowserWith: builder
- "assemble the spec for a full system browser, build it and return the built but not opened morph"
- "this build-but-don't-open phase is factored out to support the prototypicalToolWindow facility"
-
- | max windowSpec |
- max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5].
-
- windowSpec := self buildWindowWith: builder specs: {
- (0@0 corner: 0.25@max) -> [self buildSystemCategoryListWith: builder].
- (self classListFrame: max) -> [self buildClassListWith: builder].
- (self switchesFrame: max) -> [self buildSwitchesWith: builder].
- (0.5@0 corner: 0.75@max) -> [self buildMessageCategoryListWith: builder].
- (0.75@0 corner: 1@max) -> [self buildMessageListWith: builder].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
- self setMultiWindowFor:windowSpec.
- windowSpec defaultFocus: #systemCategoryList.
-
- ^builder build: windowSpec!
Item was removed:
- ----- Method: Browser>>buildMessageCategoryBrowser (in category 'message category functions') -----
- buildMessageCategoryBrowser
- "Create and schedule a message category browser for the currently
- selected message category."
-
- self buildMessageCategoryBrowserEditString: nil!
Item was removed:
- ----- Method: Browser>>buildMessageCategoryBrowserEditString: (in category 'message category functions') -----
- buildMessageCategoryBrowserEditString: aString
- "Create and schedule a new class browser for the current selection,
- with initial textual contents set to aString. This is used specifically in
- spawning where a class is established but a method-category is not."
- ^ self hasMessageCategorySelected ifTrue: [Browser
- newOnClass: self selectedClassOrMetaClass
- messageCategory: self selectedMessageCategoryName
- selector: self selectedMessageName
- editString: aString
- label: 'Message category Browser: ' , self selectedClassOrMetaClass name , self categoryOfCurrentMethod]!
Item was removed:
- ----- Method: Browser>>buildMessageCategoryListWith: (in category 'toolbuilder') -----
- buildMessageCategoryListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #messageCategoryList;
- list: #messageCategoryList;
- getIndex: #messageCategoryListIndex;
- setIndex: #messageCategoryListIndex:;
- menu: #messageCategoryMenu:;
- keyPress: #messageCategoryListKey:from:.
- SystemBrowser browseWithDragNDrop ifTrue:[
- listSpec
- dropAccept: #wantsMessageCategoriesDrop:;
- dropItem: #dropOnMessageCategories:at:].
- ^listSpec
- !
Item was removed:
- ----- Method: Browser>>buildMessageListCatSingletonWith: (in category 'toolbuilder') -----
- buildMessageListCatSingletonWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #messageCatListSingleton;
- getIndex: #indexIsOne;
- setIndex: #indexIsOne:;
- menu: #messageCategoryMenu:;
- hScrollBarPolicy: #never;
- vScrollBarPolicy: #never;
- minimumHeight: 0.
- ^listSpec
- !
Item was removed:
- ----- Method: Browser>>buildMessageListWith: (in category 'toolbuilder') -----
- buildMessageListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #messageList;
- list: #messageList;
- getIndex: #messageListIndex;
- setIndex: #messageListIndex:;
- icon: #messageIconAt:;
- helpItem: #messageHelpAt:;
- menu: #messageListMenu:shifted:;
- keyPress: #messageListKey:from:.
- SystemBrowser browseWithDragNDrop ifTrue: [
- listSpec
- dragItem: #dragFromMessageList:;
- dragType: #dragTypeForMessageListAt:].
- ^listSpec
- !
Item was removed:
- ----- Method: Browser>>buildSwitchesWith: (in category 'toolbuilder') -----
- buildSwitchesWith: builder
- "Build the instance/comment/class switch"
-
- | panelSpec i q c |
- panelSpec := builder pluggablePanelSpec new
- name: #switches;
- layout: #horizontal;
- spacing: (-1 * RealEstateAgent scaleFactor) truncated;
- children: OrderedCollection new;
- yourself.
-
- i := builder pluggableButtonSpec new.
- i
- model: self;
- label: 'instance';
- help: 'Show instance-side methods' translated;
- state: #instanceMessagesIndicated;
- action: #indicateInstanceMessages.
-
- q := builder pluggableButtonSpec new.
- q
- model: self;
- horizontalResizing: #shrinkWrap;
- label: '?';
- help: 'Cycle between definition, comment, and hierarchy view' translated;
- state: #classCommentIndicated;
- action: #plusButtonHit.
-
- c := builder pluggableButtonSpec new.
- c
- model: self;
- label: 'class';
- help: 'Show class-side methods' translated;
- state: #classMessagesIndicated;
- action: #indicateClassMessages.
-
- panelSpec children addAll: {
- i. c.
- builder pluggableSpacerSpec new.
- q
- }.
-
- ^panelSpec!
Item was removed:
- ----- Method: Browser>>buildSystemCatListSingletonWith: (in category 'toolbuilder') -----
- buildSystemCatListSingletonWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #systemCategorySingleton;
- getIndex: #indexIsOne;
- setIndex: #indexIsOne:;
- menu: #systemCategoryMenu:;
- keyPress: #systemCatSingletonKey:from:;
- hScrollBarPolicy: #never;
- vScrollBarPolicy: #never;
- minimumHeight: 0.
- ^listSpec!
Item was removed:
- ----- Method: Browser>>buildSystemCategoryBrowser (in category 'system category functions') -----
- buildSystemCategoryBrowser
- "Open a new system category browser on the selelcted category, if there is one"
-
- self hasSystemCategorySelected
- ifTrue:
- [self class newOnCategory: self selectedSystemCategory]!
Item was removed:
- ----- Method: Browser>>buildSystemCategoryBrowserEditString: (in category 'system category functions') -----
- buildSystemCategoryBrowserEditString: aString
- "Open a new system category browser on the selelcted category, if
- there is one"
- self hasSystemCategorySelected
- ifTrue: [self class
- newOnCategory: self selectedSystemCategory
- editString: aString
- label: 'Classes in category ' , self selectedSystemCategory]!
Item was removed:
- ----- Method: Browser>>buildSystemCategoryListWith: (in category 'toolbuilder') -----
- buildSystemCategoryListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #systemCategoryList;
- list: #systemCategoryList;
- getIndex: #systemCategoryListIndex;
- setIndex: #systemCategoryListIndex:;
- menu: #systemCategoryMenu:;
- keyPress: #systemCatListKey:from:.
- SystemBrowser browseWithDragNDrop ifTrue:[
- listSpec
- dropAccept: #wantsSystemCategoriesDrop:;
- dropItem: #dropOnSystemCategories:at:].
- ^listSpec!
Item was removed:
- ----- Method: Browser>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- "Create the ui for the browser"
- "Browser is a bit of an oddity in the ToolBuilder>build: world since the class provides several dfferent UIs rather than the one-per-class idiom of ToolBuilder. Here we are building the full browser version"
-
- ^self buildDefaultBrowserWith: builder !
Item was removed:
- ----- Method: Browser>>canShowMultipleMessageCategories (in category 'message category functions') -----
- canShowMultipleMessageCategories
- "Answer whether the receiver is capable of showing multiple message categories"
-
- ^ true!
Item was removed:
- ----- Method: Browser>>categorizeAllUncategorizedMethods (in category 'message category list') -----
- categorizeAllUncategorizedMethods
- "Categorize methods by looking in parent classes for a method category."
-
- self classOrMetaClassOrganizer classifyAllUnclassified.
- self changed: #messageCategoryList!
Item was removed:
- ----- Method: Browser>>categoryOfCurrentMethod (in category 'message category functions') -----
- 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]]!
Item was removed:
- ----- Method: Browser>>changeMessageCategories: (in category 'message category functions') -----
- 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 selectClassNamed: selectedClassName.
- ^ true!
Item was removed:
- ----- Method: Browser>>changeSystemCategories: (in category 'system category functions') -----
- changeSystemCategories: aString
- "Update the class categories by parsing the argument aString."
-
- systemOrganizer changeFromString: aString.
- self changed: #systemCategoryList.
- ^ true!
Item was removed:
- ----- Method: Browser>>classCommentIndicated (in category 'metaclass') -----
- classCommentIndicated
- "Answer true iff we're viewing the class comment."
-
- ^ editSelection == #editComment
- !
Item was removed:
- ----- Method: Browser>>classCommentText (in category 'class functions') -----
- 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: [ self noCommentNagString ]!
Item was removed:
- ----- Method: Browser>>classDefinitionIndicated (in category 'metaclass') -----
- classDefinitionIndicated
-
- ^ editSelection == #editClass
- !
Item was removed:
- ----- Method: Browser>>classDefinitionText (in category 'class functions') -----
- classDefinitionText
- "return the text to display for the definition of the currently selected class"
- | theClass |
- ^(theClass := self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass definition]!
Item was removed:
- ----- Method: Browser>>classIconAt: (in category 'class list') -----
- classIconAt: anIndex
-
- self class showClassIcons
- ifFalse: [^ nil].
-
- ^ ToolIcons iconNamed: (ToolIcons iconForClass: (self classList at: anIndex) withBlanksTrimmed asSymbol)!
Item was removed:
- ----- Method: Browser>>classList (in category 'class list') -----
- classList
-
- ^ self class listClassesHierarchically
- ifTrue: [self hierarchicalClassList]
- ifFalse: [self defaultClassList].!
Item was removed:
- ----- Method: Browser>>classListFrame: (in category 'initialize-release') -----
- classListFrame: bottomFraction
- ^self
- classListFrame: bottomFraction
- fromTop: 0
- fromLeft: 0.25
- width: 0.25.!
Item was removed:
- ----- Method: Browser>>classListFrame:fromLeft:width: (in category 'initialize-release') -----
- classListFrame: bottomFraction fromLeft: leftFraction width: rightFraction
- ^self
- classListFrame: bottomFraction
- fromTop: 0
- fromLeft: leftFraction
- width: rightFraction.!
Item was removed:
- ----- Method: Browser>>classListFrame:fromTop:fromLeft:width: (in category 'initialize-release') -----
- classListFrame: bottomFraction fromTop: topFraction fromLeft: leftFraction width: rightFraction
- ^LayoutFrame new
- leftFraction: leftFraction offset: 0;
- topFraction: topFraction offset: 0;
- rightFraction: (leftFraction + rightFraction) offset: 0;
- bottomFraction: bottomFraction offset: self buttonHeight negated!
Item was removed:
- ----- Method: Browser>>classListIndex (in category 'class list') -----
- classListIndex
- "Answer the index of the current class selection."
-
- ^ self classListIndexOf: self selectedClassName.!
Item was removed:
- ----- Method: Browser>>classListIndex: (in category 'class list') -----
- classListIndex: anInteger
- | newClassName |
- newClassName := self classList at: anInteger ifAbsent: [ nil ].
- newClassName := newClassName ifNotNil: [newClassName withoutLeadingBlanks asSymbol].
- self selectClassNamed: newClassName.!
Item was removed:
- ----- Method: Browser>>classListIndexOf: (in category 'class list') -----
- classListIndexOf: className
-
- | classList |
- classList := self classList.
- classList := classList collect: [:ea | ea withoutLeadingBlanks asSymbol].
- ^ classList indexOf: className.!
Item was removed:
- ----- Method: Browser>>classListMenu: (in category 'class functions') -----
- classListMenu: aMenu
- "Conveniently fit for backward compatibility with old browers stored in image segments"
- <classListMenuShifted: false>
- aMenu addList: #(
- -
- ('browse full (b)' browseMethodFull)
- ('browse hierarchy (h)' spawnHierarchy)
- ('browse protocol (p)' browseFullProtocol)
- ('browse documentation' browseAllCommentsForClass)
- -
- ('printOut' printOutClass)
- ('fileOut' fileOutClass)
- -
- ('show hierarchy' hierarchy)
- ('show definition' editClass)
- ('show comment' editComment)
- -
- ('references... (r)' browseVariableReferences)
- ('assignments... (a)' browseVariableAssignments)
- ('class refs (N)' browseClassRefs)
- -
- ('rename class ...' renameClass)
- ('copy class' copyClass)
- ('remove class (x)' removeClass)
- -
- ('find method...' findMethod)).
- ^ aMenu
- !
Item was removed:
- ----- Method: Browser>>classListMenu:shifted: (in category 'class functions') -----
- classListMenu: aMenu shifted: shifted
- "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean"
- ^ self menu: aMenu for: #(classListMenu classListMenuShifted:) shifted: shifted.
- !
Item was removed:
- ----- Method: Browser>>classListMenuHook:shifted: (in category 'pluggable menus - hooks') -----
- classListMenuHook: aMenu shifted: aBoolean
- <classListMenu>
- <menuPriority: 400>
- ^ self menuHook: aMenu named: #classListMenu shifted: aBoolean.
- !
Item was removed:
- ----- Method: Browser>>classListMenuMore: (in category 'class functions') -----
- classListMenuMore: aMenu
- " The 'more..' link that toggles between shifted and unshifted menus
- in class lists "
- <classListMenuShifted: false>
- <menuPriority: 1000>
- ^ aMenu addList: #(- ('more...' offerShiftedClassListMenu)); yourself
- !
Item was removed:
- ----- Method: Browser>>classListSingleton (in category 'class list') -----
- classListSingleton
-
- | name |
- name := self selectedClassName.
- ^ name ifNil: [Array new]
- ifNotNil: [Array with: name]!
Item was removed:
- ----- Method: Browser>>classMessagesIndicated (in category 'metaclass') -----
- classMessagesIndicated
- "Answer whether the messages to be presented should come from the
- metaclass."
-
- ^ self metaClassIndicated and: [self classCommentIndicated not]!
Item was removed:
- ----- Method: Browser>>classNotFound (in category 'system category functions') -----
- classNotFound
-
- self changed: #flash.!
Item was removed:
- ----- Method: Browser>>classOrMetaClassOrganizer (in category 'metaclass') -----
- classOrMetaClassOrganizer
- "Answer the class organizer for the metaclass or class, depending on
- which (instance or class) is indicated."
-
- self metaClassIndicated
- ifTrue: [^metaClassOrganizer]
- ifFalse: [^classOrganizer]!
Item was removed:
- ----- Method: Browser>>compileMessage:notifying: (in category 'code pane') -----
- 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."
- | fallBackCategoryName originalSelectorName result fallBackMethodName |
- self selectedMessageCategoryName = ClassOrganizer allCategory
- ifTrue:
- [ "User tried to save a method while the ALL category was selected"
- fallBackCategoryName := selectedMessageCategoryName.
- fallBackMethodName := selectedMessageName.
- editSelection == #newMessage
- ifTrue:
- [ "Select the 'as yet unclassified' category"
- selectedMessageCategoryName := nil.
- (result := self defineMessageFrom: aText notifying: aController)
- ifNil:
- ["Compilation failure: reselect the original category & method"
- selectedMessageCategoryName := fallBackCategoryName.
- selectedMessageName := fallBackMethodName]
- ifNotNil:
- [self setSelector: result]]
- ifFalse:
- [originalSelectorName := self selectedMessageName.
- self setOriginalCategoryIndexForCurrentMethod.
- selectedMessageName := fallBackMethodName := originalSelectorName.
- (result := self defineMessageFrom: aText notifying: aController)
- ifNotNil:
- [self setSelector: result]
- ifNil:
- [ "Compilation failure: reselect the original category & method"
- selectedMessageCategoryName := fallBackCategoryName.
- selectedMessageName := fallBackMethodName.
- ^ result notNil]].
- self changed: #messageCategoryList.
- self changed: #messageList.
- ^ result notNil]
- ifFalse:
- [ "User tried to save a method while the ALL category was NOT selected"
- ^ (self defineMessageFrom: aText notifying: aController) notNil]!
Item was removed:
- ----- Method: Browser>>contents (in category 'accessing') -----
- 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 == #newTrait
- ifTrue: [^ClassDescription newTraitTemplateIn: self selectedSystemCategory].
- editSelection == #none ifTrue: [^ ''].
- editSelection == #editSystemCategories
- ifTrue: [^ systemOrganizer printString].
- editSelection == #newClass
- ifTrue: [^ self newClassContents].
- editSelection == #editClass
- ifTrue: [^self classDefinitionText].
- editSelection == #editComment
- ifTrue:
- [(theClass := self selectedClass) ifNil: [^ ''].
- comment := theClass comment.
- currentCompiledMethod := classOrganizer 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 editContentsWithDefault:
- [currentCompiledMethod := latestCompiledMethod.
- self selectedMessage]].
-
- self error: 'Browser internal error: unknown edit selection.'!
Item was removed:
- ----- Method: Browser>>contents:notifying: (in category 'accessing') -----
- 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 == #newTrait ifTrue: [^self defineTrait: input asString notifying: aController].
- 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'!
Item was removed:
- ----- Method: Browser>>contentsSelection (in category 'accessing') -----
- contentsSelection
- "Return the interval of text in the code pane to select when I set the pane's contents"
-
- self hasMessageCategorySelected & (self hasMessageSelected not)
- ifTrue: [^ 1 to: 500] "entire empty method template"
- ifFalse: [^ 1 to: 0] "null selection"!
Item was removed:
- ----- Method: Browser>>copyClass (in category 'class functions') -----
- copyClass
- | originalClass originalName copysName |
- self hasClassSelected ifFalse: [^ self].
- self okToChange ifFalse: [^ self].
- originalClass := self selectedClass.
- originalName := originalClass name.
- copysName := self request: 'Please type new class name' initialAnswer: originalName.
- copysName = '' ifTrue: [^ self]. " Cancel returns '' "
- copysName := copysName asSymbol.
- copysName = originalName ifTrue: [^ self].
- (self environment hasClassNamed: copysName)
- ifTrue: [^ self error: copysName , ' already exists'].
- Cursor wait showWhile: [
- | newDefinition newMetaDefinition newClass |
- newDefinition := originalClass definition
- copyReplaceAll: originalName printString
- with: copysName printString.
- newClass := Compiler evaluate: newDefinition environment: self environment
- logged: true.
- newMetaDefinition := originalClass class definition
- copyReplaceAll: originalClass class name
- with: newClass class name.
- Compiler evaluate: newMetaDefinition environment: self environment
- logged: true.
- newClass copyAllCategoriesFrom: originalClass.
- newClass class copyAllCategoriesFrom: originalClass class.
- originalClass hasComment ifTrue: [
- newClass comment: originalClass comment ] ].
- self classListIndex: 0.
- self changed: #classList!
Item was removed:
- ----- Method: Browser>>couldBrowseAnyClass (in category 'accessing') -----
- couldBrowseAnyClass
- "Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name. This implementation is clearly ugly, but the feature it enables is handsome enough. 3/1/96 sw"
-
- ^self dependents
- anySatisfy: [:d | (d respondsTo: #getListSelector)
- and: [d getListSelector == #systemCategoryList]]!
Item was removed:
- ----- Method: Browser>>createHierarchyTreeOf: (in category 'class list') -----
- createHierarchyTreeOf: col
-
- "Create a tree from a flat collection of classes"
- | transformed |
- transformed := col collect: [:ea |
- | childs indexes |
- childs := col select: [:class | class isTrait not and: [class superclass = ea]].
- indexes := childs collect: [:child | col indexOf: child].
- ea -> indexes].
- transformed copy do: [:ea |
- ea value: (ea value collect: [:idx |
- | val |
- val := transformed at: idx.
- transformed at: idx put: nil.
- val])].
- ^ transformed select: [:ea | ea notNil].
- !
Item was removed:
- ----- Method: Browser>>createInstVarAccessors (in category 'class functions') -----
- createInstVarAccessors
-
- self selectedClassOrMetaClass
- ifNotNil: [:aClass | aClass createInstVarAccessors].
- !
Item was removed:
- ----- Method: Browser>>decorateButtons (in category 'controls') -----
- decorateButtons
-
- super decorateButtons.
-
- self changed: #classCommentIndicated.
- self changed: #instanceMessagesIndicated.
- self changed: #classMessagesIndicated.!
Item was removed:
- ----- Method: Browser>>defaultBrowserTitle (in category 'initialize-release') -----
- defaultBrowserTitle
- | title |
- title := 'System Browser'.
- ^ self environment = self class environment
- ifTrue: [title]
- ifFalse: [title, ' on environment ', self environment asString]!
Item was removed:
- ----- Method: Browser>>defaultClassList (in category 'class list') -----
- defaultClassList
- "Answer an array of the class names of the selected category. Answer an
- empty array if no selection exists."
-
- ^ self hasSystemCategorySelected
- ifFalse: [Array new]
- ifTrue: [self selectedSystemCategory = SystemOrganizer allCategory
- ifTrue: [systemOrganizer allElements sort]
- ifFalse: [systemOrganizer listAtCategoryNamed: self selectedSystemCategory]]
- !
Item was removed:
- ----- Method: Browser>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.764 g: 0.9 b: 0.63)!
Item was removed:
- ----- Method: Browser>>defineClass:notifying: (in category 'class functions') -----
- 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.
-
- ((defTokens first = 'Trait' and: [defTokens second = 'named:'])
- or: [defTokens second = 'classTrait'])
- ifTrue: [^self defineTrait: defString notifying: aController].
-
- keywdIx := defTokens findFirst: [:x | x beginsWith: 'category'].
- envt := self selectedEnvironment.
- keywdIx := defTokens findFirst: [:x | '*subclass*' match: x].
- newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
- ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName])
- and: [envt includesKey: 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 := envt beCurrentDuring:
- [oldClass subclassDefinerClass
- evaluate: defString
- in: envt
- notifying: aController
- logged: false].
- (class isKindOf: Behavior)
- ifTrue: [self changed: #systemCategoryList; changed: #classList.
- self clearUserEditFlag; spawnOrNavigateTo: class.
- ^ true]
- ifFalse: [^ false]!
Item was removed:
- ----- Method: Browser>>defineMessageFrom:notifying: (in category 'message functions') -----
- defineMessageFrom: aString notifying: aController
- "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise."
- | currentSelector selector category oldMessageList selectedClassOrMetaClass |
- currentSelector := self selectedMessageName.
- oldMessageList := self messageList.
- selectedClassOrMetaClass := self selectedClassOrMetaClass.
- contents := nil.
- selector := (selectedClassOrMetaClass newParser parseSelector: aString).
- (self metaClassIndicated
- and: [(selectedClassOrMetaClass includesSelector: selector) not
- and: [Metaclass isScarySelector: selector]])
- ifTrue: ["A first-time definition overlaps the protocol of Metaclasses"
- (self confirm: ((selector , ' is used in the existing class system.
- Overriding it could cause serious problems.
- Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size))
- ifFalse: [^nil]].
- category := currentSelector
- ifNil: [ self selectedMessageCategoryName ]
- ifNotNil: [ (selectedClassOrMetaClass >> selectedMessageName) methodReference ifNotNil: [ : ref | ref category ]].
- selector := selectedClassOrMetaClass
- compile: aString
- classified: category
- notifying: aController.
- selector ifNil: [^ nil].
- contents := aString copy.
-
- self changed: #messageCategoryList. "Because the 'as yet unclassified' might just appear."
- self changed: #messageList. "Because we have code-dependent list formatting by now such as #isDeprecated."
-
- selector ~~ currentSelector
- ifTrue:
- [category = ClassOrganizer nullCategory
- ifTrue: [self changed: #classSelectionChanged.
- self changed: #classList.
- self messageCategoryListIndex: 1].
- self setClassOrganizer. "In case organization not cached"
- (oldMessageList includes: selector)
- ifFalse: [self changed: #messageList].
- self messageListIndex: (self messageList indexOf: selector)].
- ^ selector!
Item was removed:
- ----- Method: Browser>>defineTrait:notifying: (in category 'traits') -----
- defineTrait: defString notifying: aController
-
- | defTokens keywdIx envt oldTrait newTraitName trait |
- oldTrait := self selectedClassOrMetaClass.
- defTokens := defString findTokens: Character separators.
- keywdIx := defTokens findFirst: [:x | x = 'category'].
- envt := self selectedEnvironment.
- keywdIx := defTokens findFirst: [:x | x = 'named:'].
- newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'.
- ((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName])
- and: [envt includesKey: newTraitName asSymbol]) ifTrue:
- ["Attempting to define new class/trait over existing one when
- not looking at the original one in this browser..."
- (self confirm: ((newTraitName , ' is an existing class/trait in this system.
- Redefining it might cause serious problems.
- Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size))
- ifFalse: [^ false]].
-
- trait := envt beCurrentDuring:
- [Compiler evaluate: defString in: envt notifying: aController logged: true].
- ^(trait isTrait)
- ifTrue: [
- self changed: #classList.
- self classListIndex: (self classListIndexOf: trait baseTrait name).
- self clearUserEditFlag; editClass.
- true]
- ifFalse: [ false ]
- !
Item was removed:
- ----- Method: Browser>>didCodeChangeElsewhere (in category 'self-updating') -----
- didCodeChangeElsewhere
-
- super didCodeChangeElsewhere ifTrue:
- [^true].
- self classDefinitionIndicated ifFalse:
- [^false].
- ^self metaClassIndicated
- ifFalse:
- [classDefinition ~= (self selectedClass ifNotNil: [:selectedClass| selectedClass definition])]
- ifTrue:
- [metaClassDefinition ~= (self selectedClass ifNotNil: [:selectedClass| selectedClass theMetaClass definition])]!
Item was removed:
- ----- Method: Browser>>dragFromClassList: (in category 'drag and drop') -----
- dragFromClassList: index
- "Drag a class from the browser"
- | name envt |
- (name := self classList at: index) ifNil: [ ^ nil ].
- (envt := self selectedEnvironment) ifNil: [ ^ nil ].
- ^ envt
- at: name withBlanksTrimmed asSymbol
- ifAbsent: [ ]!
Item was removed:
- ----- Method: Browser>>dragFromMessageList: (in category 'drag and drop') -----
- dragFromMessageList: index
- "Drag a method from the browser"
-
- | selector |
- self flag: #refactor. "mt: Maybe use an approach similar to MessageSet class >> #parse:toClassAndSelector instead of #asString? There could be any fancy representation of a message in the message list."
- selector := Symbol lookup: (self messageList at: index) asString.
- selector ifNil: [^ self].
-
- ^self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent:[nil]!
Item was removed:
- ----- Method: Browser>>dragTypeForClassListAt: (in category 'drag and drop') -----
- dragTypeForClassListAt: index
-
- ^ #sourceCode!
Item was removed:
- ----- Method: Browser>>dragTypeForMessageListAt: (in category 'drag and drop') -----
- dragTypeForMessageListAt: index
-
- ^ #sourceCode!
Item was removed:
- ----- Method: Browser>>dropOnMessageCategories:at: (in category 'drag and drop') -----
- dropOnMessageCategories: method at: index
-
- | sourceClass destinationClass category copy |
- copy := Sensor shiftPressed.
- (method isKindOf: CompiledMethod)
- ifFalse:[^self inform: 'Can only drop methods'].
- sourceClass := method methodClass.
- destinationClass := self selectedClassOrMetaClass.
- sourceClass == destinationClass ifTrue:[
- category := self messageCategoryList at: index.
- category = ClassOrganizer allCategory ifTrue: [^false].
- destinationClass organization classify: method selector under: category suppressIfDefault: false logged: true.
- self changed: #messageCategoryList.
- self changed: #messageList.
- ^true ].
- (copy
- or: [ (destinationClass inheritsFrom: sourceClass)
- or: [ (sourceClass inheritsFrom: destinationClass)
- or: [ sourceClass theNonMetaClass == destinationClass theNonMetaClass ] ] ])
- ifFalse: [
- (self confirm: (
- 'Classes "{1}" and "{2}" are unrelated.{3}Are you sure you want to move this method?'
- translated format: { sourceClass. destinationClass. Character cr }))
- ifFalse: [ ^false ] ].
- destinationClass
- compile: method getSource
- classified: (self messageCategoryList at: index)
- withStamp: method timeStamp
- notifying: nil.
- copy ifFalse: [
- sourceClass removeSelector: method selector ].
- ^true!
Item was removed:
- ----- Method: Browser>>dropOnSystemCategories:at: (in category 'drag and drop') -----
- dropOnSystemCategories: aClass at: index
- | category |
- (aClass isBehavior) ifFalse:[^self inform: 'Can only drop classes'].
- category := self systemCategoryList at: index.
- self selectedEnvironment organization classify: aClass instanceSide name under: category.
- self changed: #systemCategoryList.
- self changed: #classList.
- ^true!
Item was removed:
- ----- Method: Browser>>editClass (in category 'class functions') -----
- editClass
- "Retrieve the description of the class definition."
-
- self hasClassSelected ifFalse: [^ self].
- self okToChange ifFalse: [^ self].
- self messageCategoryListIndex: 0.
- self editSelection: #editClass.
- self changed: #contents.
- self changed: #classCommentText.
- !
Item was removed:
- ----- Method: Browser>>editComment (in category 'class functions') -----
- editComment
- "Retrieve the description of the class comment."
-
- self hasClassSelected ifFalse: [^ 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
- !
Item was removed:
- ----- Method: Browser>>editMessageCategories (in category 'message category functions') -----
- editMessageCategories
- "Indicate to the receiver and its dependents that the message categories of
- the selected class have been changed."
-
- self okToChange ifFalse: [^ self].
- self hasClassSelected
- ifTrue:
- [self messageCategoryListIndex: 0.
- self editSelection: #editMessageCategories.
- self changed: #editMessageCategories.
- self contentsChanged]!
Item was removed:
- ----- Method: Browser>>editSelection (in category 'accessing') -----
- editSelection
- ^editSelection!
Item was removed:
- ----- Method: Browser>>editSelection: (in category 'accessing') -----
- editSelection: aSelection
- "Set the editSelection as requested."
-
- editSelection := aSelection.
- self changed: #editSelection.!
Item was removed:
- ----- Method: Browser>>editSystemCategories (in category 'system category functions') -----
- editSystemCategories
- "Retrieve the description of the class categories of the system organizer."
-
- self okToChange ifFalse: [^ self].
- self selectSystemCategory: nil.
- self editSelection: #editSystemCategories.
- self changed: #editSystemCategories.
- self contentsChanged!
Item was removed:
- ----- Method: Browser>>environment (in category 'accessing') -----
- environment
- ^ environment ifNil: [Environment default]!
Item was removed:
- ----- Method: Browser>>explainSpecial: (in category 'class functions') -----
- 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 anySatisfy: [:frag | frag = string] ]
- 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 anySatisfy: [:name | name = string] ]
- ifNone: [^nil].
- classes := classes printString.
- ^'"is an instance variable in class ' , classes , '."
- ' , classes , ' browseAllAccessesTo: ''' , string , '''.'].
- editSelection == #editSystemCategories ifTrue: [^nil].
- editSelection == #editMessageCategories ifTrue: [^nil].
- ^nil!
Item was removed:
- ----- Method: Browser>>fileOutClass (in category 'class functions') -----
- fileOutClass
- "Print a description of the selected class onto a file whose name is the
- category name followed by .st."
-
- Cursor write showWhile:
- [self hasClassSelected ifTrue: [self selectedClass fileOut]]!
Item was removed:
- ----- Method: Browser>>fileOutMessageCategories (in category 'message category functions') -----
- fileOutMessageCategories
- "Print a description of the selected message category of the selected class
- onto an external file."
-
- Cursor write showWhile:
- [self hasMessageCategorySelected
- ifTrue:
- [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]!
Item was removed:
- ----- Method: Browser>>fileOutSystemCategory (in category 'system category functions') -----
- fileOutSystemCategory
- "Print a description of each class in the selected category onto a file
- whose name is the category name followed by .st."
-
- self hasSystemCategorySelected
- ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategory]!
Item was removed:
- ----- Method: Browser>>findClass (in category 'system category functions') -----
- findClass
- "Search for a class by name."
-
- | foundClass |
- (self multiWindowState notNil
- or: [self okToChange]) ifFalse:
- [^self classNotFound].
- foundClass := Project uiManager chooseClassOrTraitFrom: self environment withRecentList: self recentClassListFormatted.
- foundClass ifNil: [^self classNotFound].
- (self selectedClass notNil
- and: [self multiWindowState notNil
- "Can only support multi-window if original window has all the right panes."
- and: [self multiWindowState prototype isHierarchy not]]) ifTrue:
- [(self classList includes: foundClass name)
- ifTrue: [self multiWindowState copyWindow]
- ifFalse: [self multiWindowState addNewWindow]].
- self selectCategoryForClass: foundClass.
- self selectClass: foundClass!
Item was removed:
- ----- Method: Browser>>findMethod (in category 'class functions') -----
- 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 sorted.
- selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self].
- reply := UIManager default
- chooseFrom: selectors
- values: selectors
- lines: #(1).
- reply ifNil: [^ self].
- cat := aClass whichCategoryIncludesSelector: reply.
- messageCatIndex := self messageCategoryList indexOf: cat.
- self messageCategoryListIndex: messageCatIndex.
- messageIndex := (self messageList indexOf: reply).
- self messageListIndex: messageIndex!
Item was removed:
- ----- Method: Browser>>flattenHierarchyTree:on:indent: (in category 'class list') -----
- flattenHierarchyTree: classHierarchy on: col indent: indent
- ^ self
- flattenHierarchyTree: classHierarchy
- on: col
- indent: indent
- by: ' '.!
Item was removed:
- ----- Method: Browser>>flattenHierarchyTree:on:indent:by: (in category 'class list') -----
- flattenHierarchyTree: classHierarchy on: col indent: indent by: indentChars
- ^ self
- flattenHierarchyTree: classHierarchy
- on: col
- indent: indent
- by: indentChars
- format: [:class | class name]!
Item was removed:
- ----- Method: Browser>>flattenHierarchyTree:on:indent:by:format: (in category 'class list') -----
- flattenHierarchyTree: classHierarchy on: col indent: indent by: indentChars format: formatBlock
- "Recursively add to col the names in classHierarchy indenting to show the hierarchical relationship. Use indentChars to do the indenting: spaces, tabs, etc."
- | plusIndent |
- plusIndent := indentChars.
- classHierarchy do: [:assoc |
- | class childs label |
- class := assoc key.
- label := formatBlock value: class.
- label isText
- ifTrue: [col add: (Text string: indent attributes: (label attributesAt: 1)), label]
- ifFalse: [col add: indent, label].
- childs := assoc value.
- self
- flattenHierarchyTree: childs
- on: col
- indent: indent , plusIndent
- by: indentChars
- format: formatBlock].
- ^ col!
Item was removed:
- ----- Method: Browser>>frameOffsetFromTop:fromLeft:width:bottomFraction: (in category 'initialize-release') -----
- frameOffsetFromTop: height fromLeft: leftFraction width: rightFraction bottomFraction: bottomFraction
- ^LayoutFrame new
- topFraction: 0 offset: height;
- leftFraction: leftFraction offset: 0;
- rightFraction: (leftFraction + rightFraction) offset: 0;
- bottomFraction: bottomFraction offset: 0;
- yourself.!
Item was removed:
- ----- Method: Browser>>hasClassSelected (in category 'class list') -----
- hasClassSelected
- ^ selectedClassName notNil and: [(self environment classNamed: selectedClassName) notNil]!
Item was removed:
- ----- Method: Browser>>hasMessageCategorySelected (in category 'message category list') -----
- hasMessageCategorySelected
- ^ self selectedMessageCategoryName notNil.!
Item was removed:
- ----- Method: Browser>>hasMessageSelected (in category 'message list') -----
- hasMessageSelected
- ^ self selectedMessageName notNil.!
Item was removed:
- ----- Method: Browser>>hasSystemCategorySelected (in category 'system category list') -----
- hasSystemCategorySelected
- ^ self selectedSystemCategory notNil.!
Item was removed:
- ----- Method: Browser>>hierarchicalClassList (in category 'class list') -----
- hierarchicalClassList
-
- "classNames are an arbitrary collection of classNames of the system.
- Reorder those class names so that they are sorted and indended by inheritance"
- | classes |
- "Creating the hierarchy is *really slow* for the full class list. Skip it for now."
- self selectedSystemCategory = SystemOrganizer allCategory
- ifTrue: [^ self defaultClassList].
-
- classes := self defaultClassList collect: [:sym | self environment classNamed: sym].
- ^ self
- flattenHierarchyTree: (self createHierarchyTreeOf: classes)
- on: OrderedCollection new
- indent: ''.!
Item was removed:
- ----- Method: Browser>>hierarchy (in category 'class functions') -----
- hierarchy
- "Display the inheritance hierarchy of the receiver's selected class."
-
- self hasClassSelected ifFalse: [^ self].
- self okToChange ifFalse: [^ self].
- self messageCategoryListIndex: 0.
- self editSelection: #hierarchy.
- self changed: #editComment.
- self contentsChanged.
- ^ self!
Item was removed:
- ----- Method: Browser>>highlightMessageList:with: (in category 'message category functions') -----
- 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)]]!
Item was removed:
- ----- Method: Browser>>indexIsOne (in category 'system category list') -----
- indexIsOne
- "When used as a singleton list, index is always one"
- ^ 1!
Item was removed:
- ----- Method: Browser>>indexIsOne: (in category 'system category list') -----
- indexIsOne: value
- "When used as a singleton list, can't change it"
-
- ^ self!
Item was removed:
- ----- Method: Browser>>indicateClassMessages (in category 'metaclass') -----
- indicateClassMessages
- "Indicate that the message selection should come from the metaclass
- messages."
-
- self okToChange ifTrue: [
- self metaClassIndicated: true]!
Item was removed:
- ----- Method: Browser>>indicateInstanceMessages (in category 'metaclass') -----
- indicateInstanceMessages
- "Indicate that the message selection should come from the class (instance)
- messages."
-
- self okToChange ifTrue: [
- self metaClassIndicated: false]!
Item was removed:
- ----- Method: Browser>>informUnknownPackage (in category 'system category functions') -----
- informUnknownPackage
-
- self inform: ('The category <b>{1}</b> does not belong to a known package.' translated format: {self selectedSystemCategory}) asTextFromHtml.!
Item was removed:
- ----- Method: Browser>>inspectInstances (in category 'message functions') -----
- inspectInstances
- "Inspect all instances of the selected class. 1/26/96 sw"
-
- | myClass |
- ((myClass := self selectedClassOrMetaClass) isNil or: [myClass isTrait])
- ifFalse: [myClass theNonMetaClass inspectAllInstances]
- !
Item was removed:
- ----- Method: Browser>>inspectSubInstances (in category 'message functions') -----
- inspectSubInstances
- "Inspect all instances of the selected class and all its subclasses 1/26/96 sw"
-
- | aClass |
- ((aClass := self selectedClassOrMetaClass) isNil or: [aClass isTrait])
- ifFalse: [
- aClass := aClass theNonMetaClass.
- aClass inspectSubInstances].
- !
Item was removed:
- ----- Method: Browser>>instanceMessagesIndicated (in category 'metaclass') -----
- instanceMessagesIndicated
- "Answer whether the messages to be presented should come from the
- class."
-
- ^metaClassIndicated not and: [self classCommentIndicated not]!
Item was removed:
- ----- Method: Browser>>isHierarchy (in category 'multi-window support') -----
- isHierarchy
- ^false!
Item was removed:
- ----- Method: Browser>>isPackage (in category 'multi-window support') -----
- isPackage
- ^false!
Item was removed:
- ----- Method: Browser>>labelString (in category 'initialize-release') -----
- labelString
- | label |
- label := self selectedClassName
- ifNil: [ self defaultBrowserTitle ]
- ifNotNil: [ self defaultBrowserTitle, ': ', self selectedClassName asString ].
- (self multiWindowState notNil
- and: [self multiWindowState models size > 1]) ifTrue:
- [label := (self multiWindowState models indexOf: self) printString, '. ', label].
- ^label!
Item was removed:
- ----- Method: Browser>>lastMessageName (in category 'message list') -----
- lastMessageName
- ^ self messageList last.!
Item was removed:
- ----- Method: Browser>>mainMessageCategoryMenu: (in category 'message category functions') -----
- mainMessageCategoryMenu: aMenu
- <messageCategoryMenu>
- ^ aMenu addList: #(
- ('browse' buildMessageCategoryBrowser)
- ('print out' printOutMessageCategories)
- ('file out' fileOutMessageCategories)
- -
- ('reorganize' editMessageCategories)
- ('alphabetize' alphabetizeMessageCategories)
- ('remove empty categories' removeEmptyCategories)
- ('categorize all uncategorized' categorizeAllUncategorizedMethods)
- ('new category...' addCategory)
- -
- ('rename...' renameCategory)
- ('remove (x)' removeMessageCategory));
- yourself
- !
Item was removed:
- ----- Method: Browser>>mainMessageListMenu: (in category 'message functions') -----
- mainMessageListMenu: aMenu
- <messageListMenuShifted: false>
-
- ^ aMenu
- addTranslatedList: #(
- ('what to show...' offerWhatToShowMenu));
- add: (self isBreakOnEntry ifTrue: ['<on>'] ifFalse: ['<off>']) , 'break on entry' translated
- action: #toggleBreakOnEntry;
- addTranslatedList: #(
- -
- ('browse full (b)' browseMethodFull)
- ('browse hierarchy (h)' browseClassHierarchy)
- ('browse protocol (p)' browseFullProtocol)
- -
- ('fileOut' fileOutMessage)
- ('printOut' printOutMessage)
- ('copy selector (c)' copySelector)
- ('copy reference (C)' copyReference)
- -
- ('senders of... (n)' browseSendersOfMessages)
- ('implementors of... (m)' browseMessages)
- ('inheritance (i)' methodHierarchy)
- ('versions (v)' browseVersions)
- -
- ('references... (r)' browseVariableReferences)
- ('assignments... (a)' browseVariableAssignments)
- ('class refs (N)' browseClassRefs)
- -
- ('remove method (x)' removeMessage)
- ('explore method' exploreMethod)
- ('inspect method' inspectMethod));
- yourself!
Item was removed:
- ----- Method: Browser>>mainPackageMenu: (in category 'system category functions') -----
- mainPackageMenu: aMenu
- <packageMenu>
-
- self selectedPackage ifNil: [
- ^ aMenu
- add: '(No package found.)' translated action: #yourself;
- yourself].
-
- aMenu addList: #(
- ('browse package' browsePackage)
- #-
- ('extensions' browsePackageExtensions)).
-
- aMenu
- add: 'extensions local to ''', self selectedSystemCategory, ''''
- action: #browsePackageExtensionsLocalTo.
-
- aMenu addList: #(
- #-
- ('dependencies' browsePackageDependencies)
- ('inverted dependencies' browsePackageDependenciesInverted)).
-
- ^ aMenu!
Item was removed:
- ----- Method: Browser>>mainSystemCategoryMenu: (in category 'system category functions') -----
- mainSystemCategoryMenu: aMenu
- <systemCategoryMenu>
- aMenu addTranslatedList: #(
- ('find class... (f)' findClass)
- ('back... (b)' recent)
- -
- ('browse all' browseAllClasses)
- ('browse' buildSystemCategoryBrowser)).
-
- (Smalltalk isMorphic and: [self selectedPackage notNil]) ifTrue: [
- aMenu
- add: ('browse package ''{1}''' translated format: {self selectedPackage name})
- subMenu: (self packageMenu: ((Smalltalk isMorphic
- ifTrue: [MenuMorph new defaultTarget: self; yourself]
- ifFalse: [CustomMenu new])
- yourself))
- target: self
- selector: #yourself
- argumentList: #()].
-
- aMenu addTranslatedList: #(
- -
- ('printOut' printOutSystemCategory)
- ('fileOut' fileOutSystemCategory)
- -
- ('reorganize' editSystemCategories)
- ('alphabetize' alphabetizeSystemCategories)
- -
- ('update' updateSystemCategories)
- ('add item...' addSystemCategory)
- ('rename...' renameSystemCategory)
- ('remove (x)' removeSystemCategory)).
- ^ aMenu!
Item was removed:
- ----- Method: Browser>>makeNewSubclass (in category 'class functions') -----
- makeNewSubclass
-
- self selectedClassOrMetaClass ifNil: [^ self].
- self okToChange ifFalse: [^ self].
- self editSelection: #newClass.
- self contentsChanged.
- "Force the text view to assume there are changes"
- self changed: #editString with: self contents!
Item was removed:
- ----- Method: Browser>>messageCatListSingleton (in category 'message category list') -----
- messageCatListSingleton
-
- | name |
- name := self selectedMessageCategoryName.
- ^ name ifNil: [Array new]
- ifNotNil: [Array with: name]!
Item was removed:
- ----- Method: Browser>>messageCategoryList (in category 'message category list') -----
- messageCategoryList
- "Answer the selected category of messages."
-
- ^ self hasClassSelected
- ifFalse: [Array new]
- ifTrue: [ {ClassOrganizer allCategory},
- (self class sortMessageCategoriesAlphabetically
- ifTrue: [self rawMessageCategoryList sorted]
- ifFalse: [self rawMessageCategoryList]) ]!
Item was removed:
- ----- Method: Browser>>messageCategoryListIndex (in category 'message category list') -----
- messageCategoryListIndex
- "Answer the index of the selected message category."
-
- ^self messageCategoryList indexOf: selectedMessageCategoryName!
Item was removed:
- ----- Method: Browser>>messageCategoryListIndex: (in category 'message category list') -----
- messageCategoryListIndex: anInteger
- "Set the selected message category to be the one indexed by anInteger."
-
- selectedMessageCategoryName := nil.
- self selectMessageCategoryNamed: (self messageCategoryList at: anInteger ifAbsent: [nil]).!
Item was removed:
- ----- Method: Browser>>messageCategoryListKey:from: (in category 'message category list') -----
- messageCategoryListKey: aCharacter from: view
-
- aCharacter == $x ifTrue: [ ^self removeMessageCategory ].
- ^self arrowKey: aCharacter from: view
- !
Item was removed:
- ----- Method: Browser>>messageCategoryListSelection (in category 'message category list') -----
- messageCategoryListSelection
- "Return the selected category name or nil."
-
- ^ ((self messageCategoryList size = 0
- or: [self messageCategoryListIndex = 0])
- or: [self messageCategoryList size < self messageCategoryListIndex])
- ifTrue: [nil]
- ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]!
Item was removed:
- ----- Method: Browser>>messageCategoryMenu: (in category 'message category functions') -----
- messageCategoryMenu: aMenu
- ^ self menu: aMenu for: #(messageCategoryMenu messageCategoryMenuShifted:)
- !
Item was removed:
- ----- Method: Browser>>messageCategoryMenuHook:shifted: (in category 'pluggable menus - hooks') -----
- messageCategoryMenuHook: aMenu shifted: aBoolean
- <messageCategoryMenu>
- <menuPriority: 400>
- ^ self menuHook: aMenu named: #messageCategoryMenu shifted: aBoolean.
- !
Item was removed:
- ----- Method: Browser>>messageHelpAt: (in category 'message list') -----
- messageHelpAt: anIndex
- "Show the first n lines of the sources code of the selected message."
-
- | iconHelp selector method |
- Preferences balloonHelpInMessageLists ifFalse: [^ nil].
- self messageList size < anIndex ifTrue: [^ nil].
-
- "Items in the message list can be formatted texts."
- self flag: #refactor.
- selector := Symbol lookup: (self messageList at: anIndex) asString.
- selector ifNil: [^ nil].
-
- method := self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: [^ nil].
- iconHelp := (self messageIconHelpFor: method selector) ifNotEmpty: [:t |
- t , Character cr, Character cr].
-
- ^ iconHelp asText
- append: (self messageHelpForMethod: method);
- yourself!
Item was removed:
- ----- Method: Browser>>messageIconAt: (in category 'message list') -----
- messageIconAt: anIndex
-
- | selector |
- self class showMessageIcons ifFalse: [^ nil].
-
- self flag: #refactor.
- selector := Symbol lookup: (self messageList at: anIndex ifAbsent: [^nil]) asString.
- selector ifNil: [^ nil].
-
- ^ self messageIconFor: selector!
Item was removed:
- ----- Method: Browser>>messageIconFor: (in category 'message list') -----
- messageIconFor: aSelector
-
- self class showMessageIcons ifFalse: [^ nil].
-
- ^ ToolIcons iconNamed: (ToolIcons
- iconForClass: self selectedClassOrMetaClass
- selector: aSelector)!
Item was removed:
- ----- Method: Browser>>messageIconHelpFor: (in category 'message list') -----
- messageIconHelpFor: aSelector
-
- self class showMessageIcons ifFalse: [^ String empty].
-
- ^ ToolIconHelp iconHelpNamed: (ToolIcons
- iconForClass: self selectedClassOrMetaClass
- selector: aSelector)!
Item was removed:
- ----- Method: Browser>>messageList (in category 'message list') -----
- messageList
- "Answer an Array of the message selectors of the currently selected message category. If no category is selected or the '-- all --' category is selected, return all method selectors. Make deprecated messages look gray and struck-out."
-
-
- ^ (self selectedMessageCategoryName isNil or: [self selectedMessageCategoryName = ClassOrganizer allCategory])
- ifTrue: [
- self classOrMetaClassOrganizer
- ifNil: [Array new]
- ifNotNil: [:organizer | organizer allMethodSelectors collect: [:ea |
- self formattedLabel: ea]]]
- ifFalse: [
- (self classOrMetaClassOrganizer listAtCategoryNamed: self selectedMessageCategoryName)
- collect: [:ea | self formattedLabel: ea]]!
Item was removed:
- ----- Method: Browser>>messageListIndex (in category 'message list') -----
- messageListIndex
- "Answer the index of the selected message selector into the currently
- selected message category."
-
- ^ self messageListIndexOf: self selectedMessageName!
Item was removed:
- ----- Method: Browser>>messageListIndex: (in category 'message list') -----
- messageListIndex: anInteger
- "Set the selected message selector to be the one indexed by anInteger."
-
- self selectMessageNamed: (self messageList at: anInteger ifPresent: [:lbl | lbl asString] ifAbsent: [nil] )!
Item was removed:
- ----- Method: Browser>>messageListIndexOf: (in category 'message list') -----
- messageListIndexOf: aString
- ^ self messageList indexOf: aString.!
Item was removed:
- ----- Method: Browser>>messageListMenu:shifted: (in category 'message list') -----
- messageListMenu: aMenu shifted: shifted
- "Answer the message-list menu"
- ^ self menu: aMenu for: #(messageListMenu messageListMenuShifted:) shifted: shifted
- !
Item was removed:
- ----- Method: Browser>>messageListMenuHook:shifted: (in category 'pluggable menus - hooks') -----
- messageListMenuHook: aMenu shifted: aBoolean
- <messageListMenu>
- <menuPriority: 400>
- ^ self menuHook: aMenu named: #messageListMenu shifted: aBoolean.
- !
Item was removed:
- ----- Method: Browser>>metaClassIndicated (in category 'metaclass') -----
- metaClassIndicated
- "Answer the boolean flag that indicates which of the method dictionaries,
- class or metaclass."
-
- ^ metaClassIndicated!
Item was removed:
- ----- Method: Browser>>metaClassIndicated: (in category 'metaclass') -----
- metaClassIndicated: trueOrFalse
- "Indicate whether browsing instance or class messages."
-
- metaClassIndicated := trueOrFalse.
- self setClassOrganizer.
- self hasSystemCategorySelected ifTrue:
- [self editSelection: (self hasClassSelected
- ifFalse: [metaClassIndicated
- ifTrue: [#none]
- ifFalse: [#newClass]]
- ifTrue: [#editClass])].
- selectedMessageCategoryName := nil.
- selectedMessageName := nil.
- contents := nil.
- self changed: #classSelectionChanged.
- self changed: #messageCategoryList.
- self changed: #messageList.
- self changed: #contents.
- self changed: #annotation.
- self decorateButtons
- !
Item was removed:
- ----- Method: Browser>>methodCategoryChanged (in category 'initialize-release') -----
- methodCategoryChanged
- self changed: #messageCategoryList.
- self changed: #messageList.
- self changed: #annotation.
- self messageListIndex: 0!
Item was removed:
- ----- Method: Browser>>multiWindowName (in category 'multi-window support') -----
- multiWindowName
- "Answer the string to display for the receiver in a multi-window."
- ^String streamContents:
- [:s| | str |
- self selectedClass
- ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle]
- ifNotNil:
- [s print: self selectedClass.
- self metaClassIndicated ifTrue:
- [s nextPutAll: ' class'].
- self isHierarchy ifTrue:
- [s space; nextPutAll: ' Hierarchy']].
- (str := self selectedMessageName) notNil
- ifTrue: [s nextPutAll: '>>'; nextPutAll: str]
- ifFalse:
- [(str := self selectedMessageCategoryName) notNil
- ifTrue: [s space; nextPut: ${; nextPutAll: str; nextPut: $}]]]!
Item was removed:
- ----- Method: Browser>>multiWindowNameForState: (in category 'multi-window support') -----
- multiWindowNameForState: savedStateMessage
- "Answer the string to display for the receiver in a multi-window."
- | getarg |
- getarg := [:keyword| savedStateMessage arguments at: (savedStateMessage selector keywords indexOf: keyword)].
- ^String streamContents:
- [:s|
- (getarg value: 'className:')
- ifNil: [(getarg value: 'restoreToCategory:')
- ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle]
- ifNotNil: [:categoryName| s nextPutAll: categoryName]]
- ifNotNil:
- [:className|
- s nextPutAll: className.
- (getarg value: 'meta:') ifTrue:
- [s nextPutAll: ' class'].
- self isHierarchy ifTrue:
- [s space; nextPutAll: ' Hierarchy'].
- (getarg value: 'selector:')
- ifNil: [(getarg value: 'protocol:') ifNotNil:
- [:protocol| s space; nextPut: ${; nextPutAll: protocol; nextPut: $}]]
- ifNotNil: [:selector| s nextPutAll: '>>'; nextPutAll: selector]]]!
Item was removed:
- ----- Method: Browser>>newClass (in category 'traits') -----
- newClass
- (self selectedClassOrMetaClass notNil and:
- [self selectedClassOrMetaClass isTrait]) ifTrue: [self classListIndex: 0].
- self editClass.
- editSelection := #newClass.
- self contentsChanged!
Item was removed:
- ----- Method: Browser>>newClassContents (in category 'accessing') -----
- newClassContents
- | theClassName |
- ^ (theClassName := self selectedClassName)
- ifNil:
- [Class template: self selectedSystemCategory]
- ifNotNil:
- [Class templateForSubclassOf: theClassName asString category: self selectedSystemCategory]!
Item was removed:
- ----- Method: Browser>>newTrait (in category 'traits') -----
- newTrait
- self classListIndex: 0.
- self editClass.
- editSelection := #newTrait.
- self contentsChanged!
Item was removed:
- ----- Method: Browser>>noCommentNagString (in category 'class comment pane') -----
- noCommentNagString
-
- ^ Text
- string: 'THIS CLASS HAS NO COMMENT!!' translated
- attribute: (TextColor color: (self userInterfaceTheme noClassCommentColor ifNil: [Color red]))!
Item was removed:
- ----- Method: Browser>>noteSelectionIndex:for: (in category 'accessing') -----
- noteSelectionIndex: anInteger for: aSymbol
- aSymbol == #systemCategoryList
- ifTrue:
- [self systemCategoryListIndex: anInteger].
- aSymbol == #classList
- ifTrue:
- [self classListIndex: anInteger].
- aSymbol == #messageCategoryList
- ifTrue:
- [self messageCategoryListIndex: anInteger].
- aSymbol == #messageList
- ifTrue:
- [self messageListIndex: anInteger].!
Item was removed:
- ----- Method: Browser>>okToClose (in category 'multi-window support') -----
- okToClose
- ^super okToClose
- and: [self multiWindowState isNil or: [self multiWindowState okToClose]]!
Item was removed:
- ----- Method: Browser>>packageMenu: (in category 'system category functions') -----
- packageMenu: aMenu
- ^ self menu: aMenu for: #(packageMenu packageMenuShifted:)
- !
Item was removed:
- ----- Method: Browser>>plusButtonHit (in category 'class functions') -----
- plusButtonHit
- "Cycle among definition, comment, and hierachy"
-
- editSelection == #editComment ifTrue: [
- self hierarchy.
- self decorateButtons.
- ^ self].
-
- editSelection == #hierarchy ifTrue: [
- self editSelection: #editClass.
- (self hasClassSelected and: [self okToChange]) ifTrue: [
- self changed: #editComment.
- self contentsChanged].
- self decorateButtons.
- ^ self].
-
- self editComment.
- self decorateButtons.!
Item was removed:
- ----- Method: Browser>>printOutClass (in category 'class functions') -----
- printOutClass
- "Print a description of the selected class onto a file whose name is the
- category name followed by .html."
-
- Cursor write showWhile:
- [self hasClassSelected ifTrue: [self selectedClass fileOutAsHtml: true]]!
Item was removed:
- ----- Method: Browser>>printOutMessageCategories (in category 'message category functions') -----
- printOutMessageCategories
- "Print a description of the selected message category of the selected class
- onto an external file in Html format."
-
- Cursor write showWhile:
- [self hasMessageCategorySelected
- ifTrue:
- [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName
- asHtml: true]]!
Item was removed:
- ----- Method: Browser>>printOutSystemCategory (in category 'system category functions') -----
- printOutSystemCategory
- "Print a description of each class in the selected category as Html."
-
- Cursor write showWhile:
- [self hasSystemCategorySelected
- ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategory
- asHtml: true ]]
- !
Item was removed:
- ----- Method: Browser>>rawMessageCategoryList (in category 'message category list') -----
- rawMessageCategoryList
- ^ self hasClassSelected
- ifTrue: [self classOrMetaClassOrganizer categories]
- ifFalse: [Array new]!
Item was removed:
- ----- Method: Browser>>recategorizeMethodSelector: (in category 'message category list') -----
- recategorizeMethodSelector: sel
- "Categorize method named sel by looking in parent classes for a
- method category.
- Answer true if recategorized."
- self selectedClassOrMetaClass allSuperclasses
- do: [:ea |
- | thisCat |
- thisCat := ea organization categoryOfElement: sel.
- (thisCat ~= ClassOrganizer default
- and: [thisCat notNil])
- ifTrue: [self classOrMetaClassOrganizer classify: sel under: thisCat logged: true.
- self changed: #messageCategoryList.
- ^ true]].
- ^ false!
Item was removed:
- ----- Method: Browser>>recent (in category 'class list') -----
- recent
- "Let the user select from a list of recently visited classes"
-
- | className class recentList |
- recentList := self recentClassList.
- recentList size = 0 ifTrue: [^ Beeper beep].
- className := UIManager default chooseFrom: recentList values: recentList.
- className == nil ifTrue: [^ self].
-
- self okToChange ifFalse: [^ self].
-
- class := Smalltalk at: className.
- self selectCategoryForClass: class.
- self classListIndex: (self classListIndexOf: class name)!
Item was removed:
- ----- Method: Browser>>recentClassList (in category 'class list') -----
- recentClassList
-
- ^ RecentClasses
- select: [:className | className ~= self selectedClassName and: [Smalltalk hasClassNamed: className]]!
Item was removed:
- ----- Method: Browser>>recentClassListFormatted (in category 'class list') -----
- recentClassListFormatted
-
- ^ self recentClassList collect: [:className |
- className asText
- addAttribute: TextEmphasis italic;
- yourself]!
Item was removed:
- ----- Method: Browser>>reformulateList (in category 'message list') -----
- reformulateList
- "If the receiver has a way of reformulating its message list, here is a chance for it to do so"
- super reformulateList.
- (self messageList includes: self selectedMessageName)
- ifFalse: [ self messageList
- ifEmpty: [ self selectMessageNamed: nil ]
- ifNotEmpty: [ self selectMessageNamed: self lastMessageName ]].!
Item was removed:
- ----- Method: Browser>>removeClass (in category 'class functions') -----
- removeClass
- "Overwritten to update the class list."
-
- self hasClassSelected ifFalse: [^ false].
- super removeClass ifFalse: [^ false].
-
- self classListIndex: 0.
- self changed: #classList.
-
- ^ true!
Item was removed:
- ----- Method: Browser>>removeEmptyCategories (in category 'message category functions') -----
- removeEmptyCategories
- self okToChange ifFalse: [^ self].
- self selectedClassOrMetaClass organization removeEmptyCategories.
- self changed: #messageCategoryList
- !
Item was removed:
- ----- Method: Browser>>removeMessage (in category 'message functions') -----
- removeMessage
- "Overwritten to update the message list."
-
- self hasMessageSelected ifFalse: [^ false].
- super removeMessage ifFalse: [^ false].
-
- self selectMessageNamed: nil.
- self changed: #messageList.
-
- self setClassOrganizer. "In case organization not cached"
-
- ^ true!
Item was removed:
- ----- Method: Browser>>removeMessageCategory (in category 'message category functions') -----
- removeMessageCategory
- "Overwritten to update the message category list."
-
- self hasMessageCategorySelected ifFalse: [^ false].
- super removeMessageCategory ifFalse: [^ false].
-
- self selectMessageCategoryNamed: nil.
- self changed: #classSelectionChanged. "mt: Obsolete?"
- self changed: #messageCategoryList.
-
- ^ true!
Item was removed:
- ----- Method: Browser>>removeMessageFromBrowser (in category 'message functions') -----
- removeMessageFromBrowser
- "Our list speaks the truth and can't have arbitrary things removed"
-
- ^ self changed: #flash!
Item was removed:
- ----- Method: Browser>>removeSystemCategory (in category 'system category functions') -----
- removeSystemCategory
- "Overwritten to update system category list."
-
- | nextSelectedCategory |
- self hasSystemCategorySelected ifFalse: [^ false].
-
- nextSelectedCategory := self systemCategoryList after: self selectedSystemCategory ifAbsent: [nil].
- super removeSystemCategory ifFalse: [^ false].
-
- self changed: #systemCategoryList.
- self selectSystemCategory: nextSelectedCategory.
-
- ^ true!
Item was removed:
- ----- Method: Browser>>renameCategory (in category 'message category functions') -----
- renameCategory
- "Prompt for a new category name and add it before the
- current selection, or at the end if no current selection"
- | oldName newName |
- self hasClassSelected ifFalse: [^ self].
- self okToChange ifFalse: [^ self].
- self hasMessageCategorySelected ifFalse: [^ 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 selectClassNamed: selectedClassName.
- self selectMessageCategoryNamed: newName.
- self changed: #messageCategoryList.
- !
Item was removed:
- ----- Method: Browser>>renameClass (in category 'class functions') -----
- renameClass
- | oldName newName obs oldBinding |
- self hasClassSelected ifFalse: [^ 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].
- (self selectedClass environment includesKey: newName)
- ifTrue: [^ self error: newName , ' already exists'].
- oldBinding := self selectedClass environment declarationOf: oldName.
- [self selectedClass rename: newName]
- on: RemarkNotification
- do: [:ex | self inform: ex messageText. ex resume].
- selectedClassName := newName.
- self changed: #classList.
- obs := self systemNavigation allCallsOn: oldBinding.
- obs isEmpty
- ifFalse: [self systemNavigation
- browseMessageList: obs
- name: 'Obsolete References to ' , oldName
- autoSelect: oldName].
- self selectClassNamed: newName.!
Item was removed:
- ----- Method: Browser>>renameSystemCategory (in category 'system category functions') -----
- renameSystemCategory
- "Prompt for a new category name and add it before the
- current selection, or at the end if no current selection"
- | oldSelection newName |
- oldSelection := self selectedSystemCategory.
- oldSelection isNil
- ifTrue: [^ self]. "no selection"
- self okToChange ifFalse: [^ self].
-
- newName := self
- request: 'Please type new category name'
- initialAnswer: oldSelection.
- newName isEmpty
- ifTrue: [^ self]
- ifFalse: [newName := newName asSymbol].
- oldSelection = newName ifTrue: [^ self].
- systemOrganizer
- renameCategory: oldSelection
- toBe: newName.
- self selectSystemCategory: newName.
- self changed: #systemCategoryList.!
Item was removed:
- ----- Method: Browser>>representsSameBrowseeAs: (in category 'morphic ui') -----
- representsSameBrowseeAs: anotherBrowser
-
- ^ self hasUnacceptedEdits not
- and: [self selectedClass == anotherBrowser selectedClass]
- and: [anotherBrowser selectedMessageName isNil
- or: [anotherBrowser selectedMessageName = self selectedMessageName]]!
Item was removed:
- ----- Method: Browser>>request:initialAnswer: (in category 'accessing') -----
- request: prompt initialAnswer: initialAnswer
-
- ^ UIManager default
- request: prompt
- initialAnswer: initialAnswer
- !
Item was removed:
- ----- Method: Browser>>restoreMultiWindowState: (in category 'multi-window support') -----
- restoreMultiWindowState: aMessage
- "Restore the state after a multi-window switch.."
- aMessage sentTo: self!
Item was removed:
- ----- Method: Browser>>restoreToCategory:className:protocol:selector:mode:meta: (in category 'multi-window support') -----
- restoreToCategory: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool
- selectedSystemCategory := nil. "forces recomputation in selectSystemCategory:"
- self selectSystemCategory: category.
- self selectClassNamed: className.
- self metaClassIndicated: metaBool.
- self selectMessageCategoryNamed: protocol.
- self selectMessageNamed: selector.
- editSelection := editMode.
- self
- contentsChanged;
- decorateButtons!
Item was removed:
- ----- Method: Browser>>saveMultiWindowState (in category 'multi-window support') -----
- saveMultiWindowState
- ^Message
- selector: #restoreToCategory:className:protocol:selector:mode:meta:
- arguments: { self selectedSystemCategory.
- self selectedClassName.
- self selectedMessageCategoryName.
- self selectedMessageName.
- self editSelection.
- self metaClassIndicated }!
Item was removed:
- ----- Method: Browser>>selectCategoryForClass: (in category 'system category list') -----
- selectCategoryForClass: theClass
- self selectSystemCategory: theClass category.!
Item was removed:
- ----- Method: Browser>>selectClass: (in category 'class list') -----
- selectClass: classNotMeta
- ^ self selectClassNamed:
- (classNotMeta
- ifNil: [ nil ]
- ifNotNil: [ classNotMeta name ]).!
Item was removed:
- ----- Method: Browser>>selectClassNamed: (in category 'class list') -----
- selectClassNamed: aSymbolOrString
- | className currentMessageCategoryName currentMessageName |
-
- currentMessageCategoryName := [self selectedMessageCategoryName]
- on: Error
- do: [:ex| ex return: nil].
- currentMessageName := [self selectedMessageName]
- on: Error
- do: [:ex| ex return: nil].
-
- selectedClassName := aSymbolOrString ifNotNil: [ aSymbolOrString asSymbol ].
- self setClassOrganizer.
- self setClassDefinition.
-
- "Try to reselect the category and/or selector if the new class has them."
- selectedMessageCategoryName :=(self messageCategoryList includes: currentMessageCategoryName)
- ifTrue: [currentMessageCategoryName]
- ifFalse: [nil].
- selectedMessageName := (self messageList includes: currentMessageName)
- ifTrue: [currentMessageName]
- ifFalse: [nil].
-
- self hasMessageSelected ifTrue:
- [self editSelection: #editMessage] ifFalse:
- [self hasMessageCategorySelected ifTrue:
- [self editSelection: #newMessage] ifFalse:
- [self classCommentIndicated
- ifTrue: [self editSelection: #editComment]
- ifFalse: [self editSelection: (self hasClassSelected not
- ifTrue: [(metaClassIndicated or: [ self hasSystemCategorySelected not ])
- 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 changed: #selectedSystemCategoryName.
- self contentsChanged!
Item was removed:
- ----- Method: Browser>>selectEnvironment: (in category 'accessing') -----
- selectEnvironment: anEnvironment
- environment := anEnvironment.
- systemOrganizer := environment organization!
Item was removed:
- ----- Method: Browser>>selectMessageCategoryNamed: (in category 'message category list') -----
- selectMessageCategoryNamed: aSymbol
- "Given aSymbol, select the category with that name. Do nothing if
- aSymbol doesn't exist."
-
- selectedMessageCategoryName := aSymbol.
- selectedMessageName := nil.
-
- self changed: #messageCategorySelectionChanged.
- self changed: #messageCategoryListIndex. "update my selection"
- self changed: #messageList.
- self changed: #messageListIndex.
-
- self editSelection: (aSymbol notNil
- ifTrue: [#newMessage]
- ifFalse: [self hasClassSelected
- ifTrue: [#editClass]
- ifFalse: [#newClass]]).
- contents := nil.
- self contentsChanged.!
Item was removed:
- ----- Method: Browser>>selectMessageNamed: (in category 'message list') -----
- selectMessageNamed: aSymbolOrString
- | name |
- name := aSymbolOrString ifNotNil: [ aSymbolOrString asSymbol ].
- selectedMessageName := name.
-
- self editSelection: (name notNil
- ifTrue: [#editMessage]
- ifFalse: [self messageCategoryListIndex > 0
- ifTrue: [#newMessage]
- ifFalse: [self hasClassSelected
- ifTrue: [#editClass]
- ifFalse: [#newClass]]]).
- contents := nil.
- self changed: #messageListIndex. "update my selection"
- self contentsChanged.
- self decorateButtons.!
Item was removed:
- ----- Method: Browser>>selectSystemCategory: (in category 'system category list') -----
- selectSystemCategory: aSymbol
- "Set the selected system category. Update all other selections to be deselected."
- aSymbol = selectedSystemCategory ifTrue: [^ self].
- selectedSystemCategory := aSymbol.
- selectedClassName := nil.
- selectedMessageCategoryName := nil.
- selectedMessageName := nil.
- self editSelection: ( aSymbol isNil ifTrue: [#none] ifFalse: [#newClass]).
- self metaClassIndicated: false.
- self setClassOrganizer.
- contents := nil.
-
- self
- changed: #systemCategorySelectionChanged;
- changed: #systemCategoryListIndex; "update my selection"
- changed: #classList;
- changed: #messageCategoryList;
- changed: #messageList;
- changed: #relabel.
-
- self
- decorateButtons;
- contentsChanged!
Item was removed:
- ----- Method: Browser>>selectedClass (in category 'class list') -----
- selectedClass
- "Answer the class that is currently selected. Answer nil if no selection
- exists."
-
- | name envt |
- (name := self selectedClassName) ifNil: [^ nil].
- (envt := self selectedEnvironment) ifNil: [^ nil].
- ^ envt at: name ifAbsent: [envt valueOf: name ifAbsent: [nil]]!
Item was removed:
- ----- Method: Browser>>selectedClassName (in category 'class list') -----
- selectedClassName
- ^ selectedClassName.!
Item was removed:
- ----- Method: Browser>>selectedClassOrMetaClass (in category 'metaclass') -----
- selectedClassOrMetaClass
- "Answer the selected class/trait or metaclass/classTrait."
-
- | cls |
- ^self metaClassIndicated
- ifTrue: [(cls := self selectedClass) ifNil: [nil] ifNotNil: [cls classSide]]
- ifFalse: [self selectedClass]!
Item was removed:
- ----- Method: Browser>>selectedClassOrMetaClassName (in category 'metaclass') -----
- selectedClassOrMetaClassName
- "Answer the selected class name or metaclass name."
-
- ^self selectedClassOrMetaClass name!
Item was removed:
- ----- Method: Browser>>selectedEnvironment (in category 'system category list') -----
- selectedEnvironment
- "Answer the browsed environment. If this returned a system category dependent
- value and possibly nil (as it did in previous versions), selectedClass would not work in
- a hierarchy browser that has to display classes from different environments
- (because the correct categories might be missing in the browser)"
-
- ^ environment ifNil: [Smalltalk globals]!
Item was removed:
- ----- Method: Browser>>selectedMessage (in category 'message list') -----
- 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.
-
- ^ contents := (self showingDocumentation
- ifFalse: [ self sourceStringPrettifiedAndDiffed ]
- ifTrue: [ self commentContents ])
- copy asText makeSelectorBoldIn: class!
Item was removed:
- ----- Method: Browser>>selectedMessageCategoryName (in category 'message category list') -----
- selectedMessageCategoryName
- "Answer the name of the selected message category, if any. Answer nil
- otherwise."
-
- ^ selectedMessageCategoryName!
Item was removed:
- ----- Method: Browser>>selectedMessageName (in category 'message list') -----
- selectedMessageName
- "Answer the message selector of the currently selected message, if any.
- Answer nil otherwise."
-
- ^ selectedMessageName.!
Item was removed:
- ----- Method: Browser>>selectedMessageName: (in category 'message list') -----
- selectedMessageName: aSelector
- "Make the given selector be the selected message name"
-
- | anIndex |
- anIndex := self messageList indexOf: aSelector.
- anIndex > 0 ifTrue:
- [self messageListIndex: anIndex].
- self changed: #selectedMessageName. "inform interested parties"!
Item was removed:
- ----- Method: Browser>>selectedPackage (in category 'system category list') -----
- selectedPackage
-
- ^ self environment packageOrganizer
- packageOfSystemCategory: self selectedSystemCategory
- ifNone: []!
Item was removed:
- ----- Method: Browser>>selectedSystemCategory (in category 'system category list') -----
- selectedSystemCategory
- ^ selectedSystemCategory!
Item was removed:
- ----- Method: Browser>>selectedSystemCategoryName (in category 'system category list') -----
- selectedSystemCategoryName
- "Answer the name of the selected system category or nil."
-
- ^ self selectedSystemCategory.!
Item was removed:
- ----- Method: Browser>>setClass: (in category 'initialize-release') -----
- setClass: aBehavior
- "Set the state of a new, uninitialized Browser."
-
- | isMeta aClass |
- aBehavior ifNil: [^ self].
- aBehavior isMeta
- ifTrue: [
- isMeta := true.
- aClass := aBehavior soleInstance]
- ifFalse: [
- isMeta := false.
- aClass := aBehavior].
-
- self
- selectEnvironment: aClass environment;
- selectCategoryForClass: aClass;
- classListIndex: (self classListIndexOf: aClass name);
- metaClassIndicated: isMeta.!
Item was removed:
- ----- Method: Browser>>setClass:selector: (in category 'initialize-release') -----
- setClass: aBehavior selector: aSymbol
- "Set the state of a new, uninitialized Browser."
-
- aBehavior ifNil: [^ self].
-
- self
- setClass: aBehavior;
- setSelector: aSymbol.!
Item was removed:
- ----- Method: Browser>>setClassDefinition (in category 'metaclass') -----
- setClassDefinition
- "Remember the current class definition."
-
- | theClass |
- classDefinition := nil.
- metaClassDefinition := nil.
- self hasClassSelected ifFalse: [^ self].
- theClass := self selectedClass ifNil: [ ^self ].
- classDefinition := theClass definition.
- metaClassDefinition := theClass theMetaClass definition.!
Item was removed:
- ----- Method: Browser>>setClassOrganizer (in category 'metaclass') -----
- setClassOrganizer
- "Install whatever organization is appropriate"
- | theClass |
- classOrganizer := nil.
- metaClassOrganizer := nil.
- self hasClassSelected ifFalse: [^ self].
- theClass := self selectedClass ifNil: [ ^self ].
- classOrganizer := theClass organization.
- metaClassOrganizer := theClass classSide organization.!
Item was removed:
- ----- Method: Browser>>setMultiWindowFor: (in category 'toolbuilder') -----
- setMultiWindowFor: windowSpec
- "set the multi-window style for the windowSpec according to both the users preference and the browser's ability"
- (self class canUseMultiWindowBrowsers and: [self class useMultiWindowBrowsers])
- ifTrue: [windowSpec multiWindowStyle: #labelButton].
-
- !
Item was removed:
- ----- Method: Browser>>setOriginalCategoryIndexForCurrentMethod (in category 'message category list') -----
- setOriginalCategoryIndexForCurrentMethod
- "private - Set the message category index for the currently selected method.
-
- Note: This should only be called when somebody tries to save
- a method that they are modifying while ALL is selected."
-
- selectedMessageCategoryName := self categoryOfCurrentMethod.!
Item was removed:
- ----- Method: Browser>>setSelector: (in category 'initialize-release') -----
- setSelector: aSymbol
- "Make the receiver point at the given selector, in the currently chosen class. If the selector is found in the class organization we also set the message category to suit"
-
- | aClass |
- aSymbol ifNil: [^ self].
- (aClass := self selectedClassOrMetaClass) ifNil: [^ self].
- (aClass organization categoryOfElement: aSymbol)
- ifNil: [^ self]
- ifNotNil: [:category |
- self
- selectMessageCategoryNamed: category;
- selectMessageNamed: aSymbol].!
Item was removed:
- ----- Method: Browser>>shiftedClassListMenu: (in category 'class functions') -----
- shiftedClassListMenu: aMenu
- <classListMenuShifted: true>
- "Set up the menu to apply to the receiver's class list when the shift key is down"
- ^ aMenu
- addList: #(
- -
- ('local senders...' browseLocalSenders 'browse senders local to this class')
- ('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')
- -
- ('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'));
- yourself!
Item was removed:
- ----- Method: Browser>>shiftedClassListMenuMore: (in category 'class functions') -----
- shiftedClassListMenuMore: aMenu
- " The 'more..' link that toggles between unshifted and shifted menus
- in class lists "
- <classListMenuShifted: true>
- <menuPriority: 1000>
- ^ aMenu addList: #(-
- ('more...' offerUnshiftedClassListMenu 'return to the standard class-list menu'));
- yourself!
Item was removed:
- ----- Method: Browser>>shiftedMessageListMenu: (in category 'message list') -----
- shiftedMessageListMenu: aMenu
- <messageListMenuShifted: true>
- "Fill aMenu with the items appropriate when the shift key is held down"
-
- aMenu addStayUpItem.
- aMenu addList: #(
- ('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:
- #(('toggle category selection (Y)' 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)).
- ^ aMenu
- !
Item was removed:
- ----- Method: Browser>>showBytecodes (in category 'code pane') -----
- showBytecodes
- "Show or hide the bytecodes of the selected method -- an older protocol now mostly not relevant."
-
- self toggleShowingByteCodes!
Item was removed:
- ----- Method: Browser>>showHomeCategory (in category 'message category functions') -----
- showHomeCategory
- "Select the category of the currently-selected method. If it is already selected, or if no method is selected, deselect it to unfilter the message list."
- self okToChange ifTrue:
- [ | aSelector | ((aSelector := self selectedMessageName) notNil or: [ selectedMessageCategoryName notNil ]) ifTrue:
- [ aSelector
- ifNil: [ self selectMessageCategoryNamed: nil ]
- ifNotNil: [ self toggleCategorySelectionForCurrentMethod ].
- self selectedMessageName: aSelector ] ]!
Item was removed:
- ----- Method: Browser>>spawn: (in category 'accessing') -----
- spawn: aString
- "Create and schedule a fresh browser and place aString in its code pane. This method is called when the user issues the #spawn command (cmd-o) in any code pane. Whatever text was in the original code pane comes in to this method as the aString argument; the changes in the original code pane have already been cancelled by the time this method is called, so aString is the only copy of what the user had in his code pane."
-
- self selectedClassOrMetaClass ifNotNil: [^ super spawn: aString].
-
- self hasSystemCategorySelected ifTrue:
- ["Open a browser with the initial codepane string set"
- ^ self buildSystemCategoryBrowserEditString: aString].
-
- ^ super spawn: aString
- "This bail-out at least saves the text being spawned, which would otherwise be lost"!
Item was removed:
- ----- Method: Browser>>spawnOrNavigateTo: (in category 'private') -----
- spawnOrNavigateTo: aClass
- self setClass: aClass selector: nil!
Item was removed:
- ----- Method: Browser>>stripNaggingAttributeFromComment: (in category 'class comment pane') -----
- stripNaggingAttributeFromComment: aText
- ^aText removeAttribute: TextColor red from: 1 to: aText size!
Item was removed:
- ----- Method: Browser>>suggestCategoryToSpawnedBrowser: (in category 'accessing') -----
- 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]!
Item was removed:
- ----- Method: Browser>>switchesFrame: (in category 'initialize-release') -----
- switchesFrame: bottomFraction
- ^self switchesFrame: bottomFraction fromLeft: 0.25 width: 0.25.!
Item was removed:
- ----- Method: Browser>>switchesFrame:fromLeft:width: (in category 'initialize-release') -----
- switchesFrame: bottomFraction fromLeft: leftFraction width: rightFraction
- ^LayoutFrame new
- leftFraction: leftFraction offset: 0;
- topFraction: bottomFraction offset: self buttonHeight negated;
- rightFraction: (leftFraction + rightFraction) offset: 0;
- bottomFraction: bottomFraction offset: 0!
Item was removed:
- ----- Method: Browser>>systemCatListKey:from: (in category 'system category list') -----
- systemCatListKey: 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."
-
- aChar == $f ifTrue: [^ self findClass].
- aChar == $x ifTrue: [^ self removeSystemCategory].
- aChar == $b ifTrue: [^ self recent].
- ^ self classListKey: aChar from: view!
Item was removed:
- ----- Method: Browser>>systemCatSingletonKey:from: (in category 'initialize-release') -----
- systemCatSingletonKey: aChar from: aView
- ^ self messageListKey: aChar from: aView!
Item was removed:
- ----- Method: Browser>>systemCatSingletonMenu: (in category 'system category functions') -----
- systemCatSingletonMenu: aMenu
-
- ^ aMenu labels:
- 'browse all
- browse
- printOut
- fileOut
- update
- rename...
- remove'
- lines: #(2 4)
- selections:
- #(browseAllClasses buildSystemCategoryBrowser
- printOutSystemCategory fileOutSystemCategory updateSystemCategories
- renameSystemCategory removeSystemCategory)
- !
Item was removed:
- ----- Method: Browser>>systemCategoryList (in category 'system category list') -----
- systemCategoryList
- "Answer the class categories modelled by the receiver."
-
- ^ {SystemOrganizer allCategory}, systemOrganizer categories!
Item was removed:
- ----- Method: Browser>>systemCategoryListIndex (in category 'system category list') -----
- systemCategoryListIndex
- "Answer the index of the selected class category."
-
- ^ self systemCategoryList indexOf: self selectedSystemCategory.!
Item was removed:
- ----- Method: Browser>>systemCategoryListIndex: (in category 'system category list') -----
- systemCategoryListIndex: anInteger
- "Set the selected system category index to be anInteger. Update all other
- selections to be deselected."
-
- self selectSystemCategory: (self systemCategoryList at: anInteger ifAbsent: [ nil ])!
Item was removed:
- ----- Method: Browser>>systemCategoryMenu: (in category 'system category functions') -----
- systemCategoryMenu: aMenu
- ^ self menu: aMenu for: #(systemCategoryMenu systemCategoryMenuShifted:)
- !
Item was removed:
- ----- Method: Browser>>systemCategoryMenuHook:shifted: (in category 'pluggable menus - hooks') -----
- systemCategoryMenuHook: aMenu shifted: aBoolean
- <systemCategoryMenu>
- <menuPriority: 400>
- ^ self menuHook: aMenu named: #systemCategoryMenu shifted: aBoolean.
- !
Item was removed:
- ----- Method: Browser>>systemCategorySingleton (in category 'system category list') -----
- systemCategorySingleton
-
- | cat |
- cat := self selectedSystemCategory.
- ^ cat ifNil: [Array new]
- ifNotNil: [Array with: cat]!
Item was removed:
- ----- Method: Browser>>systemOrganizer (in category 'accessing') -----
- systemOrganizer
-
- ^ systemOrganizer!
Item was removed:
- ----- Method: Browser>>systemOrganizer: (in category 'initialize-release') -----
- 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.
- selectedSystemCategory := nil.
- selectedMessageCategoryName := nil.
- selectedClassName := nil.
- selectedMessageName := nil.
- metaClassIndicated := false.
- self setClassOrganizer.
- self editSelection: #none.!
Item was removed:
- ----- Method: Browser>>toggleCategorySelectionForCurrentMethod (in category 'message category list') -----
- toggleCategorySelectionForCurrentMethod
- | methodCategory selectorName |
- methodCategory := self categoryOfCurrentMethod.
- selectorName := self selectedMessageName.
- (methodCategory notNil and:
- [ methodCategory ~= ClassOrganizer allCategory and: [ methodCategory ~= selectedMessageCategoryName ] ])
- ifTrue:
- [ selectedMessageCategoryName := methodCategory.
- selectedMessageName := selectorName.
- self changed: #messageCategorySelectionChanged.
- self changed: #messageCategoryListIndex.
- "update my selection"
- self changed: #messageList.
- self changed: #messageListIndex ]
- ifFalse:
- [ methodCategory = selectedMessageCategoryName ifTrue:
- [ selectedMessageCategoryName := nil.
- self
- changed: #messageCategorySelectionChanged ;
- changed: #messageCategoryListIndex ;
- changed: #messageList ] ]!
Item was removed:
- ----- Method: Browser>>topConstantHeightFrame:fromLeft:width: (in category 'initialize-release') -----
- topConstantHeightFrame: height fromLeft: leftFraction width: rightFraction
- ^LayoutFrame new
- topFraction: 0 offset: 0;
- leftFraction: leftFraction offset: 0;
- rightFraction: (leftFraction + rightFraction) offset: 0;
- bottomFraction: 0 offset: height;
- yourself.!
Item was removed:
- ----- Method: Browser>>traitsMenu: (in category 'traits') -----
- traitsMenu: aMenu
- <classListMenuShifted: false>
- <menuPriority: 140>
-
- self selectedClass isTrait ifTrue: [
- aMenu add: 'browse trait users' action: #browseTraitUsers].
- ^ aMenu!
Item was removed:
- ----- Method: Browser>>updateCodePaneIfNeeded (in category 'self-updating') -----
- updateCodePaneIfNeeded
-
- super updateCodePaneIfNeeded.
-
- (self didCodeChangeElsewhere and: [self hasUnacceptedEdits not])
- ifTrue:
- [self setClassDefinition.
- self contentsChanged].!
Item was removed:
- ----- Method: Browser>>updateSystemCategories (in category 'system category functions') -----
- updateSystemCategories
- "The class categories were changed in another browser. The receiver must
- reorganize its lists based on these changes."
-
- self okToChange ifFalse: [^ self].
- self changed: #systemCategoryList!
Item was removed:
- ----- Method: Browser>>veryDeepInner: (in category 'copying') -----
- veryDeepInner: deepCopier
- "Copy all of my instance variables. Some need to be not copied at all, but shared. See DeepCopier class comment."
-
- super veryDeepInner: deepCopier.
- "systemOrganizer := systemOrganizer. clone has the old value. we share it"
- "classOrganizer := classOrganizer clone has the old value. we share it"
- "metaClassOrganizer := metaClassOrganizer clone has the old value. we share it"
- selectedSystemCategory := selectedSystemCategory veryDeepCopyWith: deepCopier.
- selectedClassName := selectedClassName veryDeepCopyWith: deepCopier.
- selectedMessageCategoryName := selectedMessageCategoryName veryDeepCopyWith: deepCopier.
- selectedMessageName := selectedMessageName veryDeepCopyWith: deepCopier.
- editSelection := editSelection veryDeepCopyWith: deepCopier.
- metaClassIndicated := metaClassIndicated veryDeepCopyWith: deepCopier.
- !
Item was removed:
- ----- Method: Browser>>wantsMessageCategoriesDrop: (in category 'drag and drop') -----
- wantsMessageCategoriesDrop: anObject
- "Only accept drops of compiled methods on system categories"
- ^anObject isKindOf: CompiledMethod!
Item was removed:
- ----- Method: Browser>>wantsSystemCategoriesDrop: (in category 'drag and drop') -----
- wantsSystemCategoriesDrop: anObject
- "Only accept drops of behaviors on system categories"
- ^anObject isBehavior!
Item was removed:
- PluggableTextMorph subclass: #BrowserCommentTextMorph
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !BrowserCommentTextMorph commentStamp: '<historical>' prior: 0!
- I am a PluggableTextMorph that knows enough to make myself invisible when necessary.!
Item was removed:
- ----- Method: BrowserCommentTextMorph>>hideOrShowPane (in category 'displaying') -----
- hideOrShowPane
- (self model editSelection == #editClass)
- ifTrue: [ self showPane ]
- ifFalse: [ self hidePane ]!
Item was removed:
- ----- Method: BrowserCommentTextMorph>>hidePane (in category 'displaying') -----
- hidePane
- | win |
- self window ifNotNil: [:window | window removePaneSplitters].
-
- self lowerPane ifNotNil:
- [ :lp |
- lp layoutFrame bottomFraction: self layoutFrame bottomFraction.
- lp layoutFrame bottomOffset: SystemWindow borderWidth negated].
- win := self window ifNil: [ ^self ].
- self delete.
- win updatePanesFromSubmorphs.
- win addPaneSplitters!
Item was removed:
- ----- Method: BrowserCommentTextMorph>>lowerPane (in category 'accessing') -----
- lowerPane
- "Answer the AlignmentMorph that I live beneath"
- ^self valueOfProperty: #browserLowerPane!
Item was removed:
- ----- Method: BrowserCommentTextMorph>>noteNewOwner: (in category 'updating') -----
- 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 notNil
- and: [ m layoutFrame bottomFraction >= self layoutFrame topFraction ]]]
- ifNone: [])!
Item was removed:
- ----- Method: BrowserCommentTextMorph>>showPane (in category 'displaying') -----
- showPane
- owner ifNil: [
- | win |
- win := self window ifNil: [ ^self ].
- win addMorph: self fullFrame: self layoutFrame.
- win updatePanesFromSubmorphs ].
-
- self lowerPane ifNotNil: [ :lp | lp layoutFrame bottomFraction: self layoutFrame topFraction ].
-
- self window ifNotNil: [:win | win addPaneSplitters]!
Item was removed:
- ----- Method: BrowserCommentTextMorph>>update: (in category 'updating') -----
- update: anAspect
- super update: anAspect.
- anAspect == #editSelection ifFalse: [ ^self ].
- self hideOrShowPane!
Item was removed:
- ----- Method: BrowserCommentTextMorph>>window (in category 'accessing') -----
- window
- ^self owner ifNil: [ self valueOfProperty: #browserWindow ].!
Item was removed:
- ----- Method: ByteTextConverter class>>browseAllCodePoints (in category '*Tools-Browsing') -----
- browseAllCodePoints
- "
- MacRomanTextConverter browseAllCodePoints.
- Latin1TextConverter browseAllCodePoints.
- CP1252TextConverter browseAllCodePoints.
-
- MacLatin2TextConverter browseAllCodePoints.
- Latin2TextConverter browseAllCodePoints.
-
- MacCyrillicTextConverter browseAllCodePoints.
-
-
- "
- self browseAllCodePointsUsing: TextStyle defaultFont.!
Item was removed:
- ----- Method: ByteTextConverter class>>browseAllCodePointsUsing: (in category '*Tools-Browsing') -----
- browseAllCodePointsUsing: aFont
- "Apply the receivers encoding (code points 0 to 255) to browse the result using glyphs of aFont (and its #fallbackFont)."
-
- aFont
- browseGlyphsOf: (Array streamContents: [:s | | |
- self decodeTable withIndexDo: [:ea :i | | codePoint |
- codePoint := ea = -1
- ifTrue: [ea]
- ifFalse: [ea bitAnd: 16r1FFFFF "Drop language info / leadingChar"].
- codePoint := codePoint caseOf: { [-1] -> [32]. [9 "tab"] -> [32]. [10 "line break"] -> [32]. [13 "line break"] -> [32]. } otherwise: [codePoint].
- (i-1 \\ 16 = 0 and: [s position > 0]) ifTrue: [s cr].
- s tab; nextPut: codePoint]])
- label: self name, ' decoding table'.!
Item was removed:
- Model subclass: #CPUWatcher
- instanceVariableNames: 'tally watcher threshold'
- classVariableNames: 'CpuWatcherEnabled CurrentCPUWatcher'
- poolDictionaries: ''
- category: 'Tools-Process Browser'!
-
- !CPUWatcher commentStamp: '<historical>' 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.
- !
Item was removed:
- ----- Method: CPUWatcher class>>cpuWatcherEnabled (in category 'preferences') -----
- cpuWatcherEnabled
- <preference: 'CPU Watcher enabled' category: #('debug' 'performance') description: 'If true, Squeak will monitor processes for CPU usage. If any uses too much CPU, you will get a notification menu that will allow you to debug, resume or terminate the process.' type: #Boolean>
- ^ CpuWatcherEnabled ifNil: [false].!
Item was removed:
- ----- Method: CPUWatcher class>>cpuWatcherEnabled: (in category 'preferences') -----
- cpuWatcherEnabled: aBoolean
- CpuWatcherEnabled := aBoolean.
- self monitorPreferenceChanged.!
Item was removed:
- ----- Method: CPUWatcher class>>current (in category 'singleton') -----
- current
- ^CurrentCPUWatcher
- !
Item was removed:
- ----- Method: CPUWatcher class>>currentWatcherProcess (in category 'accessing') -----
- currentWatcherProcess
- ^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ]
- !
Item was removed:
- ----- Method: CPUWatcher class>>dumpTallyOnTranscript (in category 'monitoring') -----
- dumpTallyOnTranscript
- self current ifNotNil: [
- ProcessBrowser dumpTallyOnTranscript: self current tally
- ]!
Item was removed:
- ----- Method: CPUWatcher class>>initialize (in category 'class initialization') -----
- initialize
- "CPUWatcher initialize"
- Smalltalk addToStartUpList: self.
- Smalltalk addToShutDownList: self.!
Item was removed:
- ----- Method: CPUWatcher class>>isMonitoring (in category 'monitoring') -----
- isMonitoring
-
- ^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ]
- !
Item was removed:
- ----- Method: CPUWatcher class>>monitorPreferenceChanged (in category 'preferences') -----
- monitorPreferenceChanged
- self cpuWatcherEnabled
- ifTrue: [ self startMonitoring ]
- ifFalse: [ self stopMonitoring ]!
Item was removed:
- ----- Method: CPUWatcher class>>shutDown (in category 'system startup') -----
- shutDown
- self stopMonitoring.!
Item was removed:
- ----- Method: CPUWatcher class>>startMonitoring (in category 'monitoring') -----
- startMonitoring
- "CPUWatcher startMonitoring"
-
- ^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8!
Item was removed:
- ----- Method: CPUWatcher class>>startMonitoringPeriod:rate:threshold: (in category 'monitoring') -----
- startMonitoringPeriod: pd rate: rt threshold: th
- "CPUWatcher startMonitoring"
-
- CurrentCPUWatcher ifNotNil: [ ^CurrentCPUWatcher startMonitoring. ].
- CurrentCPUWatcher := (self new)
- monitorProcessPeriod: pd sampleRate: rt;
- threshold: th;
- yourself.
- ^CurrentCPUWatcher
- !
Item was removed:
- ----- Method: CPUWatcher class>>startUp (in category 'system startup') -----
- startUp
- self monitorPreferenceChanged.!
Item was removed:
- ----- Method: CPUWatcher class>>stopMonitoring (in category 'monitoring') -----
- stopMonitoring
- "CPUWatcher stopMonitoring"
-
- CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ].
- CurrentCPUWatcher := nil.
- !
Item was removed:
- ----- Method: CPUWatcher>>catchThePig: (in category 'porcine capture') -----
- 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 ]
- !
Item was removed:
- ----- Method: CPUWatcher>>debugProcess: (in category 'process operations') -----
- debugProcess: aProcess
- | uiPriority oldPriority |
- uiPriority := Processor activeProcess priority.
- aProcess priority >= uiPriority ifTrue: [
- oldPriority := ProcessBrowser setProcess: aProcess toPriority: uiPriority - 1
- ].
- ProcessBrowser debugProcess: aProcess.!
Item was removed:
- ----- Method: CPUWatcher>>debugProcess:fromMenu: (in category 'process operations') -----
- debugProcess: aProcess fromMenu: aMenuMorph
- aMenuMorph delete.
- self debugProcess: aProcess.!
Item was removed:
- ----- Method: CPUWatcher>>findThePig (in category 'porcine capture') -----
- 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
- ].
- !
Item was removed:
- ----- Method: CPUWatcher>>isMonitoring (in category 'accessing') -----
- isMonitoring
- ^watcher notNil!
Item was removed:
- ----- Method: CPUWatcher>>monitorProcessPeriod:sampleRate: (in category 'startup-shutdown') -----
- 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 !
Item was removed:
- ----- Method: CPUWatcher>>openMVCWindowForSuspendedProcess: (in category 'porcine capture') -----
- openMVCWindowForSuspendedProcess: aProcess
- ProcessBrowser open!
Item was removed:
- ----- Method: CPUWatcher>>openMorphicWindowForSuspendedProcess: (in category 'porcine capture') -----
- 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
- !
Item was removed:
- ----- Method: CPUWatcher>>openWindowForSuspendedProcess: (in category 'porcine capture') -----
- openWindowForSuspendedProcess: aProcess
-
- Smalltalk isMorphic
- ifTrue: [ WorldState addDeferredUIMessage: [ self openMorphicWindowForSuspendedProcess: aProcess ] ]
- ifFalse: [ [ self openMVCWindowForSuspendedProcess: aProcess ] forkAt: Processor userSchedulingPriority ]
- !
Item was removed:
- ----- Method: CPUWatcher>>resumeProcess:fromMenu: (in category 'process operations') -----
- resumeProcess: aProcess fromMenu: aMenuMorph
- aMenuMorph delete.
- ProcessBrowser resumeProcess: aProcess.!
Item was removed:
- ----- Method: CPUWatcher>>startMonitoring (in category 'startup-shutdown') -----
- startMonitoring
- self
- monitorProcessPeriod: 20 sampleRate: 100!
Item was removed:
- ----- Method: CPUWatcher>>stopMonitoring (in category 'startup-shutdown') -----
- stopMonitoring
- watcher ifNotNil: [
- ProcessBrowser terminateProcess: watcher.
- watcher := nil.
- ]!
Item was removed:
- ----- Method: CPUWatcher>>tally (in category 'accessing') -----
- tally
- ^tally copy!
Item was removed:
- ----- Method: CPUWatcher>>terminateProcess:fromMenu: (in category 'process operations') -----
- terminateProcess: aProcess fromMenu: aMenuMorph
- aMenuMorph delete.
- ProcessBrowser terminateProcess: aProcess.!
Item was removed:
- ----- Method: CPUWatcher>>threshold (in category 'accessing') -----
- threshold
- "What fraction of the time can a process be the active process before we stop it?"
- ^threshold!
Item was removed:
- ----- Method: CPUWatcher>>threshold: (in category 'accessing') -----
- 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!
Item was removed:
- ----- Method: CPUWatcher>>watcherProcess (in category 'accessing') -----
- watcherProcess
- ^watcher!
Item was removed:
- CodeHolder subclass: #ChangeList
- instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer showsVersions'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Changes'!
-
- !ChangeList commentStamp: '<historical>' prior: 0!
- A ChangeList represents a list of changed methods that reside on a file in fileOut format. The classes and methods in my list are not necessarily in this image!! Used as the model for both Version Lists and Changed Methods (in Screen Menu, Changes...). Note that the two kinds of window have different controller classes!!!!
-
- It holds three lists:
- changeList - a list of ChangeRecords
- list - a list of one-line printable headers
- listSelections - a list of Booleans (true = selected, false = not selected) multiple OK.
- listIndex
- Items that are removed (removeDoits, remove an item) are removed from all three lists.
- Most recently clicked item is the one showing in the bottom pane.!
Item was removed:
- ----- Method: ChangeList class>>browseChangesFile: (in category 'fileIn/Out') -----
- browseChangesFile: fullName
- "Browse the selected file in fileIn format."
-
- fullName
- ifNotNil:
- [ChangeList browseStream: (FileStream readOnlyFileNamed: fullName)]
- ifNil:
- [Beeper beep]!
Item was removed:
- ----- Method: ChangeList class>>browseCompressedChangesFile: (in category 'fileIn/Out') -----
- browseCompressedChangesFile: fullName
- "Browse the selected file in fileIn format."
-
- | unzipped |
- fullName ifNil: [^Beeper beep].
- FileStream readOnlyFileNamed: fullName do: [:stream |
- unzipped := (GZipReadStream on: stream) contents].
- ChangeList browseStream: (MultiByteBinaryOrTextStream with: unzipped asString)!
Item was removed:
- ----- Method: ChangeList class>>browseFile: (in category 'public access') -----
- browseFile: fileName "ChangeList browseFile: 'AutoDeclareFix.st'"
- "Opens a changeList on the file named fileName"
-
- ^ self browseStream: (FileStream readOnlyFileNamed: fileName)!
Item was removed:
- ----- Method: ChangeList class>>browseMethodVersions (in category 'public access') -----
- browseMethodVersions
-
- | changeList end changesFile filteredRecords |
- changesFile := (SourceFiles at: 2) readOnlyCopy.
- end := changesFile size.
- changeList := self new.
- Cursor read showWhile: [
- changeList scanFile: changesFile from: 0 to: end].
- changesFile close.
-
- filteredRecords := Dictionary new.
- changeList changeList
- do: [:changeRecord |
- changeRecord methodSelector ifNotNil: [:selector |
- | class |
- class := changeRecord methodClass.
- "Only collect records that point to not-installed methods."
- (class isNil or: [(class includesSelector: selector) not]) ifTrue: [
- (filteredRecords at: selector ifAbsentPut: [OrderedCollection new])
- add: changeRecord]]]
- displayingProgress: [:changeRecord | 'Parsing source code at {1}...' translated format: {changeRecord position}].
- filteredRecords explore. "Open explorer to allow user to repeat the following step manually."
- self browseMethodVersions: filteredRecords.!
Item was removed:
- ----- Method: ChangeList class>>browseMethodVersions: (in category 'public access') -----
- browseMethodVersions: filteredRecords
-
- | changeList sortedKeys choice |
- sortedKeys := filteredRecords keys sorted.
- choice := Project uiManager chooseFrom: sortedKeys values: sortedKeys title: 'Recover method versions' translated.
- choice ifNil: [^ self].
-
- "Only ChangeList can handle the mix of (maybe non-existing) class references in records. For example, VersionsBrowser is not supported."
- changeList := ChangeList new.
-
- (filteredRecords at: choice) do: [:changeRecord |
- changeList
- addItem: changeRecord
- text: ('{1} {2}{3}{4} \{{5}\}' format: {
- changeRecord stamp.
- changeRecord methodClassName.
- changeRecord isMetaClassChange
- ifTrue: [' class '] ifFalse: [' '].
- choice.
- changeRecord category})].
- changeList resetListSelections.
-
- self
- open: changeList
- name: ('All local versions for {1}' translated format: {choice storeString})
- multiSelect: false!
Item was removed:
- ----- Method: ChangeList class>>browseRecent: (in category 'public access') -----
- browseRecent: charCount
- "ChangeList browseRecent: 5000"
- "Opens a changeList on the end of the changes log file"
- ^ self browseRecent: charCount on: (SourceFiles at: 2) !
Item was removed:
- ----- Method: ChangeList class>>browseRecent:on: (in category 'public access') -----
- browseRecent: charCount on: origChangesFile
- "Opens a changeList on the end of the specified changes log file"
- | changeList end changesFile |
- changesFile := origChangesFile readOnlyCopy.
- changesFile setConverterForCode.
- end := changesFile size.
- changeList := Cursor read
- showWhile: [self new
- scanFile: changesFile
- from: (0 max: end - charCount)
- to: end].
- changesFile close.
- self
- open: changeList
- name: 'Recent changes' translated
- multiSelect: true!
Item was removed:
- ----- Method: ChangeList class>>browseRecentLog (in category 'public access') -----
- 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!
Item was removed:
- ----- Method: ChangeList class>>browseRecentLogOn: (in category 'public access') -----
- browseRecentLogOn: origChangesFile
- "figure out where the last snapshot or quit was, then browse the recent entries."
-
- | end done block pos chunk changesFile position prevBlock |
- changesFile := origChangesFile readOnlyCopy.
- position := nil.
- end := changesFile size.
- prevBlock := end.
- block := end - 1024 max: 0.
- done := false.
- [done
- or: [position notNil]]
- 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: [position := pos]]].
- block = 0
- ifTrue: [done := true]
- ifFalse: [prevBlock := block.
- block := block - 1024 max: 0]].
- changesFile close.
- position
- ifNil: [self inform: ('File {1} does not appear to be a changes file' translated format: {changesFile name})]
- ifNotNil: [self browseRecentLogOn: origChangesFile startingFrom: position]!
Item was removed:
- ----- Method: ChangeList class>>browseRecentLogOn:startingFrom: (in category 'public access') -----
- 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.
- changesFile setConverterForCode.
- pos := initialPos.
- [pos = 0
- or: [banners size > 500]]
- 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' translated].
- pos := UIManager default chooseFrom: banners values: positions title: 'Browse as far back as...' translated.
- pos ifNil: [^ self].
- self browseRecent: end - pos on: origChangesFile!
Item was removed:
- ----- Method: ChangeList class>>browseRecentLogOnPath: (in category 'public access') -----
- 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]
- !
Item was removed:
- ----- Method: ChangeList class>>browseStream: (in category 'public access') -----
- browseStream: changesFile
- "Opens a changeList on a fileStream"
- | changeList charCount |
- changesFile readOnly.
- changesFile setConverterForCode.
- charCount := changesFile size.
- charCount > 1000000 ifTrue:
- [(self confirm: ('The file {1}
- is really long ({2} characters).
- Would you prefer to view only the last million characters?' translated format: {changesFile name. charCount}))
- ifTrue: [charCount := 1000000]].
- "changesFile setEncoderForSourceCodeNamed: changesFile name."
- changeList := Cursor read showWhile:
- [self new
- scanFile: changesFile from: changesFile size-charCount to: changesFile size].
- changesFile close.
- self open: changeList name: changesFile localName , ' log' multiSelect: true!
Item was removed:
- ----- Method: ChangeList class>>fileReaderServicesForFile:suffix: (in category 'fileIn/Out') -----
- 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!
Item was removed:
- ----- Method: ChangeList class>>getRecentLocatorWithPrompt: (in category 'public access') -----
- 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 := Smalltalk 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 := UIManager default chooseFrom: banners values: positions title: aPrompt.
- pos == nil ifTrue: [^ nil].
- ^ end - pos!
Item was removed:
- ----- Method: ChangeList class>>initialize (in category 'initialize-release') -----
- initialize
-
- FileServices registerFileReader: self!
Item was removed:
- ----- Method: ChangeList class>>open:name:multiSelect: (in category 'instance creation') -----
- 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"
- ^ToolBuilder default open: aChangeList label: aString!
Item was removed:
- ----- Method: ChangeList class>>serviceBrowseChangeFile (in category 'fileIn/Out') -----
- serviceBrowseChangeFile
- "Answer a service for opening a changelist browser on a file"
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'changelist browser' translatedNoop
- selector: #browseStream:
- description: 'open a changelist tool on this file' translatedNoop
- buttonLabel: 'changes' translatedNoop)
- argumentGetter: [ :fileList | fileList readOnlyStream ]!
Item was removed:
- ----- Method: ChangeList class>>serviceBrowseCompressedChangeFile (in category 'fileIn/Out') -----
- serviceBrowseCompressedChangeFile
- "Answer a service for opening a changelist browser on a file"
-
- ^ SimpleServiceEntry
- provider: self
- label: 'changelist browser' translatedNoop
- selector: #browseCompressedChangesFile:
- description: 'open a changelist tool on this file' translatedNoop
- buttonLabel: 'changes' translatedNoop!
Item was removed:
- ----- Method: ChangeList class>>serviceBrowseDotChangesFile (in category 'fileIn/Out') -----
- 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' translatedNoop
- selector: #browseRecentLogOnPath:
- description: 'open a changelist tool on recent changes in file' translatedNoop
- buttonLabel: 'recent changes' translatedNoop!
Item was removed:
- ----- Method: ChangeList class>>services (in category 'fileIn/Out') -----
- services
- "Answer potential file services associated with this class"
-
- ^ { self serviceBrowseChangeFile.
- self serviceBrowseDotChangesFile.
- self serviceBrowseCompressedChangeFile }!
Item was removed:
- ----- Method: ChangeList class>>unload (in category 'class initialization') -----
- unload
-
- FileServices unregisterFileReader: self !
Item was removed:
- ----- Method: ChangeList>>acceptFrom: (in category 'menu actions') -----
- acceptFrom: aView
-
- aView controller text = aView controller initialText ifFalse: [
- aView flash.
- ^ self inform: 'You can only accept this version as-is.
- If you want to edit, copy the text to a browser' translated].
- (aView setText: aView controller text from: self) ifTrue:
- [aView ifNotNil: [aView controller accept]]. "initialText"
- !
Item was removed:
- ----- Method: ChangeList>>addItem:text: (in category 'initialization-release') -----
- addItem: item text: text
- | cr |
- cr := Character cr.
- changeList addLast: item.
- list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])!
Item was removed:
- ----- Method: ChangeList>>annotation (in category 'viewing access') -----
- 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]]!
Item was removed:
- ----- Method: ChangeList>>browseAllVersionsOfSelections (in category 'menu actions') -----
- 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' translated].!
Item was removed:
- ----- Method: ChangeList>>browseCurrentVersionsOfSelections (in category 'menu actions') -----
- browseCurrentVersionsOfSelections
- "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted"
- | aList |
- aList := OrderedCollection new.
- Cursor read showWhile: [
- 1 to: changeList size do: [:i |
- (listSelections at: i) ifTrue: [
- | aClass aChange |
- aChange := changeList at: i.
- (aChange type = #method
- and: [(aClass := aChange methodClass) notNil
- and: [aClass includesSelector: aChange methodSelector]])
- ifTrue: [
- aList add: (
- MethodReference class: aClass
- selector: aChange methodSelector
- )
- ]]]].
-
- aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts' translated].
- ToolSet
- browseMessageSet: aList
- name: ('Current versions of selected methods in {1}' translated format: {file localName})
- autoSelect: nil!
Item was removed:
- ----- Method: ChangeList>>browseVersions (in category 'menu actions') -----
- 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!
Item was removed:
- ----- Method: ChangeList>>buildChangeListWith:multiSelect: (in category 'toolbuilder') -----
- buildChangeListWith: builder multiSelect: multiSelect
-
- | listSpec |
- multiSelect ifTrue:[
- listSpec := builder pluggableMultiSelectionListSpec new.
- listSpec getSelectionList: #listSelectionAt:.
- listSpec setSelectionList: #listSelectionAt:put:.
- ] ifFalse:[
- listSpec := builder pluggableListSpec new.
- ].
-
- listSpec
- model: self;
- list: #list;
- getIndex: #listIndex;
- setIndex: #toggleListIndex:;
- menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:]);
- keyPress: #changeListKey:from:.
-
- ^listSpec!
Item was removed:
- ----- Method: ChangeList>>buildMorphicCodePaneWith: (in category 'menu actions') -----
- buildMorphicCodePaneWith: editString
-
- | codePane |
-
- codePane := AcceptableCleanTextMorph
- on: self
- text: #contents
- accept: #contents:
- readSelection: #contentsSelection
- menu: #codePaneMenu:shifted:.
- codePane font: Preferences standardCodeFont.
- editString ifNotNil: [
- codePane editString: editString.
- codePane hasUnacceptedEdits: true
- ].
- ^codePane
- !
Item was removed:
- ----- Method: ChangeList>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- ^self buildWith: builder multiSelect: self showsVersions not!
Item was removed:
- ----- Method: ChangeList>>buildWith:multiSelect: (in category 'toolbuilder') -----
- buildWith: builder multiSelect: multiSelect
- "Open a morphic view for the messageSet, whose label is labelString.
- The listView may be either single or multiple selection type"
- | windowSpec max |
- max := self wantsOptionalButtons ifTrue:[0.33] ifFalse:[0.4].
- windowSpec := self buildWindowWith: builder specs: {
- (0@0 corner: 1@max) -> [self buildChangeListWith: builder multiSelect: multiSelect].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
- ^builder build: windowSpec!
Item was removed:
- ----- Method: ChangeList>>changeList (in category 'accessing') -----
- changeList
- ^ changeList!
Item was removed:
- ----- Method: ChangeList>>changeListButtonSpecs (in category 'initialization-release') -----
- changeListButtonSpecs
-
- ^#(
- ('select all' selectAll 'select all entries')
- ('deselect all' deselectAll 'deselect all entries')
- ('select conflicts' selectAllConflicts 'select all methods that occur in any change set')
- ('file in selections' fileInSelections 'file in all selected entries')
- )!
Item was removed:
- ----- Method: ChangeList>>changeListKey:from: (in category 'menu actions') -----
- changeListKey: aChar from: view
- "Respond to a Command key in the list pane."
-
- aChar == $D ifTrue: [^ self toggleDiffing].
- aChar == $a ifTrue: [^ self selectAll].
-
- ^ self arrowKey: aChar from: view!
Item was removed:
- ----- Method: ChangeList>>changeListMenu: (in category 'menu actions') -----
- changeListMenu: aMenu
- ^ self menu: aMenu for: #(changeListMenu changeListMenuShifted)
- !
Item was removed:
- ----- Method: ChangeList>>changes:file: (in category 'accessing') -----
- changes: changeRecords file: aFile
- file := aFile.
- changeList := OrderedCollection new.
- list := OrderedCollection new.
- listIndex := 0.
- changeRecords do: [:each |
- (each respondsTo: #methodClass)
- ifFalse: [self addItem: ChangeRecord new text: each asString]
- ifTrue:
- [self addItem: each text: ('method: ' , each methodClass name , (each isMetaClassChange ifTrue: [' class '] ifFalse: [' '])
- , each methodSelector
- , '; ' , each stamp)]].
- listSelections := Array new: list size withAll: false!
Item was removed:
- ----- Method: ChangeList>>compareToCurrentSource: (in category 'menu actions') -----
- compareToCurrentSource: currentSource
- "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text"
-
- | change selectedSource |
- change := changeList at: listIndex ifAbsent: [^ self].
- selectedSource := change string.
- currentSource = selectedSource
- ifTrue: [^ self inform: 'Exact Match' translated].
- (StringHolder new
- textContents: (TextDiffBuilder
- buildDisplayPatchFrom: selectedSource
- to: currentSource
- inClass: change methodClass
- prettyDiffs: self showingPrettyDiffs))
- openLabel: 'Comparison to Current Version' translated.!
Item was removed:
- ----- Method: ChangeList>>compareToCurrentVersion (in category 'menu actions') -----
- compareToCurrentVersion
- "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text"
-
- | change class |
- change := changeList at: listIndex ifAbsent: [^ self].
- class := change methodClass.
- (class notNil and: [(class includesSelector: change methodSelector)])
- ifFalse: [^ self flash].
- ^ self compareToCurrentSource: (class sourceCodeAt: change methodSelector) asString!
Item was removed:
- ----- Method: ChangeList>>contents (in category 'viewing access') -----
- contents
- "Answer the contents string, obeying diffing directives if needed"
-
- ^ self showingAnyKindOfDiffs
- ifFalse:
- [self undiffedContents]
- ifTrue:
- [self showsVersions
- ifTrue:
- [self diffedVersionContents]
- ifFalse:
- [self contentsDiffedFromCurrent]]!
Item was removed:
- ----- Method: ChangeList>>contents: (in category 'viewing access') -----
- contents: aString
- listIndex = 0 ifTrue: [self changed: #flash. ^ false].
- lostMethodPointer ifNotNil: [^ self restoreDeletedMethod].
- self okToChange "means not dirty" ifFalse: ["is dirty"
- self inform: 'This is a view of a method on a file.\Please cancel your changes. You may\accept, but only when the method is untouched.' translated withCRs. ^ false].
- "Can't accept changes here. Method text must be unchanged!!"
- (changeList at: listIndex) fileIn.
- ^ true!
Item was removed:
- ----- Method: ChangeList>>contentsDiffedFromCurrent (in category 'viewing access') -----
- 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:
- [^self
- methodDiffFor: aChange text
- class: aClass
- selector: aChange methodSelector
- prettyDiffs: self showingPrettyDiffs].
-
- aChange type == #doIt ifTrue:
- [| tokens |
- tokens := Scanner new scanTokens: aChange string.
- ((tokens select:
- [:substr| #(subclass: variableByteSubclass: variableWordSubclass:
- instanceVariableNames: classVariableNames: ) includes: substr])
- asSet size >= 3
- and: [(aClass := Smalltalk at: tokens third ifAbsent: []) notNil
- and: [aClass isBehavior]]) ifTrue:
- [^ClassDiffBuilder buildDisplayPatchFrom: aClass definition to: aChange string].
-
- (tokens size = 4
- and: [tokens second == #class
- and: [tokens third == #instanceVariableNames:
- and: [(aClass := Smalltalk at: tokens first ifAbsent: []) notNil
- and: [aClass isBehavior]]]]) ifTrue:
- [^ClassDiffBuilder buildDisplayPatchFrom: aClass class definition to: aChange string]].
-
- (aChange type == #classComment
- and: [(aClass := aChange commentClass) notNil]) ifTrue:
- [^ClassDiffBuilder buildDisplayPatchFrom: aClass comment asString to: aChange string].
-
- ^(changeList at: listIndex) text!
Item was removed:
- ----- Method: ChangeList>>contentsSymbolQuints (in category 'viewing access') -----
- contentsSymbolQuints
- "Answer a list of quintuplets representing information on the alternative views available in the code pane"
-
- ^ self sourceAndDiffsQuintsOnly!
Item was removed:
- ----- Method: ChangeList>>currentChange (in category 'accessing') -----
- currentChange
- "return the current change being viewed, or nil if none"
- listIndex = 0 ifTrue: [ ^nil ].
- ^changeList at: listIndex!
Item was removed:
- ----- Method: ChangeList>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.719 g: 0.9 b: 0.9)!
Item was removed:
- ----- Method: ChangeList>>deselectAll (in category 'menu actions') -----
- deselectAll
- "Deselect all items in the list pane, and clear the code pane"
-
- listIndex := 0.
- listSelections atAllPut: false.
- self changed: #allSelections.
- self contentsChanged!
Item was removed:
- ----- Method: ChangeList>>destroyCurrentCodeOfSelections (in category 'menu actions') -----
- destroyCurrentCodeOfSelections
- "Actually remove from the system any in-memory methods with class and selector identical to items current selected. This may seem rather arcane but believe me it has its great uses, when trying to split out code. To use effectively, first file out a change set that you wish to split off. Then open a ChangeList browser on that fileout. Now look through the methods, and select any of them which you want to remove completely from the system, then issue this command. For those methods where you have made changes to pre-existing versions, of course, you won't want to remove them from the system, so use this mechanism with care!!"
-
- | aClass aChange aList |
- aList := OrderedCollection new.
- 1 to: changeList size do:
- [:index |
- (listSelections at: index) ifTrue:
- [aChange := changeList at: index.
- (aChange type = #method
- and: [(aClass := aChange methodClass) notNil
- and: [aClass includesSelector: aChange methodSelector]])
- ifTrue:
- [aList add: {aClass. aChange methodSelector}]]].
-
- aList size > 0 ifTrue:
- [(self confirm: ('Warning!! This will actually remove {1} method(s) from the system!!' translated format: {aList size})) ifFalse: [^ self]].
- aList do:
- [:aPair | Transcript cr; show: 'Removed: ', aPair first printString, '.', aPair second.
- aPair first removeSelector: aPair second]!
Item was removed:
- ----- Method: ChangeList>>diffedVersionContents (in category 'viewing access') -----
- 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: self environment.
- (listIndex == changeList size or: [class == nil])
- ifTrue: [^ (self showingPrettyDiffs and: [class notNil])
- ifTrue: [class prettyPrinterClass format: later in: class notifying: nil]
- ifFalse: [later]].
-
- earlier := (changeList at: listIndex + 1) text.
-
- ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs!
Item was removed:
- ----- Method: ChangeList>>file (in category 'accessing') -----
- file
- ^file!
Item was removed:
- ----- Method: ChangeList>>fileInSelections (in category 'menu actions') -----
- fileInSelections
- | any |
- any := false.
- self selectedClass environment beCurrentDuring: [
- listSelections with: changeList do:
- [:selected :item | selected ifTrue: [any := true. item fileIn]]].
- any ifFalse:
- [self inform: 'nothing selected, so nothing done' translated]!
Item was removed:
- ----- Method: ChangeList>>fileOutSelections (in category 'menu actions') -----
- fileOutSelections
- | fileName internalStream |
- fileName := Project uiManager request: 'Enter the base of file name' translated initialAnswer: 'Filename' translated.
- internalStream := WriteStream on: (String new: 1000).
- internalStream header; timeStamp.
- listSelections with: changeList do:
- [:selected :item | selected ifTrue: [item fileOutOn: internalStream]].
-
- FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true useHtml: false.!
Item was removed:
- ----- Method: ChangeList>>initialize (in category 'initialization-release') -----
- 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!
Item was removed:
- ----- Method: ChangeList>>invertSelections (in category 'menu actions') -----
- invertSelections
- "Invert the selectedness of each item in the changelist"
-
- listSelections := listSelections collect: [ :ea | ea not].
- listIndex := 0.
- self changed: #allSelections.
- self contentsChanged!
Item was removed:
- ----- Method: ChangeList>>list (in category 'viewing access') -----
- list
- ^ list!
Item was removed:
- ----- Method: ChangeList>>listHasSingleEntry (in category 'accessing') -----
- listHasSingleEntry
- "does the list of changes have only a single item?"
- ^list size = 1!
Item was removed:
- ----- Method: ChangeList>>listIndex (in category 'viewing access') -----
- listIndex
- ^ listIndex!
Item was removed:
- ----- Method: ChangeList>>listSelectionAt: (in category 'viewing access') -----
- listSelectionAt: index
- ^ listSelections at: index!
Item was removed:
- ----- Method: ChangeList>>listSelectionAt:put: (in category 'viewing access') -----
- listSelectionAt: index put: value
-
- listSelections at: index put: value.
- self
- changed: #listSelectionAt:;
- changed: #listIndex.
- ^ value!
Item was removed:
- ----- Method: ChangeList>>listSelections (in category 'accessing') -----
- listSelections
- listSelections ifNil: [
- list ifNotNil: [
- listSelections := Array new: list size withAll: false]].
- ^ listSelections!
Item was removed:
- ----- Method: ChangeList>>mainChangeListMenu: (in category 'menu actions') -----
- mainChangeListMenu: aMenu
- "Fill aMenu up so that it comprises the primary changelist-browser menu"
- <changeListMenu>
-
- aMenu addTitle: 'change list' translated.
- aMenu addStayUpItemSpecial.
-
- aMenu addTranslatedList: #(
-
- ('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 definitions' selectUnchangedDefinitions 'select class definitions, class comments and methods in the file whose in-image versions are the same as their in-file counterparts' )
- ('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 methods for extant classes' selectMethodsForExtantClasses 'select all methods in the file that belong to a class that exists in the image')
- ('select changes with contents matching' selectContentsMatching 'select all changes in the file whose text includes a pattern')
-
- -
- ('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')
- ('select all before' selectAllBefore 'select every item before the current selection')
- -
- ('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!
Item was removed:
- ----- Method: ChangeList>>methodDiffFor:class:selector:prettyDiffs: (in category 'viewing access') -----
- methodDiffFor: aString class: aClass selector: aSelector prettyDiffs: prettyDiffBoolean
- "Return a string comprising a source-code diff between an existing method and the source-code in aString. DO prettyDiff if prettyDiffBoolean is true."
-
- ^ (aClass notNil and: [aClass includesSelector: aSelector])
- ifTrue:
- [TextDiffBuilder
- buildDisplayPatchFrom: (aClass sourceCodeAt: aSelector)
- to: aString
- inClass: aClass
- prettyDiffs: prettyDiffBoolean]
- ifFalse:
- [aString copy]!
Item was removed:
- ----- Method: ChangeList>>optionalButtonHeight (in category 'initialization-release') -----
- optionalButtonHeight
-
- ^ 15!
Item was removed:
- ----- Method: ChangeList>>perform:orSendTo: (in category 'menu actions') -----
- perform: selector orSendTo: otherTarget
- "Selector was just chosen from a menu by a user. If I can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked."
-
- (#accept == selector) ifTrue:
- [otherTarget isMorph ifFalse: [^ self acceptFrom: otherTarget view]].
- "weird special case just for mvc changlist"
-
- ^ super perform: selector orSendTo: otherTarget!
Item was removed:
- ----- Method: ChangeList>>removeDoIts (in category 'menu actions') -----
- removeDoIts
- "Remove doits from the receiver, other than initializes. 1/26/96 sw"
-
- | newChangeList newList |
-
- newChangeList := OrderedCollection new.
- newList := OrderedCollection new.
-
- changeList with: list do:
- [:chRec :str |
- (chRec type ~~ #doIt or:
- [str endsWith: 'initialize'])
- ifTrue:
- [newChangeList add: chRec.
- newList add: str]].
- newChangeList size < changeList size
- ifTrue:
- [changeList := newChangeList.
- list := newList.
- listIndex := 0.
- listSelections := Array new: list size withAll: false].
- self changed: #list.
-
- !
Item was removed:
- ----- Method: ChangeList>>removeExistingMethodVersions (in category 'menu actions') -----
- removeExistingMethodVersions
- "Remove all up to date version of entries from the receiver"
- | newChangeList newList |
- newChangeList := OrderedCollection new.
- newList := OrderedCollection new.
-
- changeList with: list do:[:chRec :strNstamp |
- | str keep cls sel |
- keep := true.
- (cls := chRec methodClass) ifNotNil:[
- str := chRec string.
- sel := cls newParser 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!
Item was removed:
- ----- Method: ChangeList>>removeNonSelections (in category 'menu actions') -----
- removeNonSelections
- "Remove the unselected items from the receiver."
-
- | newChangeList newList |
-
- newChangeList := OrderedCollection new.
- newList := OrderedCollection new.
-
- 1 to: changeList size do:
- [:i | (listSelections at: i) ifTrue:
- [newChangeList add: (changeList at: i).
- newList add: (list at: i)]].
- newChangeList size = 0 ifTrue:
- [^ self inform: 'That would remove everything.
- Why would you want to do that?' translated].
-
- newChangeList size < changeList size
- ifTrue:
- [changeList := newChangeList.
- list := newList.
- listIndex := 0.
- listSelections := Array new: list size withAll: false].
- self changed: #list!
Item was removed:
- ----- Method: ChangeList>>removeOlderMethodVersions (in category 'menu actions') -----
- removeOlderMethodVersions
- "Remove older versions of entries from the receiver."
- | newChangeList newList found |
- newChangeList := OrderedCollection new.
- newList := OrderedCollection new.
- found := OrderedCollection new.
-
- changeList reverseWith: list do:
- [:chRec :strNstamp | | str | str := strNstamp copyUpTo: $;.
- (found includes: str)
- ifFalse:
- [found add: str.
- newChangeList add: chRec.
- newList add: strNstamp]].
- newChangeList size < changeList size
- ifTrue:
- [changeList := newChangeList reversed.
- list := newList reversed.
- listIndex := 0.
- listSelections := Array new: list size withAll: false].
- self changed: #list!
Item was removed:
- ----- Method: ChangeList>>removeSelections (in category 'menu actions') -----
- removeSelections
- "Remove the selected items from the receiver. 9/18/96 sw"
-
- | newChangeList newList |
-
- newChangeList := OrderedCollection new.
- newList := OrderedCollection new.
-
- 1 to: changeList size do:
- [:i | (listSelections at: i) ifFalse:
- [newChangeList add: (changeList at: i).
- newList add: (list at: i)]].
- newChangeList size < changeList size
- ifTrue:
- [changeList := newChangeList.
- list := newList.
- listIndex := 0.
- listSelections := Array new: list size withAll: false].
- self changed: #list
-
- !
Item was removed:
- ----- Method: ChangeList>>resetListSelections (in category 'initialization-release') -----
- resetListSelections
-
- listSelections := Array new: list size withAll: false.!
Item was removed:
- ----- Method: ChangeList>>restoreDeletedMethod (in category 'viewing access') -----
- 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 toReturnSelfTrailerBytes:
- (CompiledMethodTrailer new sourcePointer: 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!
Item was removed:
- ----- Method: ChangeList>>scanCategory (in category 'scanning') -----
- scanCategory
- "Scan anything that involves more than one chunk; method name is historical only"
-
- | itemPosition item tokens stamp anIndex class meta |
- itemPosition := file position.
- item := file nextChunk.
-
- ((item includesSubstring: 'commentStamp:')
- or: [(item includesSubstring: 'methodsFor:')
- or: [(item includesSubstring: 'classDefinition:')
- or: [item endsWith: 'reorganize']]]) ifFalse:
- ["Maybe a preamble, but not one we recognize; bail out with the preamble trick"
- ^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble)
- text: ('preamble: ' , item contractTo: 50)].
-
- tokens := Scanner new scanTokens: item.
- tokens size >= 3 ifTrue:
- [stamp := ''.
- anIndex := tokens indexOf: #stamp: ifAbsent: [nil].
- anIndex ifNotNil: [stamp := tokens at: (anIndex + 1)].
-
- tokens second == #methodsFor:
- ifTrue: [^ self scanCategory: tokens third class: tokens first
- meta: false stamp: stamp].
- tokens third == #methodsFor:
- ifTrue: [^ self scanCategory: tokens fourth class: tokens first
- meta: true stamp: stamp]].
-
- tokens second == #commentStamp:
- ifTrue:
- [stamp := tokens third.
- self addItem:
- (ChangeRecord new file: file position: file position type: #classComment
- class: tokens first category: nil meta: false stamp: stamp)
- text: 'class comment for ' , tokens first,
- (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]).
- file nextChunk.
- ^ file skipStyleChunk].
-
- tokens first == #classDefinition:
- ifTrue:
- [class := tokens second.
- meta := tokens size >= 3 and: [tokens third = 'class'].
- stamp := ''.
- self addItem:
- (ChangeRecord new file: file position: file position type: #classDefinition
- class: class category: nil meta: meta stamp: stamp)
- text: 'class definition for ' , class,
- (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]).
- file nextChunk.
- ^ file skipStyleChunk].
-
- self assert: tokens last == #reorganize.
- self addItem:
- (ChangeRecord new
- file: file position: file position type: #reorganize
- class: tokens first category: nil meta: false stamp: stamp)
- text: 'organization for ' , tokens first, (tokens second == #class ifTrue: [' class'] ifFalse: ['']).
- file nextChunk!
Item was removed:
- ----- Method: ChangeList>>scanCategory:class:meta:stamp: (in category 'scanning') -----
- scanCategory: category class: class meta: meta stamp: stamp
- | itemPosition method selector |
- [itemPosition := file position.
- method := file nextChunk.
- file skipStyleChunk.
- method size > 0] "done when double terminators"
- whileTrue:
- [self addItem: (ChangeRecord new file: file position: itemPosition type: #method
- class: class category: category meta: meta stamp: stamp)
- text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' '])
- , ((selector := ((Smalltalk classNamed: class) ifNil: [Object]) newParser parseSelector: method) isNil
- ifTrue: ['unparsableSelector']
- ifFalse: [selector])
- , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]!
Item was removed:
- ----- Method: ChangeList>>scanFile:from:to: (in category 'scanning') -----
- scanFile: aFile from: startPosition to: stopPosition
-
- file := aFile.
- changeList := OrderedCollection new.
- list := OrderedCollection new.
- listIndex := 0.
- file position: startPosition.
- ('Scanning {1}...' translated format: {aFile localName})
- displayProgressFrom: startPosition to: stopPosition
- during: [:bar | | prevChar itemPosition item |
- [ [file position < stopPosition]
- whileTrue:
- [bar value: file position.
- [file atEnd not and: [file peek isSeparator]]
- whileTrue: [prevChar := file next].
- (file peekFor: $!!)
- ifTrue:
- [(prevChar = Character cr or: [prevChar = Character lf])
- ifTrue: [self scanCategory]]
- ifFalse:
- [itemPosition := file position.
- item := file nextChunk.
- file skipStyleChunk.
- item size > 0 ifTrue:
- [(item beginsWith: '----')
- ifTrue:
- [self addItem: (ChangeRecord new
- file: file position: itemPosition type: #misc)
- text: 'misc: ' , (item contractTo: 50)]
- ifFalse:
- [self addItem: (ChangeRecord new
- file: file position: itemPosition type: #doIt)
- text: 'do it: ' , (item contractTo: 50)]]]]
- ] on: InvalidUTF8 do: [:ex |
- aFile isSourceFile ifTrue: [ex pass] ifFalse: [
- self notify: ex messageText, '\\Proceed to try the legacy MacRoman encoding.' translated withCRs.
- aFile reset; setConverterForOldCode.
- ^ self scanFile: aFile from: startPosition to: stopPosition]] ].
- self resetListSelections.!
Item was removed:
- ----- Method: ChangeList>>selectAll (in category 'menu actions') -----
- selectAll
- listIndex := 0.
- listSelections atAllPut: true.
- self changed: #allSelections!
Item was removed:
- ----- Method: ChangeList>>selectAllBefore (in category 'menu actions') -----
- selectAllBefore
- listIndex <= 1 ifTrue:
- [Project current beep.
- ^self changed: #flash].
- listSelections atAll: (1 to: listIndex - 1) put: true.
- self changed: #allSelections!
Item was removed:
- ----- Method: ChangeList>>selectAllConflicts (in category 'menu actions') -----
- 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."
- Cursor read showWhile:
- [ | aClass aChange |
- 1 to: changeList size do:
- [:i | aChange := changeList at: i.
- listSelections at: i put:
- (aChange type = #method
- and: [(aClass := aChange methodClass) notNil
- and: [ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aChange methodSelector]])]].
- self changed: #allSelections!
Item was removed:
- ----- Method: ChangeList>>selectConflicts (in category 'menu actions') -----
- selectConflicts
- "Selects all method definitions for which there is ALSO an entry in changes"
- Cursor read showWhile:
- [ | change class |
- 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!
Item was removed:
- ----- Method: ChangeList>>selectConflicts: (in category 'menu actions') -----
- selectConflicts: changeSetOrList
- "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList"
- Cursor read showWhile:
- [ | change class |
- (changeSetOrList isKindOf: ChangeSet) ifTrue: [
- 1 to: changeList size do:
- [:i | change := changeList at: i.
- listSelections at: i put:
- (change type = #method
- and: [(class := change methodClass) notNil
- and: [(changeSetOrList atSelector: change methodSelector
- class: class) ~~ #none]])]]
- ifFalse: ["a ChangeList"
- 1 to: changeList size do:
- [:i | change := changeList at: i.
- listSelections at: i put:
- (change type = #method
- and: [(class := change methodClass) notNil
- and: [changeSetOrList list includes: (list at: i)]])]]
- ].
- self changed: #allSelections!
Item was removed:
- ----- Method: ChangeList>>selectConflictsWith (in category 'menu actions') -----
- 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 := ChangesOrganizer 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 := (UIManager default chooseFrom: (aStream contents substrings)).
- index > 0 ifTrue: [
- self selectConflicts: (all at: index)].
- !
Item was removed:
- ----- Method: ChangeList>>selectContentsMatching (in category 'menu actions') -----
- selectContentsMatching
- | pattern |
- pattern := Project uiManager request: 'pattern to match' translated.
- pattern isEmpty ifTrue: [^self].
- ^Cursor execute showWhile:
- [self selectSuchThat: ((pattern includesAnyOf: '?*')
- ifTrue: [[ :change | pattern match: change string]]
- ifFalse: [[ :change | change string includesSubstring: pattern]])]!
Item was removed:
- ----- Method: ChangeList>>selectMethodsForExtantClasses (in category 'menu actions') -----
- selectMethodsForExtantClasses
- ^self selectSuchThat:
- [ :change |
- Smalltalk hasClassNamed: change methodClassName]!
Item was removed:
- ----- Method: ChangeList>>selectMethodsForThisClass (in category 'menu actions') -----
- selectMethodsForThisClass
- self currentChange ifNil: [ ^self ].
- self currentChange methodClassName ifNotNil:
- [:name|
- self selectSuchThat:
- (Sensor leftShiftDown
- ifTrue: [[:change :index| (listSelections at: index) or: [change methodClassName = name]]]
- ifFalse: [[:change| change methodClassName = name]])]!
Item was removed:
- ----- Method: ChangeList>>selectNewMethods (in category 'menu actions') -----
- selectNewMethods
- "Selects all method definitions for which there is no counterpart method in the current image"
- Cursor read showWhile:
- [ | change class |
- 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!
Item was removed:
- ----- Method: ChangeList>>selectSuchThat (in category 'menu actions') -----
- selectSuchThat
- "query the user for a selection criterio. By Lex Spoon. NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:"
- | code block |
- code := Project uiManager request: ('selection criteria for a change named aChangeRecord?\For instance, "{1}"' translated withCRs format: {'aChangeRecord category = ''System-Network'''}).
-
- code isEmpty ifTrue: [^ self ].
-
- block := Compiler evaluate: '[:aChangeRecord | ', code, ']'.
-
- self selectSuchThat: block!
Item was removed:
- ----- Method: ChangeList>>selectSuchThat: (in category 'menu actions') -----
- selectSuchThat: aBlock
- "select all changes for which block returns true"
- listSelections := aBlock numArgs = 2
- ifTrue: [changeList withIndexCollect: aBlock]
- ifFalse: [changeList collect: aBlock].
- self changed: #allSelections!
Item was removed:
- ----- Method: ChangeList>>selectUnchangedDefinitions (in category 'menu actions') -----
- selectUnchangedDefinitions
- "Selects all recognizable definitions for which there is already a definition in the current image, whose source is exactly the same."
- | change class tokens |
- Cursor read showWhile:
- [1 to: changeList size do:
- [:i | change := changeList at: i.
- listSelections at: i put: false.
-
- (change type = #method
- and: [(class := change methodClass) notNil
- and: [class includesSelector: change methodSelector]]) ifTrue:
- [listSelections
- at: i
- put: change string withBlanksCondensed
- = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed].
-
- (change type == #classComment
- and: [(class := change commentClass) notNil]) ifTrue:
- [listSelections at: i put: change string = class comment asString].
-
- change type == #doIt ifTrue:
- [tokens := Scanner new scanTokens: change string.
-
- ((tokens select:
- [:substr| #(subclass: variableSubclass: variableByteSubclass: variableWordSubclass:
- instanceVariableNames: classVariableNames: ) includes: substr])
- asSet size >= 3
- and: [(class := Smalltalk at: tokens third ifAbsent: []) notNil
- and: [class isBehavior]]) ifTrue:
- [listSelections
- at: i
- put: change string withBlanksCondensed
- = class definition withBlanksCondensed].
-
- (tokens size = 4
- and: [tokens second == #class
- and: [tokens third == #instanceVariableNames:
- and: [(class := Smalltalk at: tokens first ifAbsent: []) notNil
- and: [class isBehavior]]]]) ifTrue:
- [listSelections
- at: i
- put: change string withBlanksCondensed
- = class class definition withBlanksCondensed].
-
- (tokens size = 3
- and: [tokens second == #removeSelector:
- and: [(class := Smalltalk at: tokens first ifAbsent: []) isNil
- or: [class isBehavior and: [(class includesSelector: tokens third) not]]]]) ifTrue:
- [listSelections at: i put: true].
-
- (tokens size = 4
- and: [tokens second == #class
- and: [tokens third == #removeSelector:
- and: [(class := Smalltalk at: tokens first ifAbsent: []) isNil
- or: [class isBehavior and: [(class class includesSelector: tokens fourth) not]]]]]) ifTrue:
- [listSelections at: i put: true]]]].
-
- self changed: #allSelections!
Item was removed:
- ----- Method: ChangeList>>selectUnchangedMethods (in category 'menu actions') -----
- 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"
- Cursor read showWhile:
- [ | class change |
- 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!
Item was removed:
- ----- Method: ChangeList>>selectedClass (in category 'viewing access') -----
- selectedClass
- ^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass !
Item was removed:
- ----- Method: ChangeList>>selectedClassOrMetaClass (in category 'viewing access') -----
- selectedClassOrMetaClass
- | c |
- ^ (c := self currentChange) ifNotNil: [c methodClass]!
Item was removed:
- ----- Method: ChangeList>>selectedMessageName (in category 'viewing access') -----
- selectedMessageName
- | c |
- ^ (c := self currentChange) ifNotNil: [c methodSelector]!
Item was removed:
- ----- Method: ChangeList>>setLostMethodPointer: (in category 'accessing') -----
- setLostMethodPointer: sourcePointer
- lostMethodPointer := sourcePointer!
Item was removed:
- ----- Method: ChangeList>>showsVersions (in category 'accessing') -----
- showsVersions
- ^ false!
Item was removed:
- ----- Method: ChangeList>>toggleListIndex: (in category 'viewing access') -----
- toggleListIndex: newListIndex
-
- listIndex = newListIndex ifTrue: [^ self].
- listIndex := newListIndex.
-
- self changed: #listIndex.
- self contentsChanged!
Item was removed:
- ----- Method: ChangeList>>undiffedContents (in category 'viewing access') -----
- undiffedContents
- ^ listIndex = 0
- ifTrue: ['']
- ifFalse: [(changeList at: listIndex) text]!
Item was removed:
- ----- Method: ChangeList>>wantsPrettyDiffOption (in category 'initialization-release') -----
- wantsPrettyDiffOption
- "Answer whether pretty-diffs are meaningful for this tool"
-
- ^ true!
Item was removed:
- ChangeList subclass: #ChangeListForProjects
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Changes'!
-
- !ChangeListForProjects commentStamp: '<historical>' prior: 0!
- A ChangeList that looks at the changes in a revokable project. This class has no users at present.!
Item was removed:
- ----- Method: ChangeListForProjects>>contents (in category 'contents') -----
- contents
- ^ self showingAnyKindOfDiffs
- ifFalse: [self undiffedContents]
- ifTrue: [self currentDiffedFromContents]
- "Current is writing over one in list. Show how I would change it"!
Item was removed:
- ----- Method: ChangeListForProjects>>currentDiffedFromContents (in category 'contents') -----
- 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]!
Item was removed:
- ChangeSorter subclass: #ChangeSetBrowser
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Changes'!
-
- !ChangeSetBrowser commentStamp: '<historical>' prior: 0!
- A tool allowing you to browse the methods of a single change set.!
Item was removed:
- ----- Method: ChangeSetBrowser class>>on: (in category 'instance creation') -----
- on: aChangeSet
-
- ^ self new
- myChangeSet: aChangeSet;
- yourself!
Item was removed:
- ----- Method: ChangeSetBrowser class>>openOn: (in category 'instance creation') -----
- openOn: aChangeSet
-
- ^ ToolBuilder open: (self on: aChangeSet)!
Item was removed:
- ----- Method: ChangeSetBrowser class>>openOnCurrent (in category 'instance creation') -----
- openOnCurrent
-
- ^ self openOn: ChangeSet current!
Item was removed:
- ----- Method: ChangeSetBrowser>>addModelItemsToWindowMenu: (in category 'initialization') -----
- 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' translated action: #rename.
- aMenu add: 'make changes go to me' translated action: #newCurrent.
- aMenu addLine.
- aMenu add: 'file out' translated action: #fileOut.
- aMenu add: 'browse methods' translated action: #browseChangeSet.
- aMenu addLine.
- myChangeSet hasPreamble
- ifTrue:
- [aMenu add: 'edit preamble...' translated action: #editPreamble.
- aMenu add: 'remove preamble' translated action: #removePreamble]
- ifFalse:
- [aMenu add: 'add preamble...' translated action: #editPreamble].
-
- myChangeSet hasPostscript
- ifTrue:
- [aMenu add: 'edit postscript...' translated action: #editPostscript.
- aMenu add: 'remove postscript' translated action: #removePostscript]
- ifFalse:
- [aMenu add: 'add postscript...' translated action: #editPostscript].
- aMenu addLine.
-
- aMenu add: 'destroy change set' translated action: #remove.
- aMenu addLine.
- Smalltalk isMorphic ifTrue:
- [aMenu addLine.
- aMenu add: 'what to show...' translated target: self action: #offerWhatToShowMenu].
- aMenu addLine.
- aMenu add: 'more...' translated action: #offerShiftedChangeSetMenu.
- aMenu defaultTarget: oldTarget.
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSetBrowser>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
-
- | max windowSpec |
- max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5].
- windowSpec := self buildWindowWith: builder specs: {
- (0.0(a)0.0 corner: 0.5@max) -> [self buildClassListWith: builder].
- (0.5(a)0.0 corner: 1.0@max) -> [self buildMessageListWith: builder].
- (0.0@max corner: 1.0(a)1.0) -> [self buildCodePaneWith: builder] }.
- ^ builder build: windowSpec!
Item was removed:
- ----- Method: ChangeSetBrowser>>changeSetMenuForDropInClassCats: (in category 'menu') -----
- changeSetMenuForDropInClassCats: aMenu
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSetBrowser>>changeSetMenuForModification: (in category 'menu') -----
- changeSetMenuForModification: aMenu
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSetBrowser>>changeSetMenuForOpposite: (in category 'menu') -----
- changeSetMenuForOpposite: aMenu
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSetBrowser>>changeSetMenuForPromote: (in category 'menu') -----
- changeSetMenuForPromote: aMenu
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSetBrowser>>offerUnshiftedChangeSetMenu (in category 'menu') -----
- offerUnshiftedChangeSetMenu
- "The user chose 'more' from the shifted window menu; go back to the regular window menu"
-
- self containingWindow ifNotNil: [self containingWindow offerWindowMenu] !
Item was removed:
- ----- Method: ChangeSetBrowser>>wantsAnnotationPane (in category 'initialization') -----
- wantsAnnotationPane
- "This kind of browser always wants annotation panes, so answer true"
-
- ^ true!
Item was removed:
- ----- Method: ChangeSetBrowser>>wantsOptionalButtons (in category 'initialization') -----
- wantsOptionalButtons
- "Sure, why not?"
-
- ^ true!
Item was removed:
- CodeHolder subclass: #ChangeSorter
- instanceVariableNames: 'parent myChangeSet currentClassName currentSelector priorChangeSetList contentsAreStyleable'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Changes'!
-
- !ChangeSorter commentStamp: 'ct 3/10/2021 18:24' prior: 0!
- I display a ChangeSet. Two of me are in a DualChangeSorter.
-
- aStringOrNil
- Instance Variables
- currentClassName: <aStringOrNil>
- currentSelector: <aStringOrNil>
- myChangeSet: <aChangeSet>
- parent: <aDualChangeSorterOrNil>
- priorChangeSetList: <aCollection>
- contentsAreStyleable <aBoolean>
-
-
- currentClassName
- - string parseable into class-name [class] [class trait]
- needs to be fitlered by (self withoutItemAnnotation: currentClassName) to remove pakaging note
-
-
- currentSelector
- - string parseable into selector-name
- needs to be fitlered by (self withoutItemAnnotation: currentSelector) to remove pakaging note
-
- myChangeSet
- - name of current changeset
- parent
- -the dual changesorter that contains this one. Used for dealing with the other half.
- priorChangeSetList
- - holds the current change set list. Used to detect changes in list when a newly generated list no long match the prior list.!
Item was removed:
- ----- Method: ChangeSorter class>>browseChangeSetsWithClass:selector: (in category 'browse') -----
- 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 := ChangeSet allChangeSets select:
- [:cs | (cs atSelector: selector class: class) ~~ #none].
- hits isEmpty ifTrue: [^ self inform: ('{1}\is not in any change set' translated withCRs format: {class name, ' >> #', selector})].
- index := hits size = 1
- ifTrue: [1]
- ifFalse: [(Project uiManager chooseFrom: (hits collect: [:cs | cs name])
- lines: #())].
- index = 0 ifTrue: [^ self].
- (ChangeSorter new myChangeSet: (hits at: index)) open.
- !
Item was removed:
- ----- Method: ChangeSorter class>>browseChangeSetsWithSelector: (in category 'browse') -----
- 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 := ChangeSet allChangeSets select:
- [:cs | cs hasAnyChangeForSelector: aSelector].
- hits isEmpty ifTrue: [^ self inform: ('{1}\is not in any change set' translated withCRs format: {aSelector})].
- index := hits size = 1
- ifTrue: [1]
- ifFalse: [(Project uiManager chooseFrom: (hits collect: [:cs | cs name])
- lines: #())].
- index = 0 ifTrue: [^ self].
- (ChangeSetBrowser new myChangeSet: (hits at: index)) open
-
- "ChangeSorter browseChangeSetsWithSelector: #clearPenTrails"
- !
Item was removed:
- ----- Method: ChangeSorter class>>initialize (in category 'class initialization') -----
- initialize
- "ChangeSorter initialize"
-
- FileServices registerFileReader: self.
-
- self registerInFlapsRegistry.
- !
Item was removed:
- ----- Method: ChangeSorter class>>open (in category 'instance creation') -----
- open
- "Open a new instance of the receiver's class"
-
- self new open!
Item was removed:
- ----- Method: ChangeSorter class>>prototypicalToolWindow (in category 'browse') -----
- prototypicalToolWindow
- "Answer a window representing a prototypical instance of the receiver"
-
- ^ToolBuilder build: self new!
Item was removed:
- ----- Method: ChangeSorter class>>registerInFlapsRegistry (in category 'class initialization') -----
- registerInFlapsRegistry
- "Register the receiver in the system's flaps registry"
- self environment
- at: #Flaps
- ifPresent: [:cl | cl registerQuad: {#ChangeSorter. #prototypicalToolWindow. 'Change Set' translatedNoop. 'A tool that allows you to view and manipulate all the code changes in a single change set' translatedNoop}
- forFlapNamed: 'Tools']!
Item was removed:
- ----- Method: ChangeSorter class>>unload (in category 'initialize-release') -----
- unload
- "Unload the receiver from global registries"
-
- self environment at: #FileServices ifPresent: [:cl |
- cl unregisterFileReader: self].
- self environment at: #Flaps ifPresent: [:cl |
- cl unregisterQuadsWithReceiver: self] !
Item was removed:
- ----- Method: ChangeSorter>>aboutToStyle: (in category 'code pane') -----
- aboutToStyle: aStyler
- "This is a notification that aStyler is about to re-style its text.
- Set the classOrMetaClass in aStyler, so that identifiers
- will be resolved correctly.
- Answer true to allow styling to proceed, or false to veto the styling"
-
- self isModeStyleable ifFalse: [^false].
- aStyler classOrMetaClass: self selectedClassOrMetaClass.
- ^true!
Item was removed:
- ----- Method: ChangeSorter>>addPriorVersionsCountForSelector:ofClass:to: (in category 'annotation') -----
- 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' translated]
- ifNotNil:
- ['version(s) retrievable here' translated]), self annotationSeparator!
Item was removed:
- ----- Method: ChangeSorter>>annotationForPackageforSelector:ofClass: (in category 'annotation') -----
- annotationForPackageforSelector: aSelector ofClass: aClass
- "Provide a line of content for an annotation pane, representing
- information about the given selector and class"
- "requestList"
- | aCategory |
- aClass ifNil: [ ^nil].
- aSelector ifNotNil:
- [ aCategory := aClass organization categoryOfElement: aSelector.
- (aCategory notNil and: [ aCategory first = $* ])
- ifTrue: [^ aCategory asString]] .
-
- "Ok. So the selector category does not indicate our package. We defer to the class category"
- ^ aClass category asString.
- !
Item was removed:
- ----- Method: ChangeSorter>>basicClassList (in category 'class list') -----
- basicClassList
- "Computed. View should try to preserve selections, even though index changes"
-
- ^ myChangeSet ifNotNil: [myChangeSet changedClassNames] ifNil: [OrderedCollection new]
- !
Item was removed:
- ----- Method: ChangeSorter>>basicMessageList (in category 'message list') -----
- basicMessageList
-
- | probe newSelectors className |
- currentClassName ifNil: [^ #()].
- className := (self withoutItemAnnotation: currentClassName) .
- probe := (className endsWith: ' class')
- ifTrue: [className]
- ifFalse: [className asSymbol].
- newSelectors := myChangeSet selectorsInClass: probe.
- (newSelectors includes: (self selectedMessageName))
- ifFalse: [currentSelector := nil].
- ^ newSelectors sort
- !
Item was removed:
- ----- Method: ChangeSorter>>beginNote (in category 'annotation') -----
- beginNote
- "return the string at the beginning of item annotation"
- ^' {'
- !
Item was removed:
- ----- Method: ChangeSorter>>browseChangeSet (in category 'changeSet menu') -----
- browseChangeSet
- "Open a message list browser on the new and changed methods in the current change set"
-
- ChangedMessageSet openFor: myChangeSet
-
- !
Item was removed:
- ----- Method: ChangeSorter>>browseMethodConflicts (in category 'changeSet menu') -----
- 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 |
- (ChangesOrganizer allChangeSetsWithClass: aClass selector: aSelector) size > 1
- ]
- ifNone: [^ self inform: 'No other change set has changes
- for any method in this change set.' translated].
-
- ToolSet
- browseMessageSet: aList
- name: ('Methods in "{1}" that are also in other change sets ({2})' translated format: {myChangeSet name. aList size})
- autoSelect: nil!
Item was removed:
- ----- Method: ChangeSorter>>browseVersions (in category 'message list') -----
- browseVersions
- "Create and schedule a changelist browser on the versions of the
- selected message."
- | class selector method category pair sourcePointer |
-
- (selector := self selectedMessageName) ifNil: [^ self].
- class := self selectedClassOrMetaClass.
- (class includesSelector: selector)
- ifTrue: [method := class compiledMethodAt: selector.
- category := class whichCategoryIncludesSelector: selector.
- sourcePointer := nil]
- ifFalse: [pair := myChangeSet methodInfoFromRemoval: {class name. selector}.
- pair ifNil: [^ nil].
- sourcePointer := pair first.
- method := CompiledMethod toReturnSelfTrailerBytes:
- (CompiledMethodTrailer new sourcePointer: sourcePointer).
- category := pair second].
- VersionsBrowser
- browseVersionsOf: method
- class: self selectedClass meta: class isMeta
- category: category selector: selector
- lostMethodPointer: sourcePointer.
- !
Item was removed:
- ----- Method: ChangeSorter>>buildChangeSetListWith: (in category 'toolbuilder') -----
- buildChangeSetListWith: builder
-
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #changeSetList;
- getSelected: #currentCngSet;
- setSelected: #showChangeSetNamed:;
- menu: #changeSetMenu:shifted:;
- keyPress: #changeSetListKey:from:;
- dragItem: #dragChangeSet:;
- autoDeselect: false.
- ^ listSpec!
Item was removed:
- ----- Method: ChangeSorter>>buildClassListWith: (in category 'toolbuilder') -----
- buildClassListWith: builder
-
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #classList;
- getSelected: #currentClassName;
- setSelected: #currentClassName:;
- menu: #classListMenu:shifted:;
- keyPress: #classListKey:from:;
- dragItem: #dragClass:.
- ^ listSpec!
Item was removed:
- ----- Method: ChangeSorter>>buildMessageListWith: (in category 'toolbuilder') -----
- buildMessageListWith: builder
-
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #messageList;
- getSelected: #currentSelector;
- setSelected: #currentSelector:;
- menu: #messageMenu:shifted:;
- keyPress: #messageListKey:from:;
- dragItem: #dragMessage:.
- ^ listSpec!
Item was removed:
- ----- Method: ChangeSorter>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
-
- ^ self
- buildWith: builder
- in: (self buildWindowWith: builder)
- rect: (0@0 extent: 1@1)!
Item was removed:
- ----- Method: ChangeSorter>>buildWith:in:rect: (in category 'toolbuilder') -----
- buildWith: builder in: window rect: rect
-
- | windowSpec offset factor |
- offset := rect origin.
- factor := rect extent.
- windowSpec := self buildWindow: window with: builder specs: (({
- (0.0(a)0.0 corner: 0.5(a)0.25) -> [self buildChangeSetListWith: builder].
- (0.5(a)0.0 corner: 1.0(a)0.25) -> [self buildClassListWith: builder].
- (0.0(a)0.25 corner: 1.0(a)0.5) -> [self buildMessageListWith: builder].
- (0.0(a)0.5 corner: 1.0(a)1.0) -> [self buildCodePaneWith: builder] })
- collect: [:spec | ((spec key scaleBy: factor) translateBy: offset) -> spec value]).
- ^ builder build: windowSpec!
Item was removed:
- ----- Method: ChangeSorter>>changeSet (in category 'access') -----
- changeSet
- ^ myChangeSet!
Item was removed:
- ----- Method: ChangeSorter>>changeSetCategories (in category 'changeSet menu') -----
- changeSetCategories
-
- ^ ChangesOrganizer changeSetCategories!
Item was removed:
- ----- Method: ChangeSorter>>changeSetCurrentlyDisplayed (in category 'access') -----
- changeSetCurrentlyDisplayed
- ^ myChangeSet!
Item was removed:
- ----- Method: ChangeSorter>>changeSetList (in category 'changeSet menu') -----
- changeSetList
- "Answer a list of ChangeSet names to be shown in the change sorter."
-
- ^ChangeSet allChangeSets reverse collect: [:cs | cs name]!
Item was removed:
- ----- Method: ChangeSorter>>changeSetListKey:from: (in category 'changeSet menu') -----
- 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 editPreamble].
- aChar == $r ifTrue: [^ self rename].
- aChar == $x ifTrue: [^ self remove].
- aChar == $- ifTrue: [^ self subtractOtherSide].
-
- ^ self messageListKey: aChar from: view!
Item was removed:
- ----- Method: ChangeSorter>>changeSetMenu:shifted: (in category 'changeSet menu') -----
- changeSetMenu: aMenu shifted: isShifted
-
- ^ self menu: aMenu for: #( changeSetMenu changeSetMenuShifted: ) shifted: isShifted
- !
Item was removed:
- ----- Method: ChangeSorter>>changeSetMenuForDropInClassCats: (in category 'changeSet menu') -----
- changeSetMenuForDropInClassCats: aMenu
-
- aMenu add: 'remove contained in class categories...' translated action: #removeContainedInClassCategories.
- aMenu balloonTextForLastItem: ' Drops any changes in given class categories' translated.
-
- ^ aMenu
- !
Item was removed:
- ----- Method: ChangeSorter>>changeSetMenuForModification: (in category 'changeSet menu') -----
- changeSetMenuForModification: aMenu
-
- aMenu addLine.
-
- aMenu add: 'file into new...' translated 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.)' translated.
-
- aMenu add: 'reorder all change sets' translated 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' translated.
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSorter>>changeSetMenuForOpposite: (in category 'changeSet menu') -----
- changeSetMenuForOpposite: aMenu
-
- parent ifNotNil:
- [aMenu add: 'conflicts with change set opposite' translated 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.' translated].
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSorter>>changeSetMenuForPromote: (in category 'changeSet menu') -----
- changeSetMenuForPromote: aMenu
-
- aMenu add: 'promote to top of list' translated action: #promoteToTopChangeSet.
- aMenu balloonTextForLastItem:
- 'Make this change set appear first in change-set lists in all change sorters.' translated.
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSorter>>checkForAlienAuthorship (in category 'changeSet menu') -----
- checkForAlienAuthorship
- "Open a message list browser on all uncommented methods in the current change set that have alien authorship"
-
- myChangeSet checkForAlienAuthorship
-
- !
Item was removed:
- ----- Method: ChangeSorter>>checkForAnyAlienAuthorship (in category 'changeSet menu') -----
- checkForAnyAlienAuthorship
- "Open a message list browser on all uncommented methods in the current change set that have alien authorship, even historically"
-
- myChangeSet checkForAnyAlienAuthorship
-
- !
Item was removed:
- ----- Method: ChangeSorter>>checkForUnclassifiedMethods (in category 'changeSet menu') -----
- checkForUnclassifiedMethods
- "Open a message list browser on all methods in the current change set that have not been categorized"
-
- myChangeSet checkForUnclassifiedMethods
-
- !
Item was removed:
- ----- Method: ChangeSorter>>checkForUncommentedClasses (in category 'changeSet menu') -----
- checkForUncommentedClasses
- "Open a class list browser on classes in the change set that lack class comments"
-
- myChangeSet checkForUncommentedClasses!
Item was removed:
- ----- Method: ChangeSorter>>checkForUncommentedMethods (in category 'changeSet menu') -----
- checkForUncommentedMethods
- "Open a message list browser on all uncommented methods in the current change set"
-
- myChangeSet checkForUncommentedMethods
-
- !
Item was removed:
- ----- Method: ChangeSorter>>checkForUnsentMessages (in category 'changeSet menu') -----
- checkForUnsentMessages
- "Open a message list browser on all unsent messages in the current change set"
-
- myChangeSet checkForUnsentMessages
-
- !
Item was removed:
- ----- Method: ChangeSorter>>checkThatSidesDiffer: (in category 'changeSet menu') -----
- checkThatSidesDiffer: escapeBlock
- "If the change sets on both sides of the dual sorter are the same, put up an error message and escape via escapeBlock, else proceed happily"
-
- parent ifNil: [^ escapeBlock value]. "Not relevant unless in dual change sorter."
-
- (myChangeSet == (parent other: self) changeSet)
- ifTrue:
- [self inform:
- 'This command requires that the
- change sets selected on the two
- sides of the change sorter *not*
- be the same.' translated.
- ^ escapeBlock value]
- !
Item was removed:
- ----- Method: ChangeSorter>>chooseCngSet (in category 'changeSet menu') -----
- 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 sorted:
- [:a :b | a asLowercase withoutLeadingDigits < b asLowercase withoutLeadingDigits].
-
- chosen := UIManager default chooseFrom: changeSetsSortedAlphabetically values: changeSetsSortedAlphabetically.
- chosen ifNil: [^ self].
- self showChangeSet: (ChangesOrganizer changeSetNamed: chosen)!
Item was removed:
- ----- Method: ChangeSorter>>classList (in category 'class list') -----
- classList
- "return the classlist with package note appended."
-
- ^ self basicClassList collect: [: each |
- each asString, (self packageNoteForClass: (Smalltalk classNamed: each) selector: nil) ] .!
Item was removed:
- ----- Method: ChangeSorter>>classListKey:from: (in category 'class list') -----
- 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"!
Item was removed:
- ----- Method: ChangeSorter>>classListMenu:shifted: (in category 'class list') -----
- classListMenu: aMenu shifted: shifted
- "Fill aMenu with items appropriate for the class list"
- ^ self menu: aMenu for: #(classListMenu classListMenuShifted:) shifted: shifted
- !
Item was removed:
- ----- Method: ChangeSorter>>classMenu: (in category 'class list') -----
- 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!
Item was removed:
- ----- Method: ChangeSorter>>classMenu:shifted: (in category 'class list') -----
- classMenu: aMenu shifted: shifted
- "Fill aMenu with items appropriate for the class list. Retained for bkwd compatibility"
-
- ^ self classListMenu: aMenu shifted: shifted!
Item was removed:
- ----- Method: ChangeSorter>>clearChangeSet (in category 'changeSet menu') -----
- clearChangeSet
- "Clear out the current change set, after getting a confirmation."
- | message |
-
- self okToChange ifFalse: [^ self].
- myChangeSet isEmpty ifFalse:
- [message := 'Are you certain that you want to\forget all the changes in this set?' translated withCRs.
- (self confirm: message) ifFalse: [^ self]].
- myChangeSet clear.
- self changed: #classList.
- self changed: #messageList.
- self setContents.
- self contentsChanged.
- !
Item was removed:
- ----- Method: ChangeSorter>>contents:notifying: (in category 'code pane') -----
- contents: aString notifying: aController
- "Compile the code in aString. Notify aController of any syntax errors.
- Create an error if the category of the selected message is unknown.
- Answer false if the compilation fails. Otherwise, if the compilation
- created a new method, deselect the current selection. Then answer true."
- | category selector class oldSelector |
-
- (class := self selectedClassOrMetaClass) ifNil:
- [(myChangeSet preambleString == nil or: [aString size = 0]) ifTrue: [ ^ false].
- (aString count: [:char | char == $"]) odd
- ifTrue: [self inform: 'unmatched double quotes in preamble' translated]
- ifFalse: [(Scanner new scanTokens: aString) size > 0 ifTrue: [
- self inform: 'Part of the preamble is not within double-quotes.
- To put a double-quote inside a comment, type two double-quotes in a row.
- (Ignore this warning if you are including a doIt in the preamble.)' translated]].
- myChangeSet preambleString: aString.
- self currentSelector: nil. "forces update with no 'unsubmitted chgs' feedback"
- ^ true].
- oldSelector := self selectedMessageName.
- category := class organization categoryOfElement: oldSelector.
- selector := class compile: aString
- classified: category
- notifying: aController.
- selector ifNil: [^ false].
- (self messageList includes: selector)
- ifTrue: [self currentSelector: selector]
- ifFalse: [self currentSelector: oldSelector].
- self update.
- ^ true!
Item was removed:
- ----- Method: ChangeSorter>>copyAllToOther (in category 'changeSet menu') -----
- copyAllToOther
- "Copy this entire change set into the one on the other side"
- | companionSorter |
- self checkThatSidesDiffer: [^ self].
- (companionSorter := parent other: self) changeSetCurrentlyDisplayed assimilateAllChangesFoundIn: myChangeSet.
- companionSorter changed: #classList. "Later the changeSet itself will notice..."
- companionSorter changed: #messageList!
Item was removed:
- ----- Method: ChangeSorter>>copyClassToOther (in category 'class list') -----
- 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.!
Item was removed:
- ----- Method: ChangeSorter>>copyMethodToOther (in category 'message list') -----
- copyMethodToOther
- "Place this change in the other changeSet also"
- | other cls sel |
- self checkThatSidesDiffer: [^ self].
- currentSelector ifNotNil:
- [other := (parent other: self) changeSet.
- cls := self selectedClassOrMetaClass.
- sel := self selectedMessageName.
-
- other absorbMethod: sel class: cls from: myChangeSet.
- (parent other: self) showChangeSet: other]
- !
Item was removed:
- ----- Method: ChangeSorter>>currentClassName (in category 'class list') -----
- currentClassName
-
- ^ currentClassName!
Item was removed:
- ----- Method: ChangeSorter>>currentClassName: (in category 'class list') -----
- currentClassName: aString
-
- currentClassName := aString.
- self changed: #currentClassName.
- self changed: #messageList.
-
- self currentSelector: (self messageList ifEmpty: [nil] ifNotEmpty: [:list | list first]).
- !
Item was removed:
- ----- Method: ChangeSorter>>currentCngSet (in category 'changeSet menu') -----
- currentCngSet
- ^ myChangeSet name!
Item was removed:
- ----- Method: ChangeSorter>>currentSelector (in category 'message list') -----
- currentSelector
-
- ^ currentSelector!
Item was removed:
- ----- Method: ChangeSorter>>currentSelector: (in category 'message list') -----
- currentSelector: messageName
-
- currentSelector := messageName.
- self changed: #currentSelector.
- self setContents.
- self contentsChanged.
- self decorateButtons.!
Item was removed:
- ----- Method: ChangeSorter>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.719 g: 0.9 b: 0.9)!
Item was removed:
- ----- Method: ChangeSorter>>dragChangeSet: (in category 'dragging') -----
- dragChangeSet: anIndex
-
- anIndex = 0 ifTrue: [^ nil].
- ^ ChangesOrganizer changeSetNamed: (self changeSetList at: anIndex) !
Item was removed:
- ----- Method: ChangeSorter>>dragClass: (in category 'dragging') -----
- dragClass: anIndex
-
- anIndex = 0 ifTrue: [^ nil].
- ^ (Smalltalk classNamed: (self basicClassList at: anIndex)) classReference!
Item was removed:
- ----- Method: ChangeSorter>>dragMessage: (in category 'dragging') -----
- dragMessage: anIndex
-
- anIndex = 0 ifTrue: [^ nil].
- ^ MethodReference
- class: self selectedClassOrMetaClass
- selector: (self basicMessageList at: anIndex)!
Item was removed:
- ----- Method: ChangeSorter>>editPostscript (in category 'changeSet menu') -----
- editPostscript
- "Allow the user to edit the receiver's change-set's postscript -- in a separate window"
-
- myChangeSet editPostscript!
Item was removed:
- ----- Method: ChangeSorter>>editPreamble (in category 'changeSet menu') -----
- editPreamble
- "Allow the user to edit the receiver's change-set's preamble -- in a separate window"
-
- myChangeSet editPreamble!
Item was removed:
- ----- Method: ChangeSorter>>endNote (in category 'annotation') -----
- endNote
- "return the string at the beginning of item annotation"
- ^'}'
- !
Item was removed:
- ----- Method: ChangeSorter>>expungeUniclasses (in category 'changeSet menu') -----
- expungeUniclasses
- "remove all memory of uniclasses in the receiver"
-
- self okToChange ifFalse: [^ self].
- myChangeSet expungeUniclasses.
- self changed: #classList.
- self changed: #messageList.
-
- !
Item was removed:
- ----- Method: ChangeSorter>>fileIntoNewChangeSet (in category 'changeSet menu') -----
- 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."
- self okToChange
- ifFalse: [^ self].
- ChangeSet promptForDefaultChangeSetDirectoryIfNecessary.
-
- (FileChooserDialog openOn: ChangeSet defaultChangeSetDirectory) ifNotNil:
- [:fileName |
- FileStream oldFileNamed: fileName do:
- [:stream | | localName |
- localName := FileDirectory localNameFor: fileName.
- (ChangeSet newChangesFromStream: stream named: localName)
- ifNotNil: [:aNewChangeSet | self showChangeSet: aNewChangeSet]]].!
Item was removed:
- ----- Method: ChangeSorter>>fileOut (in category 'changeSet menu') -----
- fileOut
- "File out the current change set."
-
- myChangeSet fileOut.
- parent modelWakeUp. "notice object conversion methods created"
- !
Item was removed:
- ----- Method: ChangeSorter>>fileOutClass (in category 'class list') -----
- fileOutClass
- "this is a hack!!!! makes a new change set, called the class name, adds author initials to try to make a unique change set name, files it out and removes it. kfr 16 june 2000"
- | aSet |
- "File out the selected class set."
- aSet := ChangeSet newChangeSet: (self withoutItemAnnotation: currentClassName).
- aSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet.
- aSet fileOut.
- ChangeSet removeChangeSet: aSet.
- parent modelWakeUp. "notice object conversion methods created"
-
- !
Item was removed:
- ----- Method: ChangeSorter>>findCngSet (in category 'changeSet menu') -----
- 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 := Project uiManager request: 'ChangeSet name or fragment?' translated.
- pattern isEmpty ifTrue: [^ self].
- nameList := self changeSetList asSet.
- candidates := ChangeSet 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 := Project uiManager chooseFrom: (candidates collect: [:each | each name]).
- index = 0 ifFalse: [self showChangeSet: (candidates at: index)].
- !
Item was removed:
- ----- Method: ChangeSorter>>forget (in category 'message list') -----
- forget
- "Drop this method from the changeSet"
-
- | className index messageList |
- self okToChange ifFalse: [^ self].
- currentSelector ifNil: [^ self].
- className := self currentClassName.
- index := self messageList indexOf: currentSelector.
- myChangeSet
- removeSelectorChanges: self selectedMessageName
- class: self selectedClassOrMetaClass.
- self changed: #classList.
- self changed: #messageList.
- (self classList includes: className)
- ifFalse: ["Last entry removed"
- self currentClassName: nil]
- ifTrue: [
- messageList := self messageList.
- self currentSelector: (messageList isEmpty ifFalse:
- [messageList at: (index min: messageList size)])].!
Item was removed:
- ----- Method: ChangeSorter>>forgetClass (in category 'class list') -----
- forgetClass
- "Remove all mention of this class from the changeSet.
- After forgetting, select at the same point in the class
- list, which helps if e.g. doing something repetitive such
- as moving a number of classes to the other side."
- | index classList |
- self okToChange ifFalse: [^ self].
- currentClassName ifNil: [^self].
- index := self classList indexOf: currentClassName.
- myChangeSet removeClassChanges: (self withoutItemAnnotation: currentClassName).
- self changed: #classList.
- classList := self classList.
- self currentClassName: (classList isEmpty ifFalse:
- [classList at: (index min: classList size)]).!
Item was removed:
- ----- Method: ChangeSorter>>goToChangeSetsProject (in category 'changeSet menu') -----
- goToChangeSetsProject
- "Transport the user to a project which bears the selected changeSet as its current changeSet"
-
- | aProject |
- (aProject := myChangeSet correspondingProject)
- ifNotNil:
- [aProject enter: false revert: false saveForRevert: false]
- ifNil:
- [self inform: 'Has no project' translated]!
Item was removed:
- ----- Method: ChangeSorter>>initialize (in category 'initialize') -----
- initialize
- super initialize.
- self showChangeSet: ChangeSet current.!
Item was removed:
- ----- Method: ChangeSorter>>inspectChangeSet (in category 'changeSet menu') -----
- inspectChangeSet
- "Open a message list browser on the new and changed methods in the current change set"
-
- myChangeSet inspectWithLabel: ('Change set: {1}' translated format: {myChangeSet name})
-
- !
Item was removed:
- ----- Method: ChangeSorter>>isModeStyleable (in category 'contents') -----
- isModeStyleable
-
- ^ currentCompiledMethod notNil
- and: [super isModeStyleable]!
Item was removed:
- ----- Method: ChangeSorter>>label (in category 'access') -----
- label
- ^ self labelString!
Item was removed:
- ----- Method: ChangeSorter>>labelString (in category 'access') -----
- 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 "{1}"' translated format: {myChangeSet name}]
- ifFalse: ['ChangeSet: {1}' translated format: {myChangeSet name}])]!
Item was removed:
- ----- Method: ChangeSorter>>lookForSlips (in category 'changeSet menu') -----
- lookForSlips
- "Open a message list browser on the new and changed methods in the current change set"
-
- myChangeSet lookForSlips
-
- !
Item was removed:
- ----- Method: ChangeSorter>>mailOut (in category 'changeSet menu') -----
- mailOut
- "Create a mail with a gzipped attachment holding out the current change
- set. "
- myChangeSet mailOut.
- parent modelWakeUp!
Item was removed:
- ----- Method: ChangeSorter>>mainButtonName (in category 'changeSet menu') -----
- mainButtonName
-
- ^ myChangeSet name!
Item was removed:
- ----- Method: ChangeSorter>>mainClassListMenu: (in category 'class list') -----
- mainClassListMenu: aMenu
- "Fill aMenu with items appropriate for the class list"
-
- <classListMenuShifted: false>
- aMenu title: 'class list' translated.
- aMenu addStayUpItemSpecial.
- parent ifNotNil: [
- aMenu addTranslatedList: #( "These two only apply to dual change sorters"
- ('copy class chgs to other side' copyClassToOther)
- ('move class chgs to other side' moveClassToOther))].
-
- aMenu addTranslatedList: #(
- -
- ('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)
- -
- ('references... (r)' browseVariableReferences)
- ('assignments... (a)' browseVariableAssignments)
- ('class refs (N)' browseClassRefs)
- -
- ('more...' offerShiftedClassListMenu)).
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSorter>>messageList (in category 'message list') -----
- messageList
- | thisClass organization |
- (thisClass := self selectedClassOrMetaClass) ifNil: [^ #() ] .
- organization := thisClass organization.
- ^self basicMessageList collect: [ :each |
- each asString , (self noteString: (organization categoryOfElement: each))].
- !
Item was removed:
- ----- Method: ChangeSorter>>messageListKey:from: (in category 'class list') -----
- messageListKey: aChar from: view
- "Respond to a Command key in the message-list pane."
-
- aChar == $d ifTrue: [^ self forget].
- super messageListKey: aChar from: view!
Item was removed:
- ----- Method: ChangeSorter>>messageListMenu:shifted: (in category 'message list') -----
- 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!
Item was removed:
- ----- Method: ChangeSorter>>messageMenu:shifted: (in category 'message list') -----
- messageMenu: aMenu shifted: shifted
- "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter"
-
- ^ self menu: aMenu for: #(messageListMenu messageListMenuShifted:) shifted: shifted!
Item was removed:
- ----- Method: ChangeSorter>>methodConflictsWithOtherSide (in category 'changeSet menu') -----
- 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.' translated].
-
- ToolSet
- browseMessageSet: aList
- name: ('Methods in "{1}" that are also in {2} ({3})' translated format: {myChangeSet name. other name. aList size})
- autoSelect: nil!
Item was removed:
- ----- Method: ChangeSorter>>modelWakeUp (in category 'access') -----
- modelWakeUp
- "A window with me as model is being entered.
- Make sure I am up-to-date with the changeSets."
-
- self canDiscardEdits ifTrue: [self update]!
Item was removed:
- ----- Method: ChangeSorter>>moveClassToOther (in category 'class list') -----
- 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!
Item was removed:
- ----- Method: ChangeSorter>>moveMethodToOther (in category 'message list') -----
- 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: [^Beeper beep].
- cls := self selectedClassOrMetaClass.
- sel := self selectedMessageName.
- other
- absorbMethod: sel
- class: cls
- from: myChangeSet.
- (parent other: self) showChangeSet: other.
- self forget "removes the method from this side"]!
Item was removed:
- ----- Method: ChangeSorter>>myChangeSet: (in category 'access') -----
- myChangeSet: anObject
- myChangeSet := anObject!
Item was removed:
- ----- Method: ChangeSorter>>newCurrent (in category 'changeSet menu') -----
- 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.!
Item was removed:
- ----- Method: ChangeSorter>>newSet (in category 'changeSet menu') -----
- 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 := ChangeSet newChangeSet.
- aSet ifNotNil:[
- self update.
- self showChangeSet: aSet.
- self changed: #relabel]!
Item was removed:
- ----- Method: ChangeSorter>>noteString: (in category 'annotation') -----
- noteString: aString
- ^ self beginNote , aString asString , self endNote!
Item was removed:
- ----- Method: ChangeSorter>>offerShiftedChangeSetMenu (in category 'changeSet menu') -----
- offerShiftedChangeSetMenu
- "Offer the shifted version of the change set menu"
-
- self offerMenuFrom: #changeSetMenu:shifted: shifted: true!
Item was removed:
- ----- Method: ChangeSorter>>offerUnshiftedChangeSetMenu (in category 'changeSet menu') -----
- offerUnshiftedChangeSetMenu
- "Offer the unshifted version of the change set menu"
-
- self offerMenuFrom: #changeSetMenu:shifted: shifted: false!
Item was removed:
- ----- Method: ChangeSorter>>open (in category 'creation') -----
- open
- "ChangeSorterPluggable new open"
- ^ToolBuilder open: self!
Item was removed:
- ----- Method: ChangeSorter>>openChangeSetBrowser (in category 'changeSet menu') -----
- openChangeSetBrowser
- "Open a ChangeSet browser on the current change set"
- ToolBuilder open: (ChangeSetBrowser new myChangeSet: myChangeSet)!
Item was removed:
- ----- Method: ChangeSorter>>packageNoteForClass:selector: (in category 'annotation') -----
- packageNoteForClass: aClass selector: aSelector
- "return the category name that represents the package name for aClass>>aSelector.
- when selector is nil or in a normal catagory return "
- | package |
- package := (self annotationForPackageforSelector: aSelector
- ofClass: aClass) ifNil: ['<class was deleted???>' translated] .
-
- ^ self noteString: package
-
-
-
-
-
-
- !
Item was removed:
- ----- Method: ChangeSorter>>parent (in category 'access') -----
- parent
- ^ parent!
Item was removed:
- ----- Method: ChangeSorter>>parent: (in category 'access') -----
- parent: anObject
- parent := anObject!
Item was removed:
- ----- Method: ChangeSorter>>promoteToTopChangeSet (in category 'changeSet menu') -----
- promoteToTopChangeSet
- "Move the selected change-set to the top of the list"
-
- ChangeSet promoteToTop: myChangeSet.
- (parent ifNil: [self]) modelWakeUp!
Item was removed:
- ----- Method: ChangeSorter>>remove (in category 'changeSet menu') -----
- remove
- "Completely destroy my change set. Check if it's OK first"
-
- self okToChange ifFalse: [^ self].
- self removePrompting: true.
- self update!
Item was removed:
- ----- Method: ChangeSorter>>removeContainedInClassCategories (in category 'changeSet menu') -----
- removeContainedInClassCategories
- | matchExpression |
- myChangeSet removePreamble.
- matchExpression := Project uiManager request: 'Enter class category name (wildcard is ok)' translated initialAnswer: 'System-*'.
- (Smalltalk organization categories
- select: [:each | matchExpression match: each])
- do: [:eachCat |
- | classNames |
- classNames := Smalltalk organization listAtCategoryNamed: eachCat.
- classNames
- do: [:eachClassName |
- myChangeSet removeClassChanges: eachClassName.
- myChangeSet removeClassChanges: eachClassName , ' class'].
- self showChangeSet: myChangeSet]!
Item was removed:
- ----- Method: ChangeSorter>>removeFromCurrentChanges (in category 'message list') -----
- removeFromCurrentChanges
- "Redisplay after removal in case we are viewing the current changeSet"
-
- super removeFromCurrentChanges.
- currentSelector := nil.
- self showChangeSet: myChangeSet!
Item was removed:
- ----- Method: ChangeSorter>>removeMessage (in category 'message list') -----
- removeMessage
-
- ^ super removeMessage
- ifTrue: [self update];
- yourself!
Item was removed:
- ----- Method: ChangeSorter>>removePostscript (in category 'changeSet menu') -----
- removePostscript
- (myChangeSet hasPostscript and: [myChangeSet postscriptHasDependents]) ifTrue:
- [^ self inform:
- 'Cannot remove the postscript right
- now because there is at least one
- window open on that postscript.
- Close that window and try again.' translated].
-
- myChangeSet removePostscript.!
Item was removed:
- ----- Method: ChangeSorter>>removePreamble (in category 'changeSet menu') -----
- removePreamble
- myChangeSet removePreamble.!
Item was removed:
- ----- Method: ChangeSorter>>removePrompting: (in category 'changeSet menu') -----
- 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 "{1}" ?' translated format: {aName}.
- (self confirm: message) ifFalse: [^ self]].
-
- doPrompt ifTrue:
- [msg := myChangeSet hasPreamble
- ifTrue:
- [myChangeSet hasPostscript
- ifTrue:
- ['a preamble and a postscript' translated]
- ifFalse:
- ['a preamble' translated]]
- ifFalse:
- [myChangeSet hasPostscript
- ifTrue:
- ['a postscript' translated]
- ifFalse:
- ['']].
- msg isEmpty ifFalse:
- [(self confirm:
- ('Caution!! This change set has
- {1} which will be
- lost if you destroy the change set.
- Do you really want to go ahead with this?' translated format: {msg})) ifFalse: [^ self]]].
-
- "Go ahead and remove the change set"
- changeSetNumber := myChangeSet name initialIntegerOrNil.
- changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber].
- ChangesOrganizer removeChangeSet: myChangeSet.
- self changed: #changeSetList.
- self showChangeSet: ChangeSet current.!
Item was removed:
- ----- Method: ChangeSorter>>rename (in category 'changeSet menu') -----
- rename
- "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out"
-
- | newName |
- newName := Project uiManager request: 'New name for this change set' translated
- initialAnswer: myChangeSet name.
- (newName = myChangeSet name or: [newName size = 0]) ifTrue:
- [^ self].
-
- (ChangeSet named: newName) ifNotNil:
- [^ Project uiManager inform: 'Sorry that name is already used' translated].
-
- myChangeSet name: newName.
- self update.
- self changed: #mainButtonName.
- self changed: #relabel.!
Item was removed:
- ----- Method: ChangeSorter>>reorderChangeSets (in category 'changeSet menu') -----
- reorderChangeSets
- "apply a standard reordering -- let the class handle this"
-
- ^ ChangesOrganizer reorderChangeSets!
Item was removed:
- ----- Method: ChangeSorter>>selectedClass (in category 'class list') -----
- selectedClass
- "Answer the currently-selected class. If there is no selection, or if the selection refers to a class no longer extant, return nil"
- | c |
- ^ currentClassName ifNotNil: [(c := self selectedClassOrMetaClass)
- ifNotNil: [c theNonMetaClass]]!
Item was removed:
- ----- Method: ChangeSorter>>selectedClassOrMetaClass (in category 'traits') -----
- selectedClassOrMetaClass
- "Careful, the class may have been removed!!"
-
- | cName tName className |
- currentClassName ifNil: [^ nil].
- className := (self withoutItemAnnotation: currentClassName) .
- (className endsWith: ' class')
- ifTrue: [cName := (className copyFrom: 1 to: className size-6) asSymbol.
- ^ (Smalltalk at: cName ifAbsent: [^nil]) class].
- (currentClassName endsWith: ' classTrait')
- ifTrue: [tName := (className copyFrom: 1 to: className size-11) asSymbol.
- ^ (Smalltalk at: tName ifAbsent: [^nil]) classTrait].
- cName := className asSymbol.
- ^ Smalltalk at: cName ifAbsent: [nil]!
Item was removed:
- ----- Method: ChangeSorter>>selectedMessageName (in category 'message list') -----
- selectedMessageName
-
- currentSelector ifNil: [^ nil].
- ^ (self withoutItemAnnotation: currentSelector) asSymbol!
Item was removed:
- ----- Method: ChangeSorter>>setContents (in category 'code pane') -----
- setContents
- "return the source code that shows in the bottom pane"
-
- | sel class strm changeType |
- self clearUserEditFlag.
- contentsAreStyleable := false.
- currentCompiledMethod := nil.
- myChangeSet ifNil: [^ contents := String empty]. "should not happen but can"
- currentClassName ifNil: [^ contents := myChangeSet preambleString ifNil: [String empty]].
- class := self selectedClassOrMetaClass.
- (sel := self selectedMessageName) == nil
- ifFalse: [changeType := (myChangeSet atSelector: (sel := sel asSymbol) class: class).
- changeType == #remove
- ifTrue: [^ contents := 'Method has been removed (see versions)' translated].
- changeType == #addedThenRemoved
- ifTrue: [^ contents := 'Added then removed (see versions)' translated].
- class ifNil: [^ contents := 'Method was added, but cannot be found!!' translated].
- (class includesSelector: sel)
- ifFalse: [^ contents := 'Method was added, but cannot be found!!' translated].
- contentsAreStyleable := true.
- currentCompiledMethod := class compiledMethodAt: sel.
- contents := class sourceCodeAt: sel.
- (#(prettyPrint prettyDiffs) includes: contentsSymbol) ifTrue:
- [contents := class prettyPrinterClass
- format: contents in: class notifying: nil].
- self showingAnyKindOfDiffs ifTrue: [
- contentsAreStyleable := false.
- contents := self diffFromPriorSourceFor: contents].
- ^ contents := contents asText makeSelectorBoldIn: class]
- ifTrue: [strm := WriteStream on: (String new: 100).
- (myChangeSet classChangeAt: (self withoutItemAnnotation: currentClassName)) do:
- [:each |
- each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.' translated; cr].
- each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.' translated].
- each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.' translated; cr].
- each = #add ifTrue: [strm nextPutAll: 'Class definition was added.' translated; cr].
- each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.' translated; cr].
- each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.' translated; cr].
- each = #comment ifTrue: [strm nextPutAll: 'New class comment.' translated; cr.
- ]].
- ^ contents := strm contents].!
Item was removed:
- ----- Method: ChangeSorter>>setRecentUpdatesMarker (in category 'changeSet menu') -----
- setRecentUpdatesMarker
- "Allow the user to change the recent-updates marker"
-
- | result |
- result := Project uiManager 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 {1})' translated format: {ChangeSet highestNumberedChangeSet}) initialAnswer: ChangesOrganizer recentUpdateMarker recentUpdateMarker asString.
- (result notNil and: [result startsWithDigit]) ifTrue:
- [ChangesOrganizer recentUpdateMarker: result asInteger.
- Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]]!
Item was removed:
- ----- Method: ChangeSorter>>shiftedChangeSetMenu: (in category 'changeSet menu') -----
- shiftedChangeSetMenu: aMenu
- "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down"
-
- <changeSetMenuShifted: true>
-
- aMenu title: 'Change set (shifted)' translated.
- aMenu addStayUpItemSpecial.
-
- "CONFLICTS SECTION"
- aMenu add: 'conflicts with other change sets' translated action: #browseMethodConflicts.
- aMenu balloonTextForLastItem:
- 'Browse all methods that occur both in this change set and in at least one other change set.' translated.
- self changeSetMenuForOpposite: aMenu.
- aMenu addLine.
-
- "CHECKS SECTION"
- aMenu add: 'check for slips' translated action: #lookForSlips.
- aMenu balloonTextForLastItem:
- 'Check this change set for halts and references to Transcript.' translated.
-
- aMenu add: 'check for unsent messages' translated action: #checkForUnsentMessages.
- aMenu balloonTextForLastItem:
- 'Check this change set for messages that are not sent anywhere in the system' translated.
-
- aMenu add: 'check for uncommented methods' translated action: #checkForUncommentedMethods.
- aMenu balloonTextForLastItem:
- 'Check this change set for methods that do not have comments' translated.
-
- aMenu add: 'check for uncommented classes' translated action: #checkForUncommentedClasses.
- aMenu balloonTextForLastItem:
- 'Check for classes with code in this changeset which lack class comments' translated.
-
- Utilities authorInitialsPerSe isEmptyOrNil ifFalse:
- [aMenu add: 'check for other authors' translated action: #checkForAlienAuthorship.
- aMenu balloonTextForLastItem:
- ('Check this change set for methods whose current authoring stamp does not start with "{1}"' translated format: {Utilities authorInitials}).
-
- aMenu add: 'check for any other authors' translated action: #checkForAnyAlienAuthorship.
- aMenu balloonTextForLastItem:
- ('Check this change set for methods any of whose authoring stamps do not start with "{1}"' translated format: {Utilities authorInitials})].
-
- aMenu add: 'check for uncategorized methods' translated 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.' translated.
- aMenu addLine.
-
- aMenu add: 'inspect change set' translated 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.)' translated.
-
- aMenu add: 'update' translated action: #update.
- aMenu balloonTextForLastItem:
- 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)' translated.
-
- aMenu add: 'go to change set''s project' translated action: #goToChangeSetsProject.
- aMenu balloonTextForLastItem:
- 'If this change set is currently associated with a Project, go to that project right now.' translated.
-
- self changeSetMenuForPromote: aMenu.
-
- aMenu add: 'trim history' translated 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' translated.
-
- self changeSetMenuForDropInClassCats: aMenu.
-
- aMenu add: 'clear this change set' translated action: #clearChangeSet.
- aMenu balloonTextForLastItem:
- 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!' translated.
- aMenu add: 'expunge uniclasses' translated 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.' translated.
-
- aMenu add: 'uninstall this change set' translated action: #uninstallChangeSet.
- aMenu balloonTextForLastItem:
- 'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!' translated.
-
- self changeSetMenuForModification: aMenu.
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSorter>>shiftedChangeSetMore: (in category 'changeSet menu') -----
- shiftedChangeSetMore: aMenu
- <changeSetMenuShifted: false>
- <menuPriority: 1000>
- ^ aMenu addTranslatedList: #(
- -
- ('more...' offerShiftedChangeSetMenu));
- yourself!
Item was removed:
- ----- Method: ChangeSorter>>shiftedClassListMenu: (in category 'class list') -----
- shiftedClassListMenu: aMenu
- "Fill aMenu with items appropriate for the class list"
- <classListMenuShifted: true>
-
- aMenu title: 'class list' translated.
- aMenu addStayUpItemSpecial.
-
- aMenu addTranslatedList: #(
- -
- ('unsent methods' browseUnusedMethods)
- ('unreferenced inst vars' showUnreferencedInstVars)
- ('unreferenced class vars' showUnreferencedClassVars)
- -
- ('sample instance' makeSampleInstance)
- ('inspect instances' inspectInstances)
- ('inspect subinstances' inspectSubInstances)
- -
- ('more...' offerUnshiftedClassListMenu )).
-
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSorter>>shiftedMessageMenu: (in category 'message list') -----
- shiftedMessageMenu: aMenu
- "Arm the menu so that it holds items appropriate to the message-list while the shift key is down. Answer the menu."
- <messageListMenuShifted: true>
- ^ aMenu addTranslatedList: #(
- -
- ('toggle diffing (D)' toggleDiffing)
- ('implementors of sent messages' browseAllMessages)
- ('change category...' changeCategory)
- -
- ('sample instance' makeSampleInstance)
- ('inspect instances' inspectInstances)
- ('inspect subinstances' inspectSubInstances)
- -
- ('change sets with this method' findMethodInChangeSets)
- ('revert to previous version' revertToPreviousVersion)
- ('revert & remove from changes' revertAndForget));
- yourself
- !
Item was removed:
- ----- Method: ChangeSorter>>showChangeSet: (in category 'access') -----
- showChangeSet: chgSet
-
- myChangeSet == chgSet ifFalse: [
- myChangeSet := chgSet.
- currentClassName := nil.
- currentSelector := nil].
- self changed: #relabel.
- self changed: #currentCngSet. "new -- list of sets"
- self changed: #mainButtonName. "old, button"
- self changed: #classList.
-
- self currentClassName: (self classList ifEmpty: [nil] ifNotEmpty: [:list | list first]).!
Item was removed:
- ----- Method: ChangeSorter>>showChangeSetNamed: (in category 'access') -----
- showChangeSetNamed: aName
-
- self showChangeSet: (ChangesOrganizer changeSetNamed: aName) !
Item was removed:
- ----- Method: ChangeSorter>>submergeIntoOtherSide (in category 'changeSet menu') -----
- 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 all |
- self checkThatSidesDiffer: [^ self].
- self okToChange ifFalse: [^ self].
- other := (parent other: self) changeSet.
- other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!' translated].
- myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy. To remove,
- simply choose "remove".' translated].
-
- myChangeSet okayToRemove ifFalse: [^ self].
- message := 'Please confirm: copy all changes
- in "{1}" into "{2}"
- and then destroy the change set
- named "{3}"?' translated format: {myChangeSet name. other name. 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?' translated) ifFalse: [^ self]].
-
- other assimilateAllChangesFoundIn: myChangeSet.
- all := ChangeSet allChangeSets.
- nextToView := ((all includes: myChangeSet)
- and: [(i := all indexOf: myChangeSet) < all size])
- ifTrue: [all at: i+1]
- ifFalse: [other].
-
- self removePrompting: false.
- self showChangeSet: nextToView.
- parent modelWakeUp.!
Item was removed:
- ----- Method: ChangeSorter>>subtractOtherSide (in category 'changeSet menu') -----
- subtractOtherSide
- "Subtract the changes found on the other side from the requesting side."
- self checkThatSidesDiffer: [^ self].
- myChangeSet forgetAllChangesFoundIn: ((parent other: self) changeSet).
- self showChangeSet: myChangeSet!
Item was removed:
- ----- Method: ChangeSorter>>toggleDiffing (in category 'code pane') -----
- toggleDiffing
- "Toggle whether diffs should be shown in the code pane"
-
- self okToChange ifTrue:
- [super toggleDiffing.
- self changed: #contents.
- self update]
-
- !
Item was removed:
- ----- Method: ChangeSorter>>trimHistory (in category 'changeSet menu') -----
- trimHistory
- "Drop non-essential history (rename, reorg, method removals) from newly-added classes."
-
- myChangeSet trimHistory
-
- !
Item was removed:
- ----- Method: ChangeSorter>>uninstallChangeSet (in category 'changeSet menu') -----
- uninstallChangeSet
- "Attempt to uninstall the current change set, after confirmation."
-
- self okToChange ifFalse: [^ self].
- (self confirm: 'Uninstalling a changeSet is unreliable at best.
- It will only work if the changeSet consists only of single
- changes, additions and removals of methods, and if
- no subsequent changes have been to any of them.
- No changes to classes will be undone.
- The changeSet will be cleared after uninstallation.
- Do you still wish to attempt to uninstall this changeSet? translated')
- ifFalse: [^ self].
-
- myChangeSet uninstall.
- self changed: #relabel.
- self changed: #classList.
- self changed: #messageList.
- self setContents.
- self contentsChanged.!
Item was removed:
- ----- Method: ChangeSorter>>unshiftedChangeSetMenu: (in category 'changeSet menu') -----
- unshiftedChangeSetMenu: aMenu
- "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter"
- <changeSetMenuShifted: false>
- Smalltalk isMorphic
- ifTrue:
- [aMenu title: 'Change Set' translated]
- ifFalse:
- [aMenu title: 'Change Set:
- ' translated , myChangeSet name].
- aMenu addStayUpItemSpecial.
-
- aMenu add: 'make changes go to me (m)' translated action: #newCurrent.
- aMenu addLine.
- aMenu add: 'new change set... (n)' translated action: #newSet.
- aMenu add: 'find...(f)' translated action: #findCngSet.
- aMenu add: 'select change set...' translated action: #chooseCngSet.
- aMenu addLine.
- aMenu add: 'rename change set (r)' translated action: #rename.
- aMenu add: 'file out (o)' translated action: #fileOut.
- aMenu add: 'mail to list' translated action: #mailOut.
- aMenu add: 'browse methods (b)' translated action: #browseChangeSet.
- aMenu add: 'browse change set (B)' translated action: #openChangeSetBrowser.
- aMenu addLine.
- parent
- ifNotNil:
- [aMenu add: 'copy all to other side (c)' translated action: #copyAllToOther.
- aMenu add: 'submerge into other side' translated action: #submergeIntoOtherSide.
- aMenu add: 'subtract other side (-)' translated action: #subtractOtherSide.
- aMenu addLine].
- myChangeSet hasPreamble
- ifTrue:
- [aMenu add: 'edit preamble... (p)' translated action: #editPreamble.
- aMenu add: 'remove preamble' translated action: #removePreamble]
- ifFalse: [aMenu add: 'add preamble... (p)' translated action: #editPreamble].
- myChangeSet hasPostscript
- ifTrue:
- [aMenu add: 'edit postscript...' translated action: #editPostscript.
- aMenu add: 'remove postscript' translated action: #removePostscript]
- ifFalse: [aMenu add: 'add postscript...' translated action: #editPostscript].
- aMenu addLine.
-
- aMenu add: 'destroy change set (x)' translated action: #remove.
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSorter>>unshiftedChangeSetMore: (in category 'changeSet menu') -----
- unshiftedChangeSetMore: aMenu
- <changeSetMenuShifted: true>
- <menuPriority: 1000>
- ^ aMenu addTranslatedList: #(
- -
- ('more...' offerUnshiftedChangeSetMenu 'Takes you back to the primary change-set menu.'));
- yourself!
Item was removed:
- ----- Method: ChangeSorter>>unshiftedMessageMenu: (in category 'message list') -----
- unshiftedMessageMenu: aMenu
- "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter"
-
- <messageListMenuShifted: false>
-
- aMenu title: 'message list' translated.
- aMenu addStayUpItemSpecial.
-
- parent ifNotNil:
- [aMenu addTranslatedList: #(
- ('copy method to other side' copyMethodToOther)
- ('move method to other side' moveMethodToOther))].
-
- aMenu addTranslatedList: #(
- ('delete method from changeSet (d)' forget)
- -
- ('remove method from system (x)' removeMessage)
- -
- ('browse full (b)' browseMethodFull)
- ('browse hierarchy (h)' spawnHierarchy)
- ('browse protocol (p)' browseFullProtocol)
- -
- ('fileOut' fileOutMessage)
- ('printOut' printOutMessage)
- -
- ('senders of... (n)' browseSendersOfMessages)
- ('implementors of... (m)' browseMessages)
- ('inheritance (i)' methodHierarchy)
- ('versions (v)' browseVersions)).
- ^ aMenu!
Item was removed:
- ----- Method: ChangeSorter>>update (in category 'changeSet menu') -----
- update
- "recompute all of my panes"
-
- self updateIfNecessary.
- parent ifNotNil: [(parent other: self) updateIfNecessary]!
Item was removed:
- ----- Method: ChangeSorter>>updateIfNecessary (in category 'changeSet menu') -----
- updateIfNecessary
- "Recompute all of my panes."
-
- | newList |
- self okToChange ifFalse: [^ self].
-
- myChangeSet ifNil: [^ self]. "Has been known to happen though shouldn't"
- (myChangeSet isMoribund) ifTrue:
- [self changed: #changeSetList.
- ^ self showChangeSet: ChangeSet current].
-
- newList := self changeSetList.
-
- (priorChangeSetList == nil or: [priorChangeSetList ~= newList])
- ifTrue:
- [priorChangeSetList := newList.
- self changed: #changeSetList].!
Item was removed:
- ----- Method: ChangeSorter>>veryDeepFixupWith: (in category 'creation') -----
- veryDeepFixupWith: deepCopier
-
- super veryDeepFixupWith: deepCopier.
- parent := deepCopier references at: parent ifAbsent: [parent].
- self updateIfNecessary!
Item was removed:
- ----- Method: ChangeSorter>>veryDeepInner: (in category 'creation') -----
- 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.
-
-
- !
Item was removed:
- ----- Method: ChangeSorter>>wantsAnnotationPane (in category 'code pane') -----
- wantsAnnotationPane
-
- ^ false!
Item was removed:
- ----- Method: ChangeSorter>>wantsOptionalButtons (in category 'code pane') -----
- wantsOptionalButtons
- "No optional buttons for ChangeSorter"
- ^false!
Item was removed:
- ----- Method: ChangeSorter>>withoutItemAnnotation: (in category 'annotation') -----
- withoutItemAnnotation: aStringOrNil
- "return the current item without the package annotation we added on"
- | endItemIndex |
- aStringOrNil ifNil: [^nil] .
- ( endItemIndex := aStringOrNil findString: self beginNote) = 0
- ifTrue: [^ aStringOrNil ] .
- ^ aStringOrNil first: endItemIndex - 1!
Item was removed:
- MessageSet subclass: #ChangedMessageSet
- instanceVariableNames: 'changeSet'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !ChangedMessageSet commentStamp: '<historical>' 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.!
Item was removed:
- ----- Method: ChangedMessageSet class>>openFor: (in category 'opening') -----
- 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!
Item was removed:
- ----- Method: ChangedMessageSet class>>openMessageList:name:autoSelect:changeSet: (in category 'opening') -----
- openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet
- | messageSet |
- messageSet := self messageList: messageList.
- messageSet changeSet: aChangeSet.
- messageSet autoSelectString: autoSelectString;
- setInitialLabel: labelString.
- ToolBuilder open: messageSet!
Item was removed:
- ----- Method: ChangedMessageSet>>changeSet: (in category 'initialization') -----
- changeSet: aChangeSet
- changeSet := aChangeSet!
Item was removed:
- ----- Method: ChangedMessageSet>>contents:notifying: (in category 'acceptance') -----
- 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 := existingClass newParser parseSelector: aString.
- newSelector ~= existingSelector
- ifTrue: "Selector changed -- maybe an addition"
- [self reformulateList.
- self changed: #messageList.
- self messageList withIndexDo:
- [:aMethodReference :anIndex |
- (aMethodReference actualClass == existingClass and:
- [aMethodReference methodSymbol == newSelector])
- ifTrue:
- [self messageListIndex: anIndex]]]].
- ^ superResult!
Item was removed:
- ----- Method: ChangedMessageSet>>growable (in category 'message list') -----
- growable
- "Answer whether the receiver can be changed by manual additions & deletions"
-
- ^ false!
Item was removed:
- ----- Method: ChangedMessageSet>>reformulateList (in category 'reformulation') -----
- reformulateList
- "Reformulate the message list of the receiver"
-
- self initializeMessageList: (changeSet changedMessageListAugmented select:
- [:each | each isValid])
- !
Item was removed:
- Object subclass: #ChangesOrganizer
- instanceVariableNames: ''
- classVariableNames: 'ChangeSetNamesInRelease RecentUpdateMarker'
- poolDictionaries: ''
- category: 'Tools-Changes'!
-
- !ChangesOrganizer commentStamp: 'cbr 7/27/2010 19:17' prior: 0!
- I manage ChangeSets in the system. See the protocols on my class side.
-
- For an example of what I can do, select the following line in a Workspace and print it.
-
-
- ChangesOrganizer allChangeSetNames!
Item was removed:
- ----- Method: ChangesOrganizer class>>allChangeSetNames (in category 'enumerating') -----
- allChangeSetNames
- ^ ChangeSet allChangeSetNames!
Item was removed:
- ----- Method: ChangesOrganizer class>>allChangeSets (in category 'enumerating') -----
- allChangeSets
- "Return the list of all current ChangeSets"
-
- ^ChangeSet allChangeSets!
Item was removed:
- ----- Method: ChangesOrganizer class>>allChangeSetsWithClass:selector: (in category 'enumerating') -----
- allChangeSetsWithClass: class selector: selector
-
- ^ ChangeSet allChangeSetsWithClass: class selector: selector!
Item was removed:
- ----- Method: ChangesOrganizer class>>assuredChangeSetNamed: (in category 'services') -----
- assuredChangeSetNamed: aName
- "Answer a change set of the given name. If one already exists, answer that, else create a new one and answer it."
-
- ^(self changeSetNamed: aName)
- ifNil:
- [self basicNewChangeSet: aName]!
Item was removed:
- ----- Method: ChangesOrganizer class>>basicNewChangeSet: (in category 'adding') -----
- basicNewChangeSet: newName
- ^ChangeSet basicNewChangeSet: newName!
Item was removed:
- ----- Method: ChangesOrganizer class>>belongsInAdditions: (in category 'class initialization') -----
- 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!
Item was removed:
- ----- Method: ChangesOrganizer class>>belongsInAll: (in category 'class initialization') -----
- belongsInAll: aChangeSet
- "Answer whether a change set belongs in the All category"
-
- ^ true !
Item was removed:
- ----- Method: ChangesOrganizer class>>belongsInMyInitials: (in category 'class initialization') -----
- belongsInMyInitials: aChangeSet
- "Answer whether a change set belongs in the MyInitials category. "
-
- ^ aChangeSet name endsWith: ('-', Utilities authorInitials)!
Item was removed:
- ----- Method: ChangesOrganizer class>>belongsInNumbered: (in category 'class initialization') -----
- belongsInNumbered: aChangeSet
- "Answer whether a change set belongs in the Numbered category. "
-
- ^ aChangeSet name startsWithDigit!
Item was removed:
- ----- Method: ChangesOrganizer class>>belongsInProjectChangeSets: (in category 'class initialization') -----
- belongsInProjectChangeSets: aChangeSet
- "Answer whether a change set belongs in the MyInitials category. "
-
- ^ aChangeSet belongsToAProject!
Item was removed:
- ----- Method: ChangesOrganizer class>>belongsInProjectsInRelease: (in category 'class initialization') -----
- 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]!
Item was removed:
- ----- Method: ChangesOrganizer class>>belongsInRecentUpdates: (in category 'class initialization') -----
- belongsInRecentUpdates: aChangeSet
- "Answer whether a change set belongs in the RecentUpdates category."
-
- ^ aChangeSet name startsWithDigit and:
- [aChangeSet name asInteger >= self recentUpdateMarker]!
Item was removed:
- ----- Method: ChangesOrganizer class>>buildAggregateChangeSet (in category 'services') -----
- buildAggregateChangeSet
-
- ^ ChangeSet buildAggregateChangeSet!
Item was removed:
- ----- Method: ChangesOrganizer class>>changeSet:containsClass: (in category 'enumerating') -----
- changeSet: aChangeSet containsClass: aClass
- | theClass |
- theClass := Smalltalk classNamed: aClass.
- theClass ifNil: [^ false].
- ^ aChangeSet containsClass: theClass!
Item was removed:
- ----- Method: ChangesOrganizer class>>changeSetNamed: (in category 'enumerating') -----
- changeSetNamed: aName
- "Return the change set of the given name, or nil if none found. 1/22/96 sw"
- ^ChangeSet named: aName!
Item was removed:
- ----- Method: ChangesOrganizer class>>changeSetNamesInReleaseImage (in category 'class initialization') -----
- 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]!
Item was removed:
- ----- Method: ChangesOrganizer class>>changeSetNamesInThreeOh (in category 'class initialization') -----
- 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' ) !
Item was removed:
- ----- Method: ChangesOrganizer class>>changeSetsNamedSuchThat: (in category 'enumerating') -----
- changeSetsNamedSuchThat: nameBlock
- ^ChangeSet changeSetsNamedSuchThat: nameBlock!
Item was removed:
- ----- Method: ChangesOrganizer class>>countOfChangeSetsWithClass:andSelector: (in category 'services') -----
- countOfChangeSetsWithClass: aClass andSelector: aSelector
- "Answer how many change sets record a change for the given class and selector"
-
- ^ (self allChangeSetsWithClass: aClass selector: aSelector) size!
Item was removed:
- ----- Method: ChangesOrganizer class>>deleteChangeSetsNumberedLowerThan: (in category 'removing') -----
- deleteChangeSetsNumberedLowerThan: anInteger
- "Delete all changes sets whose names start with integers smaller than anInteger"
-
- self removeChangeSetsNamedSuchThat:
- [:aName | aName first isDigit and: [aName initialIntegerOrNil < anInteger]].
-
- "ChangesOrganizer deleteChangeSetsNumberedLowerThan: (ChangeSorter highestNumberedChangeSet name initialIntegerOrNil - 500)"
- !
Item was removed:
- ----- Method: ChangesOrganizer class>>doesAnyChangeSetHaveClass:andSelector: (in category 'services') -----
- 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!
Item was removed:
- ----- Method: ChangesOrganizer class>>existingOrNewChangeSetNamed: (in category 'enumerating') -----
- existingOrNewChangeSetNamed: aName
- ^ChangeSet existingOrNewChangeSetNamed: aName!
Item was removed:
- ----- Method: ChangesOrganizer class>>fileOutChangeSetsNamed: (in category 'utilities') -----
- fileOutChangeSetsNamed: nameList
- "File out the list of change sets whose names are provided"
- "ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')"
-
- | notFound empty infoString |
- notFound := OrderedCollection new.
- empty := OrderedCollection new.
- nameList do:
- [:aName | | aChangeSet | (aChangeSet := self changeSetNamed: aName)
- ifNotNil:
- [aChangeSet isEmpty
- ifTrue:
- [empty add: aName]
- ifFalse:
- [aChangeSet fileOut]]
- ifNil:
- [notFound add: aName]].
-
- infoString := '{1} change set(s) filed out' translated format: {nameList size - notFound size}.
- notFound size > 0 ifTrue:
- [infoString := infoString, '
-
- ', ('{1} change set(s) not found:' translated format: {notFound size}).
- notFound do:
- [:aName | infoString := infoString, '
- ', aName]].
- empty size > 0 ifTrue:
- [infoString := infoString, '
- ', ('{1} change set(s) were empty:' translated format: {empty size }).
- empty do:
- [:aName | infoString := infoString, '
- ', aName]].
-
- self inform: infoString!
Item was removed:
- ----- Method: ChangesOrganizer class>>gatherChangeSets (in category 'enumerating') -----
- gatherChangeSets "ChangeSorter gatherChangeSets"
- ^ChangeSet gatherChangeSets!
Item was removed:
- ----- Method: ChangesOrganizer class>>highestNumberedChangeSet (in category 'enumerating') -----
- highestNumberedChangeSet
-
- ^ ChangeSet highestNumberedChangeSet!
Item was removed:
- ----- Method: ChangesOrganizer class>>initialize (in category 'class initialization') -----
- initialize
-
- "Initialize the class variables"
- RecentUpdateMarker := 0.
-
-
- !
Item was removed:
- ----- Method: ChangesOrganizer class>>mostRecentChangeSetWithChangeForClass:selector: (in category 'enumerating') -----
- mostRecentChangeSetWithChangeForClass: class selector: selector
- | hits |
- hits := self allChangeSets select:
- [:cs | (cs atSelector: selector class: class) ~~ #none].
- hits isEmpty ifTrue: [^ 'not in any change set' translated].
- ^ 'recent cs: {1}' translated format: {hits last name}!
Item was removed:
- ----- Method: ChangesOrganizer class>>newChangeSet (in category 'adding') -----
- 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 := Project uiManager
- request: 'Please name the new change set:' translated
- initialAnswer: ChangeSet defaultName.
- newName isEmptyOrNil ifTrue:
- [^ nil].
- newSet := self basicNewChangeSet: newName.
- newSet ifNotNil:
- [ChangeSet newChanges: newSet].
- ^ newSet!
Item was removed:
- ----- Method: ChangesOrganizer class>>newChangeSet: (in category 'adding') -----
- newChangeSet: aName
- "Makes a new change set called aName, add author initials to try to
- ensure a unique change set name."
-
- | newName |
- newName := aName , FileDirectory dot , Utilities authorInitials.
- ^ self basicNewChangeSet: newName!
Item was removed:
- ----- Method: ChangesOrganizer class>>newChangesFromStream:named: (in category 'adding') -----
- newChangesFromStream: aStream named: aName
- ^ChangeSet newChangesFromStream: aStream named: aName
- !
Item was removed:
- ----- Method: ChangesOrganizer class>>noteChangeSetsInRelease (in category 'class initialization') -----
- 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"!
Item was removed:
- ----- Method: ChangesOrganizer class>>promoteToTop: (in category 'enumerating') -----
- promoteToTop: aChangeSet
- "Make aChangeSet the first in the list from now on"
- ^ChangeSet promoteToTop: aChangeSet!
Item was removed:
- ----- Method: ChangesOrganizer class>>recentUpdateMarker (in category 'services') -----
- 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]!
Item was removed:
- ----- Method: ChangesOrganizer class>>recentUpdateMarker: (in category 'services') -----
- recentUpdateMarker: aNumber
- "Set the recent update marker as indicated"
-
- ^ RecentUpdateMarker := aNumber!
Item was removed:
- ----- Method: ChangesOrganizer class>>removeChangeSet: (in category 'removing') -----
- removeChangeSet: aChangeSet
- "Remove the given changeSet. Caller must assure that it's cool to do this"
- ^ChangeSet removeChangeSet: aChangeSet!
Item was removed:
- ----- Method: ChangesOrganizer class>>removeChangeSetsNamedSuchThat: (in category 'removing') -----
- removeChangeSetsNamedSuchThat: nameBlock
- (self changeSetsNamedSuchThat: nameBlock)
- do: [:cs | self removeChangeSet: cs]!
Item was removed:
- ----- Method: ChangesOrganizer class>>removeEmptyUnnamedChangeSets (in category 'removing') -----
- 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: ('{1} change set(s) removed.' translated format: {toGo size}).!
Item was removed:
- ----- Method: ChangesOrganizer class>>reorderChangeSets (in category 'services') -----
- 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.
- ChangeSet allChangeSets do:
- [:aChangeSet |
- (self belongsInProjectsInRelease: aChangeSet)
- ifTrue:
- [newHead add: aChangeSet]
- ifFalse:
- [(self belongsInNumbered: aChangeSet)
- ifTrue:
- [newMid add: aChangeSet]
- ifFalse:
- [newTail add: aChangeSet]]].
- ChangeSet allChangeSets: newHead, newMid, newTail.
- Project current wakeUpTopWindow!
Item was removed:
- ----- Method: ChangesOrganizer class>>secondaryChangeSet (in category 'services') -----
- secondaryChangeSet
- ^ChangeSet secondaryChangeSet!
Item was removed:
- ----- Method: ChangesOrganizer class>>unload (in category 'class initialization') -----
- unload
- "Unload the receiver from global registries"
-
- self environment at: #FileServices ifPresent: [:cl |
- cl unregisterFileReader: self].
- self environment at: #Flaps ifPresent: [:cl |
- cl unregisterQuadsWithReceiver: self] !
Item was removed:
- ----- Method: Character>>defaultLabelForInspector (in category '*Tools-Inspecting-label') -----
- defaultLabelForInspector
- "Answer the default label to be used for an Inspector window on the receiver."
-
- ^ super defaultLabelForInspector, ': code ', self asInteger printString!
Item was removed:
- ----- Method: CharacterSet>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
-
- ^ CharacterSetInspector!
Item was removed:
- CollectionInspector subclass: #CharacterSetInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
Item was removed:
- ----- Method: CharacterSetInspector>>canAddOrRemoveElements (in category 'private') -----
- canAddOrRemoveElements
-
- ^ false!
Item was removed:
- ----- Method: CharacterSetInspector>>characterNameFor: (in category 'private') -----
- characterNameFor: character
- "Extracted from Character >> #printOn:."
-
- ^ String streamContents: [:stream | | integerValue |
- ((integerValue := character asInteger) > 32 and: [integerValue ~= 127])
- ifTrue: [
- character printAsLiteralOn: stream.
- stream space].
- stream nextPut: $(; print: integerValue; nextPut: $)].!
Item was removed:
- ----- Method: CharacterSetInspector>>characterValueFor: (in category 'private') -----
- characterValueFor: character
- "Extracted from Character >> #printOn: (and #storeOn:)."
-
- ^ String streamContents: [:stream |
- (character class constantNameFor: character)
- ifNotNil: [:name | stream nextPutAll: character class name; space; nextPutAll: name]
- ifNil: [stream nextPutAll: character class name; nextPutAll: ' value: '; print: character asInteger]].!
Item was removed:
- ----- Method: CharacterSetInspector>>elementAt: (in category 'menu - private') -----
- elementAt: indexOrKey
- "All field keys are characters."
-
- ^ indexOrKey!
Item was removed:
- ----- Method: CharacterSetInspector>>elementGetterAt: (in category 'private') -----
- elementGetterAt: character
-
- self shouldNotImplement.!
Item was removed:
- ----- Method: CharacterSetInspector>>elementIndices (in category 'private') -----
- elementIndices
-
- self shouldNotImplement.!
Item was removed:
- ----- Method: CharacterSetInspector>>elementNameAt: (in category 'private') -----
- elementNameAt: index
-
- self shouldNotImplement.!
Item was removed:
- ----- Method: CharacterSetInspector>>elementSetterAt: (in category 'private') -----
- elementSetterAt: index
-
- self shouldNotImplement.!
Item was removed:
- ----- Method: CharacterSetInspector>>streamElementsOn: (in category 'fields - streaming') -----
- streamElementsOn: aStream
- "Overwritten to realize array representation of character sets if they can be enumerated. Assume that enumeration is deterministic."
-
- self object canBeEnumerated ifFalse: [^ self].
-
- self
- streamOn: aStream
- truncate: self object asArray "Requires character set to be enumerable."
- collectFields: [:character :index |
- (self newFieldForType: #element key: index)
- name: ('{1}: {2}' format: {index. self characterNameFor: character});
- valueGetter: [:characterSet | self characterValueFor: character]; printValueAsIs;
- yourself]!
Item was removed:
- ----- Method: Class>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Class'!
Item was removed:
- ----- Method: Class>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
-
- ^ ClassInspector!
Item was removed:
- VersionsBrowser subclass: #ClassCommentVersionsBrowser
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Changes'!
-
- !ClassCommentVersionsBrowser commentStamp: 'asm 8/13/2002 23:20' prior: 0!
- A class-comment-versions-browser tool!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser class>>browseCommentOf: (in category 'instance creation') -----
- browseCommentOf: class
- Cursor read showWhile:
- [| changeList |
- changeList := self new scanVersionsOf: class.
- changeList ifNil: [^ self inform: 'No versions available' translated].
- self open: changeList name: ('Recent versions of {1}''s comments' translated format: {class name}) multiSelect: false ]
- !
Item was removed:
- ----- Method: ClassCommentVersionsBrowser class>>commentRecordsOf: (in category 'utilities') -----
- 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]!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser class>>timeStampFor:class:reverseOrdinal: (in category 'utilities') -----
- 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]]!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>aboutToStyle: (in category 'contents') -----
- aboutToStyle: aStyler
-
- ^false!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>classCommentIndicated (in category 'misc') -----
- classCommentIndicated
- "Answer whether the receiver is pointed at a class comment"
-
- ^ true!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>compareToCurrentVersion (in category 'menu') -----
- compareToCurrentVersion
- "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text"
-
- ^ self compareToCurrentSource: classOfMethod organization classComment!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>contentsSymbolQuints (in category 'misc') -----
- 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'))!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.753 g: 0.677 b: 0.9)!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>diffedVersionContents (in category 'basic function') -----
- 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!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>listSelectionVersionsMenu: (in category 'menu') -----
- listSelectionVersionsMenu: aMenu
-
- ^ aMenu addTranslatedList: #(
- ('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'));
- yourself
- !
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>offerVersionsHelp (in category 'menu') -----
- offerVersionsHelp
- (StringHolder new contents: self versionsHelpString)
- openLabel: 'Class Comment Versions Browsers' translated!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>priorSourceOrNil (in category 'misc') -----
- 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
- !
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>reformulateList (in category 'basic function') -----
- reformulateList
-
- classOfMethod organization classComment ifNil: [^ self].
-
- self scanVersionsOf: classOfMethod.
- self changed: #list. "for benefit of mvc"
- listIndex := 1.
- self changed: #listIndex.
- self contentsChanged!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>scanVersionsOf: (in category 'basic function') -----
- 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 := '<historical>' translated].
-
- self addItem:
- (ChangeRecord new file: file position: position type: #classComment
- class: class name category: nil meta: class isMeta 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!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>selectedClass (in category 'misc') -----
- 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!
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>updateListsAndCodeIn: (in category 'basic function') -----
- 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
- !
Item was removed:
- ----- Method: ClassCommentVersionsBrowser>>wantsPrettyDiffOption (in category 'misc') -----
- wantsPrettyDiffOption
- "Answer whether pretty-diffs are meaningful for this tool"
-
- ^ false!
Item was removed:
- Inspector subclass: #ClassInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !ClassInspector commentStamp: 'mt 3/30/2020 14:47' prior: 0!
- I am an Inspector that is specialized for inspecting Class objects. I show fields for my class variables and the shared pools I use.!
Item was removed:
- ----- Method: ClassInspector>>streamClassVariablesOn: (in category 'fields - streaming') -----
- streamClassVariablesOn: aStream
-
- self object classVarNames do: [:name |
- aStream nextPut: ((self newFieldForType: #classVar key: name)
- shouldStyleName: true;
- valueGetter: [:object | object classPool at: name];
- valueSetter: [:object :value | object classPool at: name put: value];
- yourself)]!
Item was removed:
- ----- Method: ClassInspector>>streamSharedPoolsOn: (in category 'fields - streaming') -----
- streamSharedPoolsOn: aStream
-
- self object sharedPools withIndexDo: [:pool :index |
- aStream nextPut: ((self newFieldForType: #poolDictionary key: (self environment keyAtIdentityValue: pool))
- shouldStyleName: true;
- valueGetter: [:object | object sharedPools at: index];
- valueSetter: [:object :value | object sharedPools at: index put: value];
- yourself)].!
Item was removed:
- ----- Method: ClassInspector>>streamVariableFieldsOn: (in category 'fields - streaming') -----
- streamVariableFieldsOn: aStream
- "Add fields for class variables and pool dictionaries."
-
- super streamVariableFieldsOn: aStream.
- self
- streamClassVariablesOn: aStream;
- streamSharedPoolsOn: aStream.!
Item was removed:
- HierarchyBrowser subclass: #ClassListBrowser
- instanceVariableNames: 'defaultTitle'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !ClassListBrowser commentStamp: 'tpr 10/15/2017 16:46' 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 newOnClassesNamed: #(Browser Boolean) label: 'Browser and Boolean!!'.
- ClassListBrowser newOnAllClasses "all classes listed alphabetically"
- !
Item was removed:
- ----- Method: ClassListBrowser class>>browseClassesSatisfying:title: (in category 'instance creation') -----
- browseClassesSatisfying: classBlock title: aTitle
- "Put up a ClassListBrowser showing all classes that satisfy the classBlock."
-
- self newOnClassesNamed:
- (self systemNavigation allClasses select: [:c | (classBlock value: c) == true]
- thenCollect: [:c | c name])
- label: aTitle!
Item was removed:
- ----- Method: ClassListBrowser class>>example1 (in category 'examples') -----
- 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"
- !
Item was removed:
- ----- Method: ClassListBrowser class>>example2 (in category 'examples') -----
- example2
- "Put up a ClassListBrowser that shows all classes whose names start with
- the letter S"
-
- self newOnClassesNamed: (self systemNavigation allClasses
- collect: [:c | c name]
- thenSelect: [:aName | aName first == $S])
- label: 'All classes starting with S'
- "ClassListBrowser example2"!
Item was removed:
- ----- Method: ClassListBrowser class>>example3 (in category 'examples') -----
- example3
- "Put up a ClassListBrowser that shows all Variable classes"
-
- self browseClassesSatisfying: [:c | c isVariable] title: 'All Variable classes'
-
- "ClassListBrowser example3"
- !
Item was removed:
- ----- Method: ClassListBrowser class>>example4 (in category 'examples') -----
- 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"
- !
Item was removed:
- ----- Method: ClassListBrowser class>>example5 (in category 'examples') -----
- 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"
- !
Item was removed:
- ----- Method: ClassListBrowser class>>example6 (in category 'examples') -----
- 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"!
Item was removed:
- ----- Method: ClassListBrowser class>>newOnAllClasses (in category 'instance creation') -----
- newOnAllClasses
- "Open a browser on all the classes in the system, listed alphabetically"
- "NB - what meaning does 'all classes' have in an environment that is not the root?
- - what might alphabetic ordering need to do for non-latin languages?"
- "ClassListBrowser newOnAllClasses"
-
- | newBrowser |
-
- newBrowser := self new.
- ^ newBrowser buildAndOpenBrowserLabel: 'All Classes Alphabetically'
- !
Item was removed:
- ----- Method: ClassListBrowser class>>newOnClassesNamed:label: (in category 'instance creation') -----
- newOnClassesNamed: aListOfClassNames label: aString
- "Open a browser on all the classes in the list, set the label to aString since we may need to specify to the user what the list includes"
- "ClassListBrowser newOnClassesNamed: #(Browser Boolean) label: 'Browser and Boolean!!'."
- | newBrowser |
-
- newBrowser := self new.
- newBrowser initForClassesNamed: aListOfClassNames.
- ^ newBrowser buildAndOpenBrowserLabel: aString
- !
Item was removed:
- ----- Method: ClassListBrowser>>defaultBrowserTitle (in category 'initialization') -----
- defaultBrowserTitle
- ^ 'Class List Browser' !
Item was removed:
- ----- Method: ClassListBrowser>>defaultTitle: (in category 'title') -----
- defaultTitle: aTitle
- "Set the browser's default title"
-
- defaultTitle := aTitle!
Item was removed:
- ----- Method: ClassListBrowser>>initAlphabeticListing (in category 'initialization') -----
- initAlphabeticListing
- | tab stab index |
- self systemOrganizer: SystemOrganization.
- metaClassIndicated := false.
- classDisplayList := Smalltalk classNames.!
Item was removed:
- ----- Method: ClassListBrowser>>initForClassesNamed: (in category 'initialization') -----
- initForClassesNamed: nameList
- "Initialize the receiver for the class-name-list"
-
- self systemOrganizer: SystemOrganization.
- metaClassIndicated := false.
- classDisplayList := nameList copy!
Item was removed:
- ----- Method: ClassListBrowser>>labelString (in category 'title') -----
- labelString
- "Answer the label strilng to use on the browser"
-
- ^ defaultTitle ifNil: [super labelString]!
Item was removed:
- ----- Method: ClassListBrowser>>setupIfNotInitialisedYet (in category 'toolbuilder') -----
- setupIfNotInitialisedYet
- "ClassListBrowser needs some initialisation to work in the ToolBuilder>build: world since there has to be a list of classes ready to be listed. As a default we use the full list of classes in the system"
-
- classDisplayList ifNil:[self initAlphabeticListing]!
Item was removed:
- StringHolder subclass: #CodeHolder
- instanceVariableNames: 'currentCompiledMethod contentsSymbol multiWindowState'
- classVariableNames: 'ContentsSymbolQuints EditContentsOptions MultiWindowBrowsers'
- poolDictionaries: ''
- category: 'Tools-Base'!
-
- !CodeHolder commentStamp: '<historical>' prior: 0!
- An ancestor class for all models which can show code. Eventually, much of the code that currently resides in StringHolder which only applies to code-holding StringHolders might get moved down here.!
Item was removed:
- ----- Method: CodeHolder class>>addContentsSymbolQuint:afterEntry: (in category 'controls') -----
- addContentsSymbolQuint: quint afterEntry: aSymbol
- "Register a menu selection item in the position after the entry with
- selection symbol aSymbol."
-
- "CodeHolder
- addContentsSymbolQuint: #(#altSyntax #toggleAltSyntax #showingAltSyntaxString 'altSyntax' 'alternative syntax')
- afterEntry: #colorPrint"
-
- (ContentsSymbolQuints
- anySatisfy: [:e | (e isKindOf: Collection) and: [e first = quint first]])
- ifFalse: [
- | entry |
- entry := ContentsSymbolQuints
- detect: [:e | (e isKindOf: Collection) and: [e first = aSymbol]].
- ContentsSymbolQuints add: quint after: entry.
- ^ self].
- self notify: 'entry already exists for ', quint first!
Item was removed:
- ----- Method: CodeHolder class>>addContentsSymbolQuint:afterPosition: (in category 'controls') -----
- addContentsSymbolQuint: quint afterPosition: index
- "Register a menu selection item in the position after index."
-
- "CodeHolder
- addContentsSymbolQuint: #(#altSyntax #toggleAltSyntax #showingAltSyntaxString 'altSyntax' 'alternative syntax')
- afterPosition: 1"
-
- | entry |
- entry := ContentsSymbolQuints at: index.
- self contentsSymbolQuints add: quint after: entry!
Item was removed:
- ----- Method: CodeHolder class>>addEditContentsOption: (in category 'controls') -----
- addEditContentsOption: anAssociation
-
- "CodeHolder addEditContentsOption: #translateToC -> #selectedTranslateToC"
-
- EditContentsOptions add: anAssociation!
Item was removed:
- ----- Method: CodeHolder class>>canUseMultiWindowBrowsers (in category 'preferences') -----
- canUseMultiWindowBrowsers
- "This is a hook to allow browsers to control whether to respond to the muli-window preference.
- Currenty CodeHolder cannot usefully use multi-windows, but may be able to do so in the future."
- ^false!
Item was removed:
- ----- Method: CodeHolder class>>defaultContentsSymbolQuints (in category 'controls') -----
- defaultContentsSymbolQuints
- "Default 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 written' translated} .
- {#documentation
- . #toggleShowDocumentation
- . #showingDocumentationString
- . 'documentation'
- . 'the first comment in the method' translated} .
-
- #- .
- {#prettyPrint
- . #togglePrettyPrint
- . #prettyPrintString
- . 'prettyPrint'
- . 'the method source presented in a standard text format' translated} .
-
- #- .
- {#showDiffs
- . #toggleRegularDiffing
- . #showingRegularDiffsString
- . 'showDiffs'
- . 'the textual source diffed from its prior version' translated} .
-
- #- .
- {#decompile
- . #toggleDecompile
- . #showingDecompileString
- . 'decompile'
- . 'source code decompiled from byteCodes' translated} .
- {#byteCodes
- . #toggleShowingByteCodes
- . #showingByteCodesString
- . 'byteCodes'
- . 'the bytecodes that comprise the compiled method' translated} .
- }!
Item was removed:
- ----- Method: CodeHolder class>>defaultEditContentsOptions (in category 'controls') -----
- defaultEditContentsOptions
- "An array of associations of current display mode symbol to selector
- that creates the edit contents for that display mode. The default selector
- is #selectedMessage; this is a list of alternative to the default."
-
- ^ {
- #byteCodes -> #selectedBytecodes
- }!
Item was removed:
- ----- Method: CodeHolder class>>initialize (in category 'class initialization') -----
- initialize
-
- "CodeHolder initialize"
-
- ContentsSymbolQuints := self defaultContentsSymbolQuints asOrderedCollection.
- EditContentsOptions := Dictionary new.
- self defaultEditContentsOptions
- do: [:opt | EditContentsOptions at: opt key put: opt value]!
Item was removed:
- ----- Method: CodeHolder class>>removeContentsSymbol: (in category 'controls') -----
- removeContentsSymbol: aSymbol
- "Unregister the menu selection item with selection symbol aSymbol."
-
- "CodeHolder removeContentsSymbol: #altSyntax"
-
- | entries |
- entries := ContentsSymbolQuints
- select: [:e | (e isKindOf: Collection) and: [e first = aSymbol]].
- ContentsSymbolQuints removeAll: entries.
- ^ entries
- !
Item was removed:
- ----- Method: CodeHolder class>>useMultiWindowBrowsers (in category 'preferences') -----
- useMultiWindowBrowsers
- <preference: 'Multi-window browsers'
- category: 'browsing'
- description: 'When enabled, the browser uses a multi-window to conserve real-estate. e.g. enable then click in the window label of a browser to see the items being browsed.'
- type: #Boolean>
- ^MultiWindowBrowsers ifNil: [false]!
Item was removed:
- ----- Method: CodeHolder class>>useMultiWindowBrowsers: (in category 'preferences') -----
- useMultiWindowBrowsers: aBoolean
- MultiWindowBrowsers := aBoolean!
Item was removed:
- ----- Method: CodeHolder>>aboutToStyle: (in category 'code pane') -----
- aboutToStyle: aStyler
-
- currentCompiledMethod ifNil: [^ false].
- self isModeStyleable ifFalse: [^ false].
- aStyler classOrMetaClass: self selectedClassOrMetaClass.
- ^ true!
Item was removed:
- ----- Method: CodeHolder>>addModelItemsToWindowMenu: (in category 'misc') -----
- addModelItemsToWindowMenu: aMenu
- "Add model-related item to the window menu"
-
- super addModelItemsToWindowMenu: aMenu.
- Smalltalk isMorphic ifTrue:
- [aMenu addLine.
- aMenu add: 'what to show...' translated target: self action: #offerWhatToShowMenu]!
Item was removed:
- ----- Method: CodeHolder>>addPriorVersionsCountForSelector:ofClass:to: (in category 'annotation') -----
- 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)!
Item was removed:
- ----- Method: CodeHolder>>adoptMessageInCurrentChangeset (in category 'commands') -----
- 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]]
- !
Item was removed:
- ----- Method: CodeHolder>>annotation (in category 'annotation') -----
- 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 |
-
- ((aSelector := self selectedMessageName) == nil or: [(aClass := self selectedClassOrMetaClass) == nil]) ifTrue: [^ ''].
- ^ self annotationForSelector: aSelector ofClass: aClass!
Item was removed:
- ----- Method: CodeHolder>>annotation: (in category 'annotation') -----
- annotation: aString
- "The user accepted aString in our annotation pane. Return false because by default we cannot edit annotations"
- ^ false
- !
Item was removed:
- ----- Method: CodeHolder>>annotationForClassCommentFor: (in category 'annotation') -----
- 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 = '<historical>'
- ifFalse:
- [' - ', aStamp]
- ifTrue:
- [''])]!
Item was removed:
- ----- Method: CodeHolder>>annotationForClassDefinitionFor: (in category 'annotation') -----
- 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."
-
- | annotation |
- annotation := 'Class definition for ', aClass name.
- (self annotationRequests includes: #package) ifTrue:
- [Environment current packageOrganizer ifNotNil:
- [:organizer|
- (organizer
- packageOfClass: aClass
- ifNone: nil) ifNotNil:
- [:package| annotation := annotation, ' in package ', package name]]].
- ^annotation!
Item was removed:
- ----- Method: CodeHolder>>annotationForHierarchyFor: (in category 'annotation') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>annotationForSelector:ofClass: (in category 'annotation') -----
- annotationForSelector: aSelector ofClass: aClass
- "Provide a line of content for an annotation pane, representing
- information about the given selector and class"
- | separator aStream requestList |
- aSelector == #Comment
- ifTrue: [^ self annotationForClassCommentFor: aClass].
- aSelector == #Definition
- ifTrue: [^ self annotationForClassDefinitionFor: aClass].
- aSelector == #Hierarchy
- ifTrue: [^ self annotationForHierarchyFor: aClass].
- aStream := (String new: 512) writeStream.
- requestList := self annotationRequests.
- separator := requestList size > 1
- ifTrue: [self annotationSeparator]
- ifFalse: [''].
- requestList
- do: [:aRequest | | aString sendersCount aComment aCategory implementorsCount aList stamp authorInitials |
- aRequest == #firstComment
- ifTrue: [aComment := aClass firstCommentAt: aSelector.
- aComment isEmptyOrNil
- ifFalse: [aStream nextPutAll: aComment; nextPutAll: separator]].
- aRequest == #masterComment
- ifTrue: [aComment := aClass supermostPrecodeCommentFor: aSelector.
- aComment isEmptyOrNil
- ifFalse: [aStream nextPutAll: aComment; nextPutAll: separator]].
- aRequest == #documentation
- ifTrue: [aComment := aClass precodeCommentOrInheritedCommentFor: aSelector.
- aComment isEmptyOrNil
- ifFalse: [aStream nextPutAll: aComment; nextPutAll: separator]].
- aRequest == #timeStamp
- ifTrue: [stamp := self timeStamp.
- aStream
- nextPutAll: (stamp size > 0
- ifTrue: [stamp]
- ifFalse: ['no timeStamp']);
- nextPutAll: separator].
- aRequest == #author
- ifTrue: [authorInitials := self timeStamp
- findTokens ifEmpty: [''] ifNotEmpty: [:tokens | tokens first].
- aStream
- nextPutAll: (SystemNavigation authorsInverted
- at: authorInitials
- ifPresent: [:fullNames | fullNames anyOne]
- ifAbsent: ['unknown author']);
- nextPutAll: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; nextPutAll: separator]].
- aRequest == #sendersCount
- ifTrue: [sendersCount := (self systemNavigation allCallsOn: aSelector) size.
- sendersCount := sendersCount = 1
- ifTrue: ['1 sender']
- ifFalse: [sendersCount printString , ' senders'].
- aStream nextPutAll: sendersCount; nextPutAll: separator].
- aRequest == #implementorsCount
- ifTrue: [implementorsCount := self systemNavigation numberOfImplementorsOf: aSelector.
- implementorsCount := implementorsCount = 1
- ifTrue: ['1 implementor']
- ifFalse: [implementorsCount printString , ' implementors'].
- aStream nextPutAll: implementorsCount; nextPutAll: 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: '; nextPutAll: stamp; nextPutAll: separator]].
- aRequest == #recentChangeSet
- ifTrue: [aString := ChangesOrganizer mostRecentChangeSetWithChangeForClass: aClass selector: aSelector.
- aString size > 0
- ifTrue: [aStream nextPutAll: aString; nextPutAll: separator]].
- aRequest == #allChangeSets
- ifTrue: [aList := ChangesOrganizer 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].
- aRequest == #package
- ifTrue: [Environment current packageOrganizer ifNotNil:
- [:organizer|
- (organizer
- packageOfMethod: (MethodReference class: aClass selector: aSelector environment: aClass environment)
- ifNone: nil) ifNotNil:
- [:package| aStream nextPutAll: 'in package '; nextPutAll: package name; nextPutAll: separator]]]].
- ^ aStream contents!
Item was removed:
- ----- Method: CodeHolder>>annotationFrame (in category 'toolbuilder') -----
- annotationFrame
- ^LayoutFrame new
- leftFraction: 0 offset: 0;
- topFraction: 1 offset: self annotationPaneHeight negated;
- rightFraction: 1 offset: 0;
- bottomFraction: 1 offset: 0!
Item was removed:
- ----- Method: CodeHolder>>annotationPaneHeight (in category 'toolbuilder') -----
- annotationPaneHeight
- ^ ToolBuilder default inputFieldHeight!
Item was removed:
- ----- Method: CodeHolder>>annotationPaneMenu:shifted: (in category 'annotation') -----
- annotationPaneMenu: aMenu shifted: shifted
-
- ^ aMenu
- labels: 'change pane size'
- lines: #()
- selections: #(toggleAnnotationPaneSize)!
Item was removed:
- ----- Method: CodeHolder>>annotationRequests (in category 'annotation') -----
- annotationRequests
- ^ Preferences defaultAnnotationRequests!
Item was removed:
- ----- Method: CodeHolder>>annotationSeparator (in category 'annotation') -----
- annotationSeparator
- "Answer the separator to be used between annotations"
-
- ^ ' · '!
Item was removed:
- ----- Method: CodeHolder>>browseImplementors (in category 'commands') -----
- browseImplementors
- "Create and schedule a message set browser on all implementors of the currently selected message selector. If there is no message currently selected, offer a type-in"
-
- self sendQuery: #browseAllImplementorsOf:requestor: to: self with: #(modelMenu).!
Item was removed:
- ----- Method: CodeHolder>>browseSenders (in category 'commands') -----
- browseSenders
- "Create and schedule a message set browser on all senders of the currently selected message selector. If there is no message currently selected, offer a type-in"
-
- self sendQuery: #browseAllCallsOn:requestor: to: self with: #(modelMenu).!
Item was removed:
- ----- Method: CodeHolder>>buildAnnotationPaneWith: (in category 'toolbuilder') -----
- buildAnnotationPaneWith: builder
-
- | annoSpec |
- annoSpec := builder pluggableInputFieldSpec new.
- annoSpec
- model: self;
- plainTextOnly: true;
- getText: #annotation;
- setText: #annotation:.
- ^ annoSpec!
Item was removed:
- ----- Method: CodeHolder>>buildClassBrowserEditString: (in category 'construction') -----
- buildClassBrowserEditString: classDefinition
- "Create and schedule a new class browser for the current selection, with initial textual contents set to aString. This is used specifically in spawning where a class is established but a method-category is not."
-
- self flag: #uglyHack. "mt: We should not abuse Browser like this. We should not even know about #Browser in this superclass."
- ^(Browser
- newOnClass: self selectedClassOrMetaClass
- editString: classDefinition
- label: 'Class Browser: ', self selectedClassOrMetaClass name)
- editSelection: #editClass; "...because we know it is class def code."
- changed: #editString with: classDefinition; "...trigger re-styling."
- yourself
- !
Item was removed:
- ----- Method: CodeHolder>>buildCodePaneWith: (in category 'toolbuilder') -----
- buildCodePaneWith: builder
- | textSpec top buttonSpec annoSpec |
- self wantsOptionalButtons ifTrue: [
- top := builder pluggablePanelSpec new.
- top name: #codePane.
- top children: OrderedCollection new.
- buttonSpec := self buildOptionalButtonsWith: builder.
- buttonSpec frame: self optionalButtonsFrame.
- top children add: buttonSpec].
- textSpec := builder pluggableCodePaneSpec new.
- textSpec
- model: self;
- getText: #contents;
- setText: #contents:notifying:;
- selection: #contentsSelection;
- menu: #codePaneMenu:shifted:.
- self wantsAnnotationPane ifTrue: [
- top ifNil: [
- top := builder pluggablePanelSpec new.
- top children: OrderedCollection new].
- annoSpec := self buildAnnotationPaneWith: builder.
- annoSpec frame: self annotationFrame.
- top children add: annoSpec].
- top ifNotNil: [
- textSpec frame: self textFrame.
- top children add: textSpec].
- ^top ifNil: [textSpec]!
Item was removed:
- ----- Method: CodeHolder>>buildCodeProvenanceButtonWith: (in category 'toolbuilder') -----
- buildCodeProvenanceButtonWith: builder
- | buttonSpec |
- buttonSpec := builder pluggableActionButtonSpec new.
- buttonSpec
- model: self;
- label: #codePaneProvenanceString;
- changeLabelWhen: #contents;
- style: #menuButton;
- action: #offerWhatToShowMenu;
- help: 'Governs what view is shown in the code pane. Click here to change the view';
- margin: (5@0 corner: 0@0).
- ^buttonSpec!
Item was removed:
- ----- Method: CodeHolder>>buildMessageBrowserEditString: (in category 'construction') -----
- buildMessageBrowserEditString: aString
- "Create and schedule a new message browser for the current selection,
- with initial textual contents set to aString."
- ^ Browser
- newOnClass: self selectedClassOrMetaClass
- messageCategory: self categoryOfCurrentMethod
- selector: self selectedMessageName
- editString: aString
- label: 'Message Browser: ' , self selectedClassOrMetaClass name , self categoryOfCurrentMethod!
Item was removed:
- ----- Method: CodeHolder>>buildMessageCategoryBrowserForCategory:class:selector:editString: (in category 'construction') -----
- buildMessageCategoryBrowserForCategory: aCategory class: aClass selector: aSelectorOrNil editString: methodSourceCode
- "Create and schedule a new class browser for the current selection,
- with initial textual contents set to aString. This is used specifically in
- spawning where a class is established but a method-category is not."
-
- self flag: #uglyHack. "mt: We should not abuse Browser like this. We should not even know about #Browser in this superclass."
- ^ (Browser
- newOnClass: aClass
- messageCategory: aCategory
- selector: aSelectorOrNil
- editString: methodSourceCode
- label: 'Message category Browser: ' , aClass name , aCategory)!
Item was removed:
- ----- Method: CodeHolder>>buildMorphicCodePaneWith: (in category 'construction') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>buildOptionalButtonsWith: (in category 'toolbuilder') -----
- buildOptionalButtonsWith: builder
-
- | panelSpec |
- panelSpec := builder pluggablePanelSpec new.
- panelSpec children: OrderedCollection new.
- self optionalButtonPairs do:[:spec|
- | buttonSpec |
- buttonSpec := builder pluggableActionButtonSpec new.
- buttonSpec model: self.
- buttonSpec label: spec first.
- buttonSpec action: spec second.
- spec second == #methodHierarchy
- ifTrue:[buttonSpec
- enabled: #inheritanceButtonEnabled;
- color: #inheritanceButtonColor].
- spec second == #browseVersions
- ifTrue:[buttonSpec enabled: #versionsButtonEnabled].
- spec size > 2 ifTrue:[buttonSpec help: spec third].
- panelSpec children add: buttonSpec].
-
- "What to show"
- self wantsCodeProvenanceButton ifTrue: [
- panelSpec children
- add: builder pluggableSpacerSpec new;
- add: (self buildCodeProvenanceButtonWith: builder)].
-
- panelSpec layout: #horizontal. "buttons"
- ^panelSpec!
Item was removed:
- ----- Method: CodeHolder>>buttonHeight (in category 'toolbuilder') -----
- buttonHeight
- ^ ToolBuilder default buttonRowHeight!
Item was removed:
- ----- Method: CodeHolder>>canShowMultipleMessageCategories (in category 'message category functions') -----
- canShowMultipleMessageCategories
- "Answer whether the receiver is capable of showing multiple message categories"
-
- ^ false!
Item was removed:
- ----- Method: CodeHolder>>categoryFromUserWithPrompt:for: (in category 'categories') -----
- categoryFromUserWithPrompt: aPrompt for: aClass
- "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary"
-
- | labels myCategories reject lines newName menuIndex |
- labels := OrderedCollection with: 'new...'.
- labels addAll: (myCategories := aClass organization categories sorted:
- [: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 |
- cats := cls organization categories reject:
- [:cat | reject includes: cat].
- cats isEmpty ifFalse:
- [lines add: labels size.
- labels addAll: (cats sort:
- [:a :b | a asLowercase < b asLowercase]).
- reject addAll: cats]].
-
- newName := (labels size = 1 or:
- [menuIndex := (UIManager default chooseFrom: labels lines: lines title: aPrompt).
- menuIndex = 0 ifTrue: [^ nil].
- menuIndex = 1])
- ifTrue:
- [UIManager default request: 'Please type new category name'
- initialAnswer: 'category name']
- ifFalse:
- [labels at: menuIndex].
- ^ newName ifNotNil: [newName asSymbol]!
Item was removed:
- ----- Method: CodeHolder>>categoryOfCurrentMethod (in category 'categories') -----
- 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]]!
Item was removed:
- ----- Method: CodeHolder>>changeCategory (in category 'categories') -----
- 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]]]!
Item was removed:
- ----- Method: CodeHolder>>codePaneProvenanceString (in category 'controls') -----
- 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"!
Item was removed:
- ----- Method: CodeHolder>>commentContents (in category 'contents') -----
- commentContents
- "documentation for the selected method"
-
- | poss aClass aSelector |
- ^ (poss := (aClass := self selectedClassOrMetaClass)
- ifNil:
- ['----']
- ifNotNil:
- [(aSelector := self selectedMessageName)
- ifNil:
- ['---']
- ifNotNil:
- [(aClass precodeCommentOrInheritedCommentFor: aSelector)", String cr, String cr, self timeStamp"
- "which however misses comments that are between the temps declaration and the body of the method; those are picked up by ·aClass commentOrInheritedCommentFor: aSelector· but that method will get false positives from comments *anywhere* in the method source"]])
- isEmptyOrNil
- ifTrue:
- [aSelector
- ifNotNil:
- [((aClass methodHeaderFor: aSelector), '
-
- Has no comment') asText makeSelectorBoldIn: aClass]
- ifNil:
- ['Hamna']]
- ifFalse: [aSelector
- ifNotNil: [((aClass methodHeaderFor: aSelector), '
-
- ', poss) asText makeSelectorBoldIn: aClass]
- ifNil: [poss]]!
Item was removed:
- ----- Method: CodeHolder>>compileMessage:notifying: (in category 'code pane') -----
- compileMessage: aString 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."
-
- | selectedMessageName selector category selectedClassOrMetaClass |
- selectedMessageName := self selectedMessageName.
- selectedClassOrMetaClass := self selectedClassOrMetaClass.
- contents := nil.
- selector := (selectedClassOrMetaClass newParser parseSelector: aString).
- (self metaClassIndicated
- and: [(selectedClassOrMetaClass includesSelector: selector) not
- and: [Metaclass isScarySelector: selector]])
- ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses"
- (self confirm: ((selector , ' is used in the existing class system.
- Overriding it could cause serious problems.
- Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size))
- ifFalse: [^nil]].
- category := self selectedMessageCategoryName.
- selector := selectedClassOrMetaClass
- compile: aString
- classified: category
- notifying: aController.
- selector == nil ifTrue: [^ nil].
- contents := aString copy.
- currentCompiledMethod := selectedClassOrMetaClass compiledMethodAt: selector.
- ^ true!
Item was removed:
- ----- Method: CodeHolder>>contents (in category 'contents') -----
- contents
- "Answer the source code or documentation for the selected method"
-
- self showingByteCodes ifTrue:
- [^ self selectedBytecodes].
-
- self showingDocumentation ifTrue:
- [^ self commentContents].
-
- ^ self selectedMessage!
Item was removed:
- ----- Method: CodeHolder>>contents:notifying: (in category 'accessing') -----
- contents: input notifying: aController
- "The retrieved information has changed and its source must now be updated. Answer the result of updating the source."
-
- self changed: #annotation.
-
- ^ self okayToAccept
- ifFalse: [false]
- ifTrue: [self compileMessage: input asText notifying: aController].!
Item was removed:
- ----- Method: CodeHolder>>contentsChanged (in category 'contents') -----
- contentsChanged
-
- super contentsChanged.
- self changed: #annotation!
Item was removed:
- ----- Method: CodeHolder>>contentsSymbol (in category 'contents') -----
- 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 := SystemBrowser browseWithPrettyPrint
- ifTrue:
- [#prettyPrint]
- ifFalse:
- [#source]]!
Item was removed:
- ----- Method: CodeHolder>>contentsSymbol: (in category 'contents') -----
- contentsSymbol: aSymbol
- "Set the contentsSymbol as indicated. #source means to show source code, #comment means to show the first comment found in the source code"
-
- contentsSymbol := aSymbol!
Item was removed:
- ----- Method: CodeHolder>>contentsSymbolQuints (in category 'controls') -----
- 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"
-
- ^ ContentsSymbolQuints!
Item was removed:
- ----- Method: CodeHolder>>copyUpOrCopyDown (in category 'commands') -----
- 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 |
- 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 |
- 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!
Item was removed:
- ----- Method: CodeHolder>>decompiledSourceIntoContents (in category 'message list') -----
- decompiledSourceIntoContents
- "For backwards compatibility."
-
- ^self decompiledSourceIntoContentsWithTempNames: (Sensor leftShiftDown not)
- !
Item was removed:
- ----- Method: CodeHolder>>decompiledSourceIntoContentsWithTempNames: (in category 'message list') -----
- 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."
-
- | class selector method |
- class := self selectedClassOrMetaClass.
- selector := self selectedMessageName.
- "Was method deleted while in another project?"
- method := class compiledMethodAt: selector ifAbsent: [^ ''].
-
- currentCompiledMethod := method.
- contents := (showTempNames
- ifTrue: [method decompileWithTemps]
- ifFalse: [method decompile]) decompileString.
- contents := contents asText makeSelectorBoldIn: class.
- ^ contents copy!
Item was removed:
- ----- Method: CodeHolder>>decorateButtons (in category 'controls') -----
- decorateButtons
- "Change screen feedback for any buttons in the UI of the receiver that may wish it. Initially, it is only the Inheritance button that is decorated, but one can imagine others."
- self changed: #inheritanceButtonColor.
- self changed: #inheritanceButtonEnabled.
- self changed: #versionsButtonEnabled.!
Item was removed:
- ----- Method: CodeHolder>>defaultBrowserTitle (in category 'initialize-release') -----
- defaultBrowserTitle
-
- ^ 'Source Code'!
Item was removed:
- ----- Method: CodeHolder>>defaultDiffsSymbol (in category 'diffs') -----
- defaultDiffsSymbol
- "Answer the code symbol to use when generically switching to diffing"
-
- ^ Preferences diffsWithPrettyPrint
- ifTrue:
- [#prettyDiffs]
- ifFalse:
- [#showDiffs]!
Item was removed:
- ----- Method: CodeHolder>>didCodeChangeElsewhere (in category 'self-updating') -----
- 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].
-
- self classCommentIndicated
- 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"]]!
Item was removed:
- ----- Method: CodeHolder>>diffFromPriorSourceFor: (in category 'diffs') -----
- 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]!
Item was removed:
- ----- Method: CodeHolder>>doItReceiver (in category 'accessing') -----
- doItReceiver
- "If there is an instance associated with me, answer it, for true mapping of self. If not, then do what other code-bearing tools do, viz. give access to the class vars."
-
- ^ self selectedClass!
Item was removed:
- ----- Method: CodeHolder>>editContents (in category 'contents') -----
- editContents
-
- ^ self editContentsWithDefault: [self selectedMessage]
- !
Item was removed:
- ----- Method: CodeHolder>>editContentsWithDefault: (in category 'contents') -----
- editContentsWithDefault: aBlock
-
- | selector |
- selector := EditContentsOptions
- at: self contentsSymbol
- ifAbsent: [^ aBlock value].
- ^ self perform: selector
- !
Item was removed:
- ----- Method: CodeHolder>>exploreMethod (in category 'message functions') -----
- exploreMethod
- (self selectedClassOrMetaClass
- compiledMethodAt: self selectedMessageName
- ifAbsent: []) ifNotNil:
- [:method| method explore]!
Item was removed:
- ----- Method: CodeHolder>>formattedLabel: (in category 'message list') -----
- formattedLabel: aString
- "Usually, the label is the same as the selector. Override this if the external representation of a message is different from its internal one."
-
- ^ self
- formattedLabel: aString
- forSelector: aString
- inClass: self selectedClassOrMetaClass!
Item was removed:
- ----- Method: CodeHolder>>formattedLabel:forSelector:inClass: (in category 'message list') -----
- formattedLabel: aString forSelector: aSymbol inClass: aClass
- "Show deprecated messages differently so that users recognize them quickly to avoid them. This is a performance critical method in the user interface."
-
- self flag: #investigate. "mt: aClass must never be nil!! Faulty tools should override this call themselves or fix the caller site."
- aClass ifNil: [^ aString].
-
- (aSymbol = #Definition or: [aSymbol = #Comment])
- ifTrue: [aClass isDeprecated
- ifFalse: [^ aString]]
- ifFalse: [(aClass isDeprecated or: [(aClass compiledMethodAt: aSymbol ifAbsent: [^ aString]) isDeprecated])
- ifFalse: [^ aString]].
-
- ^ aString asText addAttributesForDeprecation!
Item was removed:
- ----- Method: CodeHolder>>getSelectorAndSendQuery:to: (in category 'misc') -----
- getSelectorAndSendQuery: querySelector to: queryPerformer
- "See commentary in #getSelectorAndSendQuery:to:with:."
-
- ^ self getSelectorAndSendQuery: querySelector to: queryPerformer with: {}!
Item was removed:
- ----- Method: CodeHolder>>getSelectorAndSendQuery:to:with: (in category 'misc') -----
- 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."
-
- ^ self selectedMessageName
- ifNotNil: [ "We have a message. Let the user choose a symbol from its contents."
- self selectMessageAndEvaluate: [ :aSymbol |
- queryPerformer
- perform: querySelector
- withArguments: {aSymbol}, queryArgs ]]
- ifNil: [ "No message currently selected. Obtain a selector from a user type-in."
- (Project uiManager request: 'Type selector:' initialAnswer: 'flag:')
- ifEmpty: [ nil "Cancelled by user" ]
- ifNotEmpty: [ :typeIn | | selectorString |
- (Symbol lookup: (selectorString := typeIn asLegalSelector))
- ifNil: [ self inform: 'There is no symbol known as #', selectorString ]
- ifNotNil: [ :aSymbol |
- queryPerformer
- perform: querySelector
- withArguments: {aSymbol}, queryArgs ] ]]!
Item was removed:
- ----- Method: CodeHolder>>informPossiblyCorruptSource (in category 'misc') -----
- informPossiblyCorruptSource
-
- | sourcesName |
- 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 "{1}" 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.)' translated format: {sourcesName})!
Item was removed:
- ----- Method: CodeHolder>>inheritanceButtonColor (in category 'toolbuilder') -----
- inheritanceButtonColor
- "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."
-
- | flags aColor cm defaultButtonColor |
- defaultButtonColor := (UserInterfaceTheme current get: #color for: #PluggableButtonMorph) ifNil: [Color gray: 0.91].
- cm := currentCompiledMethod.
- ((cm isKindOf: CompiledMethod) and: [Preferences decorateBrowserButtons])
- ifFalse: [^ defaultButtonColor].
-
- "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 ].
- cm sendsToSuper ifTrue: [ flags := flags bitOr: 2 ].
- self isThereAnOverride ifTrue: [ flags := flags bitOr: 1 ].
- aColor := {
- defaultButtonColor.
- 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.
-
- ^aColor!
Item was removed:
- ----- Method: CodeHolder>>inheritanceButtonEnabled (in category 'toolbuilder') -----
- inheritanceButtonEnabled
- "The inheritance button is only enabled when a method is selected"
-
- ^ self selectedMessageName notNil
- !
Item was removed:
- ----- Method: CodeHolder>>inspectMethod (in category 'message functions') -----
- inspectMethod
- (self selectedClassOrMetaClass
- compiledMethodAt: self selectedMessageName
- ifAbsent: []) ifNotNil:
- [:method| method inspect]!
Item was removed:
- ----- Method: CodeHolder>>installTextualCodingPane (in category 'diffs') -----
- installTextualCodingPane
- "Install text into the code pane"
-
- | aWindow codePane aPane boundsToUse |
- (aWindow := self containingWindow) ifNil: [self error: 'where''s that window?'].
- codePane := self codeTextMorph ifNil: [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!
Item was removed:
- ----- Method: CodeHolder>>isBreakOnEntry (in category 'breakpoints') -----
- isBreakOnEntry
-
- ^self selectedClassOrMetaClass
- ifNil: [false]
- ifNotNil:
- [:class|
- (class
- compiledMethodAt: self selectedMessageName
- ifAbsent: nil)
- ifNil: [false]
- ifNotNil: [:method| method hasBreakpoint]]!
Item was removed:
- ----- Method: CodeHolder>>isModeStyleable (in category 'contents') -----
- isModeStyleable
- "determine the current mode can be styled"
- ^ self showingSource or: [self showingPrettyPrint] or: [self showingDecompile]!
Item was removed:
- ----- Method: CodeHolder>>isThereAnOverride (in category 'misc') -----
- isThereAnOverride
- "Answer whether any subclass of my selected class implements my selected selector"
-
- | aName aClass |
- aName := self selectedMessageName ifNil: [^ false].
- aClass := self selectedClassOrMetaClass ifNil: [^ false].
- ^aClass isSelectorOverridden: aName!
Item was removed:
- ----- Method: CodeHolder>>isThisAnOverride (in category 'misc') -----
- isThisAnOverride
- "Answer whether any superclass of my selected class implements my selected selector"
-
- | aName aClass |
- aName := self selectedMessageName ifNil: [^ false].
- aClass := self selectedClassOrMetaClass ifNil: [^ false].
- ^aClass isSelectorOverride: aName!
Item was removed:
- ----- Method: CodeHolder>>labelString (in category 'initialize-release') -----
- labelString
-
- ^ currentCompiledMethod
- ifNil: [self defaultBrowserTitle]
- ifNotNil: [
- ('{1} {2} \{{3}\} \{{4}\}' format: {
- self selectedClassOrMetaClass name.
- self selectedMessageName.
- self selectedMessageCategoryName.
- self selectedSystemCategoryName })]!
Item was removed:
- ----- Method: CodeHolder>>letUserReclassify:in: (in category 'categories') -----
- 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 logged: true.
- ^ true]
- ifFalse:
- [^ false]!
Item was removed:
- ----- Method: CodeHolder>>listPaneWithSelector: (in category 'categories & search pane') -----
- 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 |
- Smalltalk isMorphic ifFalse: [^ nil].
- ^ (aWindow := self containingWindow) ifNotNil:
- [aWindow paneMorphSatisfying:
- [:aMorph | (aMorph isKindOf: PluggableListMorph) and:
- [aMorph getListSelector == aSelector]]]!
Item was removed:
- ----- Method: CodeHolder>>makeSampleInstance (in category 'traits') -----
- makeSampleInstance
- | aClass nonMetaClass anInstance |
- ((aClass := self selectedClassOrMetaClass) isNil or: [aClass isTrait]) ifTrue: [^ self].
- nonMetaClass := aClass theNonMetaClass.
- anInstance := self sampleInstanceOfSelectedClass.
- (anInstance isNil and: [nonMetaClass ~~ UndefinedObject]) ifTrue:
- [^ self inform: 'Sorry, cannot make an instance of ', nonMetaClass name].
-
- (Smalltalk isMorphic and: [anInstance isMorph])
- ifTrue:
- [self currentHand attachMorph: anInstance]
- ifFalse:
- [anInstance inspectWithLabel: 'An instance of ', nonMetaClass name]!
Item was removed:
- ----- Method: CodeHolder>>messageHelpForMethod: (in category 'message list') -----
- messageHelpForMethod: aMethod
- "Answer the formatted help text for a method."
- "Show the first n lines of the source code of the method."
- | source formatted |
- source := aMethod getSource.
- formatted := (TextStyler for: #Smalltalk)
- ifNil: [ source asText ]
- ifNotNil: [ :textStylerClass |
- textStylerClass new
- classOrMetaClass: aMethod methodClass;
- styledTextFor: source asText ].
- ^ self messageHelpTruncated: formatted!
Item was removed:
- ----- Method: CodeHolder>>messageHelpTruncated: (in category 'message list') -----
- messageHelpTruncated: aText
- "Show only the first n lines of the text."
- | formatted lineCount |
- formatted := aText.
- lineCount := 0.
- aText withIndexDo: [:char :index |
- char = Character cr ifTrue: [lineCount := lineCount + 1].
- lineCount > 10 ifTrue: [
- formatted := formatted copyFrom: 1 to: index-1.
- formatted append: ' [...]'.
- ^ formatted]].
- ^ formatted!
Item was removed:
- ----- Method: CodeHolder>>messageListKey:from: (in category 'message list menu') -----
- messageListKey: aChar from: view
- "Overwritten to add more code-specific commands."
-
- aChar == $d ifTrue: [^ self removeMessageFromBrowser].
-
- self selectedClassOrMetaClass ifNotNil: [
- aChar == $r ifTrue: [^ self browseVariableReferences].
- aChar == $a ifTrue: [^ self browseVariableAssignments].
- (aChar == $Y and: [self canShowMultipleMessageCategories])
- ifTrue: [^ self showHomeCategory]].
-
- ^ super messageListKey: aChar from: view!
Item was removed:
- ----- Method: CodeHolder>>messageListMenuMore: (in category 'message list menu') -----
- messageListMenuMore: aMenu
- " The 'more..' link that toggles between shifted and unshifted menus
- in message lists and context stacks "
- <messageListMenuShifted: false>
- <contextStackMenuShifted: false>
- <menuPriority: 1000>
- ^ aMenu addList: #(
- -
- ('more...' shiftedYellowButtonActivity));
- yourself
- !
Item was removed:
- ----- Method: CodeHolder>>metaClassIndicated (in category 'accessing') -----
- metaClassIndicated
-
- ^ self selectedClassOrMetaClass isMeta!
Item was removed:
- ----- Method: CodeHolder>>methodCategoryChanged (in category 'categories') -----
- methodCategoryChanged
- self changed: #annotation!
Item was removed:
- ----- Method: CodeHolder>>modelWakeUpIn: (in category 'misc') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>multiWindowState (in category 'multi-window support') -----
- multiWindowState
- ^multiWindowState!
Item was removed:
- ----- Method: CodeHolder>>multiWindowState: (in category 'multi-window support') -----
- multiWindowState: aSavedMultiWindowState
- multiWindowState := aSavedMultiWindowState!
Item was removed:
- ----- Method: CodeHolder>>newSearchPane (in category 'categories & search pane') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>offerMenu (in category 'commands') -----
- offerMenu
- "Offer a menu to the user from the bar of tool buttons"
-
- self offerDurableMenuFrom: #messageListMenu:shifted: shifted: false!
Item was removed:
- ----- Method: CodeHolder>>offerShiftedClassListMenu (in category 'commands') -----
- offerShiftedClassListMenu
- "Offer the shifted class-list menu."
-
- ^ self offerMenuFrom: #classListMenu:shifted: shifted: true!
Item was removed:
- ----- Method: CodeHolder>>offerUnshiftedClassListMenu (in category 'commands') -----
- offerUnshiftedClassListMenu
- "Offer the shifted class-list menu."
-
- ^ self offerMenuFrom: #classListMenu:shifted: shifted: false!
Item was removed:
- ----- Method: CodeHolder>>offerWhatToShowMenu (in category 'what to show') -----
- offerWhatToShowMenu
- "Offer a menu governing what to show"
- | builder menuSpec |
- builder := ToolBuilder default.
- menuSpec := builder pluggableMenuSpec new.
- self contentsSymbolQuints do: [:aQuint | aQuint == #-
- ifTrue: [menuSpec addSeparator]
- ifFalse: [
- | item |
- item := menuSpec add: (self perform: aQuint third)
- target: self selector: aQuint second argumentList: #().
- item help: aQuint fifth.
- ].
- ].
- builder runModal: (builder open: menuSpec).!
Item was removed:
- ----- Method: CodeHolder>>okayToAccept (in category 'misc') -----
- 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 showingEditContentsOption ifTrue:
- [self inform: 'Cannot accept ', self contentsSymbol, ' input'.
- ^ false].
-
- self showingAnyKindOfDiffs ifFalse:
- [^ true].
- ^ (Project uiManager
- chooseOptionFrom:
- {'accept anyway -- I''ll take my chances'.
- 'um, let me reconsider'.}
- title:
- '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') = 1!
Item was removed:
- ----- Method: CodeHolder>>optionalButtonPairs (in category 'controls') -----
- 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' browseClassHierarchy 'browse class hierarchy')
- ('variables' browseVariableReferences 'browse references to variables...')).
-
- ^ aList!
Item was removed:
- ----- Method: CodeHolder>>optionalButtonsFrame (in category 'toolbuilder') -----
- optionalButtonsFrame
- ^LayoutFrame new
- leftFraction: 0 offset: 0;
- topFraction: 0 offset: 0;
- rightFraction: 1 offset: 0;
- bottomFraction: 0 offset: self buttonHeight!
Item was removed:
- ----- Method: CodeHolder>>prettyPrintString (in category 'what to show') -----
- prettyPrintString
- "Answer whether the receiver is showing pretty-print"
-
- ^ ((contentsSymbol == #prettyPrint)
- ifTrue:
- ['<yes>']
- ifFalse:
- ['<no>']), 'prettyPrint'!
Item was removed:
- ----- Method: CodeHolder>>priorSourceOrNil (in category 'misc') -----
- priorSourceOrNil
- "If the currently-selected method has a previous version, return its source, else return nil"
- | aClass aSelector changeRecords |
- (aClass := self selectedClassOrMetaClass) ifNil: [^ nil].
- (aSelector := self selectedMessageName) ifNil: [^ nil].
- changeRecords := aClass changeRecordsAt: aSelector.
- (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil].
- ^ (changeRecords at: 2) string
- !
Item was removed:
- ----- Method: CodeHolder>>receiverClass (in category 'toolbuilder') -----
- receiverClass
- ^ self selectedClassOrMetaClass !
Item was removed:
- ----- Method: CodeHolder>>refreshAnnotation (in category 'misc') -----
- 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]) ifNotNil:
- [:aPane | aPane hasUnacceptedEdits ifFalse:
- [aPane update: #annotation]]!
Item was removed:
- ----- Method: CodeHolder>>refusesToAcceptCode (in category 'misc') -----
- refusesToAcceptCode
- "Answer whether receiver, given its current contentsSymbol, could accept code happily if asked to"
-
- ^ (#(byteCodes documentation tiles) includes: self contentsSymbol)!
Item was removed:
- ----- Method: CodeHolder>>releaseCachedState (in category 'misc') -----
- releaseCachedState
- "Can always be found again. Don't write on a file."
- currentCompiledMethod := nil.!
Item was removed:
- ----- Method: CodeHolder>>removeClass (in category 'class functions') -----
- 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."
-
- self okToChange ifFalse: [^ false].
- ^ self systemNavigation confirmAndRemoveClass: self selectedClass!
Item was removed:
- ----- Method: CodeHolder>>removeMessage (in category 'message functions') -----
- 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. Answer a boolean indicating whether the removal was succesful."
-
- self okToChange ifFalse: [^ false].
- ^ self systemNavigation
- confirmAndRemoveSelector: self selectedMessageName
- class: self selectedClassOrMetaClass!
Item was removed:
- ----- Method: CodeHolder>>removeMessageCategory (in category 'message category functions') -----
- removeMessageCategory
- "If a message category is selected, create a Confirmer so the user can verify that the currently selected message category should be removed from the system. If so, remove it."
-
- self okToChange ifFalse: [^ false].
- ^ self systemNavigation
- confirmAndRemoveMessageCategory: self selectedMessageCategoryName
- class: self selectedClassOrMetaClass!
Item was removed:
- ----- Method: CodeHolder>>removeSystemCategory (in category 'system category functions') -----
- removeSystemCategory
- "If a class category is selected, create a Confirmer so the user can verify that the currently selected class category and all of its classes should be removed from the system. If so, remove it."
-
- self okToChange ifFalse: [^ false].
- ^ self systemNavigation confirmAndRemoveSystemCategory: self selectedSystemCategoryName!
Item was removed:
- ----- Method: CodeHolder>>restoreTextualCodingPane (in category 'diffs') -----
- restoreTextualCodingPane
- "If the receiver is showing tiles, restore the textual coding pane"
-
- contentsSymbol == #tiles ifTrue:
- [contentsSymbol := #source.
- self installTextualCodingPane]!
Item was removed:
- ----- Method: CodeHolder>>sampleInstanceOfSelectedClass (in category 'misc') -----
- sampleInstanceOfSelectedClass
- | aClass |
- "Return a sample instance of the class currently being pointed at"
- (aClass := self selectedClassOrMetaClass) ifNil: [^ nil].
- ^ aClass theNonMetaClass initializedInstance!
Item was removed:
- ----- Method: CodeHolder>>searchTextMorph (in category 'categories & search pane') -----
- searchTextMorph
- "Answer the search pane associated with the receiver in its window, or nil if none. Morphic only"
-
- | pane |
- pane := self anyTextPaneWithSelector: #lastSearchString.
- ^ pane isMorph ifTrue: [pane]!
Item was removed:
- ----- Method: CodeHolder>>selectedBytecodes (in category 'message list') -----
- selectedBytecodes
- "Answer text to show in a code pane when in showing-byte-codes mode"
-
- ^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName ifAbsent: [^ '' asText]) symbolic asText!
Item was removed:
- ----- Method: CodeHolder>>selectedClass (in category 'accessing') -----
- selectedClass
-
- ^ self selectedClassOrMetaClass ifNotNil: [:cls | cls theNonMetaClass]!
Item was removed:
- ----- Method: CodeHolder>>selectedClassOrMetaClass (in category 'accessing') -----
- selectedClassOrMetaClass
-
- ^ currentCompiledMethod ifNotNil: [:method | method methodClass]!
Item was removed:
- ----- Method: CodeHolder>>selectedMessage (in category 'message list') -----
- 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 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.
-
- ^ contents := (self showingDocumentation
- ifFalse: [self sourceStringPrettifiedAndDiffed]
- ifTrue: [ self commentContents])
- copy asText makeSelectorBoldIn: class!
Item was removed:
- ----- Method: CodeHolder>>selectedMessageCategoryName (in category 'categories') -----
- selectedMessageCategoryName
- "Answer the name of the message category of the message of the currently selected context."
-
- ^ self selectedClassOrMetaClass organization categoryOfElement: self selectedMessageName!
Item was removed:
- ----- Method: CodeHolder>>selectedMessageName (in category 'accessing') -----
- selectedMessageName
-
- ^ currentCompiledMethod
- ifNil: [super selectedMessageName]
- ifNotNil: [:method | method selector]!
Item was removed:
- ----- Method: CodeHolder>>selectedSystemCategoryName (in category 'categories') -----
- selectedSystemCategoryName
-
- ^ self systemOrganizer categoryOfElement: self selectedClass name!
Item was removed:
- ----- Method: CodeHolder>>sendQuery:to: (in category 'misc') -----
- sendQuery: querySelector to: queryPerformer
- "See commentary in #sendQuery:to:with:."
-
- ^ self sendQuery: querySelector to: queryPerformer with: { }!
Item was removed:
- ----- Method: CodeHolder>>sendQuery:to:with: (in category 'misc') -----
- sendQuery: querySelector to: queryPerformer with: queryArgs
- "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. Unlike #getSelectorAndSendQuery:to:with:, DO NOT let the user choose from the list of known symbols inside the selected context/message."
-
- ^ self selectedMessageName
- ifNotNil: [ :aSymbol | "We have a message name. Use it directly."
- queryPerformer
- perform: querySelector
- withArguments: {aSymbol}, queryArgs ]
- ifNil: [ "No message currently selected. Obtain a selector from a user type-in."
- (Project uiManager request: 'Type selector:' initialAnswer: 'flag:')
- ifEmpty: [ nil "Cancelled by user" ]
- ifNotEmpty: [ :typeIn | | selectorString |
- (Symbol lookup: (selectorString := typeIn asLegalSelector))
- ifNil: [ self inform: 'There is no symbol known as #', selectorString ]
- ifNotNil: [ :aSymbol |
- queryPerformer
- perform: querySelector
- withArguments: {aSymbol}, queryArgs ] ]]!
Item was removed:
- ----- Method: CodeHolder>>setClass:selector: (in category 'initialize-release') -----
- setClass: aBehavior selector: aSymbol
-
- contents := nil.
- currentCompiledMethod := aBehavior compiledMethodAt: aSymbol.
- self changed: #relabel.
- self contentsChanged.
- self decorateButtons.!
Item was removed:
- ----- Method: CodeHolder>>setClassAndSelectorIn: (in category 'misc') -----
- setClassAndSelectorIn: csBlock
- "Evaluate csBlock with my selected class and and selector as its arguments; provide nil arguments if I don't have a method currently selected"
-
- | aName |
- (aName := self selectedMessageName)
- ifNil:
- [csBlock value: nil value: nil]
- ifNotNil:
- [csBlock value: self selectedClassOrMetaClass value: aName]
- !
Item was removed:
- ----- Method: CodeHolder>>setContentsToForceRefetch (in category 'what to show') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>shiftedMessageListMore: (in category 'message list menu') -----
- shiftedMessageListMore: aMenu
- " The 'more..' link that toggles between shifted and unshifted menus
- in message lists and context stacks "
- <messageListMenuShifted: true>
- <contextStackMenuShifted: true>
- <menuPriority: 1000>
- ^ aMenu addList: #(
- -
- ('more...' unshiftedYellowButtonActivity));
- yourself
- !
Item was removed:
- ----- Method: CodeHolder>>shiftedYellowButtonActivity (in category 'commands') -----
- shiftedYellowButtonActivity
- "Offer the shifted selector-list menu"
-
- ^ self offerMenuFrom: #messageListMenu:shifted: shifted: true!
Item was removed:
- ----- Method: CodeHolder>>showByteCodes: (in category 'what to show') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>showDecompile: (in category 'what to show') -----
- showDecompile: aBoolean
- "Set the decompile toggle as indicated"
-
- self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#decompile])!
Item was removed:
- ----- Method: CodeHolder>>showDiffs (in category 'diffs') -----
- 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
- !
Item was removed:
- ----- Method: CodeHolder>>showDiffs: (in category 'diffs') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>showDocumentation: (in category 'what to show') -----
- showDocumentation: aBoolean
- "Set the showDocumentation toggle as indicated"
-
- self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#documentation])!
Item was removed:
- ----- Method: CodeHolder>>showPrettyDiffs: (in category 'diffs') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>showRegularDiffs: (in category 'diffs') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>showUnreferencedClassVars (in category 'traits') -----
- 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) isNil or: [cls isTrait]) ifTrue: [^ 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.
- UIManager default chooseFrom: aList values: aList
- title: 'Unreferenced
- class variables in
- ' , cls name!
Item was removed:
- ----- Method: CodeHolder>>showUnreferencedInstVars (in category 'traits') -----
- 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) isNil or: [cls isTrait]) ifTrue: [^ 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.
- UIManager default chooseFrom: aList values: aList title: 'Unreferenced
- instance variables in
- ', cls name!
Item was removed:
- ----- Method: CodeHolder>>showingAnyKindOfDiffs (in category 'diffs') -----
- showingAnyKindOfDiffs
- "Answer whether the receiver is currently set to show any kind of diffs"
-
- ^ #(showDiffs prettyDiffs) includes: contentsSymbol!
Item was removed:
- ----- Method: CodeHolder>>showingByteCodes (in category 'what to show') -----
- showingByteCodes
- "Answer whether the receiver is showing bytecodes"
-
- ^ contentsSymbol == #byteCodes!
Item was removed:
- ----- Method: CodeHolder>>showingByteCodesString (in category 'what to show') -----
- showingByteCodesString
- "Answer whether the receiver is showing bytecodes"
-
- ^ (self showingByteCodes
- ifTrue:
- ['<yes>']
- ifFalse:
- ['<no>']), 'byteCodes'!
Item was removed:
- ----- Method: CodeHolder>>showingDecompile (in category 'what to show') -----
- showingDecompile
- "Answer whether the receiver should show decompile rather than, say, source code"
-
- ^ self contentsSymbol == #decompile
- !
Item was removed:
- ----- Method: CodeHolder>>showingDecompileString (in category 'what to show') -----
- showingDecompileString
- "Answer a string characerizing whether decompilation is showing"
-
- ^ (self showingDecompile
- ifTrue:
- ['<yes>']
- ifFalse:
- ['<no>']), 'decompile'!
Item was removed:
- ----- Method: CodeHolder>>showingDocumentation (in category 'what to show') -----
- showingDocumentation
- "Answer whether the receiver should show documentation rather than, say, source code"
-
- ^ self contentsSymbol == #documentation
- !
Item was removed:
- ----- Method: CodeHolder>>showingDocumentationString (in category 'what to show') -----
- showingDocumentationString
- "Answer a string characerizing whether documentation is showing"
-
- ^ (self showingDocumentation
- ifTrue:
- ['<yes>']
- ifFalse:
- ['<no>']), 'documentation'!
Item was removed:
- ----- Method: CodeHolder>>showingEditContentsOption (in category 'what to show') -----
- showingEditContentsOption
- "True if any of the optional EditContentsOptions modes is in effect. This
- includes bytecode display and possibly other display modes."
-
- ^ EditContentsOptions includesKey: self contentsSymbol
- !
Item was removed:
- ----- Method: CodeHolder>>showingPlainSource (in category 'what to show') -----
- showingPlainSource
- "Answer whether the receiver is showing plain source"
-
- ^ contentsSymbol == #source!
Item was removed:
- ----- Method: CodeHolder>>showingPlainSourceString (in category 'what to show') -----
- showingPlainSourceString
- "Answer a string telling whether the receiver is showing plain source"
-
- ^ (self showingPlainSource
- ifTrue:
- ['<yes>']
- ifFalse:
- ['<no>']), 'source'!
Item was removed:
- ----- Method: CodeHolder>>showingPrettyDiffs (in category 'diffs') -----
- showingPrettyDiffs
- "Answer whether the receiver is showing pretty diffs of source code"
-
- ^ contentsSymbol == #prettyDiffs
- !
Item was removed:
- ----- Method: CodeHolder>>showingPrettyDiffsString (in category 'diffs') -----
- showingPrettyDiffsString
- "Answer a string representing whether I'm showing pretty diffs"
-
- ^ (self showingPrettyDiffs
- ifTrue:
- ['<yes>']
- ifFalse:
- ['<no>']), 'prettyDiffs'!
Item was removed:
- ----- Method: CodeHolder>>showingPrettyPrint (in category 'what to show') -----
- showingPrettyPrint
- "Answer whether the receiver is showing pretty-print"
-
- ^ contentsSymbol == #prettyPrint!
Item was removed:
- ----- Method: CodeHolder>>showingRegularDiffs (in category 'diffs') -----
- showingRegularDiffs
- "Answer whether the receiver is showing regular diffs of source code"
-
- ^ contentsSymbol == #showDiffs
- !
Item was removed:
- ----- Method: CodeHolder>>showingRegularDiffsString (in category 'diffs') -----
- showingRegularDiffsString
- "Answer a string representing whether I'm showing regular diffs"
-
- ^ (self showingRegularDiffs
- ifTrue:
- ['<yes>']
- ifFalse:
- ['<no>']), 'showDiffs'!
Item was removed:
- ----- Method: CodeHolder>>showingSource (in category 'what to show') -----
- showingSource
- "Answer whether the receiver is currently showing source code"
-
- ^ self contentsSymbol == #source
- !
Item was removed:
- ----- Method: CodeHolder>>sourceAndDiffsQuintsOnly (in category 'controls') -----
- 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'))!
Item was removed:
- ----- Method: CodeHolder>>sourceStringPrettifiedAndDiffed (in category 'message list') -----
- 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 inClass: class.
- (#(#prettyPrint #prettyDiffs)
- includes: contentsSymbol)
- ifTrue:
- [sourceString := class prettyPrinterClass
- format: sourceString
- in: class
- notifying: nil].
- self showingAnyKindOfDiffs
- ifTrue: [sourceString := self diffFromPriorSourceFor: sourceString].
- ^sourceString!
Item was removed:
- ----- Method: CodeHolder>>spawn: (in category 'commands') -----
- 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"
-
- self selectedClassOrMetaClass
- ifNil: [
- ^ aString isEmptyOrNil ifFalse: [(Workspace new contents: aString) openLabel: 'spawned workspace']]
- ifNotNil: [:cls |
- self categoryOfCurrentMethod
- ifNil: [
- self buildClassBrowserEditString: aString]
- ifNotNil: [:category |
- self
- buildMessageCategoryBrowserForCategory: category
- class: cls
- selector: self selectedMessageName
- editString: aString]]!
Item was removed:
- ----- Method: CodeHolder>>spawnHierarchy (in category 'traits') -----
- spawnHierarchy
- "Create and schedule a new hierarchy browser on the currently selected class or meta."
-
- ^ ToolSet
- browseHierarchy: self selectedClassOrMetaClass
- selector: self selectedMessageName!
Item was removed:
- ----- Method: CodeHolder>>spawnToClass: (in category 'commands') -----
- 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."
-
- self categoryOfCurrentMethod
- ifNil: [
- self buildClassBrowserEditString: self contents]
- ifNotNil: [:category |
- self
- buildMessageCategoryBrowserForCategory: category
- class: aClass
- selector: nil
- editString: self contents]!
Item was removed:
- ----- Method: CodeHolder>>spawnToCollidingClass: (in category 'commands') -----
- 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.'!
Item was removed:
- ----- Method: CodeHolder>>stepIn: (in category 'self-updating') -----
- stepIn: aSystemWindow
- self updateListsAndCodeIn: aSystemWindow!
Item was removed:
- ----- Method: CodeHolder>>suggestCategoryToSpawnedBrowser: (in category 'misc') -----
- 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!
Item was removed:
- ----- Method: CodeHolder>>systemOrganizer (in category 'accessing') -----
- systemOrganizer
-
- ^ SystemOrganization!
Item was removed:
- ----- Method: CodeHolder>>textFrame (in category 'toolbuilder') -----
- textFrame
- | topOffset bottomOffset |
- topOffset := self wantsOptionalButtons
- ifTrue: [self buttonHeight]
- ifFalse: [0].
- bottomOffset := self wantsAnnotationPane
- ifTrue: [self annotationPaneHeight negated]
- ifFalse: [0].
- ^LayoutFrame new
- leftFraction: 0 offset: 0;
- topFraction: 0 offset: topOffset;
- rightFraction: 1 offset: 0;
- bottomFraction: 1 offset: bottomOffset!
Item was removed:
- ----- Method: CodeHolder>>toggleBreakOnEntry (in category 'breakpoints') -----
- toggleBreakOnEntry
- "Install or uninstall a halt-on-entry breakpoint"
-
- | selectedMethod |
- self selectedClassOrMetaClass ifNil: [ ^self].
- selectedMethod := self selectedClassOrMetaClass
- compiledMethodAt: self selectedMessageName
- ifAbsent: [^ self].
- selectedMethod hasBreakpoint
- ifTrue:
- [BreakpointManager unInstall: selectedMethod]
- ifFalse:
- [BreakpointManager
- installInClass: self selectedClassOrMetaClass
- selector: self selectedMessageName].
- self changed: #messageList!
Item was removed:
- ----- Method: CodeHolder>>toggleDecompile (in category 'what to show') -----
- 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]
-
- !
Item was removed:
- ----- Method: CodeHolder>>toggleDiffing (in category 'diffs') -----
- 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]
-
- !
Item was removed:
- ----- Method: CodeHolder>>togglePlainSource (in category 'diffs') -----
- 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]
-
- !
Item was removed:
- ----- Method: CodeHolder>>togglePrettyDiffing (in category 'diffs') -----
- 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]
-
- !
Item was removed:
- ----- Method: CodeHolder>>togglePrettyPrint (in category 'diffs') -----
- 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]
-
- !
Item was removed:
- ----- Method: CodeHolder>>toggleRegularDiffing (in category 'diffs') -----
- 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]
-
- !
Item was removed:
- ----- Method: CodeHolder>>toggleShowDocumentation (in category 'what to show') -----
- 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]
-
- !
Item was removed:
- ----- Method: CodeHolder>>toggleShowingByteCodes (in category 'what to show') -----
- toggleShowingByteCodes
- "Toggle whether the receiver is showing bytecodes"
-
- self restoreTextualCodingPane.
- self showByteCodes: self showingByteCodes not.
- self setContentsToForceRefetch.
- self contentsChanged!
Item was removed:
- ----- Method: CodeHolder>>unshiftedYellowButtonActivity (in category 'commands') -----
- unshiftedYellowButtonActivity
- "Offer the unshifted shifted selector-list menu"
-
- ^ self offerMenuFrom: #messageListMenu:shifted: shifted: false!
Item was removed:
- ----- Method: CodeHolder>>updateCodePaneIfNeeded (in category 'self-updating') -----
- 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]]!
Item was removed:
- ----- Method: CodeHolder>>updateListsAndCodeIn: (in category 'self-updating') -----
- updateListsAndCodeIn: aWindow
- super updateListsAndCodeIn: aWindow.
- self updateCodePaneIfNeeded!
Item was removed:
- ----- Method: CodeHolder>>useSelector:orGetSelectorAndSendQuery:to: (in category 'misc') -----
- useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer
-
- self flag: #deprecated.
- self selectedMessageName = incomingSelector
- ifFalse: [^ self notify: 'This protocol is not supported anymore. Please revise using #seletedMessageName and either #sendQuery:to:with: or #getSelectorAndSendQuery:to:with:.'].
-
- ^ self sendQuery: querySelector to: queryPerformer!
Item was removed:
- ----- Method: CodeHolder>>validateMessageSource:forSelector:inClass: (in category 'message list') -----
- validateMessageSource: sourceString forSelector: aSelector inClass: theClass
- "Check whether there is evidence that method source is invalid"
-
- (theClass newParser parseSelector: sourceString asString) = aSelector
- ifFalse: [self informPossiblyCorruptSource].!
Item was removed:
- ----- Method: CodeHolder>>versionsButtonEnabled (in category 'toolbuilder') -----
- versionsButtonEnabled
- "The versions button is only enabled when a method is selected or we view the
- class comment."
-
- ^ self selectedMessageName notNil or: [self classCommentIndicated]!
Item was removed:
- ----- Method: CodeHolder>>wantsCodeProvenanceButton (in category 'what to show') -----
- wantsCodeProvenanceButton
-
- ^ true!
Item was removed:
- ----- Method: CodeHolder>>wantsDiffFeedback (in category 'diffs') -----
- wantsDiffFeedback
- "Answer whether the receiver is showing diffs of source code"
-
- ^ self showingAnyKindOfDiffs!
Item was removed:
- ----- Method: CodeHolder>>wantsStepsIn: (in category 'self-updating') -----
- wantsStepsIn: aWindow
- ^ Preferences smartUpdating!
Item was removed:
- ----- Method: Collection class>>toolIcon (in category '*Tools-icons') -----
- toolIcon
-
- ^ #collection!
Item was removed:
- ----- Method: Collection>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Collection'!
Item was removed:
- ----- Method: Collection>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
-
- ^ CollectionInspector!
Item was removed:
- Inspector subclass: #CollectionInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !CollectionInspector commentStamp: 'mt 3/31/2020 10:18' prior: 0!
- I am an Inspector that is specialized for inspecting collections. I provide extended access to the inspected collection's items, such as adding and removing items.
-
- Note that I can directly inspect instances of ArrayedCollection and alike.!
Item was removed:
- ----- Method: CollectionInspector>>addCollectionItemsTo: (in category 'menu - construction') -----
- addCollectionItemsTo: aMenu
-
- aMenu addLine.
- super addCollectionItemsTo: aMenu.
-
- self object isReadOnlyObject ifTrue: [^ self].
- aMenu addTranslatedList: #(
- ('refresh list view' updateFields) "--- useful in non-stepping debugger").
-
- self canAddOrRemoveElements ifFalse: [^ self].
- aMenu addTranslatedList: #(
- -
- ('add element...' addElement)).
-
- self typeOfSelection = #element ifFalse: [^ self].
- aMenu addTranslatedList: #(
- ('remove element (x)' removeSelection)).!
Item was removed:
- ----- Method: CollectionInspector>>addElement (in category 'menu - commands') -----
- addElement
-
- self addElement: (
- self
- requestObject: 'Enter expression for new object' translated
- orCancel: [^ self]).!
Item was removed:
- ----- Method: CollectionInspector>>addElement: (in category 'menu - commands') -----
- addElement: anObject
-
- self object add: anObject.
-
- self updateFields.
- self selectFieldSuchThat: [:field | [(field getValueFor: self) == anObject] ifError: [false]].
- self hasSelection ifFalse: [self inform: ('The new element {1} was added.\\Yet, the list of fields is quite long. The new field\got truncated and is thus not visible.' translated withCRs format: {anObject printString})].!
Item was removed:
- ----- Method: CollectionInspector>>assertElementSelectedOr: (in category 'private') -----
- assertElementSelectedOr: aBlock
-
- ^ self typeOfSelection = #element
- or: [aBlock cull: self selectedField]!
Item was removed:
- ----- Method: CollectionInspector>>canAddOrRemoveElements (in category 'private') -----
- canAddOrRemoveElements
- "For simplicity, treat those properties together. There are no collections that support addition but deny removal of elements."
-
- ^ #(add: remove:ifAbsent:) noneSatisfy: [:selector |
- (self object class lookupSelector: selector) hasLiteral: #shouldNotImplement]!
Item was removed:
- ----- Method: CollectionInspector>>elementGetterAt: (in category 'private') -----
- elementGetterAt: index
-
- ^ [:collection | collection at: index] !
Item was removed:
- ----- Method: CollectionInspector>>elementIndices (in category 'private') -----
- elementIndices
-
- ^ 1 to: self objectSize!
Item was removed:
- ----- Method: CollectionInspector>>elementNameAt: (in category 'private') -----
- elementNameAt: index
-
- ^ index printString!
Item was removed:
- ----- Method: CollectionInspector>>elementSetterAt: (in category 'private') -----
- elementSetterAt: index
-
- ^ [:collection :element | collection at: index put: element] !
Item was removed:
- ----- Method: CollectionInspector>>inspectOne (in category 'menu - commands') -----
- inspectOne
- "Only list the collection's elements. Ignore any other fields."
-
- self inspectOneOf: self elementIndices.!
Item was removed:
- ----- Method: CollectionInspector>>inspectorKey:from: (in category 'menu') -----
- inspectorKey: aChar from: view
-
- ^ aChar = $x
- ifTrue: [self removeSelection]
- ifFalse: [super inspectorKey: aChar from: view].!
Item was removed:
- ----- Method: CollectionInspector>>objectSize (in category 'private') -----
- objectSize
- "For robustness. Partially initialized collections may fail to report their size. Useful for the debugger's inspectors."
-
- ^ [self object size] ifError: [0]!
Item was removed:
- ----- Method: CollectionInspector>>removeSelectedElement (in category 'menu - commands') -----
- removeSelectedElement
-
- self object remove: self selection.!
Item was removed:
- ----- Method: CollectionInspector>>removeSelection (in category 'menu - commands') -----
- removeSelection
- "Keep the selection stable to support subsequent removals. Be robust against collections that do not allow elements to be removed such as arrays."
-
- | priorSelectionIndex |
- super removeSelection.
-
- self assertElementSelectedOr: [^ self changed: #flash].
- priorSelectionIndex := self selectionIndex.
-
- [self removeSelectedElement]
- ifError: [^ self changed: #flash].
-
- self updateFields.
- self selectionIndex: (priorSelectionIndex min: self fields size).!
Item was removed:
- ----- Method: CollectionInspector>>requestObject:initialAnswer:orCancel: (in category 'ui requests') -----
- requestObject: aMessageString initialAnswer: anAnswerString orCancel: aBlock
-
- | input |
- input := Project uiManager
- request: aMessageString
- initialAnswer: anAnswerString.
- input isEmptyOrNil ifTrue: [^ aBlock value].
- ^ Compiler evaluate: input for: self object!
Item was removed:
- ----- Method: CollectionInspector>>requestObject:orCancel: (in category 'ui requests') -----
- requestObject: aMessageString orCancel: aBlock
-
- ^ self
- requestObject: aMessageString
- initialAnswer: String empty
- orCancel: aBlock!
Item was removed:
- ----- Method: CollectionInspector>>selectElementAt: (in category 'selection') -----
- selectElementAt: index
-
- self selectFieldSuchThat: [:field | field type = #element and: [field key = index]].!
Item was removed:
- ----- Method: CollectionInspector>>selectedElementIndex (in category 'selection') -----
- selectedElementIndex
-
- self assertElementSelectedOr: [^ nil].
- ^ self selectedField key!
Item was removed:
- ----- Method: CollectionInspector>>streamElementsOn: (in category 'fields - streaming') -----
- streamElementsOn: aStream
- "Create a field for each element in the collection. Use the index' #printString (and not #asString) to reveal the nature of the key, which are usually integers (1, 2, 3, ...), but can be symbols (#apple, #tree, ...) or other objects (aMorph, aSocket, ...) in dictionary-like collections. Maybe #storeString would be even better but can be very expensive to compute."
-
- self
- streamOn: aStream
- truncate: self elementIndices
- collectFields: [:index |
- (self newFieldForType: #element key: index)
- name: (self elementNameAt: index);
- valueGetter: (self elementGetterAt: index);
- valueSetter: (self elementSetterAt: index);
- yourself]!
Item was removed:
- ----- Method: CollectionInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') -----
- streamIndexedVariablesOn: aStream
- "Override to rename 'index variables' to the collection's 'elements'."
-
- self streamElementsOn: aStream.!
Item was removed:
- ----- Method: CompiledBlock>>blockExtentsToTempsMap (in category '*Tools-Debugger-support') -----
- blockExtentsToTempsMap
- ^self homeMethod blockExtentsToTempsMap!
Item was removed:
- ----- Method: CompiledBlock>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'CompiledBlock'!
Item was removed:
- ----- Method: CompiledBlock>>debuggerMap (in category '*Tools-Debugger-support') -----
- debuggerMap
- ^self homeMethod debuggerMap!
Item was removed:
- ----- Method: CompiledBlock>>startKey (in category '*Tools-Debugger-support') -----
- startKey
- "The startKey is used as a key to identify the active sequence of temporaries for a block or
- method in a DebuggerMethodMapForClosureCompiledMethod's startKeysToTempRefs map."
- ^self!
Item was removed:
- ----- Method: CompiledCode>>abstractPCForConcretePC: (in category '*Tools-Debugger-support') -----
- abstractPCForConcretePC: concretePC
- "Answer the abstractPC matching concretePC."
-
- | abstractPC scanner client endPC |
- self flag: 'belongs in DebuggerMethodMap?'.
- abstractPC := 1.
- scanner := InstructionStream on: self.
- client := InstructionClient new.
- "cache endPC for methods with embedded source; finding out the endPC is very slow in this case..."
- endPC := self endPC.
- [(scanner pc > endPC
- or: [scanner pc >= concretePC]) ifTrue:
- [^abstractPC].
- abstractPC := abstractPC + 1.
- scanner interpretNextInstructionFor: client] repeat!
Item was removed:
- ----- Method: CompiledCode>>concretePCForAbstractPC: (in category '*Tools-Debugger-support') -----
- concretePCForAbstractPC: abstractPCQuery
- "Answer the concretePC matching abstractPC."
-
- | abstractPC scanner client endPC |
- self flag: 'belongs in DebuggerMethodMap?'.
- abstractPC := 1.
- scanner := InstructionStream on: self.
- client := InstructionClient new.
- "cache endPC for methods with embedded source; finding out the endPC is very slow in this case..."
- endPC := self endPC.
- [abstractPC >= abstractPCQuery ifTrue:
- [^scanner pc].
- abstractPC := abstractPC + 1.
- scanner interpretNextInstructionFor: client.
- scanner pc < endPC] whileTrue.
- ^endPC!
Item was removed:
- ----- Method: CompiledCode>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
- "Answer the class of the inspector to be used on the receiver. Called by inspect;
- use basicInspect to get a normal (less useful) type of inspector."
-
- ^ CompiledCodeInspector!
Item was removed:
- Inspector subclass: #CompiledCodeInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !CompiledCodeInspector commentStamp: 'ct 1/12/2020 15:21' prior: 0!
- I am an inspector specialized for inspecting CompiledMethods.!
Item was removed:
- ----- Method: CompiledCodeInspector>>fieldByteCodes (in category 'fields') -----
- fieldByteCodes
-
- ^ (self newFieldForType: #all key: #byteCodes)
- name: 'all bytecodes' translated; emphasizeName;
- valueGetter: [:object | object symbolic]; printValueAsIs;
- yourself!
Item was removed:
- ----- Method: CompiledCodeInspector>>fieldDecompile (in category 'fields') -----
- fieldDecompile
-
- ^ (self newFieldForType: #code key: #decompile)
- name: 'decompiled' translated; emphasizeName;
- valueGetter: [:compiledCode | compiledCode decompile decompileString]; printValueAsIs;
- yourself!
Item was removed:
- ----- Method: CompiledCodeInspector>>fieldHeader (in category 'fields') -----
- fieldHeader
-
- ^ (self newFieldForType: #misc key: #header)
- name: 'header' translated; emphasizeName;
- valueGetter: [:object | object headerDescription]; printValueAsIs;
- yourself!
Item was removed:
- ----- Method: CompiledCodeInspector>>fieldSource (in category 'fields') -----
- fieldSource
-
- ^ (self newFieldForType: #code key: #source)
- name: 'source code' translated; emphasizeName;
- valueGetter: [:compiledCode | '"{1}"\{2}' withCRs format: {compiledCode methodClass. compiledCode getSource}]; printValueAsIs;
- shouldStyleValue: true;
- yourself!
Item was removed:
- ----- Method: CompiledCodeInspector>>streamBaseFieldsOn: (in category 'fields - streaming') -----
- streamBaseFieldsOn: aStream
- "Instead of 'all inst vars' show all byte codes and header summary."
-
- aStream
- nextPut: self fieldSelf;
- nextPut: self fieldSource;
- nextPut: self fieldDecompile;
- nextPut: self fieldByteCodes;
- nextPut: self fieldHeader.!
Item was removed:
- ----- Method: CompiledCodeInspector>>streamByteCodesOn: (in category 'fields - streaming') -----
- streamByteCodesOn: aStream
-
- self
- streamOn: aStream
- truncate: (self object initialPC to: self object size)
- collectFields: [:pc |
- (self newFieldForType: #bytecode key: pc)
- valueGetter: [:compiledCode | compiledCode at: pc];
- flag: #dangerous; "mt: We might want to disallow inadvertent changes here..."
- valueSetter: [:compiledCode :bytecode | compiledCode at: pc put: bytecode; voidCogVMState];
- yourself]!
Item was removed:
- ----- Method: CompiledCodeInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') -----
- streamIndexedVariablesOn: aStream
- "Separate all indexed variables in literals and byte codes."
-
- self
- streamLiteralsOn: aStream;
- streamByteCodesOn: aStream.!
Item was removed:
- ----- Method: CompiledCodeInspector>>streamLiteralsOn: (in category 'fields - streaming') -----
- streamLiteralsOn: aStream
-
- self flag: #decompile. "mt: Use #to: and #do: instead of #to:do: to avoid inlining to preserve bindings in enumeration block for later decompilation. See InspectorField."
- (1 to: self object numLiterals) do: [:index |
- aStream nextPut: ((self newFieldForType: #literal key: index)
- name: 'literal' , index;
- valueGetter: [:compiledCode | compiledCode literalAt: index];
- flag: #dangerous; "mt: We might want to disallow inadvertent changes here..."
- valueSetter: [:compiledCode :literal | compiledCode literalAt: index put: literal; voidCogVMState];
- yourself)].!
Item was removed:
- ----- Method: CompiledCodeInspector>>updateStyler:requestor: (in category 'user interface - styling') -----
- updateStyler: aStyler requestor: anObject
- "Overridden to configure the styler to parse method source code correctly."
-
- | parseAMethod classOrMetaClass |
- self selectedField
- ifNil: [super updateStyler: aStyler requestor: anObject]
- ifNotNil: [:field |
- (anObject knownName = #valuePane and: [field type = #code])
- ifTrue: [parseAMethod := true. classOrMetaClass := self object methodClass]
- ifFalse: [parseAMethod := false. classOrMetaClass := self doItReceiver class].
-
- aStyler
- environment: self environment;
- classOrMetaClass: classOrMetaClass;
- context: self doItContext;
- parseAMethod: parseAMethod].
-
- !
Item was removed:
- ----- Method: CompiledMethod>>blockExtentsToTempsMap (in category '*Tools-Debugger-support') -----
- blockExtentsToTempsMap
- "If the receiver has been copied with temp names answer a
- map from blockExtent to temps map in the same format as
- BytecodeEncoder>>blockExtentsToTempNamesMap. if the
- receiver has not been copied with temps answer nil."
- ^self holdsTempNames ifTrue:
- [self mapFromBlockKeys: (self debuggerMap startKeysToBlockExtents values sort: [:assocA :assocB| assocA first <= assocB first])
- toSchematicTemps: self tempNamesString]!
Item was removed:
- ----- Method: CompiledMethod>>browse (in category '*Tools-Browsing') -----
- browse
-
- ^ ToolSet browseMethod: self!
Item was removed:
- ----- Method: CompiledMethod>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'CompiledMethod'!
Item was removed:
- ----- Method: CompiledMethod>>debuggerMap (in category '*Tools-Debugger-support') -----
- debuggerMap
- ^DebuggerMethodMap forMethod: self!
Item was removed:
- ----- Method: CompiledMethod>>startKey (in category '*Tools-Debugger-support') -----
- startKey
- "The startKey is used as a key to identify the active sequence of temporaries for a block or
- method in a DebuggerMethodMapForClosureCompiledMethod's startKeysToTempRefs map."
- ^self initialPC!
Item was removed:
- ----- Method: CompiledMethod>>tempsSubSequenceFrom: (in category '*Tools-Debugger-support') -----
- tempsSubSequenceFrom: tempNamesStream
- ^Array streamContents:
- [:tsss|
- [tempNamesStream skipSeparators.
- tempNamesStream atEnd
- or: ['[]()' includes: tempNamesStream peek]] whileFalse:
- [tsss nextPut: (String streamContents:
- [:s|
- [s nextPut: tempNamesStream next.
- tempNamesStream peek
- ifNil: [true]
- ifNotNil: [:peek| ' []()' includes: peek]] whileFalse])]]
-
- "thisContext method tempsSubSequenceFrom: 'les temps perdu(sont n''est pas la)' readStream"
- "thisContext method tempsSubSequenceFrom: ('les temps perdu(sont n''est pas la)' readStream skipTo: $(; yourself)"!
Item was removed:
- ----- Method: Context>>errorReportOn: (in category '*Tools-debugger access') -----
- 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 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 Context>>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) < 20]] 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 = 20 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr].
- strm print: aContext; cr. "just class>>selector"
-
- "exit early if too long..."
- strm position > (startPos+ self class maxLengthForASingleDebugLogReport) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. cnt > self class maxStackDepthForASingleDebugLogReport ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self].
- aContext := aContext sender]
- !
Item was removed:
- ----- Method: Context>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
-
- ^ ContextInspector!
Item was removed:
- ----- Method: Context>>namedTempAt: (in category '*Tools-debugger access') -----
- namedTempAt: index
- "Answer the value of the temp at index in the receiver's sequence of tempNames."
- ^self debuggerMap namedTempAt: index in: self!
Item was removed:
- ----- Method: Context>>namedTempAt:put: (in category '*Tools-debugger access') -----
- namedTempAt: index put: aValue
- "Set the value of the temp at index in the receiver's sequence of tempNames.
- (Note that if the value is a copied value it is also set out along the lexical chain,
- but alas not in along the lexical chain.)."
- ^self debuggerMap namedTempAt: index put: aValue in: self!
Item was removed:
- ----- Method: Context>>print:on: (in category '*Tools-debugger access') -----
- print: anObject on: aStream
- "Safely print anObject in the face of direct ProtoObject subclasses."
- | objClass title |
- objClass := self objectClass: anObject.
- (objClass canUnderstand: #printOn:) ifTrue:
- [^anObject printOn: aStream].
- title := objClass name.
- aStream
- nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']);
- nextPutAll: title!
Item was removed:
- ----- Method: Context>>startKey (in category '*Tools-debugger access') -----
- startKey
- "The startKey is used as a key to identify the active sequence of temporaries for a block or
- method in a DebuggerMethodMapForClosureCompiledMethod's startKeysToTempRefs map."
- ^closureOrNil
- ifNil: [method initialPC]
- ifNotNil: [closureOrNil isFullBlock
- ifTrue: [method]
- ifFalse: [closureOrNil startpc]]!
Item was removed:
- ----- Method: Context>>tempNames (in category '*Tools-debugger access') -----
- tempNames
- "Answer a SequenceableCollection of the names of the receiver's temporary
- variables, which are strings."
-
- ^ self debuggerMap tempNamesForContext: self!
Item was removed:
- ----- Method: Context>>tempsAndValues (in category '*Tools-debugger access') -----
- tempsAndValues
- "Return a string of the temporary variables and their current values"
- ^self debuggerMap tempsAndValuesForContext: self!
Item was removed:
- ----- Method: Context>>tempsAndValuesContractedTo: (in category '*Tools-debugger access') -----
- tempsAndValuesContractedTo: width
- "Return a string of the temporary variables and their current values"
- ^self debuggerMap tempsAndValuesForContext: self contractTo: width!
Item was removed:
- ----- Method: Context>>tempsAndValuesLimitedTo:indent: (in category '*Tools-debugger access') -----
- tempsAndValuesLimitedTo: sizeLimit indent: indent
- "Return a string of the temporary variabls and their current values"
-
- | aStream |
- aStream := WriteStream on: (String new: 100).
- self tempNames
- withIndexDo: [:title :index |
- indent timesRepeat: [aStream tab].
- aStream nextPutAll: title; nextPut: $:; space; tab.
- aStream nextPutAll:
- ((self namedTempAt: index) printStringLimitedTo: (sizeLimit - 3 - title size max: 1)).
- aStream cr].
- ^aStream contents!
Item was removed:
- Inspector subclass: #ContextInspector
- instanceVariableNames: ''
- classVariableNames: 'CachedStackTopLabel CachedTempVarsLabel'
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !ContextInspector commentStamp: 'ct 1/12/2020 15:26' prior: 0!
- I am an Inspector that is specialized for inspecting Contexts.!
Item was removed:
- ----- Method: ContextInspector>>allTempVarsTranslated (in category 'private') -----
- allTempVarsTranslated
- "Alas translation is slow enough that we notice the slow down in trying to step in the debugger..."
- (CurrentLocale ~= Locale current
- or: [CachedTempVarsLabel isNil]) ifTrue:
- [CurrentLocale := Locale current.
- CachedTempVarsLabel := 'all temp vars' translated].
- ^CachedTempVarsLabel!
Item was removed:
- ----- Method: ContextInspector>>defaultIntegerBase (in category 'user interface') -----
- defaultIntegerBase
- "Answer the default base in which to print integers.
- Defer to the class of the instance."
-
- ^ (self object receiver class respondsTo: #defaultIntegerBaseInDebugger)
- ifTrue: [self object receiver class perform: #defaultIntegerBaseInDebugger]
- ifFalse: [10]!
Item was removed:
- ----- Method: ContextInspector>>stackTopTranslated (in category 'private') -----
- stackTopTranslated
- "Alas translation is slow enough that we notice the slow down in trying to step in the debugger..."
- (CurrentLocale ~= Locale current
- or: [CachedStackTopLabel isNil]) ifTrue:
- [CurrentLocale := Locale current.
- CachedStackTopLabel := 'stack top' translated].
- ^CachedStackTopLabel!
Item was removed:
- ----- Method: ContextInspector>>streamFieldsOn: (in category 'fields - streaming') -----
- streamFieldsOn: aStream
-
- self object ifNil: [
- ^ self streamError: 'Cannot inspect a nil context' translated on: aStream].
- self object method ifNil: [
- ^ self streamError: 'Cannot inspect a context with nil method' translated on: aStream].
-
- super streamFieldsOn: aStream.!
Item was removed:
- ----- Method: ContextInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') -----
- streamIndexedVariablesOn: aStream
- "Just show (indexed) stack variables to the list."
-
- self streamStackVariablesOn: aStream.!
Item was removed:
- ----- Method: ContextInspector>>streamInstanceVariablesOn: (in category 'fields - streaming') -----
- streamInstanceVariablesOn: aStream
- "Add (named) temporary variables to the list."
-
- super streamInstanceVariablesOn: aStream.
- self streamTemporaryVariablesOn: aStream.!
Item was removed:
- ----- Method: ContextInspector>>streamStackVariablesOn: (in category 'fields - streaming') -----
- streamStackVariablesOn: aStream
- "If this context's stack pointer is not valid, silently skip streaming fields for stack variables. Do not stream an error field because freshly created or terminated contexts can be like this."
-
- self object stackPtr ifNil: [^ self].
-
- self flag: #decompile. "mt: Use #to: and #do: instead of #to:do: to avoid inlining to preserve bindings in enumeration block for later decompilation. See InspectorField."
- (self object numTemps + 1 to: self object stackPtr) do: [:index |
- aStream nextPut: ((self newFieldForType: #stackItem key: index)
- name: 'stack', index; deEmphasizeName;
- valueGetter: [:object | object at: index];
- valueSetter: [:object :value | object at: index put: value];
- yourself)]!
Item was removed:
- ----- Method: ContextInspector>>streamTemporaryVariablesOn: (in category 'fields - streaming') -----
- streamTemporaryVariablesOn: aStream
-
- | tempNames |
- tempNames := [self object tempNames] ifError: [
- ^ self streamError: 'Invalid temporaries' translated on: aStream].
-
- tempNames withIndexDo: [:name :index |
- aStream nextPut: ((self newFieldForType: #tempVar key: name)
- name: ('[{1}]' format: {name});
- valueGetter: [:context | context namedTempAt: index];
- valueSetter: [:context :value | context namedTempAt: index put: value];
- yourself)]!
Item was removed:
- ContextInspector subclass: #ContextVariablesInspector
- instanceVariableNames: ''
- classVariableNames: 'ShowStackVariables'
- poolDictionaries: ''
- category: 'Tools-Debugger'!
-
- !ContextVariablesInspector commentStamp: 'mt 3/25/2020 16:32' prior: 0!
- I am an inspector that is specialized to inspecting the variables of a Context. I am typically displayed as part of a Debugger, where I sit besides an inspector for the receiver object. That's why a traditional Contextinspector would not work because it makes "ThisContext" be "self".
-
- At some point, this should subclass from Contextinspector.!
Item was removed:
- ----- Method: ContextVariablesInspector class>>showStackVariables (in category 'preferences') -----
- showStackVariables
- <preference: 'Show stack variables in debugger'
- category: #debug
- description: 'When true, append the unnamed stack variables (if any) below the named temps in the debugger''s context inspector.'
- type: #Boolean>
- ^ ShowStackVariables ifNil: [false]!
Item was removed:
- ----- Method: ContextVariablesInspector class>>showStackVariables: (in category 'preferences') -----
- showStackVariables: aBoolean
-
- ShowStackVariables := aBoolean.!
Item was removed:
- ----- Method: ContextVariablesInspector>>doItContext (in category 'code') -----
- doItContext
-
- ^object!
Item was removed:
- ----- Method: ContextVariablesInspector>>doItReceiver (in category 'code') -----
- doItReceiver
-
- ^object ifNotNil: [object receiver]!
Item was removed:
- ----- Method: ContextVariablesInspector>>expressionForField: (in category 'private') -----
- expressionForField: anInspectorField
- "Use #ThisContext instead of #self. Note the capital 'T' to not refer to the special keyword #thisContext, which would return the current execution context but not the one we are currently inspecting."
-
- ^ anInspectorField expressionWithReceiverName: #ThisContext!
Item was removed:
- ----- Method: ContextVariablesInspector>>fieldAllTempVars (in category 'fields') -----
- fieldAllTempVars
-
- ^ (self newFieldForType: #all key: #allTempVars)
- name: self allTempVarsTranslated; emphasizeName;
- valueGetter: [:object | object tempsAndValuesContractedTo: 64]; printValueAsIs;
- yourself!
Item was removed:
- ----- Method: ContextVariablesInspector>>fieldSelf (in category 'fields') -----
- fieldSelf
-
- ^ super fieldSelf
- name: 'thisContext';
- yourself!
Item was removed:
- ----- Method: ContextVariablesInspector>>fieldStackTop (in category 'fields') -----
- fieldStackTop
-
- ^ (self newFieldForType: #stackTop key: #stackTop)
- name: self stackTopTranslated; emphasizeName;
- valueGetter: [:ctxt | ctxt top];
- valueGetterExpression: 'ThisContext top';
- valueSetter: [:ctxt :value | ctxt pop; push: value];
- valueSetterExpression: '[:value | ThisContext pop; push: value]';
- yourself!
Item was removed:
- ----- Method: ContextVariablesInspector>>streamBaseFieldsOn: (in category 'fields - streaming') -----
- streamBaseFieldsOn: aStream
-
- self object ifNil: [^ self].
- aStream nextPut: self fieldSelf.
- self object actualStackSize > 0
- ifTrue: [aStream nextPut: self fieldStackTop].
- aStream nextPut: self fieldAllTempVars.!
Item was removed:
- ----- Method: ContextVariablesInspector>>streamIndexedVariablesOn: (in category 'fields - streaming') -----
- streamIndexedVariablesOn: aStream
-
- self class showStackVariables ifTrue: [
- self streamStackVariablesOn: aStream].!
Item was removed:
- ----- Method: ContextVariablesInspector>>streamInstanceVariablesOn: (in category 'fields - streaming') -----
- streamInstanceVariablesOn: aStream
- "Just show the (named) temporary variables to the list. Hide internals. The receiver is in the debugger's companion inspector."
-
- self streamTemporaryVariablesOn: aStream.!
Item was removed:
- ----- Method: ContextVariablesInspector>>streamTemporaryVariablesOn: (in category 'fields - streaming') -----
- streamTemporaryVariablesOn: aStream
- "Overwritten to change the visuals of temps in debuggers."
-
- | tempNames |
- tempNames := [self object tempNames] ifError: [
- ^ self streamError: 'Invalid temporaries' translated on: aStream].
-
- tempNames withIndexDo: [:name :index |
- aStream nextPut: ((self newFieldForType: #tempVar key: name)
- shouldStyleName: true;
- valueGetter: [:context | context namedTempAt: index];
- valueSetter: [:context :value | context namedTempAt: index put: value];
- yourself)].!
Item was removed:
- SelectionMenu subclass: #CustomMenu
- instanceVariableNames: 'labels dividers lastDivider title targets arguments'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Menus'!
-
- !CustomMenu commentStamp: 'nice 3/24/2010 07:36' prior: 0!
- I am used to build menus on-the-fly. I maintain lists of menu items, actions (usually symbols to be sent as messages), and menu section dividing lines to which my clients may append new entries and lines by sending me the messages:
-
- add: aString action: anAction
- addLine
-
- After the menu is constructed, it may be invoked with one of the following messages:
-
- startUp: initialSelection
- startUp
-
- I am a subclass of ActionMenu, so I inherit a number of instance variables. The ones I am particularly concerned with are:
-
- items := an OrderedCollection of strings to appear in the menu
- selectors := an OrderedCollection of Symbols to be used as message selectors
- lineArray := an OrderedCollection of line positions
- lastLine := used to keep track of the last line to avoid making duplicate entries in lineArray!
Item was removed:
- ----- Method: CustomMenu class>>example (in category 'example') -----
- example
- "CustomMenu example"
-
- | menu |
- menu := CustomMenu new.
- menu add: 'apples' action: #apples.
- menu add: 'oranges' action: #oranges.
- menu addLine.
- menu addLine. "extra lines ignored"
- menu add: 'peaches' action: #peaches.
- menu addLine.
- menu add: 'pears' action: #pears.
- menu addLine.
- ^ menu startUp: #apples
-
-
- "NB: The following is equivalent to the above, but uses the compact #fromArray: consruct:
- (CustomMenu fromArray:
- #( ('apples' apples)
- ('oranges' oranges)
- -
- -
- ('peaches' peaches)
- -
- ('pears' pears)
- -))
- startUp: #apples"!
Item was removed:
- ----- Method: CustomMenu>>add:action: (in category 'construction') -----
- add: aString action: actionItem
- "Add the given string as the next menu item. If it is selected, the given action (usually but not necessarily a symbol) will be returned to the client."
-
- | s |
- aString ifNil: [^ self addLine].
- s := String new: aString size + 2.
- s at: 1 put: Character space.
- s replaceFrom: 2 to: s size - 1 with: aString.
- s at: s size put: Character space.
- labels addLast: s.
- selections addLast: actionItem.!
Item was removed:
- ----- Method: CustomMenu>>add:subMenu:target:selector:argumentList: (in category 'compatibility') -----
- 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.!
Item was removed:
- ----- Method: CustomMenu>>add:target:selector: (in category 'compatibility') -----
- add: aString target: target selector: aSymbol
-
- self add: aString
- target: target
- selector: aSymbol
- argumentList: #()!
Item was removed:
- ----- Method: CustomMenu>>add:target:selector:argument: (in category 'compatibility') -----
- 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)!
Item was removed:
- ----- Method: CustomMenu>>add:target:selector:argumentList: (in category 'compatibility') -----
- 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
- !
Item was removed:
- ----- Method: CustomMenu>>addLine (in category 'construction') -----
- addLine
- "Append a line to the menu after the last entry. Suppress duplicate lines."
-
- (lastDivider ~= selections size) ifTrue: [
- lastDivider := selections size.
- dividers addLast: lastDivider].!
Item was removed:
- ----- Method: CustomMenu>>addList: (in category 'construction') -----
- addList: listOfTuplesAndDashes
- "Add a menu item to the receiver for each tuple in the given list of the form (<what to show> <selector>). 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"
-
- !
Item was removed:
- ----- Method: CustomMenu>>addService:for: (in category 'compatibility') -----
- 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.!
Item was removed:
- ----- Method: CustomMenu>>addServices2:for:extraLines: (in category 'compatibility') -----
- addServices2: services for: served extraLines: linesArray
-
- services withIndexDo: [:service :i |
- service addServiceFor: served toMenu: self.
- (linesArray includes: i) ifTrue: [self addLine] ]!
Item was removed:
- ----- Method: CustomMenu>>addServices:for:extraLines: (in category 'compatibility') -----
- addServices: services for: served extraLines: linesArray
-
- services withIndexDo: [:service :i |
- self addService: service for: served.
- (linesArray includes: i) | service useLineAfter
- ifTrue: [self addLine]]!
Item was removed:
- ----- Method: CustomMenu>>addStayUpItem (in category 'construction') -----
- addStayUpItem
- "For compatibility with MenuMorph. Here it is a no-op"!
Item was removed:
- ----- Method: CustomMenu>>addStayUpItemSpecial (in category 'construction') -----
- addStayUpItemSpecial
- "For compatibility with MenuMorph. Here it is a no-op"!
Item was removed:
- ----- Method: CustomMenu>>addTitle: (in category 'construction') -----
- addTitle: aString
- "For compatibility with MenuMorph. Here it is a no-op"!
Item was removed:
- ----- Method: CustomMenu>>addTranslatedList: (in category 'construction') -----
- addTranslatedList: listOfTuplesAndDashes
- "Add a menu item to the receiver for each tuple in the given list of the form (<what to show> <selector>). 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"
-
- !
Item was removed:
- ----- Method: CustomMenu>>arguments (in category 'compatibility') -----
- arguments
- "Answer my arguments, initializing them to an empty collection if they're found to be nil."
-
- ^ arguments ifNil: [arguments := OrderedCollection new]!
Item was removed:
- ----- Method: CustomMenu>>balloonTextForLastItem: (in category 'construction') -----
- balloonTextForLastItem: aString
- "Vacuous backstop provided for compatibility with MorphicMenu"!
Item was removed:
- ----- Method: CustomMenu>>build (in category 'private') -----
- build
- "Turn myself into an invokable ActionMenu."
-
- | stream |
- stream := WriteStream on: (String new).
- labels do: [:label | stream nextPutAll: label; cr].
- (labels isEmpty) ifFalse: [stream skip: -1]. "remove final cr"
- super labels: stream contents
- font: Preferences standardMenuFont
- lines: dividers!
Item was removed:
- ----- Method: CustomMenu>>initialize (in category 'initialize-release') -----
- initialize
-
- labels := OrderedCollection new.
- selections := OrderedCollection new.
- dividers := OrderedCollection new.
- lastDivider := 0.
- targets := OrderedCollection new.
- arguments := OrderedCollection new !
Item was removed:
- ----- Method: CustomMenu>>invokeOn: (in category 'invocation') -----
- 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!
Item was removed:
- ----- Method: CustomMenu>>invokeOn:defaultSelection: (in category 'invocation') -----
- invokeOn: targetObject defaultSelection: defaultSelection
- "Invoke the menu with the given default selection (i.e. one of my 'action' symbols). Answer the 'action' selector associated with the menu item chosen by the user or nil if none is chosen."
-
- | sel |
- sel := self startUp: defaultSelection.
- sel = nil ifFalse: [
- sel numArgs = 0
- ifTrue: [^ targetObject perform: sel]
- ifFalse: [^ targetObject perform: sel with: nil]].
- ^ nil
- !
Item was removed:
- ----- Method: CustomMenu>>invokeOn:orSendTo: (in category 'invocation') -----
- 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)]]!
Item was removed:
- ----- Method: CustomMenu>>labels:font:lines: (in category 'construction') -----
- labels: aString font: aFont lines: anArrayOrNil
- "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:."
-
- | labelList linesArray |
- labelList := aString lines asArray.
- anArrayOrNil
- ifNil: [linesArray := #()]
- ifNotNil: [linesArray := anArrayOrNil].
- 1 to: labelList size do: [:i |
- self add: (labelList at: i) action: (labelList at: i).
- (linesArray includes: i) ifTrue: [self addLine]].
- font ifNotNil: [font := aFont].
- !
Item was removed:
- ----- Method: CustomMenu>>labels:lines:selections: (in category 'construction') -----
- 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 lines]
- ifFalse: [labelArray := labelList].
- 1 to: labelArray size do: [:i |
- self add: (labelArray at: i) action: (selectionsArray at: i).
- (linesArray includes: i) ifTrue: [self addLine]].
- !
Item was removed:
- ----- Method: CustomMenu>>preSelect: (in category 'private') -----
- preSelect: action
- "Pre-select and highlight the menu item associated with the given action."
-
- | i |
- i := selections indexOf: action ifAbsent: [^ self].
- marker ifNil: [self computeForm].
- marker := marker
- align: marker topLeft
- with: (marker left)@(frame inside top + (marker height * (i - 1))).
- selection := i.!
Item was removed:
- ----- Method: CustomMenu>>startUp (in category 'invocation') -----
- startUp
- "Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."
-
- ^ self startUp: nil!
Item was removed:
- ----- Method: CustomMenu>>startUp: (in category 'invocation') -----
- startUp: initialSelection
- "Build and invoke this menu with the given initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."
-
- ^ self startUp: initialSelection withCaption: title!
Item was removed:
- ----- Method: CustomMenu>>startUp:withCaption: (in category 'invocation') -----
- startUp: initialSelection withCaption: caption
- "Build and invoke this menu with the given initial selection and caption. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."
-
- self build.
- (initialSelection notNil) ifTrue: [self preSelect: initialSelection].
- ^ super startUpWithCaption: caption!
Item was removed:
- ----- Method: CustomMenu>>startUpWithCaption: (in category 'invocation') -----
- startUpWithCaption: caption
- "Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen; use the provided caption"
-
- ^ self startUp: nil withCaption: caption!
Item was removed:
- ----- Method: CustomMenu>>targets (in category 'compatibility') -----
- targets
- "Answer my targets, initializing them to an empty collection if found to be nil"
-
- ^ targets ifNil: [targets := OrderedCollection new]!
Item was removed:
- ----- Method: CustomMenu>>title: (in category 'initialize-release') -----
- title: aTitle
- title := aTitle!
Item was removed:
- CodeHolder subclass: #Debugger
- instanceVariableNames: 'interruptedProcess contextStack contextStackIndex contextStackList receiverInspector receiverInspectorState contextVariablesInspector contextVariablesInspectorState externalInterrupt proceedValue selectingPC savedCursor isolationHead failedProject labelString message untilExpression terminateProcessSelector'
- classVariableNames: 'CloseMeansAbandon ContextStackKeystrokes ErrorReportServer FullStackSize InterruptUIProcessIfBlockedOnErrorInBackgroundProcess NotifierStackSize SavedExtent ShowAbandonButton ShowTerminateButton StackSizeLimit WantsAnnotationPane'
- poolDictionaries: ''
- category: 'Tools-Debugger'!
-
- !Debugger commentStamp: 'mt 12/17/2019 12:19' prior: 0!
- I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context.
-
- Special note on recursive errors:
- Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery.
-
- * A recursive error is detected.
- * The current project is queried for an isolationHead
- * Changes in the isolationHead are revoked
- * The parent project of isolated project is returned to
- * The debugger is opened there and execution resumes.
-
- If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world.
-
- ---
-
- In September 2019, we added MorphicDebugger and MVCDebugger to untangle framework-specific features in our debugger infrastructure. However, this is just an intermediate step. The overall goal would be to remove those two subclasses again while preserving their functionality. Mostly, MVC and Morphic differ in their GUI-process management. This means that "proceed" and "close" work differently depending on the process that is being debugged. --- One idea is to attach that framework-specific information to the process objects. See Process >> #environmentAt: and #environmentAt:put:. Also see ToolSet's #handle* and #debug* methods.!
Item was removed:
- ----- Method: Debugger class>>closeMeansAbandon (in category 'preferences') -----
- closeMeansAbandon
- <preference: 'Terminate aggressively on window closed'
- categoryList: #(debug tools)
- description: 'When enabled, closing the window of a full or notifier debugger will terminate the process aggressively, which means that the active unwind context (i.e., ensure-block) will not be completed. Not-yet-started unwind contexts are allowed to start and complete.'
- type: #Boolean>
-
- ^ CloseMeansAbandon ifNil: [true]!
Item was removed:
- ----- Method: Debugger class>>closeMeansAbandon: (in category 'preferences') -----
- closeMeansAbandon: aBooleanOrNil
-
- CloseMeansAbandon := aBooleanOrNil.!
Item was removed:
- ----- Method: Debugger class>>errorReportServer (in category 'preferences') -----
- errorReportServer
- <preference: 'Server to send error reports to'
- category: 'debug'
- description: 'When eToyFriendly is enabled, the debugger offers to send an error report to the developers of the system. This variable controls where this error report is sent to.'
- type: #String>
- ^ErrorReportServer ifNil: ['']!
Item was removed:
- ----- Method: Debugger class>>errorReportServer: (in category 'preferences') -----
- errorReportServer: aString
-
- ErrorReportServer := aString!
Item was removed:
- ----- Method: Debugger class>>fullStackSize (in category 'preferences') -----
- fullStackSize
-
- <preference: 'Stack Size in Full Debugger'
- categoryList: #(debug tools)
- description: 'The number of stack frames to be shown in the full debugger. You can always expand the full stack there.'
- type: #Number>
-
- ^ FullStackSize ifNil: [20]!
Item was removed:
- ----- Method: Debugger class>>fullStackSize: (in category 'preferences') -----
- fullStackSize: aNumberOrNil
-
- FullStackSize := aNumberOrNil ifNotNil: [:num | num max: self notifierStackSize].!
Item was removed:
- ----- Method: Debugger class>>ifPreferredInterruptUIProcessIfBlocked: (in category 'private') -----
- ifPreferredInterruptUIProcessIfBlocked: errorWasInUIProcess
- | sema |
- errorWasInUIProcess ifTrue:
- [^self].
- self interruptUIProcessIfBlockedOnErrorInBackgroundProcess ifFalse:
- [^self].
- "Only interrupt the UI if it is unresponsive (and so is doing something that needs
- interrupting). Test using addDeferredUIMessage: to see if it is running UI activities."
- sema := Semaphore new.
- Project current addDeferredUIMessage: [sema signal].
- (sema waitTimeoutMSecs: 100) ifTrue:
- [[Project current interruptName: 'Interrupt from Background Error'] fork]
-
- "| s |
- s := Semaphore new.
- [self assert: 0 > 1000. s signal] fork.
- s wait"!
Item was removed:
- ----- Method: Debugger class>>informExistingDebugger:label: (in category 'instance creation') -----
- 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 executed outside of the debugger.
- hmm 8/3/2001 13:05"
- | ctx quickStepMethod oldSender baseContext |
- ctx := thisContext.
- quickStepMethod := Context
- compiledMethodAt: #quickSend:to:with:lookupIn:
- ifAbsent: [Context compiledMethodAt: #quickSend:to:with:super:].
- [ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse:
- [ctx := ctx sender].
- ctx sender ifNil: [^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 objectClass: ctx receiver) includesBehavior: self]] whileFalse:
- [ctx := ctx sender].
- ctx ifNil: [^self].
- "ctx is the context of the Debugger method #doStep"
- ctx receiver
- labelString: aString;
- proceedValue: aContext receiver.
- baseContext swapSender: baseContext sender sender sender. "remove intervening contexts"
- thisContext swapSender: oldSender. "make myself return to debugger"
- ^ aContext!
Item was removed:
- ----- Method: Debugger class>>initialize (in category 'class initialization') -----
- initialize
- 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.
- SavedExtent := self new initialExtent
-
- "Debugger initialize"!
Item was removed:
- ----- Method: Debugger class>>interruptUIProcessIfBlockedOnErrorInBackgroundProcess (in category 'preferences') -----
- interruptUIProcessIfBlockedOnErrorInBackgroundProcess
- <preference: 'Interrupt UI process on background error'
- category: 'debug'
- description: 'When enabled, the debugger will interrupt the UI process if an error occurs in a background process and the UI process is blocked.'
- type: #Boolean>
- ^InterruptUIProcessIfBlockedOnErrorInBackgroundProcess ifNil: [false]!
Item was removed:
- ----- Method: Debugger class>>interruptUIProcessIfBlockedOnErrorInBackgroundProcess: (in category 'preferences') -----
- interruptUIProcessIfBlockedOnErrorInBackgroundProcess: aBoolean
- InterruptUIProcessIfBlockedOnErrorInBackgroundProcess := aBoolean!
Item was removed:
- ----- Method: Debugger class>>notifierStackSize (in category 'preferences') -----
- notifierStackSize
-
- <preference: 'Stack Size in Notifier Debugger'
- categoryList: #(debug tools)
- description: 'If there is no message to be displayed in the notifier, how many stack frames should be visible?'
- type: #Number>
-
- ^ NotifierStackSize ifNil: [10]!
Item was removed:
- ----- Method: Debugger class>>notifierStackSize: (in category 'preferences') -----
- notifierStackSize: anInteger
-
- NotifierStackSize := anInteger.!
Item was removed:
- ----- Method: Debugger class>>openOn:context:label:contents:fullView: (in category 'opening') -----
- openOn: process context: context label: titleOrNil contents: contentsStringOrNil fullView: bool
- "Kind of private. Open a notifier or a full debugger in response to an error, halt, or notify. Opens a project-specific debugger. Decorates that invocation with (1) recursive-error detection and (2) error logging, which are both independent from the active GUI framework, that is, MVC or Morphic.
-
- Note that clients should debug processes through Process >> #debug instead of calling this method directly."
-
- | ap title |
- title := titleOrNil ifNil: ['Debugger' translated].
- ap := Processor activeProcess.
-
- "If the active process re-enters this method again, something went wrong with invoking the debugger."
- ap hasRecursiveError ifTrue: [
- ap clearErrorRecursionFlag.
- ^ ToolSet handleRecursiveError: title].
-
- "Explicitely handle logging exceptions. No need to bother the recursion mechanism here."
- [Preferences logDebuggerStackToFile
- ifTrue: [Smalltalk logSqueakError: title inContext: context]
- ] on: Error do: [:ex |
- Preferences disable: #logDebuggerStackToFile.
- ToolSet debugException: ex].
-
- "If project-specific debuggers mess up, we have to flag that recursion here. Se above."
- [ap setErrorRecursionFlag.
-
- self informExistingDebugger: context label: title.
-
- ^ Project current debuggerClass
- openOn: process context: context label: title contents: contentsStringOrNil fullView: bool
-
- ] ensure: [ap clearErrorRecursionFlag].!
Item was removed:
- ----- Method: Debugger class>>showAbandonButton (in category 'preferences') -----
- showAbandonButton
- <preference: 'Show ''Abandon'' button in notifier debugger'
- categoryList: #(debug tools)
- description: 'An extra button in the notifier window that allows the user to terminate the process aggressively, which means that the active unwind context (i.e., ensure-block) will not be completed. Not-yet-started unwind contexts are allowed to start and complete.'
- type: #Boolean>
-
- ^ ShowAbandonButton ifNil: [true]!
Item was removed:
- ----- Method: Debugger class>>showAbandonButton: (in category 'preferences') -----
- showAbandonButton: aBooleanOrNil
-
- ShowAbandonButton := aBooleanOrNil.!
Item was removed:
- ----- Method: Debugger class>>showTerminateButton (in category 'preferences') -----
- showTerminateButton
- <preference: 'Show ''Terminate'' button in notifier debugger'
- categoryList: #(debug tools)
- description: 'An extra button in the notifier window that allows the user to terminate the process while allowing the active context (i.e., ensure-block) to unwind first.'
- type: #Boolean>
-
- ^ ShowTerminateButton ifNil: [false]!
Item was removed:
- ----- Method: Debugger class>>showTerminateButton: (in category 'preferences') -----
- showTerminateButton: aBooleanOrNil
-
- ShowTerminateButton := aBooleanOrNil.!
Item was removed:
- ----- Method: Debugger class>>stackSizeLimit (in category 'preferences') -----
- stackSizeLimit
-
- <preference: 'Stack Size Limit'
- categoryList: #(debug tools)
- description: 'Even when expanding the entire stack, there should be a limit to avoid low-space errors.'
- type: #Number>
-
- ^ StackSizeLimit ifNil: [100000]!
Item was removed:
- ----- Method: Debugger class>>stackSizeLimit: (in category 'preferences') -----
- stackSizeLimit: aNumber
-
- StackSizeLimit := aNumber max: self fullStackSize.!
Item was removed:
- ----- Method: Debugger class>>wantsAnnotationPane (in category 'preferences') -----
- wantsAnnotationPane
- <preference: 'Show annotation pane in the debugger.'
- categoryList: #(debug tools)
- description: 'If true, a small horizontal annotation pane shows information about the selected method.'
- type: #Boolean>
- ^ WantsAnnotationPane ifNil: [false]!
Item was removed:
- ----- Method: Debugger class>>wantsAnnotationPane: (in category 'preferences') -----
- wantsAnnotationPane: boolean
-
- WantsAnnotationPane := boolean.!
Item was removed:
- ----- Method: Debugger>>abandon (in category 'context stack menu') -----
- abandon
- "Close the debugger and terminate the debugged process from the pre-debugger notifier window."
-
- self flag: #dicuss. "mt: Wouldn't it be better to let the current ensure block finish from within the pre-debugger notifier window? To use #terminate instead?"
- terminateProcessSelector := #terminateAggressively.
- self close
- !
Item was removed:
- ----- Method: Debugger>>aboutToStyle: (in category 'code pane') -----
- aboutToStyle: aStyler
- "This is a notification that aStyler is about to re-style its text.
- Set the classOrMetaClass in aStyler, so that identifiers
- will be resolved correctly.
- Answer true to allow styling to proceed, or false to veto the styling"
-
- self isModeStyleable ifFalse: [^false].
- aStyler
- classOrMetaClass: self selectedClassOrMetaClass;
- sourceMap: self debuggerMap.
- ^true!
Item was removed:
- ----- Method: Debugger>>addModelItemsToWindowMenu: (in category 'misc') -----
- addModelItemsToWindowMenu: aMenu
-
- super addModelItemsToWindowMenu: aMenu.
-
- aMenu addLine.
- aMenu
- add: 'inspect process' translated target: self interruptedProcess action: #inspect;
- add: 'explore process' translated target: self interruptedProcess action: #explore;
- addLine;
- add: 'terminate process' translated target: self action: #terminateProcess;
- balloonTextForLastItem: 'Terminates this process while allowing the active context to unwind first. Unlike ''abandon,'' even a currently active ensure-block will be allowed to finish.' translated;
- add: 'abandon process' translated target: self action: #abandon;
- balloonTextForLastItem: 'Terminates this process <b>aggressively</b>, still allowing not-yet-started unwind contexts to start and complete. Unlike ''terminate,'' a currently active ensure-block will be discarded. ' translated asTextFromHtml.!
Item was removed:
- ----- Method: Debugger>>askForCategoryIn:default: (in category 'notifier support') -----
- askForCategoryIn: aClass default: aString
-
- ^ (Project uiManager
- chooseFromOrAddTo: (aClass allMethodCategoriesIntegratedThrough: Object)
- lines: #()
- title: 'Please provide a good category for the new method' translated)
- ifNil: [aString]
- ifNotNil: [:newCategory | newCategory ifEmpty: [aString]]!
Item was removed:
- ----- Method: Debugger>>askForSuperclassOf:toImplement:ifCancel: (in category 'notifier support') -----
- askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock
- | classes chosenClassIndex |
- classes := aClass withAllSuperclasses.
- chosenClassIndex := UIManager default
- chooseFrom: (classes collect: [:c | c name])
- title: 'Define #', aSelector, ' in which class?'.
- chosenClassIndex = 0 ifTrue: [^ cancelBlock value].
- ^ classes at: chosenClassIndex!
Item was removed:
- ----- Method: Debugger>>askForSuperclassOf:upTo:toImplement:ifCancel: (in category 'notifier support') -----
- askForSuperclassOf: aClass upTo: superclass toImplement: aSelector ifCancel: cancelBlock
- | classes chosenClassIndex |
- classes := aClass withAllSuperclasses reject: [:cls | aClass isKindOf: cls].
- chosenClassIndex := UIManager default
- chooseFrom: (classes collect: [:c | c name])
- title: 'Define #', aSelector, ' in which class?'.
- chosenClassIndex = 0 ifTrue: [^ cancelBlock value].
- ^ classes at: chosenClassIndex!
Item was removed:
- ----- Method: Debugger>>browseClassHierarchy (in category 'toolbuilder') -----
- browseClassHierarchy
- "Create and schedule a class list browser on the receiver's hierarchy."
-
- (self selectedMessageName = #doesNotUnderstand: and: [ self selectedClassOrMetaClass = Object ])
- ifTrue:
- [ self systemNavigation
- spawnHierarchyForClass: self receiverClass
- selector: self selectedMessageName ]
- ifFalse: [ super browseClassHierarchy ]!
Item was removed:
- ----- Method: Debugger>>browseMessages (in category 'context stack menu') -----
- browseMessages
- "Present a menu of all messages sent by the currently selected message.
- Open a message set browser of all implementors of the message chosen.
- Do nothing if no message is chosen."
-
- contextStackIndex = 0 ifTrue: [^ self].
- self withSelectorAndMessagesIn: self selectedContext method
- evaluate: [:selector| self systemNavigation browseAllImplementorsOf: selector]!
Item was removed:
- ----- Method: Debugger>>browseSendersOfMessages (in category 'context stack menu') -----
- browseSendersOfMessages
- "Present a menu of the currently selected message, as well as all
- messages sent by it. Open a message set browser of all senders
- of the message chosen."
-
- contextStackIndex = 0 ifTrue: [^ self].
- self withSelectorAndMessagesIn: self selectedContext method
- evaluate: [:selector| self systemNavigation browseAllCallsOn: selector]!
Item was removed:
- ----- Method: Debugger>>browseVersions (in category 'context stack menu') -----
- browseVersions
- "Create and schedule a message set browser on all versions of the currently selected message selector."
- (ToolSet
- browseVersionsOf: self selectedClassOrMetaClass
- selector: self selectedMessageName) ifNil: [self changed: #flash]!
Item was removed:
- ----- Method: Debugger>>buildCodePaneWith: (in category 'toolbuilder') -----
- buildCodePaneWith: builder
-
- | textSpec top controlButtons browseButtons annoSpec |
- top := builder pluggablePanelSpec new.
- top children: OrderedCollection new.
-
- controlButtons := self buildControlButtonsWith: builder.
- controlButtons frame: self controlButtonsFrame.
- top children add: controlButtons.
-
- self wantsOptionalButtons ifTrue: [
- browseButtons := self buildOptionalButtonsWith: builder.
- browseButtons frame: self optionalButtonsFrame.
- top children add: browseButtons].
-
- textSpec := builder pluggableCodePaneSpec new.
- textSpec
- model: self;
- getText: #contents;
- setText: #contents:notifying:;
- selection: #contentsSelection;
- menu: #codePaneMenu:shifted:;
- frame: self textFrame.
- top children add: textSpec.
-
- self wantsAnnotationPane ifTrue: [
- annoSpec := self buildAnnotationPaneWith: builder.
- annoSpec frame: self annotationFrame.
- top children add: annoSpec].
- .
- ^ top!
Item was removed:
- ----- Method: Debugger>>buildControlButtonsWith: (in category 'toolbuilder') -----
- buildControlButtonsWith: builder
-
- | panelSpec |
- panelSpec := builder pluggablePanelSpec new.
- panelSpec children: OrderedCollection new.
- self customButtonSpecs do:[:spec|
- | buttonSpec |
- buttonSpec := builder pluggableActionButtonSpec new.
- buttonSpec model: self.
- buttonSpec label: spec first.
- buttonSpec action: spec second.
- spec second == #methodHierarchy ifTrue:[
- buttonSpec color: #inheritanceButtonColor.
- ].
- spec size > 2 ifTrue:
- [buttonSpec help: spec third.
- spec size > 3 ifTrue:
- [buttonSpec enabled: spec fourth]].
- panelSpec children add: buttonSpec.
- ].
-
- panelSpec layout: #horizontal. "buttons"
- ^panelSpec!
Item was removed:
- ----- Method: Debugger>>buildFullWith: (in category 'toolbuilder') -----
- buildFullWith: builder
- | windowSpec listSpec textSpec |
- windowSpec := builder pluggableWindowSpec new
- model: self;
- label: 'Debugger';
- children: OrderedCollection new.
-
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #contextStackList;
- getIndex: #contextStackIndex;
- setIndex: #toggleContextStackIndex:;
- menu: #contextStackMenu:shifted:;
- icon: #messageIconAt:;
- helpItem: #messageHelpAt:;
- keyPress: #contextStackKey:from:;
- frame: (0@0 corner: 1(a)0.22).
- windowSpec children add: listSpec.
-
-
- textSpec := self buildCodePaneWith: builder.
- textSpec frame: (0(a)0.22corner: 1(a)0.8).
- windowSpec children add: textSpec.
-
- listSpec := self receiverInspector buildFieldListWith: builder.
- listSpec
- frame: (0(a)0.8 corner: 0.2@1);
- help: 'Receiver''s\Instance\Variables' withCRs.
- windowSpec children add: listSpec.
-
- textSpec := self receiverInspector buildValuePaneWith: builder.
- textSpec
- help: '<- Select receiver''s field' translated;
- frame: (0.2(a)0.8 corner: 0.5@1).
- windowSpec children add: textSpec.
-
- listSpec := self contextVariablesInspector buildFieldListWith: builder.
- listSpec
- frame: (0.5(a)0.8 corner: 0.7@1);
- help: 'Other\Context\Bindings' withCRs.
- windowSpec children add: listSpec.
-
- textSpec := self contextVariablesInspector buildValuePaneWith: builder.
- textSpec
- help: '<- Select context''s field' translated;
- frame: (0.7(a)0.8 corner: 1@1).
- windowSpec children add: textSpec.
-
- ^builder build: windowSpec!
Item was removed:
- ----- Method: Debugger>>buildNotifierWith:label:message: (in category 'toolbuilder') -----
- buildNotifierWith: builder label: label message: messageString
- | windowSpec listSpec textSpec panelSpec quads |
- windowSpec := builder pluggableWindowSpec new
- model: self;
- extent: self initialExtentForNotifier;
- label: label asString;
- children: OrderedCollection new.
-
- panelSpec := builder pluggablePanelSpec new.
- panelSpec children: OrderedCollection new.
- quads := self preDebugButtonQuads.
- (self interruptedContext selector == #doesNotUnderstand:) ifTrue: [
- quads := quads copyWith:
- { 'Create'. #createMethod. #magenta. 'create the missing method' }
- ].
- (#(#notYetImplemented #shouldBeImplemented #requirement) includes: self interruptedContext selector) ifTrue: [
- quads := quads copyWith:
- { 'Create'. #createImplementingMethod. #magenta. 'implement the marked method' }
- ].
- (self interruptedContext selector == #subclassResponsibility) ifTrue: [
- quads := quads copyWith:
- { 'Create'. #createOverridingMethod. #magenta. 'create the missing overriding method' }
- ].
- quads do:[:spec| | buttonSpec |
- buttonSpec := builder pluggableButtonSpec new.
- buttonSpec model: self.
- buttonSpec label: spec first.
- buttonSpec action: spec second.
- buttonSpec help: spec fourth.
- spec size >= 5 ifTrue: [buttonSpec enabled: spec fifth].
- panelSpec children add: buttonSpec.
- ].
- panelSpec layout: #horizontal. "buttons"
- panelSpec frame: self preDebugButtonQuadFrame.
- windowSpec children add: panelSpec.
-
- Preferences eToyFriendly | messageString notNil ifFalse:[
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #contextStackList;
- getIndex: #contextStackIndex;
- setIndex: #debugAt:;
- icon: #messageIconAt:;
- helpItem: #messageHelpAt:;
- frame: self contextStackFrame.
- windowSpec children add: listSpec.
- ] ifTrue:[
- message := messageString.
- textSpec := builder pluggableTextSpec new.
- textSpec
- model: self;
- getText: #preDebugMessageString;
- setText: nil;
- selection: nil;
- menu: #debugProceedMenu:;
- frame: self contextStackFrame.
- windowSpec children add: textSpec.
- ].
-
- ^windowSpec!
Item was removed:
- ----- Method: Debugger>>buildWith: (in category 'toolbuilder') -----
- buildWith: aBuilder
- ^self buildFullWith: aBuilder!
Item was removed:
- ----- Method: Debugger>>checkContextSelection (in category 'private') -----
- checkContextSelection
-
- contextStackIndex = 0 ifTrue: [self contextStackIndex: 1 oldContextWas: nil].
- !
Item was removed:
- ----- Method: Debugger>>close (in category 'initialize') -----
- close
- "Close and delete this debugger. Try to trigger the close request through the UI first, do manually of not in the UI."
-
- self flag: #refactor. "mt: Maybe move this up to model?"
- self topView
- ifNotNil: [self changed: #close]
- ifNil: [
- self okToClose ifTrue: [
- self windowIsClosing; release]].!
Item was removed:
- ----- Method: Debugger>>codePaneSelectionInterval (in category 'code pane') -----
- codePaneSelectionInterval
-
- ^ self codeTextPane
- ifNotNil: [:cp | cp selectionInterval]
- ifNil: [Interval from: 0 to: 0]!
Item was removed:
- ----- Method: Debugger>>contents (in category 'accessing') -----
- contents
- "Depending on the current selection, different information is retrieved.
- Answer a string description of that information. This information is the
- method in the currently selected context."
-
- ^contents ifNil:
- [self selectedContext
- ifNotNil: [self selectedMessage]
- ifNil: [String new]] !
Item was removed:
- ----- Method: Debugger>>contents:notifying: (in category 'accessing') -----
- contents: aText notifying: aController
- "Accept new method source of the selected context."
-
- | selector classOfMethod category ctxt newMethod |
- contextStackIndex = 0 ifTrue: [^ false].
-
- "First, handle some edge cases"
- selector := self selectedClass newParser parseSelector: aText.
- "selector isDoIt ifTrue: [
- currentCompiledMethod := self compileDoIt: aText]."
- self flag: #todo. "ct: Recompile doIt method *without* creating method litters!! See Compiler>>#evaluateCue:ifFail:."
- selector = self selectedMessageName ifFalse: [
- "Different message compiled, delegating to super"
- ^ super contents: aText notifying: aController].
-
- self selectedContext isExecutingBlock ifTrue: [
- "If we are in a block context, we need to rewind the stack before ."
- | home |
- home := self selectedContext activeHome.
- home ifNil: [
- self inform: 'Method for block not found on stack, can''t edit and continue' translated.
- ^ false].
- (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' translated withCRs) ifFalse: [
- ^ false].
-
- self resetContext: home changeContents: false.
- "N.B. Only reset the contents if the compilation succeeds. If contents would be reset when compilation fails, both compiler error message and modifications were lost."
- ^ (self contents: aText notifying: aController)
- ifTrue: [self contentsChanged];
- yourself].
-
- classOfMethod := self selectedClass.
- category := self selectedMessageCategoryName.
-
- "Do the actual compilation"
- selector := classOfMethod
- compile: aText
- classified: category
- notifying: aController.
- selector ifNil: [^ false]. "compilation cancelled"
-
- "Update views"
- contents := aText.
- newMethod := classOfMethod compiledMethodAt: selector.
- newMethod isQuick ifTrue: [
- self cutBackExecutionToSenderContext].
- 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' translated withCRs]
- ifTrue: [
- newMethod isQuick ifFalse: [
- interruptedProcess restartTopWith: newMethod.
- interruptedProcess stepToSendOrReturn].
- contextVariablesInspector object: nil].
- self resetContext: ctxt.
-
- Project current addDeferredUIMessage: [
- self changed: #contentsSelection].
- ^ true!
Item was removed:
- ----- Method: Debugger>>contentsSelection (in category 'code pane') -----
- contentsSelection
- "Reverse the selection (i.e., point block and mark block) to put the text cursor at the beginning to ensure visibility of the beginning in small windows."
-
- self flag: #tofix. "mt: See http://forum.world.st/The-Inbox-Morphic-cmm-1615-mcz-td5109271.html and http://forum.world.st/stepping-in-small-panes-td5109239.html."
- ^ self pcRange in: [:interval |
- interval last + 1 to: interval first - 1]!
Item was removed:
- ----- Method: Debugger>>context: (in category 'initialize') -----
- context: aContext
-
- self
- process: Processor activeProcess
- context: aContext.!
Item was removed:
- ----- Method: Debugger>>contextStackFrame (in category 'toolbuilder') -----
- contextStackFrame
-
- ^LayoutFrame new
- leftFraction: 0 offset: 0;
- topFraction: 0 offset: self buttonHeight;
- rightFraction: 1 offset: 0;
- bottomFraction: 1 offset: 0!
Item was removed:
- ----- Method: Debugger>>contextStackIndex (in category 'context stack - message list') -----
- contextStackIndex
- "Answer the index of the selected context."
-
- ^contextStackIndex!
Item was removed:
- ----- Method: Debugger>>contextStackIndex:oldContextWas: (in category 'private') -----
- contextStackIndex: anInteger oldContextWas: oldContext
- "Change the context stack index to anInteger, perhaps in response to user selection."
-
- | isNewMethod |
- self saveReceiverInspectorState.
- self saveContextVariablesInspectorState.
- contextStackIndex := anInteger.
- anInteger = 0 ifTrue:
- [currentCompiledMethod := contents := nil.
- self changed: #contextStackIndex.
- self decorateButtons.
- self contentsChanged.
- contextVariablesInspector object: nil.
- receiverInspector context: nil; inspect: self receiver.
- ^self].
- isNewMethod := oldContext isNil
- or: [oldContext home method ~= (currentCompiledMethod := self selectedContext home method)].
- isNewMethod ifTrue:
- [contents := self selectedMessage.
- self contentsChanged.
- self pcRange].
- self changed: #contextStackIndex.
- self decorateButtons.
- contextVariablesInspector object: self selectedContext.
- self restoreContextVariablesInspectorState.
- receiverInspector context: self selectedContext; inspect: self receiver.
- self restoreReceiverInspectorState.
- isNewMethod ifFalse:
- [self changed: #contentsSelection]!
Item was removed:
- ----- Method: Debugger>>contextStackKey:from: (in category 'context stack menu') -----
- contextStackKey: aChar from: view
- "Respond to a keystroke in the context list"
-
- | selector |
- selector := ContextStackKeystrokes at: aChar ifAbsent: [nil].
- selector ifNil: [self messageListKey: aChar from: view]
- ifNotNil: [self perform: selector]!
Item was removed:
- ----- Method: Debugger>>contextStackList (in category 'context stack - message list') -----
- contextStackList
- "Answer the array of contexts."
-
- ^contextStackList!
Item was removed:
- ----- Method: Debugger>>contextStackMenu:shifted: (in category 'context stack menu') -----
- contextStackMenu: aMenu shifted: shifted
- "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided"
-
- ^ self menu: aMenu for: #(contextStackMenu contextStackMenuShifted:) shifted: shifted
- !
Item was removed:
- ----- Method: Debugger>>contextStackTop (in category 'accessing') -----
- contextStackTop
- ^ contextStack first.!
Item was removed:
- ----- Method: Debugger>>contextVariablesInspector (in category 'accessing') -----
- contextVariablesInspector
- "Answer the instance of Inspector that is providing a view of the
- variables of the selected context."
-
- ^contextVariablesInspector!
Item was removed:
- ----- Method: Debugger>>controlButtonsFrame (in category 'toolbuilder') -----
- controlButtonsFrame
- ^LayoutFrame new
- leftFraction: 0 offset: 0;
- topFraction: 0 offset: 0;
- rightFraction: 1 offset: 0;
- bottomFraction: 0 offset: self buttonHeight!
Item was removed:
- ----- Method: Debugger>>copyBugReportToClipboard (in category 'context stack menu') -----
- copyBugReportToClipboard
-
- | messageStream |
- messageStream := WriteStream on: (String new: 1500).
- self interruptedContext errorReportOn: messageStream.
- Clipboard clipboardText: messageStream contents.!
Item was removed:
- ----- Method: Debugger>>createImplementingMethod (in category 'notifier buttons') -----
- createImplementingMethod
- "Should only be called when this Debugger was created in response to a
- NotYetImplemented exception. All we need to do is pop the signalling context off the stack and open the #notYetImplemented method."
- | signallingContext |
- self initializeFull.
- signallingContext := self selectedContext sender.
- "Pop the signalling context off the stack"
- self resetContext: signallingContext.
- self debug.!
Item was removed:
- ----- Method: Debugger>>createMethod (in category 'notifier buttons') -----
- 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 |
- self initializeFull.
- msg := self contextStackTop exceptionMessage.
- chosenClass := self
- askForSuperclassOf: self contextStackTop receiver class
- toImplement: msg selector
- ifCancel: [^self].
- self implementMissingMethod: msg inClass: chosenClass.!
Item was removed:
- ----- Method: Debugger>>createOverridingMethod (in category 'notifier buttons') -----
- createOverridingMethod
- "Should only be called when this Debugger was created in response to a
- SubclassResponsibility exception. Create a stub for the method that needs
- overriding and proceed into it. Let the user only select a class in the
- inheritance chain between the actual class and the class declaring the
- subclassResponsibility."
- | chosenClass msg category |
- self initializeFull.
- msg := self contextStackTop exceptionMessage.
- chosenClass := self
- askForSuperclassOf: self contextStackTop receiver class
- upTo: self contextStackTop sender method methodClass
- toImplement: msg selector
- ifCancel: [^self].
- "Use the same category as the marker method."
- category := self contextStackTop sender selectorCategory.
- self implementOverridingMethod: msg inClass: chosenClass inCategory: category.!
Item was removed:
- ----- Method: Debugger>>customButtonSpecs (in category 'initialize') -----
- 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.' interruptedProcessShouldResume)
- ('Restart' restart 'Reset this context to its start.')
- ('Into' stepInto 'step Into message sends' interruptedProcessIsReady)
- ('Over' stepOver 'step Over message sends' interruptedProcessIsReady)
- ('Through' stepThrough 'step into a block' interruptedProcessIsReady)
- ('Full Stack' showFullStack 'show full stack')
- ('Where' showWhere 'select current pc range')
- ('Tally It' tally 'evaluate current selection and measure the time')).
- (Preferences restartAlsoProceeds and: [self interruptedProcessShouldResume]) ifTrue:
- [list := list collect: [:each |
- each second == #restart
- ifTrue: [each copy
- at: 1 put: 'Proceed Here';
- at: 3 put: 'Proceed from the beginning of this context.';
- yourself]
- ifFalse: [each second == #proceed
- ifTrue: [each copy
- at: 1 put: 'Proceed Top';
- at: 3 put: 'Proceed from the current top context.';
- yourself]
- ifFalse: [each]]]].
- ^ list!
Item was removed:
- ----- Method: Debugger>>cutBackExecutionToSenderContext (in category 'private') -----
- cutBackExecutionToSenderContext
- "When accepting a new version of a method which can't be simulated (i.e. a quick method) we
- must cut back to the sender. But this is non-trivial. If the quick method has been reached via
- a perform: (as it is when one uses Create to implement a method from an MNU) then the relevant
- arguments won't be on the stack and we can't simply proceed without crashing the VM."
- | oldContext context sel |
- oldContext := self selectedContext.
- self down.
- context := self selectedContext.
- context pc: context previousPc.
- sel := context selectorToSendOrSelf.
- sel numArgs = oldContext method numArgs
- ifTrue:
- [context push: oldContext receiver.
- oldContext arguments do:
- [:arg| context push: arg]]
- ifFalse:
- [context privRefresh; stepToSendOrReturn]!
Item was removed:
- ----- Method: Debugger>>debug (in category 'notifier menu') -----
- debug
- "Open a full debugger."
-
- self openFullFromNotifier: self topView.
- !
Item was removed:
- ----- Method: Debugger>>debugAt: (in category 'notifier buttons') -----
- debugAt: anInteger
- "Opens a full debugger with the given index selected. See #initializeFull to understand why contextStackIndex is set directly."
-
- contextStackIndex := anInteger.
- ^ self debug!
Item was removed:
- ----- Method: Debugger>>debugProceedMenu: (in category 'context stack menu') -----
- debugProceedMenu: aMenu
- ^ aMenu labels:
- 'proceed
- debug'
- lines: #()
- selections: #(proceed debug )
- !
Item was removed:
- ----- Method: Debugger>>debuggerCodePaneMenu: (in category 'code pane menu') -----
- debuggerCodePaneMenu: aMenu
- <codePaneMenu>
- <menuPriority: 200>
- ^ aMenu
- add: 'run to here' target: self selector: #runToSelection: argument: self codePaneSelectionInterval;
- add: 'run until...' target: self selector: #runUntil;
- addLine;
- yourself
- !
Item was removed:
- ----- Method: Debugger>>debuggerMap (in category 'accessing') -----
- debuggerMap
- ^self selectedContext debuggerMap!
Item was removed:
- ----- Method: Debugger>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.9 g: 0.719 b: 0.719)!
Item was removed:
- ----- Method: Debugger>>doItContext (in category 'code pane') -----
- doItContext
- "Answer the context in which a text selection can be evaluated."
-
- contextStackIndex = 0
- ifTrue: [^super doItContext]
- ifFalse: [^self selectedContext]!
Item was removed:
- ----- Method: Debugger>>doItReceiver (in category 'code pane') -----
- doItReceiver
- "Answer the object that should be informed of the result of evaluating a
- text selection."
-
- ^self receiver!
Item was removed:
- ----- Method: Debugger>>doNothing: (in category 'accessing') -----
- doNothing: newText
- "Notifier window can't accept text"!
Item was removed:
- ----- Method: Debugger>>doStep (in category 'context stack menu') -----
- doStep
- "Send the selected message in the accessed method, and regain control
- after the invoked method returns."
-
- | currentContext newContext |
- self okToChange ifFalse: [^ self].
- self interruptedProcessIsReady ifFalse: [^ self shouldNotStep].
- self checkContextSelection.
- currentContext := self selectedContext.
- newContext := self handleLabelUpdatesIn: [interruptedProcess completeStep: currentContext]
- whenExecuting: currentContext.
- interruptedProcess ifNil: [^ self shouldNotStep].
- newContext == currentContext ifTrue:
- [newContext := interruptedProcess stepToSendOrReturn].
- self updateProcess.
- self contextStackIndex > 1
- ifTrue: [self resetContext: newContext]
- ifFalse:
- [newContext == currentContext
- ifTrue: [self changed: #contentsSelection.
- self updateInspectors]
- ifFalse: [self resetContext: newContext]].!
Item was removed:
- ----- Method: Debugger>>doStepUntil: (in category 'context stack menu') -----
- doStepUntil: condition
- "Step until the given condition evaluates to other than false, reporting an error it if does not evaluate to true.
-
- If shift is pressed when the expression is supplied, don't update the UI. If shift is pressed while stepping, stop stepping. Using a user interrupt to break out would be more natural but Squeak currently doesn't provide a UserInterrupt exception. It should do."
-
- | currentContext newContext value lastUpdate updateUI breakOnShift |
- self okToChange ifFalse: [^ self].
- self interruptedProcessIsReady ifFalse: [^ self shouldNotStep].
- self checkContextSelection.
- currentContext := newContext := self selectedContext.
- lastUpdate := Time millisecondClockValue.
- updateUI := breakOnShift := Sensor shiftPressed not.
-
- Cursor execute showWhile: [[
- newContext == currentContext
- and: [currentContext willReturn not
- and: [(value := condition value) == false]] ] whileTrue: [
-
- self
- handleLabelUpdatesIn: [newContext := interruptedProcess completeStep: currentContext]
- whenExecuting: currentContext.
- interruptedProcess ifNil: [^ self shouldNotStep].
- newContext == currentContext ifTrue: [
- newContext := interruptedProcess stepToSendOrReturn.
- self resetContext: newContext changeContents: false].
-
- Time millisecondClockValue - lastUpdate > 250 "ms" ifTrue: [
- updateUI ifTrue: [
- self changed: #contentsSelection.
- Project current world displayWorldSafely].
- breakOnShift
- ifTrue: [Sensor shiftPressed ifTrue: [
- self changed: #contentsSelection.
- self updateInspectors.
- ^self]]
- ifFalse: [Sensor shiftPressed ifFalse: [breakOnShift := true]].
- lastUpdate := Time millisecondClockValue] ]].
-
- self updateProcess.
- self contextStackIndex > 1
- ifTrue: [self resetContext: newContext]
- ifFalse:
- [newContext == currentContext
- ifTrue: [self changed: #contentsSelection; updateInspectors]
- ifFalse: [self resetContext: newContext]].
-
- ^ value!
Item was removed:
- ----- Method: Debugger>>down (in category 'context stack menu') -----
- down
- "move down the context stack to the previous (enclosing) context"
-
- self toggleContextStackIndex: contextStackIndex+1!
Item was removed:
- ----- Method: Debugger>>expandNotifierStack (in category 'context stack - message list') -----
- expandNotifierStack
- "Show a small amount of stack in the context pane. Useful for notifiers."
-
- self okToChange ifFalse: [^ self].
- self newStack: (self contextStackTop stackOfSize: self class notifierStackSize).
- self changed: #contextStackList.
- !
Item was removed:
- ----- Method: Debugger>>expandStack (in category 'context stack - message list') -----
- expandStack
- "Show a substantial amount of stack in the context pane."
-
- self okToChange ifFalse: [^ self].
- self newStack: (self contextStackTop stackOfSize: (self class fullStackSize max: self class notifierStackSize)).
- self changed: #contextStackList.
- !
Item was removed:
- ----- Method: Debugger>>externalInterrupt: (in category 'private') -----
- externalInterrupt: aBoolean
-
- externalInterrupt := aBoolean !
Item was removed:
- ----- Method: Debugger>>extraCellGap (in category 'toolbuilder') -----
- extraCellGap
- "Since BorderedMorph is currently not able to add the #cellGap between *two* fixed buttons rows at the same #topFraction, add that offset here explicitely."
-
- self flag: #refactor. "mt: See BorderedMorph >> #changeCellGapOfLayoutFrames:."
- ^ ToolBuilder default panelSpacing!
Item was removed:
- ----- Method: Debugger>>findCleanHomeBelow: (in category 'context stack (message list)') -----
- findCleanHomeBelow: method
-
- | dirtyIndex |
- dirtyIndex := contextStack size + 1.
- contextStack reverse detect: [:context |
- dirtyIndex := dirtyIndex - 1.
- context home method = method homeMethod].
- ^ dirtyIndex + 1!
Item was removed:
- ----- Method: Debugger>>fullStack (in category 'context stack menu') -----
- fullStack
- "Change from displaying the minimal stack to a full one."
-
- contextStack last sender isNil
- ifTrue:
- ["Already expanded"
- self changed: #flash]
- ifFalse:
- [| oldContextStackIndex |
- oldContextStackIndex := contextStackIndex.
- self fullyExpandStack.
- oldContextStackIndex = contextStackIndex
- ifFalse:
- [self toggleContextStackIndex: oldContextStackIndex]]!
Item was removed:
- ----- Method: Debugger>>fullyExpandStack (in category 'context stack - message list') -----
- fullyExpandStack
- "Expand the stack to include all of it. Well, almost all of it, we better maintain sane limits too."
-
- self okToChange ifFalse: [^ self].
- self newStack: (self contextStackTop stackOfSize: self class stackSizeLimit - contextStack size).
- self changed: #contextStackList.!
Item was removed:
- ----- Method: Debugger>>getSelectedText (in category 'tally support') -----
- getSelectedText
- | m interval text |
- m := self codeTextPane ifNil: [^ ''].
- interval := m selectionInterval.
- text := m text.
- ^ text copyFrom: interval first to: interval last
- !
Item was removed:
- ----- Method: Debugger>>handleLabelUpdatesIn:whenExecuting: (in category 'context stack menu') -----
- handleLabelUpdatesIn: aBlock whenExecuting: aContext
- "Send the selected message in the accessed method, and regain control
- after the invoked method returns."
-
- ^aBlock
- on: Notification
- do: [:ex|
- (ex tag isArray
- and: [ex tag size = 2
- and: [(ex tag first == aContext or: [ex tag first hasSender: aContext])]])
- ifTrue:
- [self labelString: ex tag second description.
- ex resume]
- ifFalse:
- [ex pass]]!
Item was removed:
- ----- Method: Debugger>>implementMissingMethod:inClass: (in category 'notifier support') -----
- implementMissingMethod: aMessage inClass: aClass
- ^ self
- implementMissingMethod: aMessage
- inClass: aClass
- inCategory: (self askForCategoryIn: aClass default: 'as yet unclassified').!
Item was removed:
- ----- Method: Debugger>>implementMissingMethod:inClass:inCategory: (in category 'notifier support') -----
- implementMissingMethod: aMessage inClass: aClass inCategory: aSymbol
- "Create a stub implementation of the missing message and sew it onto the top of the stack, ensuring the context's arguments are set correctly. Debug the new context."
- self pushStubMethodOnStack: aMessage inClass: aClass inCategory: aSymbol.
-
- "Cut out the sender context. This is the context that signalled the MessageNotUnderstood."
- self selectedContext privSender: self selectedContext sender.
- self resetContext: self selectedContext.
- self debug.!
Item was removed:
- ----- Method: Debugger>>implementOverridingMethod:inClass:inCategory: (in category 'notifier support') -----
- implementOverridingMethod: aMessage inClass: aClass inCategory: aSymbol
- "Create a stub implementation of the overriding message and sew it onto the top of the stack, ensuring the context's arguments are set correctly. Debug the new context."
- self pushStubMethodOnStack: aMessage inClass: aClass inCategory: aSymbol.
-
- "Cut out the sender context. This is the context that signalled the SubclassResponsibility."
- self selectedContext privSender: self selectedContext sender sender.
- self resetContext: self selectedContext.
- self debug.!
Item was removed:
- ----- Method: Debugger>>initialExtent (in category 'initialize') -----
- initialExtent
- "Initial extent for the full debugger. For the notifier's extent see #initialExtentForNotifier."
-
- ^ SavedExtent ifNil: [ 600@700]!
Item was removed:
- ----- Method: Debugger>>initialExtentForNotifier (in category 'initialize') -----
- initialExtentForNotifier
-
- ^ 450@200!
Item was removed:
- ----- Method: Debugger>>initialize (in category 'initialize') -----
- initialize
-
- super initialize.
-
- Smalltalk at: #MessageTally ifPresentAndInMemory: [ :tally |
- tally terminateTimerProcess].
-
- externalInterrupt := false.
- selectingPC := true.
-
- contextStackIndex := 0.
-
- "The default termination procedure is aggressive to ignore currently running, and thus erroneous, ensure-blocks in the debugged process. The preference can change that."
- terminateProcessSelector := self class closeMeansAbandon
- ifTrue: [#terminateAggressively]
- ifFalse:[#terminate].!
Item was removed:
- ----- Method: Debugger>>initializeFull (in category 'initialize') -----
- initializeFull
- "Expand the stack for the full debugger. Create inspectors."
-
- | oldIndex |
- oldIndex := contextStackIndex.
- contextStackIndex := 0.
-
- self expandStack.
-
- receiverInspector := Inspector on: nil.
- contextVariablesInspector := ContextVariablesInspector on: nil.
-
- self toggleContextStackIndex: oldIndex.!
Item was removed:
- ----- Method: Debugger>>interruptedContext (in category 'accessing') -----
- interruptedContext
- "Answer the suspended context of the interrupted process."
-
- ^self contextStackTop.!
Item was removed:
- ----- Method: Debugger>>interruptedProcess (in category 'accessing') -----
- interruptedProcess
- "Answer the interrupted process."
-
- ^interruptedProcess!
Item was removed:
- ----- Method: Debugger>>interruptedProcessIsReady (in category 'testing') -----
- interruptedProcessIsReady
-
- ^ interruptedProcess notNil
- and: [interruptedProcess isSuspended "do not debug the active process"]
- and: [interruptedProcess isTerminated not]!
Item was removed:
- ----- Method: Debugger>>interruptedProcessShouldResume (in category 'testing') -----
- interruptedProcessShouldResume
-
- ^ self interruptedProcessIsReady and: [interruptedProcess shouldResumeFromDebugger]!
Item was removed:
- ----- Method: Debugger>>isFull (in category 'testing') -----
- isFull
-
- ^ self isNotifier not!
Item was removed:
- ----- Method: Debugger>>isNotifier (in category 'testing') -----
- isNotifier
-
- ^ receiverInspector isNil!
Item was removed:
- ----- Method: Debugger>>keyForContextVariablesInspectorState (in category 'user interface') -----
- keyForContextVariablesInspectorState
-
- ^ self contextVariablesInspector object ifNotNil: [:ctxt | ctxt method]!
Item was removed:
- ----- Method: Debugger>>keyForReceiverInspectorState (in category 'user interface') -----
- keyForReceiverInspectorState
-
- ^ self receiverInspector object!
Item was removed:
- ----- Method: Debugger>>labelString (in category 'accessing') -----
- labelString
- ^labelString!
Item was removed:
- ----- Method: Debugger>>labelString: (in category 'accessing') -----
- labelString: aString
- labelString := aString.
- self changed: #relabel!
Item was removed:
- ----- Method: Debugger>>mailOutBugReport (in category 'context stack menu') -----
- 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."
-
- MailSender default ifNil: [^self].
-
- Cursor write
- showWhile:
- ["Prepare the message"
- | messageStrm |
- messageStrm := WriteStream on: (String new: 1500).
- messageStrm nextPutAll: 'From: ';
- nextPutAll: MailSender userName;
- cr;
- nextPutAll: 'To: squeak-dev(a)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)].
- !
Item was removed:
- ----- Method: Debugger>>mainContextStackMenu: (in category 'context stack menu') -----
- mainContextStackMenu: aMenu
- "Set up the menu appropriately for the context-stack-list, unshifted"
- <contextStackMenuShifted: false>
- ^ aMenu
- addTranslatedList: #(
- ('fullStack (f)' fullStack)
- ('restart (r)' restart)
- ('proceed (p)' proceed)
- ('step (t)' doStep)
- ('step through (T)' stepIntoBlock)
- ('send (e)' send)
- ('where (w)' where)
- ('peel to first like this' peelToFirst)
- -
- ('return entered value' returnValue)
- - );
- add: (self isBreakOnEntry ifTrue: ['<on>'] ifFalse: ['<off>']) , 'break on entry' translated
- action: #toggleBreakOnEntry;
- addTranslatedList: #(
- ('senders of (n)' browseSendersOfMessages)
- ('implementors of (m)' browseMessages)
- ('inheritance (i)' methodHierarchy)
- ('versions (v)' browseVersions)
- -
- ('references (r)' browseVariableReferences)
- ('assignments (a)' browseVariableAssignments)
- -
- ('class refs (N)' browseClassRefs)
- ('browse full (b)' browseMethodFull)
- ('file out ' fileOutMessage)
- ('remove method (x) ' removeMessage)
- -
- ('copy bug report to clipboard' copyBugReportToClipboard));
- yourself!
Item was removed:
- ----- Method: Debugger>>messageHelpAt: (in category 'context stack - message list') -----
- messageHelpAt: anIndex
- "Show the first n lines of the sources code of the selected message."
-
- | method |
- Preferences balloonHelpInMessageLists ifFalse: [^ nil].
- contextStack size < anIndex ifTrue: [^ nil].
-
- method := (contextStack at: anIndex) method.
- ^ self messageHelpForMethod: method.!
Item was removed:
- ----- Method: Debugger>>messageIconAt: (in category 'context stack - message list') -----
- messageIconAt: anIndex
-
- Browser showMessageIcons
- ifFalse: [^ nil].
-
- ^ ToolIcons iconNamed: (ToolIcons
- iconForClass: (contextStack at: anIndex) method methodClass
- selector: (contextStack at: anIndex) method selector)!
Item was removed:
- ----- Method: Debugger>>messageListIndex (in category 'context stack - message list') -----
- messageListIndex
- "Answer the index of the currently selected context."
-
- ^contextStackIndex!
Item was removed:
- ----- Method: Debugger>>messageListMenu:shifted: (in category 'context stack menu') -----
- 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!
Item was removed:
- ----- Method: Debugger>>modelWakeUpIn: (in category 'user interface') -----
- modelWakeUpIn: aWindow
-
- super modelWakeUpIn: aWindow.
- self updateInspectors.!
Item was removed:
- ----- Method: Debugger>>newStack: (in category 'private') -----
- newStack: stack
- | oldStack diff matchIndex |
- oldStack := contextStack.
- contextStack := stack.
- (oldStack isNil or: [oldStack last ~~ stack last]) ifTrue:
- [contextStackList := stack collect: [:ctx | ctx printString].
- ^self].
- "May be able to re-use some of previous list"
- diff := stack size - oldStack size.
- contextStackList := diff <= 0
- ifTrue: [contextStackList copyFrom: 1 - diff to: oldStack size]
- ifFalse:
- [matchIndex := stack lastIndexOf: oldStack first startingAt: diff + 1.
- matchIndex = 0
- ifTrue: [contextStack collect: [:ctx | ctx printString]]
- ifFalse: [((contextStack first: matchIndex - 1) collect: [:ctx| ctx printString]), contextStackList]]
- "#(d e f h i) => #(a b c d e f g h i)
- diff := 3.
- matchIndex := 4.
- #(a b c d e f g h i) := #(a b c), #(d e f h i)"!
Item was removed:
- ----- Method: Debugger>>openFullFromNotifier: (in category 'initialize') -----
- openFullFromNotifier: topView
- "Create a full debugger with the given label. Subclasses should complete this procedure."
-
- self initializeFull.
-
- topView model: nil. "so close won't release me."
- self breakDependents.!
Item was removed:
- ----- Method: Debugger>>openFullNoSuspendLabel: (in category 'initialize') -----
- openFullNoSuspendLabel: aString
- "Create, schedule and answer a full debugger with the given label. Subclasses should complete this procedure."
-
- self initializeFull.!
Item was removed:
- ----- Method: Debugger>>openNotifierNoSuspendContents:label: (in category 'initialize') -----
- openNotifierNoSuspendContents: msgString label: label
- "Create, schedule and answer 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 process has not been suspended. The sender will do this."
-
- savedCursor := Cursor currentCursor.
- Cursor currentCursor: Cursor normal.
-
- self expandNotifierStack.!
Item was removed:
- ----- Method: Debugger>>optionalButtonsFrame (in category 'toolbuilder') -----
- optionalButtonsFrame
-
- ^LayoutFrame new
- leftFraction: 0 offset: 0;
- topFraction: 0 offset: self buttonHeight + self extraCellGap;
- rightFraction: 1 offset: 0;
- bottomFraction: 0 offset: self buttonHeight*2 + self extraCellGap!
Item was removed:
- ----- Method: Debugger>>pc (in category 'code pane') -----
- pc
-
- ^ self pcRange!
Item was removed:
- ----- Method: Debugger>>pcRange (in category 'code pane') -----
- pcRange
- "Answer the indices in the source code for the method corresponding to
- the selected context's program counter value."
-
- | ctxt |
- (selectingPC and: [contextStackIndex ~= 0]) ifFalse:
- [^1 to: 0].
- (ctxt := self selectedContext) isDead ifTrue:
- [^1 to: 0].
- ^ctxt debuggerMap
- rangeForPC: ctxt pc
- in: ctxt method
- contextIsActiveContext: contextStackIndex = 1!
Item was removed:
- ----- Method: Debugger>>peelToFirst (in category 'context stack menu') -----
- 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!!"
-
- | ctxt |
- contextStackIndex = 0 ifTrue: [^ Beeper beep].
- "self okToChange ifFalse: [^ self]."
- ctxt := interruptedProcess popTo: self selectedContext findSecondToOldestSimilarSender.
- self resetContext: ctxt.
- !
Item was removed:
- ----- Method: Debugger>>perform:orSendTo: (in category 'code pane menu') -----
- perform: selector orSendTo: otherTarget
- "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked."
-
- | result |
- (#(debug proceed) includes: selector) "When I am a notifier window"
- ifTrue: [^ self perform: selector]
- ifFalse: [result := super perform: selector orSendTo: otherTarget.
- selector == #doIt ifTrue: [
- result ~~ #failedDoit ifTrue: [self proceedValue: result]].
- ^ result]!
Item was removed:
- ----- Method: Debugger>>preDebugButtonQuadFrame (in category 'toolbuilder') -----
- preDebugButtonQuadFrame
- ^LayoutFrame new
- leftFraction: 0 offset: 0;
- topFraction: 0 offset: 0;
- rightFraction: 1 offset: 0;
- bottomFraction: 0 offset: self buttonHeight.!
Item was removed:
- ----- Method: Debugger>>preDebugButtonQuads (in category 'initialize') -----
- preDebugButtonQuads
-
- ^Preferences eToyFriendly
- ifTrue: [
- {
- {'Send error report' translated. #sendReport. #blue. 'send a report of the encountered problem to the Squeak developers' translated}.
- {'Abandon' translated. #abandon. #black. 'abandon this execution by closing this window' translated}.
- {'Debug' translated. #debug. #red. 'bring up a debugger' translated}}]
- ifFalse: [
- {
- {'Proceed' translated. #proceed. #blue. 'continue execution' translated. #interruptedProcessShouldResume}.
- self class showTerminateButton ifTrue: [
- {'Terminate' translated. #terminateProcess. #black. 'terminate this execution and close this window' translated}].
- self class showAbandonButton ifTrue: [
- {'Abandon' translated. #abandon. #black. 'terminate this execution aggressively and close this window' translated}].
- {'Debug' translated. #debug. #red. 'bring up a debugger' translated}}
- reject: [:quad | quad isNil] ]
- !
Item was removed:
- ----- Method: Debugger>>preDebugMessageString (in category 'toolbuilder') -----
- preDebugMessageString
- ^ message ifNil: [
- String streamContents: [:s |
- s nextPutAll: 'An error has occurred, sorry!! You could send the Squeak developers an error report or just hit ''Abandon''.
-
- In the error report, there is no personal information, only information that we can use to investigate the error. If you decide to send us the error report, it will include the following text:
-
- ' translated.
- [s nextPutAll: self contextStackTop printString; cr.
- self contextStackTop errorReportOn: s] on: Error do: [s nextPutAll: 'no text, there was an error creating the error report' translated]]].!
Item was removed:
- ----- Method: Debugger>>proceed (in category 'context stack menu') -----
- proceed
- "Proceed from the interrupted state of the currently selected context. The argument is the topView of the receiver. That view is closed. The active process usually suspends (or terminates) after this call."
-
- | processToResume canResume |
-
- Smalltalk okayToProceedEvenIfSpaceIsLow ifFalse: [^ self].
-
- self okToChange ifFalse: [^ self].
- self checkContextSelection.
-
- processToResume := interruptedProcess.
- canResume := self interruptedProcessShouldResume.
-
- interruptedProcess := nil. "Before delete, so release doesn't terminate it"
- self close.
-
- savedCursor ifNotNil: [Cursor currentCursor: savedCursor].
- Project current restoreDisplay.
-
- Smalltalk installLowSpaceWatcher. "restart low space handler"
-
- canResume
- ifTrue: [self resumeProcess: processToResume]
- ifFalse: [self notify: 'This process should not resume.\Debugger will close now.' withCRs].!
Item was removed:
- ----- Method: Debugger>>proceedValue (in category 'accessing') -----
- proceedValue
- "Answer the value to return to the selected context when the interrupted
- process proceeds."
-
- ^proceedValue!
Item was removed:
- ----- Method: Debugger>>proceedValue: (in category 'accessing') -----
- proceedValue: anObject
- "Set the value to be returned to the selected context when the interrupted
- process proceeds."
-
- proceedValue := anObject!
Item was removed:
- ----- Method: Debugger>>process:context: (in category 'initialize') -----
- process: aProcess context: aContext
-
- interruptedProcess := aProcess.
-
- self newStack: (aContext stackOfSize: 1).
- contextStackIndex := 1.!
Item was removed:
- ----- Method: Debugger>>pushStubMethodOnStack:inClass:inCategory: (in category 'private') -----
- pushStubMethodOnStack: aMessage inClass: aClass inCategory: aSymbol
- "Create a stub implementation of the message and sew it onto the top of the stack, ensuring the context's arguments are set correctly."
- aClass
- compile: aMessage createStubMethod
- classified: aSymbol.
- self setContentsToForceRefetch.
- self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector).
- aMessage numArgs > 0 ifTrue:
- [aMessage arguments withIndexDo:
- [:arg :index|
- self selectedContext tempAt: index put: arg]].!
Item was removed:
- ----- Method: Debugger>>receiver (in category 'accessing') -----
- receiver
- "Answer the receiver of the selected context, if any. Answer nil
- otherwise."
-
- contextStackIndex = 0
- ifTrue: [^nil]
- ifFalse: [^self selectedContext receiver]!
Item was removed:
- ----- Method: Debugger>>receiverClass (in category 'toolbuilder') -----
- receiverClass
- ^ self selectedContext receiver class!
Item was removed:
- ----- Method: Debugger>>receiverInspector (in category 'accessing') -----
- receiverInspector
- "Answer the instance of Inspector that is providing a view of the
- variables of the selected context's receiver."
-
- ^receiverInspector!
Item was removed:
- ----- Method: Debugger>>removeMessage (in category 'context stack menu') -----
- removeMessage
-
- | oldContext method cleanIndex |
- self okToChange ifFalse: [^ false].
- contextStackIndex isZero ifTrue: [^ false].
-
- oldContext := self selectedContext.
- method := oldContext method.
- cleanIndex := self findCleanHomeBelow: method.
- contextStack at: cleanIndex ifAbsent: [
- self inform: 'Sender of method not found on stack, can''t remove message'.
- ^ false].
- self interruptedProcessIsReady ifFalse: [^ self shouldNotStep].
- (self confirm: 'I will have to revert to the sender of this message. Is that OK?')
- ifFalse: [^ false].
-
- super removeMessage ifFalse: [^ false].
- self
- contextStackIndex: cleanIndex oldContextWas: oldContext;
- tryRestartFrom: self selectedContext.
-
- ^ true!
Item was removed:
- ----- Method: Debugger>>resetContext: (in category 'private') -----
- resetContext: aContext
- ^ self resetContext: aContext changeContents: true!
Item was removed:
- ----- Method: Debugger>>resetContext:changeContents: (in category 'private') -----
- resetContext: aContext changeContents: aBoolean
- "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.
- self newStack: (aContext ifNil: [oldContext]) contextStack.
- self changed: #contextStackList.
- self contextStackIndex: 1 oldContextWas: oldContext.
- self updateProcess.
- aBoolean ifTrue: [self contentsChanged].!
Item was removed:
- ----- Method: Debugger>>restart (in category 'context stack menu') -----
- 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"
-
- | unwindError |
- self okToChange ifFalse: [^ self].
- interruptedProcess isSuspended ifFalse: [^ self shouldNotStep].
- self checkContextSelection.
- unwindError := self tryRestartFrom: self selectedContext.
- ((Preferences restartAlsoProceeds
- and: [unwindError not])
- and: [self interruptedProcessShouldResume])
- ifTrue: [self proceed].!
Item was removed:
- ----- Method: Debugger>>restoreContextVariablesInspectorState (in category 'user interface') -----
- restoreContextVariablesInspectorState
- "For the user's convenience. Save field selection and user-typed content in the context-variables inspector. See #saveContextVariablesInspectorState."
-
- contextVariablesInspectorState ifNotNil: [:stateForAll |
- self keyForContextVariablesInspectorState ifNotNil: [:keyForState |
- stateForAll
- at: keyForState
- ifPresent: [:state |
- self contextVariablesInspector selectFieldNamed: state first.
- state second ifNotNil: [:contentsTyped |
- self contextVariablesInspector
- setContentsTyped: contentsTyped]]]].!
Item was removed:
- ----- Method: Debugger>>restoreReceiverInspectorState (in category 'user interface') -----
- restoreReceiverInspectorState
- "For the user's convenience. Restore field selection and user-typed content in the receiver inspector. See #saveReceiverInspectorState."
-
- receiverInspectorState ifNotNil: [:stateForAll |
- self keyForReceiverInspectorState ifNotNil: [:keyForState |
- stateForAll
- at: keyForState
- ifPresent: [:state |
- self receiverInspector selectFieldNamed: state first.
- state second ifNotNil: [:contentsTyped |
- self receiverInspector
- setContentsTyped: contentsTyped]]]].!
Item was removed:
- ----- Method: Debugger>>resumeProcess: (in category 'private') -----
- resumeProcess: aProcess
- "Subclusses may override this to avoid having duplicate UI processes."
-
- aProcess resume.!
Item was removed:
- ----- Method: Debugger>>returnValue (in category 'context stack menu') -----
- returnValue
- "Force a return of a given value to the previous context!!"
-
- | previous selectedContext expression value |
- contextStackIndex = 0 ifTrue: [^Beeper beep].
- selectedContext := self selectedContext.
- expression := UIManager default request: 'Enter expression for return value:'.
- value := Compiler new
- evaluate: expression
- in: selectedContext
- to: selectedContext receiver.
- previous := selectedContext sender.
- self resetContext: previous.
- interruptedProcess popTo: previous value: value!
Item was removed:
- ----- Method: Debugger>>runToSelection: (in category 'code pane menu') -----
- runToSelection: selectionInterval
-
- self pc first >= selectionInterval first ifTrue: [ ^self ].
- self doStepUntil: [ self pc first >= selectionInterval first ].!
Item was removed:
- ----- Method: Debugger>>runUntil (in category 'code pane menu') -----
- runUntil
- "Step until an expression evaluates to other than false, reporting an error if it doesn't evaluate to true. Remember the expression in an inst var."
-
- | expression receiver context method value |
- expression := UIManager default
- request: 'run until expression is true (shift to disable ui update; shift to break).'
- initialAnswer: (untilExpression ifNil: 'boolean expression').
- (expression isNil or: [expression isEmpty]) ifTrue:
- [^self].
- untilExpression := expression.
- context := self selectedContext.
- receiver := context receiver.
- method := receiver class evaluatorClass new
- compiledMethodFor: untilExpression
- in: context
- to: receiver
- notifying: nil
- ifFail: [^ #failedDoit].
-
- value := self doStepUntil: [method valueWithReceiver: receiver arguments: {context}].
-
- (value ~~ self and: [value ~~ false and: [value ~~ true]]) ifTrue:
- [UIManager default inform: 'expression ', (untilExpression contractTo: 40), ' answered ', (value printString contractTo: 20), '!!!!']!
Item was removed:
- ----- Method: Debugger>>saveContextVariablesInspectorState (in category 'user interface') -----
- saveContextVariablesInspectorState
- "For the user's convenience. Save field selection and user-typed content in the context-variables inspector. See #restoreContextVariablesInspectorState."
-
- | stateToSave keyForState |
- self flag: #duplication.
- (keyForState := self keyForContextVariablesInspectorState)
- ifNil: [^ self].
- contextVariablesInspectorState
- ifNil: [contextVariablesInspectorState := WeakIdentityKeyDictionary new].
- stateToSave := {
- self contextVariablesInspector selectedFieldName.
- self contextVariablesInspector contentsTyped }.
- contextVariablesInspectorState
- at: keyForState
- put: stateToSave.!
Item was removed:
- ----- Method: Debugger>>saveReceiverInspectorState (in category 'user interface') -----
- saveReceiverInspectorState
- "For the user's convenience. Save field selection and user-typed content in the receiver inspector. See #restoreReceiverInspectorState."
-
- | stateToSave keyForState |
- self flag: #duplication.
- (keyForState := self keyForReceiverInspectorState)
- ifNil: [^ self].
- receiverInspectorState
- ifNil: [receiverInspectorState := WeakIdentityKeyDictionary new].
- stateToSave := {
- self receiverInspector selectedFieldName.
- self receiverInspector contentsTyped }.
- receiverInspectorState
- at: keyForState
- put: stateToSave.!
Item was removed:
- ----- Method: Debugger>>selectPC (in category 'context stack menu') -----
- selectPC
- "Toggle the flag telling whether to automatically select the expression
- currently being executed by the selected context."
-
- selectingPC := selectingPC not!
Item was removed:
- ----- Method: Debugger>>selectedClass (in category 'class list') -----
- selectedClass
- "Answer the class in which the currently selected context's method was
- found."
-
- ^self selectedContext methodClass!
Item was removed:
- ----- Method: Debugger>>selectedClassOrMetaClass (in category 'class list') -----
- selectedClassOrMetaClass
- "Answer the class in which the currently selected context's method was
- found."
-
- ^self selectedClass!
Item was removed:
- ----- Method: Debugger>>selectedContext (in category 'private') -----
- selectedContext
-
- contextStackIndex = 0
- ifTrue: [^contextStack first]
- ifFalse: [^contextStack at: contextStackIndex]!
Item was removed:
- ----- Method: Debugger>>selectedMessage (in category 'context stack - message list') -----
- selectedMessage
- "Answer the source code of the currently selected context."
- | aContext |
- ^contents := (aContext := self selectedContext) debuggerMap sourceText asText makeSelectorBoldIn: aContext home receiver class!
Item was removed:
- ----- Method: Debugger>>selectedMessageCategoryName (in category 'message category list') -----
- selectedMessageCategoryName
- "Answer the name of the message category of the message of the
- currently selected context."
-
- ^self selectedClass organization categoryOfElement: self selectedMessageName!
Item was removed:
- ----- Method: Debugger>>selectedMessageName (in category 'context stack - message list') -----
- selectedMessageName
- "Answer the message selector of the currently selected context.
- If the method is unbound we can still usefully answer its old selector."
-
- | selector |
- selector := self selectedContext selector.
- ^(selector ~~ self selectedContext method selector
- and: [selector beginsWith: 'DoIt'])
- ifTrue: [self selectedContext method selector]
- ifFalse: [selector]!
Item was removed:
- ----- Method: Debugger>>send (in category 'context stack menu') -----
- 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 interruptedProcessIsReady ifFalse: [^ self shouldNotStep].
- self checkContextSelection.
- interruptedProcess step: self selectedContext.
- interruptedProcess ifNil: [^ self shouldNotStep].
- self resetContext: interruptedProcess stepToSendOrReturn.!
Item was removed:
- ----- Method: Debugger>>sendReport (in category 'notifier menu') -----
- sendReport
- [| errorReport |
- errorReport := String streamContents: [:s |
- s nextPutAll: self contextStackTop printString; cr.
- self contextStackTop errorReportOn: s].
- (Smalltalk classNamed: #WebClient)
- ifNotNil: [:wc |
- wc
- httpPost: self class errorReportServer
- content: errorReport
- type: 'text/plain']] on: Error do: ["nothing"].
- self abandon.!
Item was removed:
- ----- Method: Debugger>>shiftedContextStackMenu: (in category 'context stack menu') -----
- shiftedContextStackMenu: aMenu
- "Set up the menu appropriately for the context-stack-list, shifted"
- <contextStackMenuShifted: true>
- ^ aMenu addList: #(
- ('browse class hierarchy' browseClassHierarchy)
- ('browse class' browseClass)
- ('implementors of sent messages' browseAllMessages)
- ('change sets with this method' findMethodInChangeSets)
- -
- ('inspect instances' inspectInstances)
- ('inspect subinstances' inspectSubInstances)
- -
- ('revert to previous version' revertToPreviousVersion)
- ('remove from current change set' removeFromCurrentChanges)
- ('revert & remove from changes' revertAndForget));
- yourself
- !
Item was removed:
- ----- Method: Debugger>>shouldNotStep (in category 'private') -----
- shouldNotStep
- "An illegal attempt was to step an unready process. Update the enablement of stepping buttons and trigger a visual indication.
-
- For instance, this situation can be triggered by this:
- [self currentHand lastEvent shiftPressed] yourself
- whileFalse: [Project current world doOneCycleNow].
- Debug it, step over #whileFalse: and step over again. Move your cursor while pressing shift to continue."
-
- self
- changed: #interruptedProcessIsReady;
- changed: #interruptedProcessShouldResume.
-
- ^ self changed: #flash!
Item was removed:
- ----- Method: Debugger>>showFullStack (in category 'actions - convenience') -----
- showFullStack
-
- self fullStack.!
Item was removed:
- ----- Method: Debugger>>showWhere (in category 'actions - convenience') -----
- showWhere
- "Select the PC range"
-
- self where.!
Item was removed:
- ----- Method: Debugger>>stepInto (in category 'actions - convenience') -----
- stepInto
-
- self send.!
Item was removed:
- ----- Method: Debugger>>stepIntoBlock (in category 'context stack menu') -----
- stepIntoBlock
- "Send messages until you return to the present method context.
- Used to step into a block in the method."
-
- | currentContext newContext |
- self okToChange ifFalse: [^ self].
- self interruptedProcessIsReady ifFalse: [^ self shouldNotStep].
- self checkContextSelection.
- currentContext := self selectedContext.
- self handleLabelUpdatesIn:
- [interruptedProcess stepToHome: currentContext]
- whenExecuting: self selectedContext.
- interruptedProcess ifNil: [^ self shouldNotStep].
- newContext := interruptedProcess stepToSendOrReturn.
- self updateProcess.
- self contextStackIndex > 1
- ifTrue: [self resetContext: newContext]
- ifFalse:
- [newContext == currentContext
- ifTrue: [self changed: #contentsSelection.
- self updateInspectors]
- ifFalse: [self resetContext: newContext]].!
Item was removed:
- ----- Method: Debugger>>stepOver (in category 'actions - convenience') -----
- stepOver
-
- self doStep.!
Item was removed:
- ----- Method: Debugger>>stepThrough (in category 'actions - convenience') -----
- stepThrough
-
- self stepIntoBlock.!
Item was removed:
- ----- Method: Debugger>>storeLog (in category 'notifier menu') -----
- storeLog
-
- Smalltalk logSqueakError: labelString printString inContext: self contextStackTop
- !
Item was removed:
- ----- Method: Debugger>>tally (in category 'tally support') -----
- tally
-
- self codeTextPane ifNotNil: [:o | o tallyIt] ifNil: [Beeper beep]
- !
Item was removed:
- ----- Method: Debugger>>tallyMenu: (in category 'controls') -----
- tallyMenu: aMenu
-
- ^ aMenu
- "title: 'Tally' translated;" flag: #todo; "ct: Implement on PluggableMenuSpec"
- addTranslatedList: #(
- ('Tally selection' tallyIt 'evaluate current selection and measure the time')
- ('Record send' doRecord 'record next message send'));
- yourself!
Item was removed:
- ----- Method: Debugger>>terminateProcess (in category 'context stack menu') -----
- terminateProcess
- "Close the debugger and terminate the debugged process. Note that we use #terminate instead of #terminateAggressively to let any current ensure-block finish."
-
- terminateProcessSelector := #terminate.
- self close
- !
Item was removed:
- ----- Method: Debugger>>textFrame (in category 'toolbuilder') -----
- textFrame
-
- ^ super textFrame
- topOffset: (self wantsOptionalButtons ifTrue: [self buttonHeight * 2 + self extraCellGap] ifFalse: [self buttonHeight]);
- yourself!
Item was removed:
- ----- Method: Debugger>>toggleBreakOnEntry (in category 'breakpoints') -----
- toggleBreakOnEntry
- "Override to rset to the new breakless method if stopped at a break point.
- N.B. does not (yet) do the reverse."
- | ctxt prevPC atInitialBreak newMethod |
- ((ctxt := self selectedContext) isNil
- or: [(prevPC := ctxt previousPc) isNil]) ifTrue:
- [^super toggleBreakOnEntry].
-
- atInitialBreak := ctxt selectorJustSentOrSelf == #break
- and: [(ctxt method pcPreviousTo: ctxt previousPc) = ctxt method initialPC].
- super toggleBreakOnEntry.
- newMethod := ctxt method methodReference compiledMethod.
- (atInitialBreak
- and: [newMethod isCompiledCode
- and: [newMethod ~~ ctxt method]]) ifTrue:
- [ctxt privRefreshWith: newMethod.
- self resetContext: ctxt.
- self debug]!
Item was removed:
- ----- Method: Debugger>>toggleContextStackIndex: (in category 'context stack - message list') -----
- toggleContextStackIndex: anInteger
- "If anInteger is the same as the index of the selected context, deselect it.
- Otherwise, the context whose index is anInteger becomes the selected
- context."
-
- self contextStackIndex:
- (contextStackIndex = anInteger
- ifTrue: [0]
- ifFalse: [anInteger])
- oldContextWas:
- (contextStackIndex = 0
- ifTrue: [nil]
- ifFalse: [contextStack at: contextStackIndex])!
Item was removed:
- ----- Method: Debugger>>tryRestartFrom: (in category 'context stack menu') -----
- tryRestartFrom: context
- "Try to restart from the initial state of the context.
- Return whether an unwind error occurred."
-
- | actualContext unwindError |
- actualContext := interruptedProcess popTo: context.
- unwindError := actualContext ~= context.
- unwindError ifFalse: [
- interruptedProcess restartTop; stepToSendOrReturn].
- self resetContext: actualContext.
- ^ unwindError!
Item was removed:
- ----- Method: Debugger>>up (in category 'context stack menu') -----
- up
- "move up the context stack to the next (enclosed) context"
-
- contextStackIndex > 1 ifTrue: [self toggleContextStackIndex: contextStackIndex-1]!
Item was removed:
- ----- Method: Debugger>>updateInspectors (in category 'self-updating') -----
- updateInspectors
- "Update the inspectors on the receiver's variables."
-
- receiverInspector == nil ifFalse: [receiverInspector update].
- contextVariablesInspector == nil ifFalse: [contextVariablesInspector update]!
Item was removed:
- ----- Method: Debugger>>updateProcess (in category 'private') -----
- updateProcess
-
- self
- changed: #interruptedProcessIsReady;
- changed: #interruptedProcessShouldResume.!
Item was removed:
- ----- Method: Debugger>>wantsAnnotationPane (in category 'toolbuilder') -----
- wantsAnnotationPane
-
- ^ self class wantsAnnotationPane!
Item was removed:
- ----- Method: Debugger>>wantsCodeProvenanceButton (in category 'toolbuilder') -----
- wantsCodeProvenanceButton
-
- ^ false!
Item was removed:
- ----- Method: Debugger>>wantsOptionalButtons (in category 'toolbuilder') -----
- wantsOptionalButtons
- "The debugger benefits so majorly from the optional buttons that there is an extra preference for it."
-
- ^ Preferences extraDebuggerButtons!
Item was removed:
- ----- Method: Debugger>>wantsStepsIn: (in category 'self-updating') -----
- wantsStepsIn: aWindow
-
- ^ false!
Item was removed:
- ----- Method: Debugger>>where (in category 'context stack menu') -----
- where
- "Select the expression whose evaluation was interrupted."
-
- selectingPC := true.
- self contextStackIndex: contextStackIndex oldContextWas: self selectedContext
- !
Item was removed:
- ----- Method: Debugger>>windowIsClosing (in category 'initialize') -----
- windowIsClosing
- "My window is being closed; clean up. Restart the low space watcher."
-
- contextStack := nil.
- receiverInspector := nil.
- contextVariablesInspector := nil.
-
- interruptedProcess == nil ifTrue: [^ self].
- self flag: #discuss. "mt: Maybe #fork the termination of the process.
- See
- - http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-May/220675.html
- - http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-June/221044.html"
- interruptedProcess perform: terminateProcessSelector.
- interruptedProcess := nil.
-
- Smalltalk installLowSpaceWatcher. "restart low space handler"!
Item was removed:
- ----- Method: Debugger>>windowReqNewLabel: (in category 'user interface') -----
- windowReqNewLabel: newLabel
-
- labelString := newLabel.
- ^ true!
Item was removed:
- Object subclass: #DebuggerMethodMap
- instanceVariableNames: 'timestamp methodReference methodNode startKeysToBlockExtents abstractSourceRanges sortedSourceMap'
- classVariableNames: 'AccessLock MapCache MapCacheEntries'
- poolDictionaries: ''
- category: 'Tools-Debugger'!
-
- !DebuggerMethodMap commentStamp: 'eem 10/1/2020 19:08' prior: 0!
- I am a place-holder for information needed by the Debugger to inspect method activations. I insulate the debugger from details of code generation such as exact bytecode offsets and temporary variable locations. I have two concrete subclasses, one for methods where block bytecodes are embedded in the home method and one for methods where blocks are separate objects (CompiledBlock). These classes deal with temporary variable access. My function is to abstract the source map away from actual bytecode pcs to abstract bytecode pcs. I used to have a subclass for "BlueBook" compiled methods, with non-closure blocks, but this was removed in October 2020 for simplicity's sake.
-
- To reduce compilation time I try and defer as much computation to access time as possible as instances of me will be created after each compilation.
-
- I maintain a WeakIdentityDictionary of method to DebuggerMethodMap to cache maps. I refer to my method through a WeakArray to keep the map cache functional. If the reference from a DebuggerMethodMap to its method were strong then the method would never be dropped from the cache because the reference from its map would keep it alive.!
Item was removed:
- ----- Method: DebuggerMethodMap class>>cacheDebugMap:forMethod: (in category 'debugger support') -----
- cacheDebugMap: aDebuggerMethodMap forMethod: aCompiledMethod
-
- ^self protected: [
- MapCache size >= MapCacheEntries ifTrue: [
- MapCache slowSize >= MapCacheEntries
- ifFalse: [ MapCache rehash ]
- ifTrue: [
- | mapsByAge |
- mapsByAge := MapCache keys sort: [ :m1 :m2 |
- "We are holding strongly on the keys, so #at: is suitable."
- (MapCache at: m1) timestamp < (MapCache at: m2) timestamp].
- mapsByAge from: 1 to: mapsByAge size - MapCacheEntries do: [ :each |
- MapCache removeKey: each ] ] ].
- MapCache
- at: aCompiledMethod
- put: aDebuggerMethodMap ]!
Item was removed:
- ----- Method: DebuggerMethodMap class>>cleanUp (in category 'class initialization') -----
- cleanUp
- self initialize!
Item was removed:
- ----- Method: DebuggerMethodMap class>>forMethod: (in category 'instance creation') -----
- forMethod: aMethod "<CompiledMethod>"
- "Answer a DebuggerMethodMap suitable for debugging activations of aMethod.
- Answer an existing instance from the cache if it exists, cacheing a new one if required."
-
- ^self protected: [
- MapCache
- at: aMethod
- ifAbsent: [self
- cacheDebugMap:
- (self
- forMethod: aMethod
- methodNode: aMethod methodNode)
- forMethod: aMethod] ]!
Item was removed:
- ----- Method: DebuggerMethodMap class>>forMethod:methodNode: (in category 'instance creation') -----
- forMethod: aMethod "<CompiledCode>" methodNode: methodNode "<MethodNode>"
- "Uncached instance creation method for private use or for tests.
- Please consider using forMethod: instead."
- ^(aMethod encoderClass supportsFullBlocks
- ifTrue: [DebuggerMethodMapForFullBlockCompiledMethods]
- ifFalse: [DebuggerMethodMapForClosureCompiledMethods]) new
- forMethod: aMethod homeMethod
- methodNode: methodNode!
Item was removed:
- ----- Method: DebuggerMethodMap class>>initialize (in category 'class initialization') -----
- initialize
- "DebuggerMethodMap initialize"
-
- self voidMapCache!
Item was removed:
- ----- Method: DebuggerMethodMap class>>protected: (in category 'synchronization') -----
- protected: aBlock
-
- ^(AccessLock ifNil: [ AccessLock := Mutex new ]) critical: aBlock!
Item was removed:
- ----- Method: DebuggerMethodMap class>>voidMapCache (in category 'class initialization') -----
- voidMapCache
-
- self protected: [
- MapCache := WeakIdentityKeyDictionary new.
- MapCacheEntries := 16 ]!
Item was removed:
- ----- Method: DebuggerMethodMap>>abstractSourceMap (in category 'private') -----
- abstractSourceMap
- "Answer with a Dictionary of abstractPC <Integer> to sourceRange <Interval>."
- | theMethodToScan rawSourceRanges concreteSourceRanges abstractPC scanner client |
- abstractSourceRanges ifNotNil:
- [^abstractSourceRanges].
- "If the methodNode hasn't had a method generated it doesn't have pcs set in its
- nodes so we must generate a new method and might as well use it for scanning."
- methodNode rawSourceRangesAndMethodDo:
- [:ranges :method|
- rawSourceRanges := ranges.
- theMethodToScan := method].
- concreteSourceRanges := Dictionary new.
- rawSourceRanges keysAndValuesDo:
- [:node :range|
- node pc ~= 0 ifTrue:
- [concreteSourceRanges at: node pc put: range]].
- abstractPC := 1.
- abstractSourceRanges := Dictionary new.
- scanner := InstructionStream on: theMethodToScan.
- client := InstructionClient new.
- [(concreteSourceRanges includesKey: scanner pc) ifTrue:
- [abstractSourceRanges at: abstractPC put: (concreteSourceRanges at: scanner pc)].
- abstractPC := abstractPC + 1.
- scanner interpretNextInstructionFor: client.
- scanner atEnd] whileFalse.
- ^abstractSourceRanges!
Item was removed:
- ----- Method: DebuggerMethodMap>>abstractSourceMapForMethod: (in category 'source mapping') -----
- abstractSourceMapForMethod: aCompiledMethod
- "The default source mapping is for block bytecodes embedded within a
- single compiled method, as in the BlueBook and EncoderForV3PlusClosures."
- ^self abstractSourceMap!
Item was removed:
- ----- Method: DebuggerMethodMap>>blockExtentsInto:from:to:method:numberer: (in category 'private') -----
- blockExtentsInto: aDictionary from: initialPC to: endPC method: method numberer: numbererBlock
- "Support routine for startpcsToBlockExtents"
- | pcs extentStart locator scanner blockSizeOrMethodOrLocator |
- extentStart := numbererBlock value.
- locator := BlockStartLocator new.
- scanner := InstructionStream new method: method pc: initialPC.
- pcs := OrderedCollection new.
- [pcs addLast: scanner pc.
- scanner pc <= endPC] whileTrue:
- [blockSizeOrMethodOrLocator := scanner interpretNextInstructionFor: locator.
- blockSizeOrMethodOrLocator ~~ locator ifTrue:
- [blockSizeOrMethodOrLocator isInteger
- ifTrue:
- [self
- blockExtentsInto: aDictionary
- from: scanner pc
- to: scanner pc + blockSizeOrMethodOrLocator - 1
- method: method
- numberer: numbererBlock.
- scanner pc: scanner pc + blockSizeOrMethodOrLocator]
- ifFalse:
- [self assert: blockSizeOrMethodOrLocator isCompiledBlock.
- self
- blockExtentsInto: aDictionary
- from: blockSizeOrMethodOrLocator initialPC
- to: blockSizeOrMethodOrLocator endPC
- method: blockSizeOrMethodOrLocator
- numberer: numbererBlock]]].
- aDictionary
- at: (method isCompiledBlock
- ifTrue: [method]
- ifFalse: [initialPC])
- put: (extentStart to: numbererBlock value).
- ^aDictionary!
Item was removed:
- ----- Method: DebuggerMethodMap>>forMethod:methodNode: (in category 'initialize-release') -----
- forMethod: aMethod "<CompiledMethod>" methodNode: theMethodNode "<MethodNode>"
- methodReference := WeakArray with: aMethod.
- methodNode := theMethodNode.
- self markRecentlyUsed!
Item was removed:
- ----- Method: DebuggerMethodMap>>markRecentlyUsed (in category 'private') -----
- markRecentlyUsed
- timestamp := Time totalSeconds!
Item was removed:
- ----- Method: DebuggerMethodMap>>method (in category 'accessing') -----
- method
- ^methodReference at: 1!
Item was removed:
- ----- Method: DebuggerMethodMap>>namedTempAt:in: (in category 'accessing') -----
- namedTempAt: index in: aContext
- "Answer the value of the temp at index in aContext where index is relative
- to the array of temp names answered by tempNamesForContext:"
- self assert: aContext method homeMethod == self method.
- ^self
- privateTempAt: index
- in: aContext
- startKeysToBlockExtents: self startKeysToBlockExtents!
Item was removed:
- ----- Method: DebuggerMethodMap>>namedTempAt:put:in: (in category 'accessing') -----
- namedTempAt: index put: aValue in: aContext
- "Assign the value of the temp at index in aContext where index is relative
- to the array of temp names answered by tempNamesForContext:.
- If the value is a copied value we also need to set it along the lexical chain."
- self assert: aContext method homeMethod == self method.
- ^self
- privateTempAt: index
- in: aContext
- put: aValue
- startKeysToBlockExtents: self startKeysToBlockExtents!
Item was removed:
- ----- Method: DebuggerMethodMap>>rangeForPC:in:contextIsActiveContext: (in category 'source mapping') -----
- rangeForPC: contextsConcretePC in: method contextIsActiveContext: contextIsActiveContext
- "Answer the indices in the source code for the supplied pc.
- If the context is the actve context (is at the hot end of the stack)
- then its pc is the current pc. But if the context isn't, because it is
- suspended sending a message, then its current pc is the previous pc."
-
- | pc abstractMap i end |
- pc := method abstractPCForConcretePC: (contextIsActiveContext
- ifTrue: [contextsConcretePC]
- ifFalse: [(method pcPreviousTo: contextsConcretePC)
- ifNotNil: [:prevpc| prevpc]
- ifNil: [contextsConcretePC]]).
- abstractMap := self abstractSourceMapForMethod: method.
- (abstractMap includesKey: pc) ifTrue:
- [^abstractMap at: pc].
- sortedSourceMap ifNil:
- [sortedSourceMap := abstractMap associations
- replace: [ :each | each copy ];
- sort].
- sortedSourceMap isEmpty ifTrue: [^1 to: 0].
- i := sortedSourceMap findNearbyBinaryIndex: [:assoc| pc - assoc key].
- i < 1 ifTrue: [^1 to: 0].
- i > sortedSourceMap size ifTrue:
- [end := sortedSourceMap inject: 0 into:
- [:prev :this | prev max: this value last].
- ^end+1 to: end].
- ^(sortedSourceMap at: i) value
-
- "| method source scanner map |
- method := DebuggerMethodMap compiledMethodAt: #rangeForPC:in:contextIsActiveContext:.
- source := method getSourceFromFile asString.
- scanner := InstructionStream on: method.
- map := method debuggerMap.
- Array streamContents:
- [:ranges|
- [scanner atEnd] whileFalse:
- [| range |
- range := map rangeForPC: scanner pc in: method contextIsActiveContext: true.
- ((map abstractSourceMap includesKey: scanner abstractPC)
- and: [range first ~= 0]) ifTrue:
- [ranges nextPut: (source copyFrom: range first to: range last)].
- scanner interpretNextInstructionFor: InstructionClient new]]"!
Item was removed:
- ----- Method: DebuggerMethodMap>>sourceText (in category 'source mapping') -----
- sourceText
- self method ifNotNil:
- [:method|
- method holdsTempNames ifTrue:
- [^method
- getSourceFor: (method selector ifNil: [method defaultSelector])
- in: method methodClass]].
- ^methodNode sourceText!
Item was removed:
- ----- Method: DebuggerMethodMap>>startKeysToBlockExtents (in category 'private') -----
- startKeysToBlockExtents
- "Answer the map from start keys (either start pcs for embedded closures, or
- full block methods for full blocks) to the block extents in that method, where
- a block extent is an abstract representation of block nesting within a method."
-
- startKeysToBlockExtents ifNil:
- [| index method |
- index := 0.
- method := self method homeMethod.
- startKeysToBlockExtents :=
- self
- blockExtentsInto: self newBlockStartMap
- from: method initialPC
- to: method endPC
- method: method
- numberer: [| value | value := index. index := index + 2. value]].
- ^startKeysToBlockExtents!
Item was removed:
- ----- Method: DebuggerMethodMap>>tempNamesForContext: (in category 'accessing') -----
- tempNamesForContext: aContext
- "Answer an Array of all the temp names in scope in aContext starting with
- the home's first local (the first argument or first temporary if no arguments)."
- self assert: aContext method homeMethod == self method.
- ^(self
- privateTempRefsForContext: aContext
- startKeysToBlockExtents: self startKeysToBlockExtents) collect:
- [:pair| pair first]!
Item was removed:
- ----- Method: DebuggerMethodMap>>tempNamesForMethod: (in category 'accessing') -----
- tempNamesForMethod: aMethod
- "Answer an Array of all the temp names in scope in aMethod starting with
- the home's first local (the first argument or first temporary if no arguments)."
- self assert: aMethod homeMethod == self method.
- ^(self
- privateTempRefsForMethod: aMethod
- startKeysToBlockExtents: self startKeysToBlockExtents) collect:
- [:pair| pair first]!
Item was removed:
- ----- Method: DebuggerMethodMap>>tempsAndValuesForContext: (in category 'accessing') -----
- tempsAndValuesForContext: aContext
- "Return a string of the temporary variables and their current values"
- | aStream |
- aStream := WriteStream on: (String new: 100).
- (self tempNamesForContext: aContext) withIndexDo:
- [:title :index |
- aStream nextPutAll: title; nextPut: $:; space; tab.
- aContext print: (self namedTempAt: index in: aContext) on: aStream.
- aStream cr].
- ^aStream contents!
Item was removed:
- ----- Method: DebuggerMethodMap>>tempsAndValuesForContext:contractTo: (in category 'accessing') -----
- tempsAndValuesForContext: aContext contractTo: width
- "Return a string of the temporary variabls and their current values"
- | aStream tempStream |
- aStream := WriteStream on: (String new: 100).
- tempStream := WriteStream on: (String new: width).
- (self tempNamesForContext: aContext) withIndexDo:
- [:title :index |
- aStream nextPutAll: title; nextPut: $:; space; tab.
- tempStream reset.
- aContext print: (self namedTempAt: index in: aContext) on: tempStream.
- aStream nextPutAll: (tempStream contents contractTo: width).
- aStream cr].
- ^aStream contents!
Item was removed:
- ----- Method: DebuggerMethodMap>>timestamp (in category 'private') -----
- timestamp
- ^timestamp!
Item was removed:
- DebuggerMethodMap subclass: #DebuggerMethodMapForClosureCompiledMethods
- instanceVariableNames: 'blockExtentsToTempRefs startpcsToTempRefs startKeysToTempRefs'
- classVariableNames: 'FirstTime'
- poolDictionaries: ''
- category: 'Tools-Debugger'!
-
- !DebuggerMethodMapForClosureCompiledMethods commentStamp: 'eem 10/1/2020 19:19' prior: 0!
- I am a place-holder for information needed by the Debugger to inspect method activations. See my superclass's comment. I map methods compiled using closures whose bytecodes are embedded within the home CompiledMethod, as is the case for the V3PlusClosures bytecode set.
-
- Instance variables
- blockExtentsToTempsRefs <Dictionary of: Interval -> Array of: (Array with: String with: (Integer | (Array with: Integer with: Integer)))>
- maps a block extent to an Array of temp references for that block/method.
- Each reference is a pair of temp name and index, where the index can itself be a pair for a remote temp.
- startKeysToTempRefs <Dictionary of: Integer startpc -> Array of: (Array with: String with: temp reference)> where
- temp reference ::= Integer
- | (Array with: Integer with: Integer)
- | (Array with: #outer with: temp reference)!
Item was removed:
- ----- Method: DebuggerMethodMapForClosureCompiledMethods>>newBlockStartMap (in category 'private') -----
- newBlockStartMap
- "If blocks are embedded then keys in the map are simple integer pcs and a Dictionary can be used.
- If blocks are full (separate method objects) then keys in the map are CompiledBlocks and
- IdentityDictionary must be used to avoid confusing blocks with identical code."
- ^Dictionary new!
Item was removed:
- ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateDereference:in: (in category 'private') -----
- privateDereference: tempReference in: aContext
- "Fetch the temporary with reference tempReference in aContext.
- tempReference can be
- integer - direct temp reference
- #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index
- #( outer. temp reference ) - a temp reference in an outer context."
- ^tempReference isInteger
- ifTrue:
- [tempReference <= aContext stackPtr ifTrue:
- [aContext tempAt: tempReference]]
- ifFalse:
- [tempReference first == #outer
- ifTrue:
- [self privateDereference: tempReference last
- in: aContext outerContext]
- ifFalse: "If stopped before indirection vectors are created they will be nil. Simply answer nil"
- [tempReference first <= aContext stackPtr ifTrue:
- [(aContext tempAt: tempReference first) ifNotNil:
- [:indirectionVector|
- indirectionVector at: tempReference second]]]]!
Item was removed:
- ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateDereference:in:put: (in category 'private') -----
- privateDereference: tempReference in: aContext put: aValue
- "Assign the temporary with reference tempReference in aContext.
- tempReference can be
- integer - direct temp reference
- #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index
- #( outer. temp reference ) - a temp reference in an outer context."
- ^tempReference isInteger
- ifTrue:
- [tempReference <= aContext stackPtr
- ifTrue:
- [aContext tempAt: tempReference put: aValue]
- ifFalse:
- [UIManager default inform: 'Cannot assign temp because it is no longer on stack.\Activation has returned?' withCRs.
- nil]]
- ifFalse:
- [tempReference first == #outer
- ifTrue:
- [self privateDereference: tempReference last
- in: aContext outerContext
- put: aValue]
- ifFalse: "If stopped before indirection vectors are created they will be nil."
- [tempReference first <= aContext stackPtr
- ifTrue:
- [(aContext tempAt: tempReference first)
- ifNil: [UIManager default inform: 'Cannot assign remote temp because indirection vector is nil.\Too early in method execution?' withCRs.
- nil]
- ifNotNil:
- [:indirectionVector|
- indirectionVector
- at: tempReference second
- put: aValue]]
- ifFalse:
- [UIManager default inform: 'Cannot assign remote temp because it is no longer on stack.\Activation has returned?' withCRs.
- nil]]]!
Item was removed:
- ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempAt:in:put:startKeysToBlockExtents: (in category 'private') -----
- privateTempAt: index in: aContext put: aValue startKeysToBlockExtents: theContextsStartKeysToBlockExtents
- | nameRefPair |
- nameRefPair := (self privateTempRefsForContext: aContext
- startKeysToBlockExtents: theContextsStartKeysToBlockExtents)
- at: index
- ifAbsent: [aContext errorSubscriptBounds: index].
- ^self privateDereference: nameRefPair last in: aContext put: aValue!
Item was removed:
- ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempAt:in:startKeysToBlockExtents: (in category 'private') -----
- privateTempAt: index in: aContext startKeysToBlockExtents: theContextsStartKeysToBlockExtents
- | nameRefPair |
- nameRefPair := (self privateTempRefsForContext: aContext
- startKeysToBlockExtents: theContextsStartKeysToBlockExtents)
- at: index
- ifAbsent: [aContext errorSubscriptBounds: index].
- ^self privateDereference: nameRefPair last in: aContext!
Item was removed:
- ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempRefsForContext:startKeysToBlockExtents: (in category 'private') -----
- privateTempRefsForContext: aContext startKeysToBlockExtents: theContextsStartKeysToBlockExtents
- "Answer the sequence of temps in scope in aContext in the natural order,
- outermost arguments and temporaries first, innermost last. Each temp is
- a pair of the temp's name followed by a reference. The reference can be
- integer - index of temp in aContext
- #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index in aContext
- #( outer. temp reference ) - a temp reference in an outer context."
- blockExtentsToTempRefs ifNil:
- [blockExtentsToTempRefs := (aContext method holdsTempNames
- ifTrue: [aContext method]
- ifFalse: [methodNode]) blockExtentsToTempsMap.
- blockExtentsToTempRefs
- ifNil: ["an empty method. shouldn't be able to step into here but it
- can happen in weird circumstances (i.e. with MethodWrapper)."
- blockExtentsToTempRefs := Dictionary new.
- blockExtentsToTempRefs
- at: (theContextsStartKeysToBlockExtents at: aContext startKey)
- put: {}]
- ifNotNil:
- [(blockExtentsToTempRefs isKindOf: IdentityDictionary) ifTrue:
- [blockExtentsToTempRefs := Dictionary withAll: blockExtentsToTempRefs associations]].
- startKeysToTempRefs := self newBlockStartMap].
- ^startKeysToTempRefs
- at: aContext startKey
- ifAbsentPut:
- [| localRefs |
- localRefs := blockExtentsToTempRefs at: (theContextsStartKeysToBlockExtents at: aContext startKey) ifAbsent: [#()].
- aContext outerContext
- ifNil: [localRefs]
- ifNotNil:
- [:outer| | outerTemps |
- "Present temps in the order outermost to innermost left-to-right, but replace
- copied outermost temps with their innermost copies"
- outerTemps := (self
- privateTempRefsForContext: outer
- startKeysToBlockExtents: theContextsStartKeysToBlockExtents) collect:
- [:outerPair|
- localRefs
- detect: [:localPair| outerPair first = localPair first]
- ifNone: [{ outerPair first. { #outer. outerPair last } }]].
- outerTemps,
- (localRefs reject: [:localPair| outerTemps anySatisfy: [:outerPair| localPair first = outerPair first]])]]!
Item was removed:
- ----- Method: DebuggerMethodMapForClosureCompiledMethods>>privateTempRefsForMethod:startKeysToBlockExtents: (in category 'private') -----
- privateTempRefsForMethod: method startKeysToBlockExtents: startKeysToBlockExtents
- "Answer the sequence of temps in scope in method in the natural order,
- outermost arguments and temporaries first, innermost last. Each temp is
- a pair of the temp's name followed by a reference. The reference can be
- integer - index of temp in aContext
- #( indirectionVectorIndex tempIndex ) - remote temp in indirectionVector at index in aContext
- #( outer. temp reference ) - a temp reference in an outer context."
- blockExtentsToTempRefs ifNil:
- [blockExtentsToTempRefs := (method holdsTempNames
- ifTrue: [method]
- ifFalse: [methodNode]) blockExtentsToTempsMap.
- blockExtentsToTempRefs ifNil:
- ["an empty method. shouldn't be able to step into here but it
- can happen in weird circumstances (i.e. with MethodWrapper)."
- blockExtentsToTempRefs := Dictionary new.
- blockExtentsToTempRefs
- at: (startKeysToBlockExtents at: method startKey)
- put: {}].
- startKeysToTempRefs := Dictionary new].
- ^startKeysToTempRefs
- at: method startKey
- ifAbsentPut:
- [blockExtentsToTempRefs at: (startKeysToBlockExtents at: method startKey)]!
Item was removed:
- DebuggerMethodMapForClosureCompiledMethods subclass: #DebuggerMethodMapForFullBlockCompiledMethods
- instanceVariableNames: 'sortedSourceMaps'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Debugger'!
-
- !DebuggerMethodMapForFullBlockCompiledMethods commentStamp: 'eem 10/1/2020 19:20' prior: 0!
- I am a place-holder for information needed by the Debugger to inspect method activations. See DebuggerMethodMap's comment. I map methods compiled using full block closures, where block methods are objects separate from the home mehtod, as is the case with the SistaV1 bytecode set.
-
- Instance variables
- (inherited)
- abstractSourceRanges <Dictionary of: CompiledCode -> (Dictionary of: Integer-> Interval)
- startKeysToTempRefs <Dictionary of: CompiledCode -> Array of: (Array with: String with: temp reference)> where
- temp reference ::= Integer
- | (Array with: Integer with: Integer)
- | (Array with: #outer with: temp reference)
- (locally defined)
- sortedSourceMaps <Dictionary of: CompiledCode -> (Dictionary of: Integer-> Interval)!
Item was removed:
- ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>abstractSourceMap (in category 'source mapping') -----
- abstractSourceMap
- self shouldNotImplement!
Item was removed:
- ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>abstractSourceMapForMethod: (in category 'source mapping') -----
- abstractSourceMapForMethod: compiledCode
- "Answer with a Dictionary of abstractPC <Integer> to sourceRange <Interval>
- for compiledCode which may be either a CompiledMethod or a CompiledBlock."
- | rawSourceRanges theMethodToScan |
- abstractSourceRanges ifNotNil:
- [^abstractSourceRanges at: compiledCode].
- abstractSourceRanges := IdentityDictionary new.
- "If the methodNode hasn't had a method generated it doesn't have pcs set in its
- nodes so we must generate a new method. We use this method for scanning
- since its rawSourceRanges refer to the block methods within the method, and
- that means we can use identity comparisons to match nodes with blocks."
- methodNode rawSourceRangesAndMethodDo:
- [:ranges :method|
- rawSourceRanges := ranges.
- theMethodToScan := method].
- self scanMethod: theMethodToScan mappingRanges: rawSourceRanges.
- self mapBlockMethodKeysIn: theMethodToScan toActualBlockMethodsIn: compiledCode homeMethod.
- ^abstractSourceRanges at: compiledCode!
Item was removed:
- ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>mapBlockMethodKeysIn:toActualBlockMethodsIn: (in category 'source mapping') -----
- mapBlockMethodKeysIn: theMethodToScan toActualBlockMethodsIn: actualMethod
- abstractSourceRanges at: actualMethod put: (abstractSourceRanges removeKey: theMethodToScan).
- 1 to: theMethodToScan numLiterals - 1 do: "i.e. don't scan the last literal which, in CompiledBlocks is a back pointer"
- [:i| | lit |
- (lit := theMethodToScan literalAt: i) isCompiledCode ifTrue:
- [self mapBlockMethodKeysIn: lit toActualBlockMethodsIn: (actualMethod literalAt: i)]]!
Item was removed:
- ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>newBlockStartMap (in category 'private') -----
- newBlockStartMap
- "If blocks are embedded then keys in the map are simple integer pcs and a Dictionary can be used.
- If blocks are full (separate method objects) then keys in the map are CompiledBlocks and
- IdentityDictionary must be used to avoid confusing blocks with identical code."
- ^WeakIdentityKeyDictionary new!
Item was removed:
- ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>rangeForPC:in:contextIsActiveContext: (in category 'source mapping') -----
- rangeForPC: contextsConcretePC in: method contextIsActiveContext: contextIsActiveContext
- "Answer the indices in the source code for the supplied pc.
- If the context is the actve context (is at the hot end of the stack)
- then its pc is the current pc. But if the context isn't, because it is
- suspended sending a message, then its current pc is the previous pc."
-
- | pc i end mapForMethod sortedMap |
- pc := method abstractPCForConcretePC: (contextIsActiveContext
- ifTrue: [contextsConcretePC]
- ifFalse: [(method pcPreviousTo: contextsConcretePC)
- ifNotNil: [:prevpc| prevpc]
- ifNil: [contextsConcretePC]]).
- ((mapForMethod := self abstractSourceMapForMethod: method) includesKey: pc) ifTrue:
- [^mapForMethod at: pc].
- sortedSourceMap ifNil:
- [sortedSourceMap := IdentityDictionary new].
- sortedMap := sortedSourceMap
- at: method
- ifAbsentPut: [mapForMethod associations
- replace: [ :each | each copy ];
- sort].
- sortedMap isEmpty ifTrue: [^1 to: 0].
- i := sortedMap findNearbyBinaryIndex: [:assoc| pc - assoc key].
- i < 1 ifTrue: [^1 to: 0].
- i > sortedMap size ifTrue:
- [end := sortedMap inject: 0 into:
- [:prev :this | prev max: this value last].
- ^end+1 to: end].
- ^(sortedMap at: i) value
-
- "| method source scanner map |
- method := DebuggerMethodMapForFullBlockCompiledMethods compiledMethodAt: #rangeForPC:in:contextIsActiveContext:.
- source := method getSourceFromFile asString.
- scanner := InstructionStream on: method.
- map := method debuggerMap.
- Array streamContents:
- [:ranges|
- [scanner atEnd] whileFalse:
- [| range |
- range := map rangeForPC: scanner pc in: method contextIsActiveContext: true.
- ((map abstractSourceMap includesKey: scanner abstractPC)
- and: [range first ~= 0]) ifTrue:
- [ranges nextPut: (source copyFrom: range first to: range last)].
- scanner interpretNextInstructionFor: InstructionClient new]]"!
Item was removed:
- ----- Method: DebuggerMethodMapForFullBlockCompiledMethods>>scanMethod:mappingRanges: (in category 'source mapping') -----
- scanMethod: theMethodToScan mappingRanges: rawSourceRanges
- | abstractPC scanner client maybeBlock concreteSourceRanges rangesForMethod |
- rangesForMethod := (abstractSourceRanges at: theMethodToScan put: Dictionary new).
- concreteSourceRanges := Dictionary new.
- "The rawSourceRanges map node pcs to ranges.
- When node is one in the home method the node's pc is an integer.
- When the node is within a block method the node's pc is an association from CompiledBlock to pc.
- Extract pc -> range for this particular CompiledMethod or CompiledBlock."
- rawSourceRanges keysAndValuesDo:
- (theMethodToScan isCompiledMethod
- ifTrue:
- [[:node :range|
- (node pc isVariableBinding
- or: [node pc = 0]) ifFalse:
- [concreteSourceRanges at: node pc put: range]]]
- ifFalse:
- [[:node :range|
- (node pc isVariableBinding
- and: [node pc key == theMethodToScan
- and: [node pc value ~= 0]]) ifTrue:
- [concreteSourceRanges at: node pc value put: range]]]).
- abstractPC := 1.
- scanner := InstructionStream on: theMethodToScan.
- client := BlockStartLocator new.
- [(concreteSourceRanges includesKey: scanner pc) ifTrue:
- [rangesForMethod at: abstractPC put: (concreteSourceRanges at: scanner pc)].
- abstractPC := abstractPC + 1.
- maybeBlock := scanner interpretNextInstructionFor: client.
- (maybeBlock ~~ client
- and: [maybeBlock isCompiledCode]) ifTrue:
- [self assert: maybeBlock isCompiledBlock.
- self scanMethod: maybeBlock mappingRanges: rawSourceRanges].
- scanner atEnd] whileFalse!
Item was removed:
- CodeHolder subclass: #DependencyBrowser
- instanceVariableNames: 'packageList packageDeps packageDepsList classDeps classDepsList classList messageList packageListIndex packageDepsIndex classDepsIndex classListIndex messageListIndex autoSelectString windowTitle'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !DependencyBrowser commentStamp: 'pre 11/29/2021 11:48' prior: 0!
- A simple dependency browser showing five panes:
- [1]: Packages: The list of available packages in the system.
- [2]: Package Dependencies: The packages the currently selected package depends on.
- [3]: Class Dependencies: The classes the currently selected package [1] depends on (filtered by the selected required package [2]).
- [4]: Class List: The classes in the currently selected package [1] containing the references to the class dependencies [3].
- [5]: Messages: The messages in the currently selected package [1] and class [4] that contain the references to the class dependencies [3].
-
- # Implementation
- The dependencies are pre-computed whenever the selected package changes [1], see #computePackageAndClassDependencies.!
Item was removed:
- ----- Method: DependencyBrowser class>>initialize (in category 'class initialization') -----
- initialize
- "Initializes the receiver class"
-
- TheWorldMenu registerOpenCommand: {'Dependency Browser'. {self. #open}}. !
Item was removed:
- ----- Method: DependencyBrowser class>>open (in category 'opening') -----
- open
- "DependencyBrowser open"
- ^ToolBuilder open: self!
Item was removed:
- ----- Method: DependencyBrowser class>>openInvertedOn: (in category 'opening') -----
- openInvertedOn: requiredPackageNames
- "DependencyBrowser openInvertedOn: #(Monticello)"
-
- | model |
- model := self new.
- ^ ToolBuilder open: (
- model
- packageList: (Cursor wait showWhile: [
- model packageList select: [:packageName |
- model computePackageAndClassDependencies: packageName.
- model packageDeps includesAnyOf: requiredPackageNames]]);
- windowTitle: ('Dependency Browser (inverted on {1})' translated format: {requiredPackageNames});
- yourself)
- !
Item was removed:
- ----- Method: DependencyBrowser class>>openInvertedOnPackage: (in category 'opening') -----
- openInvertedOnPackage: aPackageInfo
- "DependencyBrowser openInvertedOnPackage: Morph packageInfo"
-
- ^ self openInvertedOn: {aPackageInfo name}!
Item was removed:
- ----- Method: DependencyBrowser class>>openOn: (in category 'opening') -----
- openOn: packageNames
- "DependencyBrowser openOn: #(Morphic EToys)"
-
- ^ ToolBuilder open: (self new
- packageList: packageNames;
- windowTitle: 'Dependency Browser (on selected packages)' translated;
- yourself)!
Item was removed:
- ----- Method: DependencyBrowser class>>openOnPackage: (in category 'opening') -----
- openOnPackage: aPackageInfo
- "DependencyBrowser openOnPackage: Morph packageInfo"
-
- ^ ToolBuilder open: (self new
- selectPackage: aPackageInfo name;
- yourself)!
Item was removed:
- ----- Method: DependencyBrowser>>aboutToStyle: (in category 'contents') -----
- aboutToStyle: aStyler
- "This is a notification that aStyler is about to re-style its text.
- Set the classOrMetaClass in aStyler, so that identifiers
- will be resolved correctly.
- Answer true to allow styling to proceed, or false to veto the styling"
- | selectedClass |
- selectedClass := self classListSelection ifNil:[^false].
- self messageListSelection ifNil:[^false].
- self isModeStyleable ifFalse: [^ false].
- aStyler classOrMetaClass: ((self messageListSelection == #Definition) ifFalse:[Smalltalk classNamed: selectedClass]).
- ^true!
Item was removed:
- ----- Method: DependencyBrowser>>autoSelectString (in category 'accessing') -----
- autoSelectString
- ^ autoSelectString!
Item was removed:
- ----- Method: DependencyBrowser>>autoSelectString: (in category 'accessing') -----
- autoSelectString: aString
- autoSelectString := aString.
- self changed: #contentsSelection.!
Item was removed:
- ----- Method: DependencyBrowser>>buildClassDepsWith: (in category 'toolbuilder') -----
- buildClassDepsWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #classDepsList;
- help: 'Required classes' translated;
- list: #classDepsList;
- getIndex: #classDepsIndex;
- setIndex: #classDepsIndex:;
- menu: #classDepsMenu:;
- keyPress: #classDepsKey:from:.
- ^listSpec
- !
Item was removed:
- ----- Method: DependencyBrowser>>buildClassListWith: (in category 'toolbuilder') -----
- buildClassListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #classList;
- help: 'Client classes' translated;
- list: #classList;
- getIndex: #classListIndex;
- setIndex: #classListIndex:;
- menu: #classListMenu:;
- keyPress: #classListKey:from:.
- ^listSpec
- !
Item was removed:
- ----- Method: DependencyBrowser>>buildMessageListWith: (in category 'toolbuilder') -----
- buildMessageListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #messageList;
- help: 'Client methods' translated;
- list: #messageList;
- getIndex: #messageListIndex;
- setIndex: #messageListIndex:;
- menu: #messageListMenu:;
- keyPress: #messageListKey:from:.
- ^listSpec!
Item was removed:
- ----- Method: DependencyBrowser>>buildPackageDepsWith: (in category 'toolbuilder') -----
- buildPackageDepsWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #packageDepsList;
- help: 'Required Packages' translated;
- list: #packageDepsList;
- getIndex: #packageDepsIndex;
- setIndex: #packageDepsIndex:;
- menu: #packageDepsMenu:;
- keyPress: #packageDepsKey:from:.
- ^listSpec
- !
Item was removed:
- ----- Method: DependencyBrowser>>buildPackageListWith: (in category 'toolbuilder') -----
- buildPackageListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #packageList;
- help: 'Packages' translated;
- list: #packageList;
- getIndex: #packageListIndex;
- setIndex: #packageListIndex:;
- menu: #packageListMenu:;
- keyPress: #packageListKey:from:.
- ^listSpec
- !
Item was removed:
- ----- Method: DependencyBrowser>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- "Create the ui for the browser"
- | windowSpec max |
- max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5].
- windowSpec := self buildWindowWith: builder specs: {
- (0@0 corner: 0.2@max) -> [self buildPackageListWith: builder].
- (0.2@0 corner: 0.4@max) -> [self buildPackageDepsWith: builder].
- (0.4@0 corner: 0.6@max) -> [self buildClassDepsWith: builder].
- (0.6@0 corner: 0.8@max) -> [self buildClassListWith: builder].
- (0.8@0 corner: 1.0@max) -> [self buildMessageListWith: builder].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
- ^builder build: windowSpec!
Item was removed:
- ----- Method: DependencyBrowser>>classDeps (in category 'class dependencies') -----
- classDeps
- "Class dependencies for the currently selected package"
- packageDeps ifNil: [^ #()].
- ^ (packageDeps at: self packageDepsSelection ifAbsent:[#()]) sort.
- !
Item was removed:
- ----- Method: DependencyBrowser>>classDepsIndex (in category 'class dependencies') -----
- classDepsIndex
- "Class dependency selection"
- ^classDepsIndex ifNil:[0]!
Item was removed:
- ----- Method: DependencyBrowser>>classDepsIndex: (in category 'class dependencies') -----
- classDepsIndex: idx
- "Class dependency selection"
- classDepsIndex := idx.
- self changed: #classDepsIndex.
- classList := nil.
- self changed: #classList.
- self classListIndex: (idx = 0 ifTrue: [0] ifFalse: [1]).!
Item was removed:
- ----- Method: DependencyBrowser>>classDepsKey:from: (in category 'class dependencies') -----
- classDepsKey: aCharacter from: aPluggableListMorphPlus
- aCharacter = $N ifTrue: [^ self referencesToIt: (self classDeps at: self classDepsIndex)].!
Item was removed:
- ----- Method: DependencyBrowser>>classDepsList (in category 'class dependencies') -----
- classDepsList
- "Class dependencies for the currently selected package"
-
- | checkDef checkExt |
- checkDef := [:mref | mref selector = #Definition].
- checkExt := [:mref | mref category notNil and: [mref category first = $*]].
-
- ^ classDepsList ifNil: [
- classDepsList := self classDeps.
- classDepsList := classDepsList collect: [:className |
- String streamContents: [:label |
- label nextPutAll: className.
- (self depsForClassNamed: className allSatisfy: checkDef)
- ifTrue: [label nextPutAll: ' (defs only)' translated]
- ifFalse: [(self depsForClassNamed: className allSatisfy: checkExt)
- ifTrue: [label nextPutAll: ' *exts only' translated]
- ifFalse: [
- (self depsForClassNamed: className anySatisfy: checkDef)
- ifTrue: [label nextPutAll: ' ()'].
- (self depsForClassNamed: className anySatisfy: checkExt)
- ifTrue: [label nextPutAll: ' *']]]]]]!
Item was removed:
- ----- Method: DependencyBrowser>>classDepsMenu: (in category 'class dependencies') -----
- classDepsMenu: aMenu
- ^aMenu!
Item was removed:
- ----- Method: DependencyBrowser>>classDepsSelection (in category 'class dependencies') -----
- classDepsSelection
- "Class dependency selection"
- ^(self classDepsIndex between: 1 and: self classDeps size)
- ifTrue:[self classDeps at: self classDepsIndex].!
Item was removed:
- ----- Method: DependencyBrowser>>classList (in category 'class list') -----
- classList
- "List of classes that refer to dependencies"
- | selectedPackage |
- classDeps ifNil: [^ #()].
- self classDepsSelection ifNil: [^ #()].
-
- selectedPackage := PackageOrganizer default
- packageNamed: self packageListSelection ifAbsent: [nil].
-
- classList := (classDeps at: self classDepsSelection ifAbsent: [#()])
- collect: [:mref |
- mref selector = #Definition
- ifTrue: [mref actualClass name, ' (class definition)' translated]
- ifFalse: [mref category first = $*
- ifTrue: ['*extensions' translated]
- ifFalse: [mref actualClass name]]]
- as: Set.
-
- ^ classList := classList asArray sort!
Item was removed:
- ----- Method: DependencyBrowser>>classListIndex (in category 'class list') -----
- classListIndex
- "Class list selection"
- ^classListIndex ifNil:[0]!
Item was removed:
- ----- Method: DependencyBrowser>>classListIndex: (in category 'class list') -----
- classListIndex: idx
- "Class list selection"
- classListIndex := idx.
- self changed: #classListIndex.
- self changed: #messageList.
- self messageListIndex: (idx = 0 ifTrue: [0] ifFalse: [1]).
- !
Item was removed:
- ----- Method: DependencyBrowser>>classListMenu: (in category 'class list') -----
- classListMenu: aMenu
- ^aMenu!
Item was removed:
- ----- Method: DependencyBrowser>>classListSelection (in category 'class list') -----
- classListSelection
- "Class list selection"
- ^ self selectedClassOrMetaClass name!
Item was removed:
- ----- Method: DependencyBrowser>>computeClassDependenciesFor: (in category 'private - dependencies') -----
- computeClassDependenciesFor: packageInfo
-
- packageInfo classes do: [:pkgClass |
- "Add the superclass and SharedPools as dependencies."
- (classDeps at: (pkgClass superclass ifNil: [ProtoObject]) name
- ifAbsentPut: [OrderedCollection new]) add:
- (MethodReference class: pkgClass selector: #Definition).
- pkgClass sharedPools do: [:sharedPool |
- sharedPool isBehavior ifTrue: [
- (classDeps at: sharedPool name
- ifAbsentPut: [OrderedCollection new]) add:
- (MethodReference class: pkgClass selector: #Definition)]]].
-
- packageInfo coreMethods do: [:mref |
- mref compiledMethod allLiteralsDo: [:lit |
- (lit isVariableBinding and: [lit value isBehavior]) ifTrue: [
- (classDeps at: lit value name ifAbsentPut: [OrderedCollection new])
- add: mref]]].
-
- packageInfo extensionMethods do: [:mref |
- (classDeps at: mref actualClass name ifAbsentPut: [OrderedCollection new])
- add: mref].
- !
Item was removed:
- ----- Method: DependencyBrowser>>computePackageAndClassDependencies: (in category 'private - dependencies') -----
- computePackageAndClassDependencies: pkgName
- "Compute the dependencies for the given package"
- | packageInfo |
- classDeps := Dictionary new.
- packageDeps := Dictionary new.
- pkgName ifNil: [^ self].
- packageInfo := PackageOrganizer default
- packageNamed: pkgName
- ifAbsent:["unloaded" ^ self].
-
- self
- computeClassDependenciesFor: packageInfo;
- computePackageDependencies.
-
- (packageDeps removeKey: pkgName ifAbsent: [#()]) do: [:each |
- classDeps removeKey: each ifAbsent: []].!
Item was removed:
- ----- Method: DependencyBrowser>>computePackageDependencies (in category 'private - dependencies') -----
- computePackageDependencies
-
- classDeps keys do:[:className| | aClass pkg |
- aClass := Smalltalk classNamed: className.
- pkg := aClass ifNil: [nil] ifNotNil: [PackageOrganizer default packageOfClass: aClass ifNone:[nil]].
- pkg
- ifNil:[
- Transcript cr; show: 'WARNING: No package for ', className.
- (classDeps removeKey: className) do:[:each| Transcript crtab; show: each]]
- ifNotNil:[
- (packageDeps at: pkg name ifAbsentPut:[OrderedCollection new]) add: className]].!
Item was removed:
- ----- Method: DependencyBrowser>>contents:notifying: (in category 'contents') -----
- 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 theMethodName |
- self changed: #annotation.
- aString := input asString.
- aText := input asText.
-
- theClass := self selectedClassOrMetaClass.
- theMethodName := self selectedMessageName.
- (theClass notNil and: [theMethodName notNil]) ifTrue: [
- ^ self okayToAccept
- ifFalse:
- [false]
- ifTrue:
- [self defineMessageFrom: aText notifying: aController]].
- self error: 'unacceptable accept' translated!
Item was removed:
- ----- Method: DependencyBrowser>>contentsSelection (in category 'accessing') -----
- contentsSelection
-
- ^ self autoSelectString
- ifNil: [super contentsSelection]
- ifNotNil: [:term | | index |
- (index := self contents asString findString: term) > 0
- ifTrue: [index to: index + term size - 1]
- ifFalse: [super contentsSelection]]!
Item was removed:
- ----- Method: DependencyBrowser>>defineMessageFrom:notifying: (in category 'contents') -----
- defineMessageFrom: aString notifying: aController
- "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise."
- | selectedMessageName selector category oldMessageList |
- selectedMessageName := self selectedMessageName.
- oldMessageList := self messageList.
- contents := nil.
- selector := (self selectedClassOrMetaClass newParser parseSelector: aString).
- selector := self selectedClassOrMetaClass
- compile: aString
- classified: (category := self selectedMessageCategoryName)
- notifying: aController.
- selector == nil ifTrue: [^ false].
- contents := aString copy.
- ^ true
- !
Item was removed:
- ----- Method: DependencyBrowser>>depsForClassNamed:allSatisfy: (in category 'enumerating') -----
- depsForClassNamed: className allSatisfy: workBlock
-
- self
- depsForClassNamed: className
- do: [:mref | (workBlock value: mref) ifFalse: [^ false]].
- ^ true!
Item was removed:
- ----- Method: DependencyBrowser>>depsForClassNamed:anySatisfy: (in category 'enumerating') -----
- depsForClassNamed: className anySatisfy: workBlock
-
- self
- depsForClassNamed: className
- do: [:mref | (workBlock value: mref) ifTrue: [^ true]].
- ^ false!
Item was removed:
- ----- Method: DependencyBrowser>>depsForClassNamed:do: (in category 'enumerating') -----
- depsForClassNamed: className do: workBlock
-
- classDeps ifNil: [^ self].
- (classDeps at: className ifAbsent: [^ self]) do: workBlock.!
Item was removed:
- ----- Method: DependencyBrowser>>depsForPackageNamed:allSatisfy: (in category 'enumerating') -----
- depsForPackageNamed: packageName allSatisfy: workBlock
-
- self
- depsForPackageNamed: packageName
- do: [:mref | (workBlock value: mref) ifFalse: [^ false]].
- ^ true!
Item was removed:
- ----- Method: DependencyBrowser>>depsForPackageNamed:anySatisfy: (in category 'enumerating') -----
- depsForPackageNamed: packageName anySatisfy: workBlock
-
- self
- depsForPackageNamed: packageName
- do: [:mref | (workBlock value: mref) ifTrue: [^ true]].
- ^ false!
Item was removed:
- ----- Method: DependencyBrowser>>depsForPackageNamed:do: (in category 'enumerating') -----
- depsForPackageNamed: packageName do: workBlock
-
- packageDeps ifNil: [^ self].
- (packageDeps at: packageName) do: [:className |
- self
- depsForClassNamed: className
- do: workBlock]!
Item was removed:
- ----- Method: DependencyBrowser>>hasPackageSelected (in category 'package list') -----
- hasPackageSelected
- ^ packageListIndex > 0.!
Item was removed:
- ----- Method: DependencyBrowser>>initialize (in category 'initialize-release') -----
- initialize
- super initialize.
- packageListIndex := 0.
- packageDepsIndex := 0.
- classDepsIndex := 0.
- classListIndex := 0.
- messageListIndex := 0.!
Item was removed:
- ----- Method: DependencyBrowser>>messageList (in category 'message list') -----
- messageList
- "List of messages creating dependencies"
- | selectedClass label filter |
- classDeps ifNil: [^ #()].
- classList ifNil: [^ #()].
-
- selectedClass := self classListSelection.
- label := classList at: classListIndex ifAbsent: [''].
-
- filter := label ifEmpty: [ [:mref | false] ] ifNotEmpty: [
- (label first = $* or: [(label endsWith: '(class definition)' translated) not])
- ifTrue: [ [:mref | mref selector ~= #Definition and: [mref actualClass name = selectedClass]] ]
- ifFalse: [ [:mref | mref selector = #Definition and: [mref actualClass name = selectedClass]] ]].
-
- ^((classDeps at: self classDepsSelection ifAbsent:[#()])
- select: filter
- thenCollect:[:mref| mref methodSymbol]) asSet asArray sort!
Item was removed:
- ----- Method: DependencyBrowser>>messageListIndex (in category 'message list') -----
- messageListIndex
- "Message list selection"
- ^messageListIndex ifNil:[0]!
Item was removed:
- ----- Method: DependencyBrowser>>messageListIndex: (in category 'message list') -----
- messageListIndex: idx
- "Message list selection"
- messageListIndex := idx.
- self changed: #messageListIndex.
- self changed: #contents.
- self changed: #annotation.
-
- self autoSelectString: self classDepsSelection.!
Item was removed:
- ----- Method: DependencyBrowser>>messageListMenu: (in category 'message list') -----
- messageListMenu: aMenu
- ^aMenu!
Item was removed:
- ----- Method: DependencyBrowser>>messageListSelection (in category 'message list') -----
- messageListSelection
- "Message list selection"
- ^(self messageListIndex between: 1 and: self messageList size)
- ifTrue:[self messageList at: self messageListIndex]!
Item was removed:
- ----- Method: DependencyBrowser>>packageDeps (in category 'package dependencies') -----
- packageDeps
- "Package dependencies for the currently selected package"
- packageDeps ifNil:[
- packageDeps := Dictionary new.
- Cursor wait showWhile:[
- self computePackageAndClassDependencies: self packageListSelection.
- ].
- ].
- ^packageDeps keys sort!
Item was removed:
- ----- Method: DependencyBrowser>>packageDepsIndex (in category 'package dependencies') -----
- packageDepsIndex
- "Current package dependencies selection"
- ^packageDepsIndex ifNil:[0]!
Item was removed:
- ----- Method: DependencyBrowser>>packageDepsIndex: (in category 'package dependencies') -----
- packageDepsIndex: aNumber
- "Current package dependencies selection"
- packageDepsIndex := aNumber.
- self changed: #packageDepsIndex.
-
- classDepsList := nil.
- self changed: #classDepsList.
- self classDepsIndex: (aNumber = 0 ifTrue: [0] ifFalse: [1]).
- !
Item was removed:
- ----- Method: DependencyBrowser>>packageDepsList (in category 'package dependencies') -----
- packageDepsList
- "Package dependencies for the currently selected package"
-
- | checkDef checkExt |
- checkDef := [:mref | mref selector = #Definition].
- checkExt := [:mref | mref category notNil and: [mref category first = $*]].
-
- ^ packageDepsList ifNil: [
- packageDepsList := self packageDeps.
- packageDepsList := packageDepsList collect: [:packageName |
- String streamContents: [:label |
- label nextPutAll: packageName.
- (self depsForPackageNamed: packageName allSatisfy: checkDef)
- ifTrue: [label nextPutAll: ' (defs only)' translated]
- ifFalse: [(self depsForPackageNamed: packageName allSatisfy: checkExt)
- ifTrue: [label nextPutAll: ' *exts only' translated]
- ifFalse: [
- (self depsForPackageNamed: packageName anySatisfy: checkDef)
- ifTrue: [label nextPutAll: ' ()'].
- (self depsForPackageNamed: packageName anySatisfy: checkExt)
- ifTrue: [label nextPutAll: ' *']]]]]]!
Item was removed:
- ----- Method: DependencyBrowser>>packageDepsMenu: (in category 'package dependencies') -----
- packageDepsMenu: aMenu
- ^aMenu!
Item was removed:
- ----- Method: DependencyBrowser>>packageDepsSelection (in category 'package dependencies') -----
- packageDepsSelection
- "Current package dependencies selection"
- ^(self packageDepsIndex between: 1 and: self packageDeps size)
- ifTrue:[self packageDeps at: self packageDepsIndex]!
Item was removed:
- ----- Method: DependencyBrowser>>packageList (in category 'package list') -----
- packageList
- "The base list of packages in the system"
- ^packageList ifNil:[packageList := (PackageInfo allPackages collect: [ :each | each packageName]) sort]!
Item was removed:
- ----- Method: DependencyBrowser>>packageList: (in category 'package list') -----
- packageList: somePackageNames
-
- packageList := somePackageNames.
- self packageListIndex: 0.!
Item was removed:
- ----- Method: DependencyBrowser>>packageListIndex (in category 'package list') -----
- packageListIndex
- "Current package list selection"
- ^packageListIndex ifNil:[0]!
Item was removed:
- ----- Method: DependencyBrowser>>packageListIndex: (in category 'package list') -----
- packageListIndex: aNumber
- "Current package list selection"
- packageListIndex := aNumber.
- self changed: #packageListIndex.
- packageDeps := nil.
- packageDepsList := nil.
- self changed: #packageDepsList.
- self packageDepsIndex: (aNumber = 0 ifTrue: [0] ifFalse: [1]).
- !
Item was removed:
- ----- Method: DependencyBrowser>>packageListKey:from: (in category 'package list') -----
- packageListKey: aChar from: view
- aChar == $f ifTrue: [^ self findClass].
- ^ self classListKey: aChar from: view!
Item was removed:
- ----- Method: DependencyBrowser>>packageListMenu: (in category 'package list') -----
- packageListMenu: aMenu
- ^aMenu!
Item was removed:
- ----- Method: DependencyBrowser>>packageListSelection (in category 'package list') -----
- packageListSelection
- "Current package list selection"
- ^(self packageListIndex between: 1 and: self packageList size)
- ifTrue:[self packageList at: self packageListIndex]!
Item was removed:
- ----- Method: DependencyBrowser>>referencesToIt: (in category 'accessing') -----
- referencesToIt: aClassName
- | binding environment |
- environment := self selectedEnvironment.
- binding := (environment bindingOf: aClassName) ifNil: [ ^ self ].
- self systemNavigation browseAllCallsOn: binding!
Item was removed:
- ----- Method: DependencyBrowser>>representsSameBrowseeAs: (in category 'morphic ui') -----
- representsSameBrowseeAs: anotherModel
- ^ self hasUnacceptedEdits not!
Item was removed:
- ----- Method: DependencyBrowser>>selectPackage: (in category 'class list') -----
- selectPackage: packageName
-
- self packageListIndex: (self packageList indexOf: packageName).!
Item was removed:
- ----- Method: DependencyBrowser>>selectedClass (in category 'class list') -----
- selectedClass
- "Answer the class that is currently selected. Answer nil if no selection exists."
-
- ^ self selectedClassOrMetaClass
- !
Item was removed:
- ----- Method: DependencyBrowser>>selectedClassName (in category 'class list') -----
- selectedClassName
- | idx |
- idx := classListIndex ifNil: [0].
- ^ (classList ifNotNil: [ :l | l at: idx ifAbsent: [nil]])
- ifNotNil: [:label |
- label first = $*
- ifTrue: [nil "extension methods"]
- ifFalse: [(label endsWith: '(class definition)' translated)
- ifTrue: [label findTokens first]
- ifFalse: [label "e.g., 'String' or 'String class'"]]]!
Item was removed:
- ----- Method: DependencyBrowser>>selectedClassOrMetaClass (in category 'class list') -----
- selectedClassOrMetaClass
- "Answer the class or metaclass that is currently selected. Answer nil if no selection
- exists."
- classList ifNil: [^nil].
- ^ (self selectedEnvironment classNamed: (self selectedClassName ifNil: ['']))
- ifNil: [classListIndex > 0 ifFalse: [nil] ifTrue: [
- "Use the class the current selection is depending on such as for method extensions or (base) class definitions."
- self selectedEnvironment classNamed: (self classDepsSelection ifNil: [''])]]!
Item was removed:
- ----- Method: DependencyBrowser>>selectedEnvironment (in category 'accessing') -----
- selectedEnvironment
- "Answer the name of the selected package or nil."
-
- self hasPackageSelected ifFalse: [^nil].
- ^ Smalltalk globals!
Item was removed:
- ----- Method: DependencyBrowser>>selectedMessage (in category 'contents') -----
- selectedMessage
- "Source code for currently selected message"
- | className methodName mref |
- className := self classListSelection.
- methodName := self messageListSelection.
- mref := (classDeps at: self classDepsSelection ifAbsent:[#()])
- detect:[:mr| mr actualClass name = className
- and:[mr methodSymbol = methodName]]
- ifNone:[nil].
- mref ifNil:[^ self class comment].
- mref methodSymbol == #Definition ifTrue:[^ mref actualClass definition].
- ^mref sourceCode!
Item was removed:
- ----- Method: DependencyBrowser>>selectedMessageName (in category 'message list') -----
- selectedMessageName
- ^ self messageList at: messageListIndex ifAbsent: [nil]!
Item was removed:
- ----- Method: DependencyBrowser>>selectedPackage (in category 'package list') -----
- selectedPackage
-
- ^ self environment packageOrganizer
- packageNamed: self selectedPackageName
- ifAbsent: [nil]!
Item was removed:
- ----- Method: DependencyBrowser>>selectedPackageName (in category 'package list') -----
- selectedPackageName
-
- ^ self hasPackageSelected
- ifFalse: [nil]
- ifTrue: [self packageList at: packageListIndex]!
Item was removed:
- ----- Method: DependencyBrowser>>windowTitle (in category 'accessing') -----
- windowTitle
-
- ^ windowTitle ifNil: ['Dependency Browser']!
Item was removed:
- ----- Method: DependencyBrowser>>windowTitle: (in category 'accessing') -----
- windowTitle: aString
-
- windowTitle := aString.
- self changed: #windowTitle.!
Item was removed:
- ----- Method: Dictionary>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
- "Answer the class of the inspector to be used on the receiver. Called by inspect;
- use basicInspect to get a normal (less useful) type of inspector."
-
- ^ DictionaryInspector!
Item was removed:
- CollectionInspector subclass: #DictionaryInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !DictionaryInspector commentStamp: 'ct 1/12/2020 15:26' prior: 0!
- I am an Inspector that is specialized for inspecting Dictionarys.!
Item was removed:
- ----- Method: DictionaryInspector>>addElement (in category 'menu - commands') -----
- addElement
-
- self addElement: (self requestKeyOrCancel: [^ self]).!
Item was removed:
- ----- Method: DictionaryInspector>>addElement: (in category 'menu - commands') -----
- addElement: aKey
-
- self object at: aKey put: nil.
- self updateFields.
-
- self selectKey: aKey.
- self hasSelection ifFalse: [self inform: ('The new key {1} was added.\\Yet, the list of fields is quite long. The new field\got truncated and is thus not visible.' translated withCRs format: {aKey printString})].!
Item was removed:
- ----- Method: DictionaryInspector>>addFieldItemsTo: (in category 'menu - construction') -----
- addFieldItemsTo: aMenu
-
- super addFieldItemsTo: aMenu.
-
- self typeOfSelection = #element ifFalse: [^ self].
-
- aMenu addLine.
-
- self selectedKey isSymbol ifTrue: [
- aMenu addTranslatedList: #(
- ('senders of this key' sendersOfSelectedKey))].
-
- aMenu addTranslatedList: #(
- ('inspect key' inspectKey)
- ('rename key' renameKey)).
-
- self isBindingSelected ifTrue: [
- aMenu addTranslatedList: #(
- -
- ('references to binding' usersOfSelectedBinding 'Browse all users of this binding.'))].!
Item was removed:
- ----- Method: DictionaryInspector>>canAddOrRemoveElements (in category 'private') -----
- canAddOrRemoveElements
- "Due to a strange reason, #add: is supported in Dictionary but #remove:ifAbsent: is not."
-
- ^ true!
Item was removed:
- ----- Method: DictionaryInspector>>elementIndices (in category 'private') -----
- elementIndices
-
- ^ [ self object keysInOrder ] ifError: [
- "Can occur when debugging Dictionary new"
- Array empty]!
Item was removed:
- ----- Method: DictionaryInspector>>inspectKey (in category 'menu - commands') -----
- inspectKey
- "Create and schedule an Inspector on the receiver's model's currently selected key."
-
- self assertElementSelectedOr: [^ self].
- self selectedKey inspect.!
Item was removed:
- ----- Method: DictionaryInspector>>isBindingSelected (in category 'bindings') -----
- isBindingSelected
- "Whether the currently selection association is a binding to a class or global."
-
- ^ self selectedKey ifNil: [false] ifNotNil: [:key |
- (self object associationAt: key) isVariableBinding]!
Item was removed:
- ----- Method: DictionaryInspector>>removeSelectedElement (in category 'menu - commands') -----
- removeSelectedElement
-
- self object removeKey: self selectedKey.!
Item was removed:
- ----- Method: DictionaryInspector>>renameKey (in category 'menu - commands') -----
- renameKey
-
- self assertElementSelectedOr: [^ self changed: #flash].
- self renameKey: (
- self
- requestKeyInitialAnswer: self selectedKey storeString
- orCancel: [^ self]).!
Item was removed:
- ----- Method: DictionaryInspector>>renameKey: (in category 'menu - commands') -----
- renameKey: aKey
-
- self assertElementSelectedOr: [^ self changed: #flash].
-
- (self object includesKey: aKey)
- ifTrue: [(self confirm: 'The target key exists. Do you want to replace it?' translated)
- ifFalse: [^ self]].
-
- self object
- at: aKey put: self selection;
- removeKey: self selectedKey.
- self updateFields.
-
- self selectKey: aKey.
- self hasSelection ifFalse: [self inform: ('The selected key was renamed to {1}.\\Yet, the list of fields is quite long. The new field\got truncated and is thus not visible.' translated withCRs format: {aKey printString})].!
Item was removed:
- ----- Method: DictionaryInspector>>requestKeyInitialAnswer:orCancel: (in category 'ui requests') -----
- requestKeyInitialAnswer: anAnswerString orCancel: aBlock
-
- ^ self
- requestObject: ('Enter an expression for the new key\such as #tree, ''apple'', and 3+4.' translated withCRs)
- initialAnswer: anAnswerString
- orCancel: aBlock!
Item was removed:
- ----- Method: DictionaryInspector>>requestKeyOrCancel: (in category 'ui requests') -----
- requestKeyOrCancel: aBlock
-
- ^ self
- requestKeyInitialAnswer: String empty
- orCancel: aBlock!
Item was removed:
- ----- Method: DictionaryInspector>>selectKey: (in category 'selection') -----
- selectKey: aKey
- "Overriden to make clear that a dictionary's indices are called 'keys'."
-
- self selectElementAt: aKey.!
Item was removed:
- ----- Method: DictionaryInspector>>selectedBinding (in category 'bindings') -----
- selectedBinding
-
- ^ self selectedKey
- ifNotNil: [:key | self object associationAt: key]!
Item was removed:
- ----- Method: DictionaryInspector>>selectedKey (in category 'selection') -----
- selectedKey
- "Overriden to make clear that a dictionary's indices are called 'keys'."
-
- ^ self selectedElementIndex!
Item was removed:
- ----- Method: DictionaryInspector>>sendersOfSelectedKey (in category 'menu - commands') -----
- sendersOfSelectedKey
- "Create a browser on all senders of the selected key"
-
- | aKey |
- ((aKey := self selectedKey) isSymbol)
- ifFalse: [^ self changed: #flash].
- self systemNavigation browseAllCallsOn: aKey!
Item was removed:
- ----- Method: DictionaryInspector>>usersOfSelectedBinding (in category 'menu - commands') -----
- usersOfSelectedBinding
- "Create a browser on all references to the association of the current selection."
-
- self selectedBinding ifNotNil: [:binding |
- self systemNavigation browseAllCallsOn: binding].!
Item was removed:
- Model subclass: #DualChangeSorter
- instanceVariableNames: 'leftCngSorter rightCngSorter'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Changes'!
-
- !DualChangeSorter commentStamp: '<historical>' prior: 0!
- This class presents a view of a two change sets at once, and supports copying changes between change sets.
- !
Item was removed:
- ----- Method: DualChangeSorter class>>open (in category 'opening') -----
- open
- "Open a new instance of the receiver's class"
-
- self new open!
Item was removed:
- ----- Method: DualChangeSorter class>>prototypicalToolWindow (in category 'opening') -----
- prototypicalToolWindow
- "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
-
- ^ ToolBuilder build: self new!
Item was removed:
- ----- Method: DualChangeSorter class>>registerInFlapsRegistry (in category 'class initialization') -----
- registerInFlapsRegistry
- "Register the receiver in the system's flaps registry"
- self environment
- at: #Flaps
- ifPresent: [:cl | cl registerQuad: {#DualChangeSorter, #prototypicalToolWindow. 'Change Sorter' translatedNoop. 'Shows two change sets side by side' translatedNoop}
- forFlapNamed: 'Tools']!
Item was removed:
- ----- Method: DualChangeSorter class>>unload (in category 'class initialization') -----
- unload
- "Unload the receiver from global registries"
-
- self environment at: #Flaps ifPresent: [:cl |
- cl unregisterQuadsWithReceiver: self] !
Item was removed:
- ----- Method: DualChangeSorter>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- | windowSpec window |
- leftCngSorter := ChangeSorter new myChangeSet: ChangeSet current.
- leftCngSorter parent: self.
- rightCngSorter := ChangeSorter new myChangeSet:
- ChangeSet secondaryChangeSet.
- rightCngSorter parent: self.
-
- windowSpec := self buildWindowWith: builder.
- leftCngSorter buildWith: builder in: windowSpec rect: (0@0 extent: 0.5@1).
- rightCngSorter buildWith: builder in: windowSpec rect: (0.5@0 extent: 0.5@1).
- window := builder build: windowSpec.
- leftCngSorter addDependent: window. "so it will get changed: #relabel"
- rightCngSorter addDependent: window. "so it will get changed: #relabel"
- ^window!
Item was removed:
- ----- Method: DualChangeSorter>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.719 g: 0.9 b: 0.9)!
Item was removed:
- ----- Method: DualChangeSorter>>isLeftSide: (in category 'other') -----
- isLeftSide: theOne
- "Which side am I?"
- ^ theOne == leftCngSorter!
Item was removed:
- ----- Method: DualChangeSorter>>labelString (in category 'other') -----
- labelString
-
- ^ 'Changes go to "{1}"' translated format: {ChangeSet current name}!
Item was removed:
- ----- Method: DualChangeSorter>>modelWakeUp (in category 'other') -----
- modelWakeUp
- "A window with me as model is being entered. Make sure I am up-to-date with the changeSets."
-
- "Dumb way"
- leftCngSorter canDiscardEdits
- ifTrue: [leftCngSorter update] "does both"
- ifFalse: [rightCngSorter update].
- !
Item was removed:
- ----- Method: DualChangeSorter>>okToChange (in category 'initialization') -----
- okToChange
- ^ leftCngSorter okToChange & rightCngSorter okToChange!
Item was removed:
- ----- Method: DualChangeSorter>>open (in category 'initialization') -----
- open
- ^ToolBuilder open: self!
Item was removed:
- ----- Method: DualChangeSorter>>other: (in category 'other') -----
- other: theOne
- "Return the other side's ChangeSorter"
- ^ theOne == leftCngSorter
- ifTrue: [rightCngSorter]
- ifFalse: [leftCngSorter]!
Item was removed:
- ----- Method: DualChangeSorter>>release (in category 'initialization') -----
- release
- leftCngSorter release.
- rightCngSorter release.!
Item was removed:
- SelectionMenu subclass: #EmphasizedMenu
- instanceVariableNames: 'emphases'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Menus'!
-
- !EmphasizedMenu commentStamp: '<historical>' prior: 0!
- A selection menu in which individual selections are allowed to have different emphases. Emphases allowed are: bold, italic, struckThrough, and plain. Provide an emphasis array, with one element per selection, to use. Refer to the class method #example.!
Item was removed:
- ----- Method: EmphasizedMenu class>>example1 (in category 'examples') -----
- example1
- "EmphasizedMenu example1"
-
- ^ (self
- selections: #('how' 'well' 'does' 'this' 'work?' )
- emphases: #(#bold #normal #italic #struckOut #normal ))
- startUpWithCaption: 'A Menu with Emphases'!
Item was removed:
- ----- Method: EmphasizedMenu class>>example2 (in category 'examples') -----
- example2
- "EmphasizedMenu example2"
-
- | aMenu |
- aMenu := EmphasizedMenu selections: #('One' 'Two' 'Three' 'Four').
- aMenu onlyBoldItem: 3.
- ^ aMenu startUpWithCaption: 'Only the Bold'!
Item was removed:
- ----- Method: EmphasizedMenu class>>example3 (in category 'examples') -----
- example3
- "EmphasizedMenu example3"
-
- ^ (self
- selectionAndEmphasisPairs: #('how' #bold 'well' #normal 'does' #italic 'this' #struckOut 'work' #normal))
- startUpWithCaption: 'A Menu with Emphases'!
Item was removed:
- ----- Method: EmphasizedMenu class>>selectionAndEmphasisPairs: (in category 'instance creation') -----
- selectionAndEmphasisPairs: interleavedList
- "An alternative form of call. "
- | selList emphList |
- selList := OrderedCollection new.
- emphList := OrderedCollection new.
- interleavedList pairsDo:
- [:aSel :anEmph |
- selList add: aSel.
- emphList add: anEmph].
- ^ self selections:selList emphases: emphList!
Item was removed:
- ----- Method: EmphasizedMenu class>>selections:emphases: (in category 'instance creation') -----
- selections: selList emphases: emphList
- "Answer an instance of the receiver with the given selections and
- emphases."
-
- ^ (self selections: selList) emphases: emphList
-
- "Example:
- (EmphasizedMenu
- selections: #('how' 'well' 'does' 'this' 'work?')
- emphases: #(bold plain italic struckOut plain)) startUp"!
Item was removed:
- ----- Method: EmphasizedMenu>>emphases: (in category 'emphasis') -----
- emphases: emphasisArray
- emphases := emphasisArray!
Item was removed:
- ----- Method: EmphasizedMenu>>onlyBoldItem: (in category 'emphasis') -----
- onlyBoldItem: itemNumber
- "Set up emphasis such that all items are plain except for the given item number. "
-
- emphases := (Array new: selections size) atAllPut: #normal.
- emphases at: itemNumber put: #bold!
Item was removed:
- ----- Method: EmphasizedMenu>>setEmphasis (in category 'private') -----
- setEmphasis
- "Set up the receiver to reflect the emphases in the emphases array. "
-
- | selStart selEnd currEmphasis |
-
- labelString := labelString asText.
- emphases isEmptyOrNil ifTrue: [^ self].
- selStart := 1.
- 1 to: selections size do:
- [:line |
- selEnd := selStart + (selections at: line) size - 1.
- ((currEmphasis := emphases at: line) size > 0 and: [currEmphasis ~~ #normal]) ifTrue:
- [labelString addAttribute: (TextEmphasis perform: currEmphasis)
- from: selStart to: selEnd].
- selStart := selEnd + 2]!
Item was removed:
- ----- Method: EmphasizedMenu>>startUpWithCaption: (in category 'display') -----
- startUpWithCaption: captionOrNil
- self setEmphasis.
- ^ super startUpWithCaption: captionOrNil!
Item was removed:
- ----- Method: EncodedCharSet class>>browseAllCodePoints (in category '*Tools-Browsing') -----
- browseAllCodePoints
- "
- JISX0208 browseAllCodePoints.
- GB2312 browseAllCodePoints.
- KSX1001 browseAllCodePoints.
- "
-
- self browseAllCodePointsUsing: TextStyle defaultFont.!
Item was removed:
- ----- Method: EncodedCharSet class>>browseAllCodePointsUsing: (in category '*Tools-Browsing') -----
- browseAllCodePointsUsing: aFont
- "Apply the receivers encoding to browse the result using glyphs of aFont (and its #fallbackFont).
-
- (Locale isoLanguage: 'ja') languageEnvironment installFont. --- Fetch StrikeFont from metatoys.org; see #fontDownloadUrls
- JISX0208 browseAllCodePointsUsing: (TextConstants at: #FontJapaneseEnvironment) last. --- Largest point size
- ...
- JISX0208 browseAllCodePointsUsing: (TTFontFileHandle fromFontFileName: 'C:\Windows\Fonts\msgothic.ttc') first font.
- GB2312 browseAllCodePointsUsing: (TTFontFileHandle fromFontFileName: 'C:\Windows\Fonts\msyh.ttc') first font.
- KSX1001 browseAllCodePointsUsing: (TTFontFileHandle fromFontFileName: 'C:\Windows\Fonts\batang.ttc') first font.
- "
-
- aFont
- browseGlyphsOf: (Array streamContents: [:s | | last |
- self ucsTable do: [:ea |
- (ea = -1 and: [last ~= -1] and: [s position > 0])
- ifTrue: [s cr; cr] ifFalse: [ea ~= -1 ifTrue: [s nextPut: ea]].
- last := ea]])
- label: self name, ' encoding'.!
Item was removed:
- ----- Method: Environment>>browse (in category '*Tools-Browsing') -----
- browse
-
- ^ ToolSet browseEnvironment: self!
Item was removed:
- ----- Method: Exception class>>toolIcon (in category '*Tools-icons') -----
- toolIcon
-
- ^ #exception!
Item was removed:
- FileList2 subclass: #FileChooser
- instanceVariableNames: 'view caption captionMorph captionBox cancelButton okButton buttonPane captionPane directoryPane filePane showShortFileNames'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-FileList'!
-
- !FileChooser commentStamp: 'miki 8/15/2005 12:07' prior: 0!
- This class provides a simple "modal" dialog box to choose a file, with a directory tree, a file list, and open and cancel buttons. It is meant to be an improvement of FileList2 modalFileSelector.
-
- An applictaion can customize the user interface in a straightforward way. Creation of the file choser is done in several steps by calling various helper methods..
-
- The order of the method calls when creating a customized file chooser are important. The UI must be created before methods that change the attributes of the UI can be called. You can either start by creating the default UI, and them modify the morphs in the file chooser (there are methods to access the buttons and the panes).
-
- You can also build a completely custom UI, by writing your own methods for creating the layout etc. One way to do this is to subclass FileChooser and override the methods you want to change, andother way is to supply your own morphic view to the file chooser. This must be an instance of MorphicModel or a subclass of it, because the file chooser uses the model functionality.
-
- There are two varieties of the UI, one that is supposed to be like a dialog box (uses colors from the menu preferences in class Preference), and one is using a system window. The way a system window works turns out to be somehat different from how a plain Morphic Model works, and this is why there are separate methods for creating the dialog box UI and the system window UI.
-
- On the class side, there are examples that shows differents ways to use this class.
-
- On the to do list is adding support for a file save dialog box, with a directory tree and a text input field for typing a file name.
-
- (Mikael Kindborg, 050815)
- !
Item was removed:
- ----- Method: FileChooser class>>example1 (in category 'examples') -----
- example1
- "Open file chooser with the standard dialog box UI."
- "FileChooser example1"
- | fc stream |
- fc := FileChooser new.
- fc initializeAsDialogBox.
- stream := fc open.
- stream inspect.!
Item was removed:
- ----- Method: FileChooser class>>example2 (in category 'examples') -----
- example2
- "Open file chooser with a system window UI."
- "FileChooser example2"
- | fc stream |
- fc := FileChooser new.
- fc initializeAsSystemWindow.
- stream := fc open.
- stream inspect.!
Item was removed:
- ----- Method: FileChooser class>>example3 (in category 'examples') -----
- example3
- "Open file chooser with a system window UI that has a caption pane and shows only picture files."
- "FileChooser example3"
- | fc stream |
- fc := FileChooser new.
- fc initializeAsSystemWindowWithCaptionPane.
- fc setCaption: 'Select a picture file' translated.
- fc setSuffixes: {'png' . 'gif' . 'bmp' . 'jpg' . 'jpeg' }.
- stream := fc open.
- stream ifNotNil: [(Form fromBinaryStream: stream) asMorph openInHand].!
Item was removed:
- ----- Method: FileChooser class>>example4 (in category 'examples') -----
- example4
- "Open file chooser with a customized dialog box UI. The order of the messages is important. In general, call the initialize method first, then modify things, and finally call open."
- "FileChooser example4"
- | fc stream |
- fc := FileChooser new.
- fc initializeAsDialogBox.
- fc setDirectory: FileDirectory root.
- fc setSuffixes: {'png' . 'gif' . 'bmp' . 'jpg' . 'jpeg' }.
- fc setCaption: 'Select a picture file' translated.
- fc morphicView
- borderColor: Color black;
- borderWidth: 2;
- color: Color white.
- fc setPaneColor: Color gray muchLighter.
- fc captionPane color: Color orange muchLighter.
- fc okButton color: Color green muchLighter.
- fc cancelButton color: Color blue muchLighter.
- fc morphicView position: 20@20.
- stream := fc open.
- stream ifNotNil: [(Form fromBinaryStream: stream) asMorph openInHand].!
Item was removed:
- ----- Method: FileChooser class>>new (in category 'instance creation') -----
- new
- "Superclass may attempt to initialize to a specific default directory. Bypass
- that behavior."
-
- ^ self basicNew initialize!
Item was removed:
- ----- Method: FileChooser>>addFullPanesTo:from: (in category 'ui creation') -----
- addFullPanesTo: aMorph from: aCollection
- aCollection do: [ :each |
- | frame |
- frame := LayoutFrame
- fractions: each second
- offsets: each third.
- aMorph addMorph: each first fullFrame: frame.
- ]!
Item was removed:
- ----- Method: FileChooser>>buttonPane (in category 'accessing') -----
- buttonPane
- ^buttonPane!
Item was removed:
- ----- Method: FileChooser>>cancelButton (in category 'accessing') -----
- cancelButton
- ^cancelButton!
Item was removed:
- ----- Method: FileChooser>>caption (in category 'accessing') -----
- caption
- ^caption!
Item was removed:
- ----- Method: FileChooser>>captionPane (in category 'accessing') -----
- captionPane
- ^captionPane!
Item was removed:
- ----- Method: FileChooser>>centerMorphicView (in category 'ui creation') -----
- centerMorphicView
- self morphicView
- fullBounds;
- position: Display extent - self morphicView extent // 2.
- !
Item was removed:
- ----- Method: FileChooser>>createCancelButton (in category 'ui creation') -----
- createCancelButton
- cancelButton := SimpleButtonMorph new.
- cancelButton
- label: 'Cancel' translated;
- color: Color transparent;
- borderColor: Color black;
- borderWidth: 1.
- cancelButton
- on: #mouseUp
- send: #cancelHit
- to: self.
- ^cancelButton
- !
Item was removed:
- ----- Method: FileChooser>>createDialogBoxButtonPane (in category 'ui creation') -----
- createDialogBoxButtonPane
- "Create buttons suitable for a MorphicModel file chooser."
-
- buttonPane := AlignmentMorph new.
- buttonPane
- layoutPolicy: ProportionalLayout new;
- color: Color transparent;
- borderWidth: 0.
- self createOkButton.
- self createCancelButton.
- buttonPane addMorph: self cancelButton
- fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 0.49 @ 1.0)
- offsets: (0 @ 0 corner: 0 @ 0)).
- buttonPane addMorph: self okButton
- fullFrame: (LayoutFrame fractions: (0.51 @ 0 corner: 1.0 @ 1.0)
- offsets: (0 @ 0 corner: 0 @ 0)).
- ^buttonPane!
Item was removed:
- ----- Method: FileChooser>>createDialogBoxCaptionPane (in category 'ui creation') -----
- createDialogBoxCaptionPane
- "Create a morph to hold the caption string. The caption is created in setCaption:"
-
- | icon frame |
- captionPane := AlignmentMorph new.
- captionPane
- color: Color transparent;
- layoutPolicy: ProportionalLayout new.
-
- "You can change the caption later by calling setCaption:"
- self setCaption: 'Please select a file' translated.
- self setCaptionFont: Preferences windowTitleFont.
- icon := SketchMorph new.
- icon form: MenuIcons openIcon.
- captionPane addMorph: icon.
- frame := LayoutFrame new.
- frame
- leftFraction: 0;
- topFraction: 0.5;
- leftOffset: icon form width // 2;
- topOffset: (icon form width // 2) negated.
- icon layoutFrame: frame.
- ^captionPane!
Item was removed:
- ----- Method: FileChooser>>createDialogBoxLayout (in category 'ui creation') -----
- createDialogBoxLayout
- "Create a layout suitable for a MorphicModel file chooser."
-
- | inset insetNeg captionTop captionBottom buttonsBottom buttonsTop contentTop contentBottom |
-
- inset := 6.
- insetNeg := inset negated.
- captionTop := 0.
- captionBottom := 33.
- contentTop := captionBottom + inset.
- contentBottom := -30 - inset - inset.
- buttonsTop := contentBottom + inset.
- buttonsBottom := insetNeg.
-
- self addFullPanesTo: self morphicView
- from: {
- {
- (self captionPane).
- (0 @ 0 corner: 1 @ 0).
- (0 @ captionTop corner: 0 @ captionBottom)
- }.
- {
- (self buttonPane).
- (0 @ 1 corner: 1 @ 1).
- (inset @ buttonsTop corner: insetNeg @ buttonsBottom)
- }.
- {
- (self directoryPane).
- (0 @ 0 corner: 0.5 @ 1).
- (inset @ contentTop corner: insetNeg @ contentBottom)
- }.
- {
- (self filePane).
- (0.5 @ 0 corner: 1 @ 1).
- (inset @ contentTop corner: insetNeg @ contentBottom)
- }
- }!
Item was removed:
- ----- Method: FileChooser>>createDialogBoxMorphicView (in category 'ui creation') -----
- createDialogBoxMorphicView
- | m |
- m := MorphicModel new
- layoutPolicy: ProportionalLayout new;
- color: (Color r: 0.9 g: 0.9 b: 0.9);
- borderColor: Color gray;
- borderWidth: 1;
- layoutInset: 0;
- extent: 600@400.
- self setMorphicView: m.
- ^m!
Item was removed:
- ----- Method: FileChooser>>createDialogBoxUI (in category 'ui creation') -----
- createDialogBoxUI
- "This method creates UI components and a layout that are suitable for a MorphicModel. Also centers the morphic view in the world. Note that the order of the method calls are important if you modify this."
-
- self
- createDialogBoxMorphicView;
- createDialogBoxCaptionPane;
- createDialogBoxButtonPane;
- createDirectoryPane;
- createFilePane;
- createDialogBoxLayout;
- centerMorphicView.
- ^self morphicView!
Item was removed:
- ----- Method: FileChooser>>createDirectoryPane (in category 'ui creation') -----
- createDirectoryPane
- directoryPane := self morphicDirectoryTreePane.
- directoryPane borderWidth: 0.
- ^directoryPane!
Item was removed:
- ----- Method: FileChooser>>createFilePane (in category 'ui creation') -----
- createFilePane
- filePane := self morphicFileListPane.
- filePane borderWidth: 0.
- ^filePane!
Item was removed:
- ----- Method: FileChooser>>createOkButton (in category 'ui creation') -----
- createOkButton
- okButton := SimpleButtonMorph new.
- okButton
- label: 'Open' translated;
- color: Color transparent;
- borderColor: Color black;
- borderWidth: 1.
- okButton
- on: #mouseUp
- send: #okHit
- to: self.
- ^okButton!
Item was removed:
- ----- Method: FileChooser>>createSystemWindowButtonPane (in category 'ui creation') -----
- createSystemWindowButtonPane
- "Create buttons suitable for a SystemWindow file chooser."
-
- self optionalButtonSpecs: self okayAndCancelServices.
- buttonPane := self optionalButtonRow.
- okButton := buttonPane firstSubmorph.
- cancelButton := buttonPane firstSubmorph.
- ^buttonPane!
Item was removed:
- ----- Method: FileChooser>>createSystemWindowCaptionPane (in category 'ui creation') -----
- createSystemWindowCaptionPane
- "Create a morph to hold the caption string. The caption is created in setCaption:"
-
- captionPane := AlignmentMorph new.
- captionPane
- color: Color transparent;
- layoutPolicy: ProportionalLayout new.
- "You can change the caption later by calling setCaption:"
- self setCaption: 'Please select a file' translated.
- ^captionPane!
Item was removed:
- ----- Method: FileChooser>>createSystemWindowLayout (in category 'ui creation') -----
- createSystemWindowLayout
- "Create a layout suitable for a SystemWindow file chooser."
-
- | buttonsHeight |
-
- buttonsHeight := 33.
-
- self addFullPanesTo: self morphicView
- from: {
- {
- (self buttonPane).
- (0 @ 0 corner: 1 @ 0).
- (0 @ 0 corner: 0 @ buttonsHeight)
- }.
- {
- (self directoryPane).
- (0 @ 0 corner: 0.5 @ 1).
- (0 @ buttonsHeight corner: 0 @ 0)
- }.
- {
- (self filePane).
- (0.5 @ 0 corner: 1 @ 1).
- (0 @ buttonsHeight corner: 0 @ 0)
- }
- }!
Item was removed:
- ----- Method: FileChooser>>createSystemWindowLayoutWithCaptionPane (in category 'ui creation') -----
- createSystemWindowLayoutWithCaptionPane
-
- | buttonsHeight captionHeight |
-
- buttonsHeight := 33.
- captionHeight := 28.
-
- self addFullPanesTo: self morphicView
- from: {
- {
- (self captionPane).
- (0 @ 0 corner: 1 @ 0).
- (0 @ 0 corner: 0 @ captionHeight)
- }.
- {
- (self buttonPane).
- (0 @ 0 corner: 1 @ 0).
- (0 @ captionHeight corner: 0 @ (captionHeight + buttonsHeight))
- }.
- {
- (self directoryPane).
- (0 @ 0 corner: 0.5 @ 1).
- (0 @ (captionHeight + buttonsHeight) corner: 0 @ 0)
- }.
- {
- (self filePane).
- (0.5 @ 0 corner: 1 @ 1).
- (0 @ (captionHeight + buttonsHeight) corner: 0 @ 0)
- }
- }!
Item was removed:
- ----- Method: FileChooser>>createSystemWindowMorphicView (in category 'ui creation') -----
- createSystemWindowMorphicView
- | m |
- m := SystemWindow labelled: 'Please select a file' translated. "self directory pathName."
- "m deleteCloseBox."
- self setMorphicView: m.!
Item was removed:
- ----- Method: FileChooser>>createSystemWindowUI (in category 'ui creation') -----
- createSystemWindowUI
- "This method creates UI components and a layout that are suitable for a SystemWindow. Note that the order of the method calls are important."
-
- self
- createSystemWindowMorphicView;
- createSystemWindowButtonPane;
- createDirectoryPane;
- createFilePane;
- createSystemWindowLayout.
- ^self morphicView!
Item was removed:
- ----- Method: FileChooser>>createSystemWindowUIWithCaptionPane (in category 'ui creation') -----
- createSystemWindowUIWithCaptionPane
- self
- createSystemWindowMorphicView;
- createSystemWindowCaptionPane;
- createSystemWindowButtonPane;
- createDirectoryPane;
- createFilePane;
- createSystemWindowLayoutWithCaptionPane.
- ^self morphicView!
Item was removed:
- ----- Method: FileChooser>>directory (in category 'accessing') -----
- directory
- ^super directory!
Item was removed:
- ----- Method: FileChooser>>directoryPane (in category 'accessing') -----
- directoryPane
- ^directoryPane!
Item was removed:
- ----- Method: FileChooser>>fileNameFormattedFrom:sizePad: (in category 'updating') -----
- fileNameFormattedFrom: entry sizePad: sizePad
- "If the short file list flag is false, we send this on to the superclass."
-
- | nameStr |
- showShortFileNames
- ifFalse: [^super fileNameFormattedFrom: entry sizePad: sizePad].
-
- "Otherwise, just show the name of the file in the file list."
- nameStr := (entry isDirectory)
- ifTrue: [entry name, self folderString]
- ifFalse: [entry name].
- ^nameStr!
Item was removed:
- ----- Method: FileChooser>>filePane (in category 'accessing') -----
- filePane
- ^filePane!
Item was removed:
- ----- Method: FileChooser>>initializeAsDialogBox (in category 'initialization') -----
- initializeAsDialogBox
- self initializeBasicParameters.
- self createDialogBoxUI.
- self morphicView
- useRoundedCorners;
- color: (Color r: 0.9 g: 0.9 b: 0.9);
- adoptPaneColor: (Color r: 0.6 g: 0.7 b: 1).
- self
- setCaptionColor: Color transparent;
- setButtonColor: (Color r: 0.9 g: 0.9 b: 0.9).
- !
Item was removed:
- ----- Method: FileChooser>>initializeAsSystemWindow (in category 'initialization') -----
- initializeAsSystemWindow
- self initializeBasicParameters.
- self createSystemWindowUI.!
Item was removed:
- ----- Method: FileChooser>>initializeAsSystemWindowWithCaptionPane (in category 'initialization') -----
- initializeAsSystemWindowWithCaptionPane
- self initializeBasicParameters.
- self createSystemWindowUIWithCaptionPane.!
Item was removed:
- ----- Method: FileChooser>>initializeBasicParameters (in category 'initialization') -----
- initializeBasicParameters
- self showShortFileNames: true.
- self setDirectory: FileDirectory default.!
Item was removed:
- ----- Method: FileChooser>>morphicView (in category 'accessing') -----
- morphicView
- ^view!
Item was removed:
- ----- Method: FileChooser>>okButton (in category 'accessing') -----
- okButton
- ^okButton!
Item was removed:
- ----- Method: FileChooser>>open (in category 'open') -----
- open
- | model |
- self postOpen. "Funny name in this context, should be renamed, but whatever..."
- self morphicView openInWorld.
- UserInterfaceTheme current applyTo: self morphicView allMorphs.
- model := self morphicView model.
- FileChooser modalLoopOn: self morphicView.
- ^ model getSelectedFile.
- !
Item was removed:
- ----- Method: FileChooser>>setButtonColor: (in category 'ui creation') -----
- setButtonColor: aColor
- self okButton color: aColor.
- self cancelButton color: aColor.
- !
Item was removed:
- ----- Method: FileChooser>>setCaption: (in category 'ui creation') -----
- setCaption: aString
- | frame |
- caption ifNil:
- [caption := StringMorph new.
- self captionPane addMorph: caption].
- caption contents: aString.
- frame := LayoutFrame new.
- frame
- leftFraction: 0.5;
- topFraction: 0.5;
- leftOffset: caption width negated // 2;
- topOffset: caption height negated // 2.
- caption layoutFrame: frame!
Item was removed:
- ----- Method: FileChooser>>setCaptionColor: (in category 'ui creation') -----
- setCaptionColor: aColor
- self captionPane color: aColor!
Item was removed:
- ----- Method: FileChooser>>setCaptionFont: (in category 'ui creation') -----
- setCaptionFont: aFont
- self caption font: aFont.
- self setCaption: self caption contents asString.
-
- !
Item was removed:
- ----- Method: FileChooser>>setDirectory: (in category 'initialization') -----
- setDirectory: aDir
- ^super directory: aDir!
Item was removed:
- ----- Method: FileChooser>>setMorphicView: (in category 'initialization') -----
- setMorphicView: aMorphicModel
- view := aMorphicModel.
- self modalView: view.
- view model: self.!
Item was removed:
- ----- Method: FileChooser>>setPaneColor: (in category 'ui creation') -----
- setPaneColor: aColor
- self morphicView
- color: aColor;
- adoptPaneColor: aColor.
-
- !
Item was removed:
- ----- Method: FileChooser>>setSuffixes: (in category 'initialization') -----
- setSuffixes: aList
- self fileSelectionBlock: [:entry :myPattern |
- entry isDirectory
- ifTrue:
- [false]
- ifFalse:
- [aList includes: (FileDirectory extensionFor: entry name asLowercase)]]!
Item was removed:
- ----- Method: FileChooser>>showShortFileNames: (in category 'initialization') -----
- showShortFileNames: aBoolean
- showShortFileNames := aBoolean!
Item was removed:
- ----- Method: FileChooser>>updateButtonRow (in category 'updating') -----
- updateButtonRow
- "Prevent updating of the the button row."!
Item was removed:
- Browser subclass: #FileContentsBrowser
- instanceVariableNames: 'packages infoString'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-File Contents Browser'!
-
- !FileContentsBrowser commentStamp: '<historical>' prior: 0!
- I am a class browser view on a fileout (either a source file (.st) or change set (.cs)). I do not actually load the code into to the system, nor do I alter the classes in the image. Use me to vet code in a comfortable way before loading it into your image.
-
- From a FileList, I can be invoked by selecting a source file and selecting the "browse code" menu item from the yellow button menu.
-
- I use PseudoClass, PseudoClassOrganizers, and PseudoMetaclass to model the class structure of the source file.!
Item was removed:
- ----- Method: FileContentsBrowser class>>browseCompressedCodeStream: (in category 'instance creation') -----
- browseCompressedCodeStream: aStandardFileStream
- "Browse the selected file in fileIn format."
- | unzipped |
- unzipped := [MultiByteBinaryOrTextStream
- with: (GZipReadStream on: aStandardFileStream) contents asString]
- ensure: [aStandardFileStream close].
- unzipped reset.
- self browseStream: unzipped named: aStandardFileStream name!
Item was removed:
- ----- Method: FileContentsBrowser class>>browseFile: (in category 'instance creation') -----
- browseFile: aFilename
- "Open a file contents browser on a file of the given name"
-
- aFilename ifNil: [^ Beeper beep].
- self browseFiles: (Array with: aFilename)!
Item was removed:
- ----- Method: FileContentsBrowser class>>browseFiles: (in category 'instance creation') -----
- browseFiles: fileList
- "Open a browser on the packages found within the files in the list; we expect the list to contain acceptable filename strings.
- If there is more than one package found the browser will be a full system browser, otherwise it will be a category browser"
- ^ (self createBrowserForPackagesFrom: fileList withEach: [:fileName |
- FilePackage fromFileNamed: fileName]) buildAndOpenBrowser
- !
Item was removed:
- ----- Method: FileContentsBrowser class>>browseStream: (in category 'instance creation') -----
- browseStream: aStream
-
- aStream setConverterForCode.
- ^ self browseStream: aStream named: aStream name!
Item was removed:
- ----- Method: FileContentsBrowser class>>browseStream:named: (in category 'instance creation') -----
- browseStream: aStream named: aString
- "Read an already opened file stream into a browser"
- ^ (self createBrowserForStream: aStream named: aString) buildAndOpenBrowser
- !
Item was removed:
- ----- Method: FileContentsBrowser class>>createBrowserForPackagesFrom:withEach: (in category 'private') -----
- createBrowserForPackagesFrom: collectionOfPackageSources withEach: filePackageCreation
-
- | browser packageDict organizer |
- Cursor wait showWhile: [
- browser := self new.
- packageDict := Dictionary new.
- organizer := SystemOrganizer defaultList: Array new.
-
- collectionOfPackageSources do: [:src | | package |
- package := filePackageCreation value: src.
- packageDict
- at: package packageName
- put: package.
- organizer
- classifyAll: package classes keys
- under: package packageName].
-
- (browser := self systemOrganizer: organizer)
- packages: packageDict].
- ^ browser!
Item was removed:
- ----- Method: FileContentsBrowser class>>createBrowserForStream:named: (in category 'private') -----
- createBrowserForStream: aStream named: aString
-
- ^ self createBrowserForPackagesFrom: {aStream} withEach: [:stream |
- (FilePackage new fullName: aString; fileInFrom: aStream)]!
Item was removed:
- ----- Method: FileContentsBrowser class>>fileReaderServicesForDirectory: (in category 'file list services') -----
- fileReaderServicesForDirectory: aDirectory
- ^{ self serviceBrowseCodeFiles }!
Item was removed:
- ----- Method: FileContentsBrowser class>>fileReaderServicesForFile:suffix: (in category 'file list services') -----
- fileReaderServicesForFile: fullName suffix: suffix
-
- ((FileStream isSourceFileSuffix: suffix) or: [ suffix = '*' ])
- ifTrue: [ ^Array with: self serviceBrowseCode].
-
- ^(fullName endsWith: 'cs.gz')
- ifTrue: [ Array with: self serviceBrowseCompressedCode ]
- ifFalse: [#()]
- !
Item was removed:
- ----- Method: FileContentsBrowser class>>initialize (in category 'class initialization') -----
- initialize
-
- FileServices registerFileReader: self!
Item was removed:
- ----- Method: FileContentsBrowser class>>selectAndBrowseFile: (in category 'file list services') -----
- selectAndBrowseFile: aFileList
- "When no file are selected you can ask to browse several of them"
-
- | selectionPattern files |
- selectionPattern := UIManager default request:'What files?' initialAnswer: '*.cs;*.st'.
- files := (aFileList directory fileNamesMatching: selectionPattern)
- collect: [:each | aFileList directory fullNameFor: each].
- self browseFiles: files.
-
-
- !
Item was removed:
- ----- Method: FileContentsBrowser class>>serviceBrowseCode (in category 'file list services') -----
- serviceBrowseCode
- "Answer the service of opening a file-contents browser"
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'code-file browser' translatedNoop
- selector: #browseStream:
- description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' translatedNoop
- buttonLabel: 'code' translatedNoop)
- argumentGetter: [ :fileList | fileList readOnlyStream ]!
Item was removed:
- ----- Method: FileContentsBrowser class>>serviceBrowseCodeFiles (in category 'file list services') -----
- serviceBrowseCodeFiles
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'browse code files' translatedNoop
- selector: #selectAndBrowseFile:)
- argumentGetter: [ :fileList | fileList ];
- yourself!
Item was removed:
- ----- Method: FileContentsBrowser class>>serviceBrowseCompressedCode (in category 'file list services') -----
- serviceBrowseCompressedCode
- "Answer a service for opening a changelist browser on a file"
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'code-file browser' translatedNoop
- selector: #browseCompressedCodeStream:
- description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' translatedNoop
- buttonLabel: 'code' translatedNoop)
- argumentGetter: [ :fileList | fileList readOnlyStream ]!
Item was removed:
- ----- Method: FileContentsBrowser class>>services (in category 'file list services') -----
- services
- "Answer potential file services associated with this class"
-
- ^ {self serviceBrowseCode}.!
Item was removed:
- ----- Method: FileContentsBrowser class>>showMessageIcons (in category 'preferences') -----
- showMessageIcons
- "Remove this method once PseudoClass implements the methods of the class API required to show the icons."
-
- ^false!
Item was removed:
- ----- Method: FileContentsBrowser class>>unload (in category 'class initialization') -----
- unload
-
- FileServices unregisterFileReader: self !
Item was removed:
- ----- Method: FileContentsBrowser>>aboutToStyle: (in category 'edit pane') -----
- aboutToStyle: aStyler
- "This is a notification that aStyler is about to re-style its text.
- Set the classOrMetaClass in aStyler, so that identifiers
- will be resolved correctly.
- Answer true to allow styling to proceed, or false to veto the styling"
-
- self isModeStyleable ifFalse: [^false].
- aStyler classOrMetaClass: self selectedClassOrMetaClass.
- ^true!
Item was removed:
- ----- Method: FileContentsBrowser>>browseMessages (in category 'other') -----
- browseMessages
- "Open a message set browser of all implementors of the currently selected message"
-
- self systemNavigation browseAllImplementorsOf: (self selectedMessageName ifNil: [ ^nil ])!
Item was removed:
- ----- Method: FileContentsBrowser>>browseMethodFull (in category 'class list') -----
- browseMethodFull
- | myClass |
- (myClass := self selectedClassOrMetaClass) ifNotNil:
- [ToolSet browse: myClass realClass selector: self selectedMessageName]!
Item was removed:
- ----- Method: FileContentsBrowser>>browseSenders (in category 'other') -----
- browseSenders
- "Create and schedule a message set browser on all senders of the
- currently selected message selector. Do nothing if no message is selected."
-
- self hasMessageSelected
- ifTrue: [self systemNavigation browseAllCallsOn: self selectedMessageName]!
Item was removed:
- ----- Method: FileContentsBrowser>>browseSendersOfMessages (in category 'other') -----
- browseSendersOfMessages
- "delegate to plain browseSenders since we can't (easily) find all the enst messages within the not-real method"
-
- ^self browseSenders!
Item was removed:
- ----- Method: FileContentsBrowser>>browseVersions (in category 'other') -----
- browseVersions
- "Create and schedule a message set browser on all versions of the
- currently selected message selector."
- | class selector |
- (selector := self selectedMessageName) ifNotNil:
- [class := self selectedClassOrMetaClass.
- (class exists and: [class realClass includesSelector: selector]) ifTrue:
- [VersionsBrowser
- browseVersionsOf: (class realClass compiledMethodAt: selector)
- class: class realClass theNonMetaClass
- meta: class realClass isMeta
- category: self selectedMessageCategoryName
- selector: selector]]!
Item was removed:
- ----- Method: FileContentsBrowser>>buildAndOpenBrowser (in category 'toolbuilder') -----
- buildAndOpenBrowser
- "assemble the spec for a file contents browser, build it and open it"
- "The browser may have either the full 4-pane layout or the simpler 3-pane version, depending on whether we have 1 or more packages to look at"
-
- contentsSymbol := self defaultDiffsSymbol. "#showDiffs or #prettyDiffs"
-
- ^ self packages size = 1
- ifTrue:[
- self systemCategoryListIndex: 1.
- self buildAndOpenCategoryBrowser]
- ifFalse: [self buildAndOpenFullBrowser]!
Item was removed:
- ----- Method: FileContentsBrowser>>buildAnnotationPaneWith: (in category 'toolbuilder') -----
- buildAnnotationPaneWith: builder
-
- | textSpec |
- textSpec := builder pluggableInputFieldSpec new.
- textSpec
- model: self;
- getText: #infoViewContents.
- ^textSpec!
Item was removed:
- ----- Method: FileContentsBrowser>>buildSystemCatListSingletonWith: (in category 'toolbuilder') -----
- buildSystemCatListSingletonWith: aToolBuilder
- "Overwritten to change callbacks for menu and keyboard interaction."
- ^ aToolBuilder pluggableInputFieldSpec new
- model: self ;
- getText: #selectedSystemCategoryName ;
- setText: nil ;
- " keyPress: #systemCatSingletonKey:from: ;
- " menu: #packageListMenu:shifted:;
- " keyPress: #packageListKey:from:;
- " yourself!
Item was removed:
- ----- Method: FileContentsBrowser>>buildSystemCategoryListWith: (in category 'toolbuilder') -----
- buildSystemCategoryListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #systemCategoryList;
- getIndex: #systemCategoryListIndex;
- setIndex: #systemCategoryListIndex:;
- menu: #packageListMenu:shifted:;
- keyPress: #packageListKey:from:.
- ^listSpec!
Item was removed:
- ----- Method: FileContentsBrowser>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- "Depending upon whether we have a single package or multiple packages, we use different window specs. "
-
- self packages ifNil:[^self error: self class name, ' cannot be built without any packages; see class instance creation methods' ].
- ^ self packages size = 1
- ifTrue:[
- self systemCategoryListIndex: 1;
- buildCategoryBrowserWith: builder]
- ifFalse: [super buildWith: builder]!
Item was removed:
- ----- Method: FileContentsBrowser>>changeMessageCategories: (in category 'other') -----
- 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 editClass.
- self selectClassNamed: selectedClassName.
- ^ true!
Item was removed:
- ----- Method: FileContentsBrowser>>classList (in category 'class list') -----
- classList
- "Answer an array of the class names of the selected category. Answer an
- empty array if no selection exists."
-
- (self hasSystemCategorySelected not or:[self selectedPackage isNil])
- ifTrue: [^Array new]
- ifFalse: [^self selectedPackage classes keys asArray sort].!
Item was removed:
- ----- Method: FileContentsBrowser>>classListKey:from: (in category 'keys') -----
- classListKey: aChar from: view
- aChar == $b ifTrue: [^ self browseMethodFull].
- aChar == $N ifTrue: [^ self browseClassRefs].
- self packageListKey: aChar from: view!
Item was removed:
- ----- Method: FileContentsBrowser>>classListMenu:shifted: (in category 'menus') -----
- classListMenu: aMenu shifted: aBool
-
- ^ self menu: aMenu for: #(fileClassListMenu fileClassListMenuShifted:) shifted: aBool
- !
Item was removed:
- ----- Method: FileContentsBrowser>>contents (in category 'accessing') -----
- contents
- self updateInfoView.
- (editSelection == #newClass and:[self selectedPackage notNil])
- ifTrue: [^self selectedPackage packageInfo].
- editSelection == #editClass
- ifTrue:[^self modifiedClassDefinition].
- ^super contents!
Item was removed:
- ----- Method: FileContentsBrowser>>contents:notifying: (in category 'accessing') -----
- 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 |
- aString := input asString.
- aText := input asText.
-
- editSelection == #editComment
- ifTrue: [theClass := self selectedClass.
- theClass ifNil: [self inform: 'You must select a class
- before giving it a comment.'.
- ^ false].
- theClass comment: aText. ^ true].
- editSelection == #editMessageCategories
- ifTrue: [^ self changeMessageCategories: aString].
-
- self inform:'You cannot change the current selection'.
- ^false
- !
Item was removed:
- ----- Method: FileContentsBrowser>>contentsSymbolQuints (in category 'menus') -----
- contentsSymbolQuints
- "Answer a list of quintuplets representing information on the alternative views available in the code pane. For the file-contents browser, the choices are restricted to source and the two diffing options"
-
- ^ self sourceAndDiffsQuintsOnly!
Item was removed:
- ----- Method: FileContentsBrowser>>defaultBrowserTitle (in category 'toolbuilder') -----
- defaultBrowserTitle
- ^ 'File Contents Browser' !
Item was removed:
- ----- Method: FileContentsBrowser>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.7 g: 0.7 b: 0.508)!
Item was removed:
- ----- Method: FileContentsBrowser>>didCodeChangeElsewhere (in category 'other') -----
- didCodeChangeElsewhere
- "Determine whether the code for the currently selected method and class has been changed somewhere else."
-
- | aClass |
- (aClass := self selectedClassOrMetaClass) ifNil: [^ false].
-
- (aClass isKindOf: PseudoClass) ifTrue: [^ false]. "class not installed"
- ^super didCodeChangeElsewhere!
Item was removed:
- ----- Method: FileContentsBrowser>>extraInfo (in category 'infoView') -----
- extraInfo
- ^ (self
- methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName)
- class: self selectedClass
- selector: self selectedMessageName
- meta: self metaClassIndicated) unembellished
- ifTrue: [' - identical']
- ifFalse: [' - modified']!
Item was removed:
- ----- Method: FileContentsBrowser>>fileClassListMenu: (in category 'menus') -----
- fileClassListMenu: aMenu
- "Answer the class list menu, ignoring the state of the shift key in this case"
- <fileClassListMenu>
- aMenu addList: #(
- ('definition' editClass)
- ('comment' editComment)
- -
- ('browse full (b)' browseMethodFull)
- ('class refs (N)' browseClassRefs)
- -
- ('fileIn' fileInClass)
- ('fileOut' fileOutClass)
- -
- ('rename...' renameClass)
- ('remove' removeClass)
- ('remove existing' removeUnmodifiedCategories)).
- ^ aMenu
- !
Item was removed:
- ----- Method: FileContentsBrowser>>fileInClass (in category 'fileIn/fileOut') -----
- fileInClass
- Cursor read showWhile:[
- self selectedClass fileIn.
- ].!
Item was removed:
- ----- Method: FileContentsBrowser>>fileInMessage (in category 'fileIn/fileOut') -----
- fileInMessage
-
- self selectedMessageName ifNil: [^self].
- Cursor read showWhile: [
- self selectedClassOrMetaClass fileInMethod: self selectedMessageName.
- ].!
Item was removed:
- ----- Method: FileContentsBrowser>>fileInMessageCategories (in category 'fileIn/fileOut') -----
- fileInMessageCategories
- Cursor read showWhile:[
- self selectedClassOrMetaClass fileInCategory: self selectedMessageCategoryName.
- ].!
Item was removed:
- ----- Method: FileContentsBrowser>>fileInPackage (in category 'fileIn/fileOut') -----
- fileInPackage
- Cursor read showWhile:[
- self selectedPackage fileIn.
- ].!
Item was removed:
- ----- Method: FileContentsBrowser>>fileIntoNewChangeSet (in category 'fileIn/fileOut') -----
- fileIntoNewChangeSet
- | p ff |
- (p := self selectedPackage) ifNil: [^ Beeper beep].
- ff := FileStream readOnlyFileNamed: p fullPackageName.
- ChangeSet newChangesFromStream: ff named: p packageName!
Item was removed:
- ----- Method: FileContentsBrowser>>fileMessageCategoryMenu: (in category 'menus') -----
- fileMessageCategoryMenu: aMenu
- <fileMessageCategoryMenu>
- ^ aMenu addList: #(
- ('file in' fileInMessageCategories)
- ('file out' fileOutMessageCategories)
- -
- ('reorganize' editMessageCategories)
- -
- ('add item...' addCategory)
- ('rename...' renameCategory)
- ('remove' removeMessageCategory)
- -
- ('remove existing' removeUnmodifiedMethods));
- yourself
- !
Item was removed:
- ----- Method: FileContentsBrowser>>fileMessageListMenu: (in category 'menus') -----
- fileMessageListMenu: aMenu
- <fileMessageListMenu>
- aMenu addList: #(
- ('fileIn' fileInMessage)
- ('fileOut' fileOutMessage)
- -
- ('senders (n)' browseSenders)
- ('implementors (m)' browseImplementors)
- ('method inheritance (h)' methodHierarchy)
- ('versions (v)' browseVersions)
- -
- ('remove' removeMessage)).
- ^ aMenu
- !
Item was removed:
- ----- Method: FileContentsBrowser>>fileOutClass (in category 'fileIn/fileOut') -----
- fileOutClass
- Cursor write showWhile:[
- self selectedClass fileOut.
- ].!
Item was removed:
- ----- Method: FileContentsBrowser>>fileOutMessageCategories (in category 'fileIn/fileOut') -----
- fileOutMessageCategories
- Cursor write showWhile:[
- self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName.
- ].!
Item was removed:
- ----- Method: FileContentsBrowser>>fileOutPackage (in category 'fileIn/fileOut') -----
- fileOutPackage
- Cursor write showWhile:[
- self selectedPackage fileOut.
- ].!
Item was removed:
- ----- Method: FileContentsBrowser>>filePackageListMenu: (in category 'menus') -----
- filePackageListMenu: aMenu
- <filePackageListMenu>
- ^ aMenu addList: #(
- ('find class... (f)' findClass)
- -
- ('file in' fileInPackage)
- ('file into new changeset' fileIntoNewChangeSet)
- ('file out' fileOutPackage)
- -
- ('remove' removePackage)
- -
- ('remove existing' removeUnmodifiedClasses));
- yourself
- !
Item was removed:
- ----- Method: FileContentsBrowser>>findClass (in category 'class list') -----
- findClass
- | pattern foundClass classNames index foundPackage |
- self okToChange ifFalse: [^ self classNotFound].
- pattern := (UIManager default request: 'Class Name?') asLowercase.
- pattern isEmpty ifTrue: [^ self].
- classNames := Set new.
- self packages do:[:p| classNames addAll: p classes keys].
- classNames := classNames asArray select:
- [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0].
- classNames isEmpty ifTrue: [^ self].
- index := classNames size = 1
- ifTrue: [1]
- ifFalse: [(UIManager default chooseFrom: classNames lines: #())].
- index = 0 ifTrue: [^ self].
- foundPackage := nil.
- foundClass := nil.
- self packages do:[:p|
- (p classes includesKey: (classNames at: index)) ifTrue:[
- foundClass := p classes at: (classNames at: index).
- foundPackage := p]].
- foundClass isNil ifTrue:[^self].
- self selectSystemCategory: foundPackage packageName asSymbol.
- self classListIndex: (self classList indexOf: foundClass name). !
Item was removed:
- ----- Method: FileContentsBrowser>>formattedLabel:forSelector:inClass: (in category 'message list') -----
- formattedLabel: aString forSelector: aSymbol inClass: aPseudoClass
- "We have no way get compiled methods for a pseudo class."
-
- ^ aString!
Item was removed:
- ----- Method: FileContentsBrowser>>hasClassSelected (in category 'class list') -----
- hasClassSelected
- ^ selectedClassName notNil !
Item was removed:
- ----- Method: FileContentsBrowser>>infoString (in category 'infoView') -----
- infoString
- ^infoString ifNil: [infoString := StringHolder new]!
Item was removed:
- ----- Method: FileContentsBrowser>>infoViewContents (in category 'infoView') -----
- infoViewContents
- "Answer the string to show in the info view"
-
- | theClass stamp exists |
- editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage].
- self selectedClass isNil ifTrue: [^ ''].
- theClass := Smalltalk at: self selectedClass name asSymbol ifAbsent: [].
- editSelection == #editClass ifTrue:
- [^ theClass notNil
- ifTrue: ['Class exists already in the system' translated]
- ifFalse: ['New class' translated]].
- editSelection == #editMessage ifFalse: [^ ''].
- (theClass notNil and: [self metaClassIndicated])
- ifTrue: [theClass := theClass class].
-
- stamp := self selectedClassOrMetaClass stampAt: self selectedMessageName.
- exists := theClass notNil and: [theClass includesSelector: self selectedMessageName].
- ^ stamp = 'methodWasRemoved'
- ifTrue:
- [exists
- ifTrue:
- ['Existing method removed by this change-set' translated]
- ifFalse:
- ['Removal request for a method that is not present in this image' translated]]
- ifFalse:
- [stamp, ' · ',
- (exists
- ifTrue: ['Method already exists' translated , self extraInfo]
- ifFalse: ['New method' translated])]!
Item was removed:
- ----- Method: FileContentsBrowser>>labelString (in category 'other') -----
- labelString
- "Answer the string for the window title"
-
- ^ 'File Contents Browser ', (self selectedSystemCategory ifNil: [''])!
Item was removed:
- ----- Method: FileContentsBrowser>>messageCategoryMenu: (in category 'menus') -----
- messageCategoryMenu: aMenu
- ^ self menu: aMenu for: #(fileMessageCategoryMenu fileMessageCategoryMenuShifted:)
- !
Item was removed:
- ----- Method: FileContentsBrowser>>messageListKey:from: (in category 'keys') -----
- messageListKey: aChar from: view
- aChar == $b ifTrue: [^ self browseMethodFull].
- super messageListKey: aChar from: view!
Item was removed:
- ----- Method: FileContentsBrowser>>messageListMenu:shifted: (in category 'menus') -----
- messageListMenu: aMenu shifted: aBool
-
- ^ self menu: aMenu for: #(fileMessageListMenu fileMessageListMenuShifted:) shifted: aBool
- !
Item was removed:
- ----- Method: FileContentsBrowser>>methodDiffFor:class:selector:meta: (in category 'diffs') -----
- methodDiffFor: aString class: aPseudoClass selector: selector meta: meta
- "Answer the diff between the current copy of the given class/selector/meta for the string provided"
-
- | theClass source |
- theClass := Smalltalk
- at: aPseudoClass name
- ifAbsent: [^ aString copy].
- meta
- ifTrue: [theClass := theClass class].
- (theClass includesSelector: selector)
- ifFalse: [^ aString copy].
- source := theClass sourceCodeAt: selector.
- ^ Cursor wait
- showWhile: [TextDiffBuilder buildDisplayPatchFrom: source to: aString inClass: theClass prettyDiffs: self showingPrettyDiffs]!
Item was removed:
- ----- Method: FileContentsBrowser>>methodHierarchy (in category 'other') -----
- methodHierarchy
- (self selectedClassOrMetaClass isNil or:
- [self selectedClassOrMetaClass hasDefinition])
- ifFalse: [super methodHierarchy]!
Item was removed:
- ----- Method: FileContentsBrowser>>modifiedClassDefinition (in category 'diffs') -----
- modifiedClassDefinition
- | pClass rClass old new diff |
- pClass := self selectedClassOrMetaClass.
- pClass hasDefinition ifFalse:[^pClass definition].
- rClass := Smalltalk at: self selectedClass name asSymbol ifAbsent:[nil].
- rClass isNil ifTrue:[^pClass definition].
- self metaClassIndicated ifTrue:[ rClass := rClass class].
- old := rClass definition.
- new := pClass definition.
- diff := Cursor wait showWhile:[
- ClassDiffBuilder buildDisplayPatchFrom: old to: new
- ].
- ^diff!
Item was removed:
- ----- Method: FileContentsBrowser>>packageInfo: (in category 'infoView') -----
- packageInfo: p
- | nClasses newClasses oldClasses |
- p isNil ifTrue:[^''].
- nClasses := newClasses := oldClasses := 0.
- p classes do:[:cls|
- nClasses := nClasses + 1.
- (Smalltalk hasClassNamed: cls name)
- ifTrue:[oldClasses := oldClasses + 1]
- ifFalse:[newClasses := newClasses + 1]].
- ^nClasses printString,' classes (', newClasses printString, ' new / ', oldClasses printString, ' modified)'!
Item was removed:
- ----- Method: FileContentsBrowser>>packageListKey:from: (in category 'keys') -----
- packageListKey: aChar from: view
- aChar == $f ifTrue: [^ self findClass].
- self arrowKey: aChar from: view!
Item was removed:
- ----- Method: FileContentsBrowser>>packageListMenu:shifted: (in category 'menus') -----
- packageListMenu: aMenu shifted: shifted
-
- ^ self menu: aMenu for: #(filePackageListMenu filePackageListMenuShifted:) shifted: shifted
- !
Item was removed:
- ----- Method: FileContentsBrowser>>packages (in category 'accessing') -----
- packages
- ^packages!
Item was removed:
- ----- Method: FileContentsBrowser>>packages: (in category 'accessing') -----
- packages: aDictionary
- packages := aDictionary.!
Item was removed:
- ----- Method: FileContentsBrowser>>removeMessage (in category 'removing') -----
- removeMessage
-
- self hasMessageSelected ifFalse: [^ false].
-
- super removeMessage ifFalse: [^ false].
- self selectMessageNamed: nil.
- self setClassOrganizer.
- "In case organization not cached"
- self changed: #messageList.!
Item was removed:
- ----- Method: FileContentsBrowser>>removeMessageCategory (in category 'removing') -----
- removeMessageCategory
- "If a message category is selected, create a Confirmer so the user can
- verify that the currently selected message category should be removed
- from the system. If so, remove it."
-
- | messageCategoryName |
- self hasMessageCategorySelected ifFalse: [^ self].
- self okToChange ifFalse: [^ self].
- messageCategoryName := self selectedMessageCategoryName.
- (self messageList size = 0
- or: [self confirm: 'Are you sure you want to
- remove this method category
- and all its methods?']) ifFalse: [^ self].
- self selectedClassOrMetaClass removeCategory: messageCategoryName.
- self messageCategoryListIndex: 0.
- self changed: #messageCategoryList.!
Item was removed:
- ----- Method: FileContentsBrowser>>removePackage (in category 'removing') -----
- removePackage
- self hasSystemCategorySelected ifTrue: [^ self].
- self okToChange ifFalse: [^ self].
- (self confirm: 'Are you sure you want to
- remove this package
- and all its classes?') ifFalse:[^self].
- (systemOrganizer listAtCategoryNamed: self selectedSystemCategory) do:[:el|
- systemOrganizer removeElement: el].
- self packages removeKey: self selectedPackage packageName.
- systemOrganizer removeCategory: self selectedSystemCategory.
- self selectSystemCategory: nil.
- self changed: #systemCategoryList!
Item was removed:
- ----- Method: FileContentsBrowser>>removeUnmodifiedCategories (in category 'removing') -----
- removeUnmodifiedCategories
- | theClass |
- self okToChange ifFalse: [^self].
- theClass := self selectedClass.
- theClass isNil ifTrue: [^self].
- Cursor wait showWhile:
- [theClass removeUnmodifiedMethods: theClass selectors.
- theClass metaClass removeUnmodifiedMethods: theClass metaClass selectors].
- self messageCategoryListIndex: 0.
- self changed: #messageCategoryList.!
Item was removed:
- ----- Method: FileContentsBrowser>>removeUnmodifiedClasses (in category 'removing') -----
- removeUnmodifiedClasses
- | packageList |
- self okToChange ifFalse:[^self].
- packageList := self selectedPackage
- ifNil: [ self packages]
- ifNotNil: [ Array with: self selectedPackage].
- packageList do:[:package|
- package classes copy do:[:theClass|
- Cursor wait showWhile:[
- theClass removeAllUnmodified.
- ].
- theClass hasChanges ifFalse:[
- package removeClass: theClass.
- ].
- ]].
- self classListIndex: 0.
- self changed: #classList!
Item was removed:
- ----- Method: FileContentsBrowser>>removeUnmodifiedMethods (in category 'removing') -----
- removeUnmodifiedMethods
- | theClass cat |
- self okToChange ifFalse:[^self].
- theClass := self selectedClassOrMetaClass.
- theClass ifNil: [ ^self].
- cat := self selectedMessageCategoryName.
- cat ifNil: [ ^self].
- Cursor wait showWhile:[
- theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat).
- ].
- self messageListIndex: 0.
- self changed: #messageList.!
Item was removed:
- ----- Method: FileContentsBrowser>>renameClass (in category 'class list') -----
- renameClass
- | oldName newName |
- self hasClassSelected ifFalse: [^ self].
- self okToChange ifFalse: [^ self].
- oldName := self selectedClass name.
- newName := (self request: 'Please type new class name'
- initialAnswer: oldName) asSymbol.
- (newName isEmpty or:[newName = oldName]) ifTrue: [^ self].
- (self selectedPackage classes includesKey: newName)
- ifTrue: [^ self error: newName , ' already exists in the package'].
- systemOrganizer classify: newName under: self selectedSystemCategory.
- systemOrganizer removeElement: oldName.
- self selectedPackage renameClass: self selectedClass to: newName.
- self changed: #classList.
- self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategory) indexOf: newName).
- !
Item was removed:
- ----- Method: FileContentsBrowser>>selectedBytecodes (in category 'edit pane') -----
- selectedBytecodes
- "Compile the source code for the selected message selector and extract and return
- the bytecode listing."
- | class selector |
- class := self selectedClassOrMetaClass.
- selector := self selectedMessageName.
- contents := class sourceCodeAt: selector.
- contents := Compiler new
- parse: contents
- in: class
- notifying: nil.
- contents := contents generate.
- ^ contents symbolic asText!
Item was removed:
- ----- Method: FileContentsBrowser>>selectedClass (in category 'class list') -----
- selectedClass
- "Answer the class that is currently selected. Answer nil if no selection
- exists."
-
- self selectedClassName == nil ifTrue: [^nil].
- ^self selectedPackage classAt: self selectedClassName!
Item was removed:
- ----- Method: FileContentsBrowser>>selectedClassOrMetaClass (in category 'metaclass') -----
- selectedClassOrMetaClass
- "Answer the selected class or metaclass."
-
- | cls |
- self metaClassIndicated
- ifTrue: [^ (cls := self selectedClass) ifNotNil: [cls metaClass]]
- ifFalse: [^ self selectedClass]!
Item was removed:
- ----- Method: FileContentsBrowser>>selectedMessage (in category 'edit pane') -----
- selectedMessage
- "Answer a copy of the source code for the selected message selector."
-
- | class selector |
- class := self selectedClassOrMetaClass.
- selector := self selectedMessageName.
- contents := class sourceCodeAt: selector.
- SystemBrowser browseWithPrettyPrint
- ifTrue:
- [contents := class prettyPrinterClass
- format: contents
- in: class
- notifying: nil
- decorated: false].
- self showingAnyKindOfDiffs
- ifTrue:
- [contents := self
- methodDiffFor: contents
- class: self selectedClass
- selector: self selectedMessageName
- meta: self metaClassIndicated].
- ^contents asText makeSelectorBoldIn: class!
Item was removed:
- ----- Method: FileContentsBrowser>>selectedPackage (in category 'accessing') -----
- selectedPackage
- | cat |
- cat := self selectedSystemCategory.
- cat isNil ifTrue:[^nil].
- ^self packages at: cat asString ifAbsent:[nil]!
Item was removed:
- ----- Method: FileContentsBrowser>>setClassOrganizer (in category 'metaclass') -----
- setClassOrganizer
- "Install whatever organization is appropriate"
- | theClass |
- classOrganizer := nil.
- metaClassOrganizer := nil.
- self hasClassSelected ifFalse: [^ self].
- classOrganizer := (theClass := self selectedClass) organization.
- metaClassOrganizer := theClass metaClass organization.
- !
Item was removed:
- ----- Method: FileContentsBrowser>>systemCategoryList (in category 'system category list') -----
- systemCategoryList
-
- ^ self packages size = 1
- ifTrue: [super systemCategoryList allButFirst "without all category"]
- ifFalse: [super systemCategoryList]!
Item was removed:
- ----- Method: FileContentsBrowser>>updateInfoView (in category 'infoView') -----
- updateInfoView
-
- Smalltalk isMorphic
- ifTrue: [self changed: #infoViewContents]
- ifFalse: [
- self infoString contents: self infoViewContents.
- self infoString changed].!
Item was removed:
- ----- Method: FileDirectory class>>serviceBrowseDirectory (in category '*Tools-FileList') -----
- serviceBrowseDirectory
-
- ^ (SimpleServiceEntry
- provider: FileList
- label: 'browse directory'
- selector: #openOn:
- description: 'browse directory'
- buttonLabel: 'browse')
- argumentGetter: [:directory | directory];
- yourself!
Item was removed:
- StringHolder subclass: #FileList
- instanceVariableNames: 'fileName directory volList volListIndex list listIndex pattern sortMode brevityState directoryCache lastGraphicsExtent'
- classVariableNames: 'FileReaderRegistry RecentDirs'
- poolDictionaries: ''
- category: 'Tools-FileList'!
-
- !FileList commentStamp: 'nk 11/26/2002 11:52' prior: 0!
- I am model that can be used to navigate the host file system. By omitting the volume list, file list, and template panes from the view, I can also be used as the model for an editor on an individual file.
-
- The FileList now provides a registration mechanism to which any tools the filelist uses ***MUST*** register. This way it is possible to dynamically load or unload a new tool and have the FileList automatically updated. This change supports a decomposition of Squeak and removes a problem with dead reference to classes after a major shrink.
-
- Tools should implement the following methods (look for implementors in the image):
-
- #fileReaderServicesForFile:suffix: (appropriate services for given file, takes a file name and a lowercased suffix)
-
- #services (all provided services, to be displayed in full list)
-
- These methods both return a collection of SimpleServiceEntry instances. These contain a class, a menu label and a method selector having one argument. They may also provide separate button labels and description.
-
- The argument to the specified method will be a string representing the full name of a file when one is selected or the file list itself when there is no selected file.
-
- Tools must register with the FileList calling the class method #registerFileReader: when they load. They also must call #unregisterFileReader: when they unload.
-
- There is a testSuite called FileListTest that presents some examples.
-
- Stef (I do not like really this distinction passing always a file list could be better)
-
-
- Old Comments:
-
-
- FileLists can now see FTP servers anywhere on the net. In the volume list menu:
- fill in server info... Gives you a form to register a new ftp server you want to use.
- open server... Choose a server to connect to.
- local disk Go back to looking at your local volume.
-
-
- Still undone (you can contribute code):
- [ ] Using a Proxy server to get out through a firewall. What is the convention for proxy servers with FTP?
- [ ] Fill in the date and size info in the list of remote files. Allow sorting by it. New smarts needed in (ServerDirectory fileNameFormattedFrom:sizePad:sortMode:).
- [ ] Currently the FileList has no way to delete a directory. Since you can't select a directory without going into it, it would have to be deleting the current directory. Which would usually be empty.!
Item was removed:
- ----- Method: FileList class>>initialize (in category 'class initialization') -----
- initialize
- "FileList initialize"
-
- RecentDirs := OrderedCollection new!
Item was removed:
- ----- Method: FileList class>>new (in category 'instance creation') -----
- new
- ^self newOn: FileDirectory default!
Item was removed:
- ----- Method: FileList class>>newOn: (in category 'instance creation') -----
- newOn: aDirectory
-
- ^super new directory: aDirectory!
Item was removed:
- ----- Method: FileList class>>open (in category 'instance creation') -----
- open
- "Open a view of an instance of me on the default directory."
- ^ToolBuilder open: self!
Item was removed:
- ----- Method: FileList class>>openEditorOn:editString: (in category 'instance creation') -----
- openEditorOn: aFileStream editString: editString
- "Open an editor on the given FileStream."
- | fileModel topView builder |
- fileModel := FileList new setFileStream: aFileStream. "closes the stream"
- builder := ToolBuilder default.
- topView := fileModel buildEditorWith: builder.
- ^builder open: topView.!
Item was removed:
- ----- Method: FileList class>>openFileDirectly (in category 'instance creation') -----
- openFileDirectly
-
- (FileChooserDialog openOn: FileDirectory default) ifNotNil:
- [:fileName | self openEditorOn: (FileStream readOnlyFileNamed: fileName) editString: nil]!
Item was removed:
- ----- Method: FileList class>>openOn: (in category 'instance creation') -----
- openOn: directory
-
- ^ToolBuilder open: (self newOn: directory)!
Item was removed:
- ----- Method: FileList class>>prototypicalToolWindow (in category 'instance creation') -----
- prototypicalToolWindow
- "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
- ^ ToolBuilder build: self new!
Item was removed:
- ----- Method: FileList class>>registerInFlapsRegistry (in category 'class initialization') -----
- registerInFlapsRegistry
- "Register the receiver in the system's flaps registry"
- self environment
- at: #Flaps
- ifPresent: [:cl | cl registerQuad: {#FileList . #prototypicalToolWindow, 'File List' translatedNoop. 'A File List is a tool for browsing folders and files on disks and on ftp types.' translatedNoop}
- forFlapNamed: 'Tools']!
Item was removed:
- ----- Method: FileList class>>removeObsolete (in category 'class initialization') -----
- removeObsolete
- "FileList removeObsolete"
- FileServices removeObsolete
- !
Item was removed:
- ----- Method: FileList class>>unload (in category 'class initialization') -----
- unload
- "Unload the receiver from global registries"
-
- self environment at: #Flaps ifPresent: [:cl |
- cl unregisterQuadsWithReceiver: self] !
Item was removed:
- ----- Method: FileList>>addNew:byEvaluating: (in category 'file menu action') -----
- addNew: aString byEvaluating: aBlock
- "A parameterization of earlier versions of #addNewDirectory and
- #addNewFile. Fixes the bug in each that pushing the cancel button
- in the FillInTheBlank dialog gave a walkback."
-
- | response newName index ending |
- self okToChange ifFalse: [^ self].
- (response := UIManager default
- request: ('New {1} Name?' translated format: {aString translated})
- initialAnswer: ('{1}Name' translated format: {aString translated}))
- isEmpty ifTrue: [^ self].
- newName := response asFileName.
- (Cursor wait showWhile: [
- directory fileOrDirectoryExists: newName])
- ifTrue: [^ self inform: ('''{1}'' already exists' translated format: {newName})].
- Cursor wait showWhile: [
- aBlock value: newName].
- self updateFileList.
- index := list indexOf: newName.
- index = 0 ifTrue: [ending := ') ',newName.
- index := list findFirst: [:line | line endsWith: ending]].
- self fileListIndex: index.
- !
Item was removed:
- ----- Method: FileList>>addNewDirectory (in category 'file menu action') -----
- addNewDirectory
- self
- addNew: 'Directory'
- byEvaluating: [:newName | directory createDirectory: newName]
- !
Item was removed:
- ----- Method: FileList>>addNewFile (in category 'file menu action') -----
- addNewFile
- self
- addNew: 'File'
- byEvaluating: [:newName | (directory newFileNamed: newName) close]
- !
Item was removed:
- ----- Method: FileList>>addPath: (in category 'private') -----
- addPath: aString
- "Add the given string to the list of recently visited directories."
-
- | full |
- aString ifNil: [^self].
- full := String streamContents:
- [ :strm | 2 to: volList size do:
- [ :i | strm nextPutAll: (volList at: i) withBlanksTrimmed.
- strm nextPut: FileDirectory pathNameDelimiter]].
- full := full, aString.
- "Remove and super-directories of aString from the collection."
- RecentDirs removeAllSuchThat: [ :aDir | ((aDir, '*') match: full)].
-
- "If a sub-directory is in the list, do nothing."
- (RecentDirs anySatisfy: [ :aDir | ((full, '*') match: aDir)])
- ifTrue: [^self].
-
- [RecentDirs size >= 10]
- whileTrue: [RecentDirs removeFirst].
- RecentDirs addLast: full!
Item was removed:
- ----- Method: FileList>>askServerInfo (in category 'server list') -----
- askServerInfo
- "Get the user to create a ServerDirectory for a new server. Fill in and say Accept."
- | template |
- template := '"Please fill in the following info, then select all text and choose DoIt."
-
- | aa |
- self flag: #ViolateNonReferenceToOtherClasses.
- aa := ServerDirectory new.
- aa server: ''st.cs.uiuc.edu''. "host"
- aa user: ''anonymous''.
- aa password: ''yourEmail(a)school.edu''.
- aa directory: ''/Smalltalk/Squeak/Goodies''.
- aa url: ''''. "<- this is optional. Only used when *writing* update files."
- ServerDirectory addServer: aa named: ''UIUCArchive''. "<- known by this name in Squeak"'.
-
- (StringHolder new contents: template) openLabel: 'FTP Server Form'
- !
Item was removed:
- ----- Method: FileList>>availableGraphicsExtent (in category 'private') -----
- availableGraphicsExtent
-
- ^ self codeTextMorph ifNotNil: [:m | m innerBounds extent - (6@22)]
- !
Item was removed:
- ----- Method: FileList>>buildButtonPaneWith: (in category 'toolbuilder') -----
- buildButtonPaneWith: builder
- | panelSpec |
- panelSpec := builder pluggablePanelSpec new.
- panelSpec
- model: self;
- children: #getButtonRow;
- layout: #horizontal.
- ^panelSpec
- !
Item was removed:
- ----- Method: FileList>>buildCodePaneWith: (in category 'toolbuilder') -----
- buildCodePaneWith: builder
- | textSpec |
- textSpec := builder pluggableTextSpec new.
- textSpec
- model: self;
- getText: #contents;
- setText: #put:;
- selection: #contentsSelection;
- menu: #fileContentsMenu:shifted:.
- ^textSpec!
Item was removed:
- ----- Method: FileList>>buildContentPaneWith: (in category 'toolbuilder') -----
- buildContentPaneWith: builder
- | textSpec |
- textSpec := builder pluggableTextSpec new.
- textSpec
- model: self;
- getText: #contents;
- setText: #put:;
- selection: #contentsSelection;
- menu: #fileContentsMenu:shifted:.
- ^textSpec
- !
Item was removed:
- ----- Method: FileList>>buildDirectoryTreeWith: (in category 'toolbuilder') -----
- buildDirectoryTreeWith: builder
- | treeSpec |
- treeSpec := builder pluggableTreeSpec new.
- treeSpec
- model: self ;
- roots: #rootDirectoryList ;
- hasChildren: #hasMoreDirectories: ;
- getChildren: #subDirectoriesOf: ;
- getSelectedPath: #selectedPath ;
- setSelected: #setDirectoryTo: ;
- getSelected: #directory;
- label: #directoryNameOf: ;
- menu: #volumeMenu: ;
- autoDeselect: false.
- SystemBrowser browseWithDragNDrop ifTrue:
- [ treeSpec
- dragItem: #dragFromDirectoryList: ;
- dropItem: #drop:ontoDirectory:shouldCopy: ;
- dropAccept: #wantsDraggedObject: ].
- ^ treeSpec!
Item was removed:
- ----- Method: FileList>>buildEditorWith: (in category 'toolbuilder') -----
- buildEditorWith: builder
- ^super buildWith: builder!
Item was removed:
- ----- Method: FileList>>buildFileListWith: (in category 'toolbuilder') -----
- buildFileListWith: builder
- | buttons listSpec top |
- top := builder pluggablePanelSpec new.
- top children: OrderedCollection new.
- buttons := self buildButtonPaneWith: builder.
- buttons frame:
- (self
- topConstantHeightFrame: self buttonHeight
- fromLeft: 0
- width: 1).
- top children add: buttons.
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self ;
- list: #fileList ;
- getIndex: #fileListIndex ;
- setIndex: #fileListIndex: ;
- menu: #fileListMenu: ;
- keyPress: nil ;
- frame:
- (self
- frameOffsetFromTop: self buttonHeight * 1.1
- fromLeft: 0
- width: 1
- bottomFraction: 1) .
- SystemBrowser browseWithDragNDrop ifTrue: [ listSpec dragItem: #dragFromFileList: ].
- top children add: listSpec.
- ^ top!
Item was removed:
- ----- Method: FileList>>buildPatternInputWith: (in category 'toolbuilder') -----
- buildPatternInputWith: builder
- | textSpec |
- textSpec := builder pluggableInputFieldSpec new.
- textSpec
- model: self;
- font: self pathAndPatternFont;
- getText: #pathAndPattern;
- setText: #pathAndPattern:.
- ^textSpec
- !
Item was removed:
- ----- Method: FileList>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- "FileList open"
- | windowSpec window |
- windowSpec := self buildWindowWith: builder specs: {
- (self topConstantHeightFrame: self pathAndPatternHeight
- fromLeft: 0
- width: 1) -> [self buildPatternInputWith: builder].
- (self frameOffsetFromTop: self pathAndPatternHeight
- fromLeft: 0.25
- width: 0.75
- bottomFraction: 0.5) -> [self buildFileListWith: builder].
- (self frameOffsetFromTop: self pathAndPatternHeight
- fromLeft: 0
- width: 0.25
- bottomFraction: 1) -> [self buildDirectoryTreeWith: builder].
- (0.25(a)0.5 corner: 1@1) -> [self buildContentPaneWith: builder].
- }.
- window := builder build: windowSpec.
- self changed: #selectedPath.
- ^window!
Item was removed:
- ----- Method: FileList>>buttonHeight (in category 'toolbuilder') -----
- buttonHeight
- ^ ToolBuilder default buttonRowHeight!
Item was removed:
- ----- Method: FileList>>buttonSelectorsToSuppress (in category 'initialization') -----
- buttonSelectorsToSuppress
- "Answer a list of action selectors whose corresponding services we would prefer *not* to have appear in the filelist's button pane; this can be hand-jimmied to suit personal taste."
-
- ^ #(removeLineFeeds: addFileToNewZip: compressFile: putUpdate:)!
Item was removed:
- ----- Method: FileList>>compressFile (in category 'file menu action') -----
- compressFile
- "Compress the currently selected file"
-
- | f |
- f := StandardFileStream
- readOnlyFileNamed: (directory fullNameFor: self fullName).
- f compressFile.
- self updateFileList!
Item was removed:
- ----- Method: FileList>>contents (in category 'private') -----
- contents
- "Answer the contents of the file, reading it first if needed."
- "Possible brevityState values:
- FileList,
- fullFile, briefFile, needToGetFull, needToGetBrief,
- fullHex, briefHex, needToGetFullHex, needToGetBriefHex"
-
- (listIndex = 0) | (brevityState == #FileList) ifTrue: [^ self defaultContents]. "no file selected"
- brevityState == #fullFile ifTrue: [^ contents].
- brevityState == #fullHex ifTrue: [^ contents].
- brevityState == #briefFile ifTrue: [^ contents].
- brevityState == #briefHex ifTrue: [^ contents].
- brevityState == #graphic ifTrue: [^ contents].
-
- brevityState == #needToGetGraphic ifTrue: [^self readGraphicContents].
-
- brevityState == #needToGetFullHex ifTrue: [^ self readContentsHex: false].
- brevityState == #needToGetBriefHex ifTrue: [^ self readContentsHex: true].
-
- brevityState == #needToGetFull ifTrue: [^ self readContentsBrief: false].
- brevityState == #needToGetBrief ifTrue: [^ self readContentsBrief: true]. "default"
-
- (TextConverter allEncodingNames includes: brevityState)
- ifTrue: [ ^self readContentsAsEncoding: brevityState].
-
- self halt: 'unknown state ' , brevityState printString!
Item was removed:
- ----- Method: FileList>>copyName (in category 'menu messages') -----
- copyName
-
- listIndex = 0 ifTrue: [^ self].
- Clipboard clipboardText: self fullName asText.
- !
Item was removed:
- ----- Method: FileList>>defaultContents (in category 'private') -----
- defaultContents
- contents := list == nil
- ifTrue: [String new]
- ifFalse: [String streamContents:
- [:s | s nextPutAll: 'NO FILE SELECTED' translated; cr.
- s nextPutAll: ' -- Folder Summary --' translated; cr.
- list do: [:item | s nextPutAll: item; cr]]].
- brevityState := #FileList.
- ^ contents!
Item was removed:
- ----- Method: FileList>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.65 g: 0.65 b: 0.65)!
Item was removed:
- ----- Method: FileList>>deleteDirectory (in category 'volume list and pattern') -----
- deleteDirectory
- "Remove the currently selected directory"
- | localDirName |
- directory hasEntries ifTrue:[^self inform:'Directory must be empty' translated].
- localDirName := directory localName.
- (self confirm: ('Really delete {1}?' translated format: {localDirName})) ifFalse: [^ self].
- self volumeListIndex: self volumeListIndex-1.
- directory deleteDirectory: localDirName.
- self updateFileList.!
Item was removed:
- ----- Method: FileList>>deleteFile (in category 'file menu action') -----
- deleteFile
- "Delete the currently selected file"
- listIndex = 0 ifTrue: [^ self].
- (self confirm: ('Really delete {1}?' translated format:{fileName})) ifFalse: [^ self].
- directory deleteFileNamed: fileName.
- self updateFileList.
- brevityState := #FileList.
- self get!
Item was removed:
- ----- Method: FileList>>dirAndFileName (in category 'file list menu') -----
- dirAndFileName
-
- ^{directory. fileName}!
Item was removed:
- ----- Method: FileList>>directory (in category 'volume list and pattern') -----
- directory
-
- ^ directory!
Item was removed:
- ----- Method: FileList>>directory: (in category 'initialization') -----
- directory: aFileDirectory
- "Set the path of the volume to be displayed."
- self okToChange ifFalse: [ ^ self ].
- self modelSleep.
- directory := aFileDirectory.
- self modelWakeUp.
- sortMode == nil ifTrue: [ sortMode := #date ].
- volList := (Array with: '[]') , directory pathParts withIndexCollect:
- [ : each : i | (String
- new: i - 1
- withAll: Character space) , each ].
- volListIndex := volList size.
- self changed: #relabel.
- self changed: #volumeList.
- self changed: #directory.
- self pattern: pattern!
Item was removed:
- ----- Method: FileList>>directoryNameOf: (in category 'directory tree') -----
- directoryNameOf: aDirectory
- "Attempt to find the name of ServerDirectories when used."
-
- ^(aDirectory isRemoteDirectory and:[aDirectory isKindOf: ServerDirectory])
- ifTrue:[ServerDirectory servers keyAtIdentityValue: aDirectory ifAbsent:[aDirectory localName]]
- ifFalse:[aDirectory localName]!
Item was removed:
- ----- Method: FileList>>dragFromDirectoryList: (in category 'file list') -----
- dragFromDirectoryList: anIndex
- ^ self directory!
Item was removed:
- ----- Method: FileList>>dragFromFileList: (in category 'file list') -----
- dragFromFileList: anIndex
- ^ self directory entryAt: (self fileNameFromFormattedItem: (self fileList at: self fileListIndex))!
Item was removed:
- ----- Method: FileList>>dragPassengerFor:inMorph: (in category 'drag''n''drop') -----
- dragPassengerFor: item inMorph: dragSource
- ^self directory fullNameFor: ((self fileNameFromFormattedItem: item contents copy)
- copyReplaceAll: self folderString with: '').
- !
Item was removed:
- ----- Method: FileList>>drop:ontoDirectory:shouldCopy: (in category 'toolbuilder') -----
- drop: aDirectoryEntryFile ontoDirectory: aFileDirectory shouldCopy: aBoolean
- aDirectoryEntryFile containingDirectory = aFileDirectory ifTrue: [ ^ self ].
- aBoolean
- ifTrue: [ aFileDirectory copyHere: aDirectoryEntryFile ]
- ifFalse:
- [ directory
- rename: aDirectoryEntryFile fullName
- toBe: (aFileDirectory fullNameFor: aDirectoryEntryFile name).
- self setDirectoryTo: directory ]!
Item was removed:
- ----- Method: FileList>>dynamicButtonServices (in category 'initialization') -----
- dynamicButtonServices
- "Answer services for buttons that may come and go in the button pane, depending on selection"
-
- ^ fileName isEmptyOrNil
- ifTrue:
- [#()]
- ifFalse:
- [ | toReject |
- toReject := self buttonSelectorsToSuppress.
- (self itemsForFile: self fullName) reject:
- [:svc | toReject includes: svc selector]]!
Item was removed:
- ----- Method: FileList>>entriesMatching: (in category 'private') -----
- entriesMatching: patternString
- "Answer a list of directory entries which match the patternString.
- The patternString may consist of multiple patterns separated by ';'.
- Each pattern can include a '*' or '#' as wildcards - see String>>match:"
-
- | entries patterns |
- entries := directory entries reject:[:e| Smalltalk isMorphic and: [e isDirectory]].
- patterns := patternString findTokens: ';'.
- (patterns anySatisfy: [:each | each = '*'])
- ifTrue: [^ entries].
- ^ entries select: [:entry | patterns anySatisfy: [:each | each match: entry name]]!
Item was removed:
- ----- Method: FileList>>executeService: (in category 'toolbuilder') -----
- executeService: aService
- aService performServiceFor: self.!
Item was removed:
- ----- Method: FileList>>fileContentsMenu:shifted: (in category 'file list menu') -----
- fileContentsMenu: aMenu shifted: shifted
- "Construct aMenu to have items appropriate for the file browser's code pane, given the shift state provided"
- ^ self menu: aMenu for: #(fileContentsMenu fileContentsMenuShifted:) shifted: shifted!
Item was removed:
- ----- Method: FileList>>fileList (in category 'file list') -----
- fileList
- "Answer the list of files in the current volume."
-
- ^ list!
Item was removed:
- ----- Method: FileList>>fileListIndex (in category 'file list') -----
- fileListIndex
- "Answer the index of the currently selected file."
-
- ^ listIndex!
Item was removed:
- ----- Method: FileList>>fileListIndex: (in category 'file list') -----
- fileListIndex: anInteger
- "Select the file name having the given index, and display its contents."
-
- | item name |
- self okToChange ifFalse: [^ self].
- listIndex := anInteger.
- listIndex = 0
- ifTrue: [fileName := nil]
- ifFalse:
- [item := self fileNameFromFormattedItem: (list at: anInteger).
- (item endsWith: self folderString)
- ifTrue:
- ["remove [...] folder string and open the folder"
- name := item copyFrom: 1 to: item size - self folderString size.
- listIndex := 0.
- brevityState := #FileList.
- self addPath: name.
- name first = $^
- ifTrue: [self directory: (ServerDirectory serverNamed: name allButFirst)]
- ifFalse: [volListIndex = 1 ifTrue: [name := name, directory slash].
- self directory: (directory directoryNamed: name)]]
- ifFalse: [fileName := item]]. "open the file selected"
-
- brevityState := self isGraphicsFileSelected
- ifTrue: [#needToGetGraphic]
- ifFalse: [#needToGetBrief]..
- self
- changed: #fileListIndex ;
- changed: #contents ;
- changed: #labelString.
- self updateButtonRow!
Item was removed:
- ----- Method: FileList>>fileListMenu: (in category 'file list menu') -----
- fileListMenu: aMenu
- ^ self menu: aMenu for: #(fileListMenu fileListMenuShifted:)
- !
Item was removed:
- ----- Method: FileList>>fileName (in category 'file list') -----
- fileName
-
- ^ fileName!
Item was removed:
- ----- Method: FileList>>fileNameFormattedFrom:sizePad: (in category 'volume list and pattern') -----
- fileNameFormattedFrom: entry sizePad: sizePad
- "entry is a 5-element array of the form:
- (name creationTime modificationTime dirFlag fileSize)"
- | sizeStr nameStr dateStr |
- nameStr := entry isDirectory
- ifTrue: [entry name , self folderString]
- ifFalse: [entry name].
- dateStr := ((Date fromSeconds: entry modificationTime )
- printFormat: #(3 2 1 $. 1 1 2)) , ' ' ,
- (String streamContents: [:s |
- (Time fromSeconds: entry modificationTime \\ 86400)
- print24: true on: s]).
- sizeStr := entry fileSize asStringWithCommas.
- sortMode = #name ifTrue:
- [^ nameStr , ' (' , dateStr , ' ' , sizeStr , ')'].
- sortMode = #date ifTrue:
- [^ '(' , dateStr , ' ' , sizeStr , ') ' , nameStr].
- sortMode = #size ifTrue:
- [^ '(' , (String new: sizePad - sizeStr size withAll: Character space) , sizeStr , ' ' , dateStr , ') ' , nameStr].
- !
Item was removed:
- ----- Method: FileList>>fileNameFromFormattedItem: (in category 'private') -----
- fileNameFromFormattedItem: item
- "Extract fileName and folderString from a formatted fileList item string"
-
- | from to |
- self sortingByName
- ifTrue: [
- from := item lastIndexOf: $(.
- to := item lastIndexOf: $)]
- ifFalse: [
- from := item indexOf: $(.
- to := item indexOf: $)].
- ^ (from * to = 0
- ifTrue: [item]
- ifFalse: [item copyReplaceFrom: from to: to with: '']) withBlanksTrimmed!
Item was removed:
- ----- Method: FileList>>fileSelectedMenu: (in category 'file list menu') -----
- fileSelectedMenu: aMenu
-
- | firstItems secondItems thirdItems n1 n2 n3 services |
- firstItems := self itemsForFile: self fullName.
- secondItems := self itemsForAnyFile.
- thirdItems := self itemsForNoFile.
- n1 := firstItems size.
- n2 := n1 + secondItems size.
- n3 := n2 + thirdItems size.
- services := firstItems, secondItems, thirdItems, self serviceAllFileOptions.
- services do: [ :svc | svc addDependent: self ].
- ^ aMenu
- addServices2: services
- for: self
- extraLines: (Array with: n1 with: n2 with: n3)
- !
Item was removed:
- ----- Method: FileList>>folderString (in category 'private') -----
- folderString
- ^ ' [...]'!
Item was removed:
- ----- Method: FileList>>frameOffsetFromTop:fromLeft:width:bottomFraction: (in category 'toolbuilder') -----
- frameOffsetFromTop: height fromLeft: leftFraction width: rightFraction bottomFraction: bottomFraction
- ^LayoutFrame new
- topFraction: 0 offset: height;
- leftFraction: leftFraction offset: 0;
- rightFraction: (leftFraction + rightFraction) offset: 0;
- bottomFraction: bottomFraction offset: 0;
- yourself.!
Item was removed:
- ----- Method: FileList>>fullFileListMenu:shifted: (in category 'file list menu') -----
- fullFileListMenu: aMenu shifted: aBoolean
- "Fill the menu with all possible items for the file list pane, regardless of selection."
-
- | lastProvider |
- aMenu title: 'all possible file operations' translated.
- aMenu addStayUpItemSpecial.
-
- lastProvider := nil.
- (self itemsForFile: self fullName) do: [ :svc |
- (lastProvider notNil and: [svc provider ~~ lastProvider])
- ifTrue: [ aMenu addLine ].
- svc addServiceFor: self toMenu: aMenu.
- Smalltalk isMorphic ifTrue: [aMenu submorphs last setBalloonText: svc description].
- lastProvider := svc provider.
- svc addDependent: self.
- ].
-
- ^aMenu!
Item was removed:
- ----- Method: FileList>>fullName (in category 'private') -----
- fullName
- "Answer the full name for the currently selected file; answer nil if no file is selected."
-
- ^ fileName ifNotNil: [directory
- ifNil:
- [FileDirectory default fullNameFor: fileName]
- ifNotNil:
- [directory fullNameFor: fileName]]
- !
Item was removed:
- ----- Method: FileList>>get (in category 'file menu action') -----
- get
- "Get contents of file again, it may have changed. Do this by making the cancel string be the contents, and doing a cancel."
-
- Cursor read showWhile: [
- self okToChange ifFalse: [^ nil].
- brevityState == #briefHex
- ifTrue: [brevityState := #needToGetFullHex]
- ifFalse: [brevityState := #needToGetFull].
- self changed: #contents].
- !
Item was removed:
- ----- Method: FileList>>getButtonRow (in category 'toolbuilder') -----
- getButtonRow
- "Answer the dynamic button row to use for the currently selected item."
- | builder svc |
- builder := ToolBuilder default.
- svc := self universalButtonServices.
- self fileListIndex = 0 ifFalse:[svc := svc, self dynamicButtonServices].
- ^svc collect:[:service| service buildWith: builder in: self].!
Item was removed:
- ----- Method: FileList>>getEncodedText (in category 'file menu action') -----
- getEncodedText
-
- Cursor read showWhile: [
- self selectEncoding.
- self changed: #contents].
- !
Item was removed:
- ----- Method: FileList>>getHex (in category 'file menu action') -----
- getHex
- "Get contents of file again, and display in Hex. Do this by making the cancel string be the contents, and doing a cancel."
-
- Cursor read showWhile: [
- brevityState := #needToGetBriefHex.
- self changed: #contents].
- !
Item was removed:
- ----- Method: FileList>>getSelectedPath (in category 'directory tree') -----
- getSelectedPath
- self halt.!
Item was removed:
- ----- Method: FileList>>hasMoreDirectories: (in category 'directory tree') -----
- hasMoreDirectories: aDirectory
- (aDirectory isKindOf: FileDirectory) ifFalse:[^true]. "server directory; don't ask"
- ^directoryCache at: aDirectory ifAbsentPut:[
- [aDirectory directoryNames notEmpty] on: Error do:[:ex| true].
- ].!
Item was removed:
- ----- Method: FileList>>initialize (in category 'initialization') -----
- initialize
- super initialize.
- directoryCache := WeakIdentityKeyDictionary new.!
Item was removed:
- ----- Method: FileList>>isFileSelected (in category 'private') -----
- isFileSelected
- "return if a file is currently selected"
-
- ^ fileName notNil!
Item was removed:
- ----- Method: FileList>>isGraphicsFileSelected (in category 'private') -----
- isGraphicsFileSelected
- ^fileName notNil
- and: [(self itemsForFile: self fullName) anySatisfy: [:each | each provider == Form and: [each selector == #importImage:]]]!
Item was removed:
- ----- Method: FileList>>itemsForAnyFile (in category 'file list menu') -----
- itemsForAnyFile
- "Answer a list of universal services that could apply to any file"
-
- | services |
- services := OrderedCollection new: 4.
- services add: self serviceCopyName.
- services add: self serviceRenameFile.
- services add: self serviceDeleteFile.
- services add: self serviceViewContentsInWorkspace.
- ^ services!
Item was removed:
- ----- Method: FileList>>itemsForDirectory: (in category 'file list menu') -----
- itemsForDirectory: dir
- | services |
- services := OrderedCollection new.
- dir ifNotNil: [
- services
- addAll: (FileServices itemsForDirectory: dir).
- services last useLineAfter: true. ].
- services add: self serviceAddNewFile.
- services add: self serviceAddNewDirectory.
- ^ services!
Item was removed:
- ----- Method: FileList>>itemsForFile: (in category 'file list menu') -----
- itemsForFile: fullName
- "Answer a list of services appropriate for a file of the given full name"
- ^ (FileServices itemsForFile: fullName) , (self myServicesForFile: fullName suffix: (FileServices suffixOf: fullName))!
Item was removed:
- ----- Method: FileList>>itemsForNoFile (in category 'file list menu') -----
- itemsForNoFile
-
- | services |
- services := OrderedCollection new.
- services add: self serviceSortByName.
- services add: self serviceSortBySize.
- services add: (self serviceSortByDate useLineAfter: true).
- services addAll: (self itemsForDirectory: (self isFileSelected ifFalse: [ self directory ] ifTrue: [])).
- ^ services
-
- !
Item was removed:
- ----- Method: FileList>>labelString (in category 'initialization') -----
- labelString
- ^ directory
- ifNil: [ 'File List' ]
- ifNotNil:
- [ fileName
- ifNil: [ directory fullName ]
- ifNotNil: [ directory fullNameFor: fileName ] ]!
Item was removed:
- ----- Method: FileList>>listForPattern: (in category 'volume list and pattern') -----
- listForPattern: pat
- "Make the list be those file names which match the pattern."
-
- | sizePad newList |
- newList := (self entriesMatching: pat) asArray sort: self sortBlock.
- sizePad := (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)])
- asStringWithCommas size - 1.
- newList := newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].
-
- volList size = 1 ifTrue:
- ["Include known servers along with other desktop volumes"
- ^ newList ,
- (ServerDirectory serverNames collect: [:n | '^' , n , self folderString])].
- ^ newList!
Item was removed:
- ----- Method: FileList>>listForPatterns: (in category 'private') -----
- listForPatterns: anArray
- "Make the list be those file names which match the pattern."
-
- | sizePad newList |
- newList := Set new.
- anArray do: [ :pat | newList addAll: (self entriesMatching: pat) ].
- newList := newList asArray sort: self sortBlock.
- sizePad := (newList inject: 0 into: [:mx :entry | mx max: entry fileSize])
- asStringWithCommas size.
- newList := newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].
-
- volList size = 1 ifTrue:
- ["Include known servers along with other desktop volumes"
- ^ newList ,
- (ServerDirectory serverNames collect: [:n | '^' , n , self folderString])].
- ^ newList!
Item was removed:
- ----- Method: FileList>>mainFileContentsMenu: (in category 'file list menu') -----
- mainFileContentsMenu: aMenu
- "Construct aMenu to have items appropriate for the file browser's code pane, for the unshifted state"
- <fileContentsMenuShifted: false>
- ^ aMenu addTranslatedList: #(
- ('find... (f)' find)
- ('find again (g)' findAgain)
- ('find and replace... ' findReplace)
- ('do/replace again (j)' again)
- -
- ('undo (z)' undo)
- ('redo (Z)' redo)
- -
- ('copy (c)' copySelection)
- ('cut (x)' cut)
- ('paste (v)' paste)
- ('paste...' pasteRecent)
- -
- ('do it (d)' doIt)
- ('print it (p)' printIt)
- ('inspect it (i)' inspectIt)
- ('fileIn selection (G)' fileItIn)
- -
- ('accept (s)' accept)
- ('cancel (l)' cancel)
- -
- ('more...' shiftedYellowButtonActivity));
- yourself
- !
Item was removed:
- ----- Method: FileList>>mainFileListMenu: (in category 'file list menu') -----
- mainFileListMenu: aMenu
- <fileListMenu>
- fileName
- ifNil: [^ self noFileSelectedMenu: aMenu]
- ifNotNil: [^ self fileSelectedMenu: aMenu].
- !
Item was removed:
- ----- Method: FileList>>mainVolumeMenu: (in category 'volume menu') -----
- mainVolumeMenu: aMenu
- <volumeMenu>
- ^ aMenu addTranslatedList: #(
- ('recent...' recentDirs)
- -
- ('add server...' askServerInfo)
- ('remove server...' removeServer)
- -
- ('delete directory...' deleteDirectory)
- -);
- yourself!
Item was removed:
- ----- Method: FileList>>modelSleep (in category 'initialization') -----
- modelSleep
- "User has exited or collapsed the window -- close any remote connection."
-
- directory ifNotNil: [directory sleep]!
Item was removed:
- ----- Method: FileList>>modelWakeUp (in category 'initialization') -----
- modelWakeUp
- "User has entered or expanded the window -- reopen any remote connection."
-
- (directory notNil and:[directory isRemoteDirectory])
- ifTrue: [[directory wakeUp] on: TelnetProtocolError do: [ :ex | self inform: ex printString ]] "It would be good to implement a null method wakeUp on the root of directory"!
Item was removed:
- ----- Method: FileList>>myServicesForFile:suffix: (in category 'file list menu') -----
- myServicesForFile: fullName suffix: suffix
-
- ^(FileStream isSourceFileSuffix: suffix)
- ifTrue: [ {self serviceBroadcastUpdate} ]
- ifFalse: [ #() ]!
Item was removed:
- ----- Method: FileList>>noFileSelectedMenu: (in category 'file list menu') -----
- noFileSelectedMenu: aMenu
-
- ^ aMenu
- addServices: self itemsForNoFile
- for: self
- extraLines: #()
-
- !
Item was removed:
- ----- Method: FileList>>offerAllFileOptions (in category 'file list menu') -----
- offerAllFileOptions
- "Put up a menu offering all possible file options, whatever the suffix of the current selection may be. Specially useful if you're wanting to keep the menu up"
-
- self offerMenuFrom: #fullFileListMenu:shifted: shifted: true!
Item was removed:
- ----- Method: FileList>>optionalButtonHeight (in category 'initialization') -----
- optionalButtonHeight
-
- ^ 15!
Item was removed:
- ----- Method: FileList>>optionalButtonSpecs (in category 'initialization') -----
- optionalButtonSpecs
- "Answer a list of services underlying the optional buttons in their initial inception."
-
- ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize}!
Item was removed:
- ----- Method: FileList>>pathAndPattern (in category 'volume list and pattern') -----
- pathAndPattern
- "Answers both path and pattern"
- ^directory fullName, directory slash, pattern!
Item was removed:
- ----- Method: FileList>>pathAndPattern: (in category 'volume list and pattern') -----
- pathAndPattern: stringOrText
- "Answers both path and pattern"
- | base pat aString |
- aString := stringOrText asString.
- base := aString copyUpToLast: directory pathNameDelimiter.
- pat := aString copyAfterLast: directory pathNameDelimiter.
- self changed: #pathAndPattern. "avoid asking if it's okToChange"
- pattern := pat.
- self directory: (FileDirectory on: base).
- self changed: #pathAndPattern.
- self changed: #selectedPath.!
Item was removed:
- ----- Method: FileList>>pathAndPatternFont (in category 'toolbuilder') -----
- pathAndPatternFont
-
- ^ TextStyle defaultFont!
Item was removed:
- ----- Method: FileList>>pathAndPatternHeight (in category 'toolbuilder') -----
- pathAndPatternHeight
-
- ^ ToolBuilder default inputFieldHeight!
Item was removed:
- ----- Method: FileList>>pattern (in category 'volume list and pattern') -----
- pattern
-
- ^ pattern ifNil: ['*']
- !
Item was removed:
- ----- Method: FileList>>pattern: (in category 'volume list and pattern') -----
- pattern: textOrStringOrNil
-
- textOrStringOrNil
- ifNil: [pattern := '*']
- ifNotNil: [pattern := textOrStringOrNil asString].
- pattern isEmpty ifTrue: [pattern := '*'].
- self updateFileList.
- ^ true
- !
Item was removed:
- ----- Method: FileList>>perform:orSendTo: (in category 'menu messages') -----
- perform: selector orSendTo: otherTarget
- "Selector was just chosen from a menu by a user.
- If it's one of the three sort-by items, handle it specially.
- If I can respond myself, then perform it on myself.
- If not, send it to otherTarget, presumably the editPane from which the menu was invoked."
-
- ^ (#(sortByDate sortBySize sortByName) includes: selector)
- ifTrue:
- [self resort: selector]
- ifFalse:
- [(#(get getHex copyName openImageInWindow importImage renameFile deleteFile addNewFile) includes: selector)
- ifTrue: [self perform: selector]
- ifFalse: [super perform: selector orSendTo: otherTarget]]!
Item was removed:
- ----- Method: FileList>>put: (in category 'private') -----
- put: aText
- "Private - put the supplied text onto the file"
-
- | ff newName contentTypeLabel |
- brevityState == #fullFile ifTrue:
- [ff := directory newFileNamed: self fullName.
- self setDefaultEncoderFor: ff.
- Cursor write showWhile: [ff nextPutAll: aText asString; close].
- (directory = ff directory and: [fileName = ff localName])
- ifTrue: [contents := aText asString]
- ifFalse: "user changed the directory and/or renamed the file"
- [self clearUserEditFlag.
- directory ~= ff directory ifTrue:
- [self directory: ff directory.
- self changed: #rootDirectoryList; changed: #selectedPath].
- self updateFileList.
- contents := aText asString.
- newName := ff localName.
- listIndex := list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName].
- listIndex > 0 ifTrue: [fileName := newName].
- brevityState := #needToGetBrief.
- self changed: #fileListIndex].
- self changed: #relabel.
- ^ true "accepted"].
-
- listIndex = 0 ifTrue:
- [self inform: 'No fileName is selected' translated.
- ^ false "failed"].
- contentTypeLabel := 'These contents' translated.
- brevityState = #briefFile ifTrue: [contentTypeLabel := 'Abbreviated contents' translated].
- brevityState = #briefHex ifTrue: [contentTypeLabel := 'Abbreviated contents' translated].
- brevityState = #fullHex ifTrue: [contentTypeLabel := 'Hexadecimal contents' translated].
- brevityState = #FileList ifTrue: [contentTypeLabel := 'Directory contents' translated].
- self inform: ('{1} cannot
- meaningfully be saved at present.' translated format: {'Abbreviated contents' translated}).
- ^ false "failed"
- !
Item was removed:
- ----- Method: FileList>>readContentsAsEncoding: (in category 'private') -----
- readContentsAsEncoding: encodingName
- | f writeStream converter c |
- f := directory oldFileOrNoneNamed: self fullName.
- f ifNil: [^ 'For some reason, this file cannot be read'].
- writeStream := WriteStream on: String new.
- converter := TextConverter defaultConverterClassForEncoding: encodingName.
- converter ifNil: [^ 'This encoding is not supported'].
- f converter: converter new.
- f wantsLineEndConversion: true.
- [f atEnd or: [(c := f next) isNil]]
- whileFalse: [writeStream nextPut: c].
- f close.
- ^ writeStream contents!
Item was removed:
- ----- Method: FileList>>readContentsBrief: (in category 'private') -----
- readContentsBrief: brevityFlag
- "Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist."
- | f fileSize first5000 |
-
- brevityFlag ifTrue: [
- directory isRemoteDirectory ifTrue: [^ self readServerBrief]].
- f := directory oldFileOrNoneNamed: self fullName.
- f ifNil: [^ 'For some reason, this file cannot be read' translated].
- self setDefaultEncoderFor: f.
- (brevityFlag not or: [(fileSize := f size) <= 100000]) ifTrue:
- [contents := f contentsOfEntireFile.
- brevityState := #fullFile. "don't change till actually read"
- ^ contents].
-
- "if brevityFlag is true, don't display long files when first selected"
- first5000 := f next: 5000.
- f close.
- contents := 'File ''{1}'' is {2} bytes long.
- You may use the ''get'' command to read the entire file.
-
- Here are the first 5000 characters...
- ------------------------------------------
- {3}
- ------------------------------------------
- ... end of the first 5000 characters.' translated format: {fileName. fileSize. first5000}.
- brevityState := #briefFile. "don't change till actually read"
- ^ contents.
- !
Item was removed:
- ----- Method: FileList>>readContentsCNGB (in category 'private') -----
- readContentsCNGB
- | f writeStream |
- f := directory oldFileOrNoneNamed: self fullName.
- f ifNil: [^ 'For some reason, this file cannot be read'].
- writeStream := WriteStream on: String new.
- f converter: CNGBTextConverter new.
- [f atEnd]
- whileFalse: [writeStream nextPut: f next].
- f close.
- ^ writeStream contents!
Item was removed:
- ----- Method: FileList>>readContentsEUCJP (in category 'private') -----
- readContentsEUCJP
- | f writeStream |
- f := directory oldFileOrNoneNamed: self fullName.
- f ifNil: [^ 'For some reason, this file cannot be read'].
- writeStream := WriteStream on: String new.
- f converter: EUCJPTextConverter new.
- [f atEnd]
- whileFalse: [writeStream nextPut: f next].
- f close.
- ^ writeStream contents!
Item was removed:
- ----- Method: FileList>>readContentsEUCKR (in category 'private') -----
- readContentsEUCKR
- | f writeStream |
- f := directory oldFileOrNoneNamed: self fullName.
- f ifNil: [^ 'For some reason, this file cannot be read'].
- writeStream := WriteStream on: String new.
- f converter: EUCKRTextConverter new.
- [f atEnd]
- whileFalse: [writeStream nextPut: f next].
- f close.
- ^ writeStream contents!
Item was removed:
- ----- Method: FileList>>readContentsHex: (in category 'private') -----
- readContentsHex: brevity
- "retrieve the contents from the external file unless it is too long.
- Don't create a file here. Check if exists."
- | f size data hexData s |
-
- f := directory oldFileOrNoneNamed: self fullName.
- f == nil ifTrue: [^ 'For some reason, this file cannot be read' translated].
- f binary.
- ((size := f size)) > 5000 & brevity
- ifTrue: [data := f next: 10000. f close. brevityState := #briefHex]
- ifFalse: [data := f contentsOfEntireFile. brevityState := #fullHex].
-
- s := WriteStream on: (String new: data size*4).
- 0 to: data size-1 by: 16 do:
- [:loc | s nextPutAll: loc printStringHex; space;
- nextPut: $(; print: loc; nextPut: $); space; tab.
- loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) printStringHex; space].
- s cr].
- hexData := s contents.
-
- ^ contents := ((size > 5000) & brevity
- ifTrue: ['File ''{1}'' is {2} bytes long.
- You may use the ''get'' command to read the entire file.
-
- Here are the first 5000 characters...
- ------------------------------------------
- {3}
- ------------------------------------------
- ... end of the first 5000 characters.' translated format: {fileName. size. hexData}]
- ifFalse: [hexData]).
- !
Item was removed:
- ----- Method: FileList>>readContentsShiftJIS (in category 'private') -----
- readContentsShiftJIS
- | f writeStream |
- f := directory oldFileOrNoneNamed: self fullName.
- f ifNil: [^ 'For some reason, this file cannot be read'].
- writeStream := WriteStream on: String new.
- f converter: ShiftJISTextConverter new.
- [f atEnd]
- whileFalse: [writeStream nextPut: f next].
- f close.
- ^ writeStream contents!
Item was removed:
- ----- Method: FileList>>readContentsUTF8 (in category 'private') -----
- readContentsUTF8
- | f writeStream |
- f := directory oldFileOrNoneNamed: self fullName.
- f ifNil: [^ 'For some reason, this file cannot be read'].
- writeStream := WriteStream on: String new.
- f converter: UTF8TextConverter new.
- [f atEnd]
- whileFalse: [writeStream nextPut: f next].
- f close.
- ^ writeStream contents!
Item was removed:
- ----- Method: FileList>>readGraphicContents (in category 'private') -----
- readGraphicContents
- | form maxExtent ext |
- form := (Form fromFileNamed: self fullName) asFormOfDepth: Display depth.
- maxExtent := lastGraphicsExtent := self availableGraphicsExtent.
- ext := form extent.
- (maxExtent notNil and: [form extent <= maxExtent]) ifFalse: [
- form := form magnify: form boundingBox by: (maxExtent x / form width min: maxExtent y / form height) asPoint smoothing: 3].
- contents := ('Image extent: ', ext printString) asText,
- (String with: Character cr),
- (Text string: ' '
- attribute: (TextFontReference toFont:
- (FormSetFont new
- fromFormArray: (Array with: form)
- asciiStart: Character space asInteger
- ascent: form height))).
- brevityState := #graphic.
- ^contents!
Item was removed:
- ----- Method: FileList>>readOnlyStream (in category 'file list') -----
- readOnlyStream
- "Answer a read-only stream on the selected file. For the various stream-reading services."
-
- ^self directory ifNotNil: [ :dir | dir readOnlyFileNamed: self fileName ]!
Item was removed:
- ----- Method: FileList>>readServerBrief (in category 'private') -----
- readServerBrief
- | lString sizeStr fsize ff first5000 parts |
- "If file on server is known to be long, just read the beginning. Cheat badly by reading the fileList string."
-
- listIndex = 0 ifTrue: [^ self].
- "Get size from file list entry"
- lString := list at: listIndex.
- parts := lString findTokens: '()'.
- sortMode = #name ifTrue: [sizeStr := (parts second findTokens: ' ') third].
- sortMode = #date ifTrue: [sizeStr := (parts first findTokens: ' ') third].
- sortMode = #size ifTrue: [sizeStr := (parts first findTokens: ' ') first].
- fsize := (sizeStr copyWithout: $,) asNumber.
-
- fsize <= 50000 ifTrue:
- [ff := directory oldFileOrNoneNamed: self fullName.
- ff ifNil: [^ 'For some reason, this file cannot be read' translated].
- contents := ff contentsOfEntireFile.
- brevityState := #fullFile. "don't change till actually read"
- ^ contents].
-
- "if brevityFlag is true, don't display long files when first selected"
- first5000 := directory getOnly: 3500 from: fileName.
- contents := 'File ''{1}'' is {2} bytes long.
- You may use the ''get'' command to read the entire file.
-
- Here are the first 3500 characters...
- ------------------------------------------
- {3}
- ------------------------------------------
- ... end of the first 3500 characters.' translated format: {fileName. sizeStr. first5000}.
- brevityState := #briefFile. "don't change till actually read"
- ^ contents.
-
- !
Item was removed:
- ----- Method: FileList>>recentDirs (in category 'private') -----
- recentDirs
- "Put up a menu and let the user select from the list of recently visited directories."
-
- | dirName |
- RecentDirs isEmpty ifTrue: [^self].
- dirName := UIManager default chooseFrom: RecentDirs values: RecentDirs.
- dirName == nil ifTrue: [^self].
- self directory: (FileDirectory on: dirName)!
Item was removed:
- ----- Method: FileList>>registeredFileReaderClasses (in category 'private') -----
- registeredFileReaderClasses
- "return the list of classes that provide file reader services"
-
- ^ FileServices registeredFileReaderClasses!
Item was removed:
- ----- Method: FileList>>release (in category 'initialization') -----
- release
-
- self modelSleep!
Item was removed:
- ----- Method: FileList>>removeServer (in category 'server list') -----
- removeServer
-
- | choice names |
- self flag: #ViolateNonReferenceToOtherClasses.
- names := ServerDirectory serverNames.
- choice := UIManager default chooseFrom: names values: names.
- choice == nil ifTrue: [^ self].
- ServerDirectory removeServerNamed: choice!
Item was removed:
- ----- Method: FileList>>renameFile (in category 'file menu action') -----
- renameFile
- "Rename the currently selected file"
- | newName response |
- listIndex = 0 ifTrue: [^ self].
- self okToChange ifFalse: [^ self].
- (response := UIManager default request: 'NewFileName?' translated
- initialAnswer: fileName)
- isEmpty ifTrue: [^ self].
- newName := response asFileName.
- newName = fileName ifTrue: [^ self].
- directory rename: fileName toBe: newName.
- self updateFileList.
- listIndex := list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName].
- listIndex > 0 ifTrue: [fileName := newName].
- self changed: #fileListIndex.
- !
Item was removed:
- ----- Method: FileList>>resort: (in category 'private') -----
- resort: newMode
- "Re-sort the list of files."
- | name |
- listIndex > 0 ifTrue: [ name := self fileNameFromFormattedItem: (list at: listIndex) ].
- sortMode := newMode.
- self pattern: pattern.
- name ifNotNil:
- [ fileName := name.
- listIndex := list findFirst:
- [ : item | (self fileNameFromFormattedItem: item) = name ].
- self
- changed: #fileListIndex ;
- changed: #labelString ].
- listIndex = 0 ifTrue: [ self changed: #contents ].
- self updateButtonRow!
Item was removed:
- ----- Method: FileList>>rootDirectoryList (in category 'directory tree') -----
- rootDirectoryList
- | dirList dir servers |
- dir := FileDirectory on: ''.
- dirList := dir directoryNames collect:[:each| dir directoryNamed: each]..
- dirList isEmpty ifTrue:[dirList := Array with: FileDirectory default].
- servers := ServerDirectory serverNames collect: [ :n | ServerDirectory serverNamed: n].
- "This is so FileListPlus will work on ancient Squeak versions."
- servers := servers select:[:each| each respondsTo: #localName].
- ^dirList, servers!
Item was removed:
- ----- Method: FileList>>selectEncoding (in category 'private') -----
- selectEncoding
-
- | encodingItems |
- encodingItems := OrderedCollection new.
- TextConverter allSubclasses do: [:each | | names |
- names := each encodingNames.
- names notEmpty ifTrue: [ | label |
- label := '' writeStream.
- names do: [:eachName | label nextPutAll: eachName ] separatedBy: [ label nextPutAll: ', '].
- encodingItems add: {label contents. names first asSymbol}.
- ].
- ].
- brevityState := UIManager default
- chooseFrom: (encodingItems collect: [:spec| spec first])
- values: (encodingItems collect: [:spec| spec last]).
- brevityState ifNil: [brevityState := #needToGetBrief].
- !
Item was removed:
- ----- Method: FileList>>selectedPath (in category 'directory tree') -----
- selectedPath
- | top here |
- top := FileDirectory root.
- here := directory.
- ^(Array streamContents:[:s| | next |
- s nextPut: here.
- [next := here containingDirectory.
- top pathName = next pathName] whileFalse:[
- s nextPut: next.
- here := next.
- ]]) reversed.!
Item was removed:
- ----- Method: FileList>>serviceAddNewDirectory (in category 'own services') -----
- serviceAddNewDirectory
- "Answer a service entry characterizing the 'add new directory' command"
-
- ^ SimpleServiceEntry
- provider: self
- label: 'add new directory' translatedNoop
- selector: #addNewDirectory
- description: 'adds a new, empty directory (folder)' translatedNoop!
Item was removed:
- ----- Method: FileList>>serviceAddNewFile (in category 'own services') -----
- serviceAddNewFile
- "Answer a service entry characterizing the 'add new file' command"
-
- ^ SimpleServiceEntry
- provider: self
- label: 'add new file' translatedNoop
- selector: #addNewFile
- description: 'create a new,. empty file, and add it to the current directory.' translatedNoop!
Item was removed:
- ----- Method: FileList>>serviceAllFileOptions (in category 'own services') -----
- serviceAllFileOptions
-
- ^ {SimpleServiceEntry
- provider: self
- label: 'more...' translatedNoop
- selector: #offerAllFileOptions
- description: 'show all the options available' translatedNoop}!
Item was removed:
- ----- Method: FileList>>serviceCompressFile (in category 'own services') -----
- serviceCompressFile
- "Answer a service for compressing a file"
-
- ^ SimpleServiceEntry
- provider: self
- label: 'compress' translatedNoop
- selector: #compressFile
- description: 'compress file' translatedNoop
- buttonLabel: 'compress' translatedNoop!
Item was removed:
- ----- Method: FileList>>serviceCopyName (in category 'own services') -----
- serviceCopyName
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'copy name to clipboard' translatedNoop
- selector: #copyName
- description:'copy name to clipboard' translatedNoop )!
Item was removed:
- ----- Method: FileList>>serviceDeleteFile (in category 'own services') -----
- serviceDeleteFile
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'delete' translatedNoop
- selector: #deleteFile)
- description: 'delete the seleted item' translatedNoop!
Item was removed:
- ----- Method: FileList>>serviceGet (in category 'own services') -----
- serviceGet
- "Answer a service for getting the entire file"
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'get entire file' translatedNoop
- selector: #get
- description: 'if the file has only been partially read in, because it is very large, read the entire file in at this time.' translatedNoop)!
Item was removed:
- ----- Method: FileList>>serviceGetEncodedText (in category 'own services') -----
- serviceGetEncodedText
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'view as encoded text' translatedNoop
- selector: #getEncodedText
- description: 'view as encoded text' translatedNoop)
-
- !
Item was removed:
- ----- Method: FileList>>serviceGetHex (in category 'own services') -----
- serviceGetHex
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'view as hex' translatedNoop
- selector: #getHex
- description: 'view as hex' translatedNoop)
-
- !
Item was removed:
- ----- Method: FileList>>serviceRenameFile (in category 'own services') -----
- serviceRenameFile
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'rename' translatedNoop
- selector: #renameFile
- description: 'rename file' translatedNoop)!
Item was removed:
- ----- Method: FileList>>serviceSortByDate (in category 'own services') -----
- serviceSortByDate
- "Answer a service for sorting by date"
-
- ^ (SimpleServiceEntry new
- provider: self
- label: 'by date' translatedNoop
- selector: #sortByDate
- description: 'sort entries by date' translatedNoop)
- extraSelector: #sortingByDate;
- buttonLabel: 'date' translatedNoop!
Item was removed:
- ----- Method: FileList>>serviceSortByName (in category 'own services') -----
- serviceSortByName
- "Answer a service for soring by name"
-
- ^ (SimpleServiceEntry new
- provider: self label: 'by name' translatedNoop
- selector: #sortByName
- description: 'sort entries by name' translatedNoop)
- extraSelector: #sortingByName;
- buttonLabel: 'name' translatedNoop!
Item was removed:
- ----- Method: FileList>>serviceSortBySize (in category 'own services') -----
- serviceSortBySize
- "Answer a service for sorting by size"
-
- ^ (SimpleServiceEntry
- provider: self
- label: 'by size' translatedNoop
- selector: #sortBySize
- description: 'sort entries by size' translatedNoop)
- extraSelector: #sortingBySize;
- buttonLabel: 'size' translatedNoop!
Item was removed:
- ----- Method: FileList>>serviceViewContentsInWorkspace (in category 'own services') -----
- serviceViewContentsInWorkspace
- "Answer a service for viewing the contents of a file in a workspace"
-
- ^ (SimpleServiceEntry provider: self label: 'workspace with contents' translatedNoop
- selector: #viewContentsInWorkspace)
- description: 'open a new Workspace whose contents are set to the contents of this file' translatedNoop!
Item was removed:
- ----- Method: FileList>>servicesFileContentsMenu: (in category 'file list menu') -----
- servicesFileContentsMenu: aMenu
- "Construct aMenu to have items appropriate for the file browser's code pane, for the unshifted state"
- <fileContentsMenuShifted: false>
-
- fileName ifNotNil: [| services maybeLine extraLines |
- services := OrderedCollection new.
- (#(briefHex briefFile needToGetBriefHex needToGetBrief) includes: brevityState) ifTrue:
- [services add: self serviceGet].
- (#(fullHex briefHex needToGetFullHex needToGetBriefHex) includes: brevityState) ifFalse:
- [services add: self serviceGetHex].
- (#(needToGetShiftJIS needToGetEUCJP needToGetCNGB needToGetEUCKR needToGetUTF8) includes: brevityState) ifFalse:
- [services add: self serviceGetEncodedText].
- maybeLine := services size.
- (FileStream sourceFileSuffixes includes: self suffixOfSelectedFile) ifTrue:
- [services addAll:
- (self servicesFromSelectorSpecs:
- #(fileIntoNewChangeSet: fileIn: browseChangesFile: browseFile:))].
-
- extraLines := OrderedCollection new.
- maybeLine > 0 ifTrue: [extraLines add: maybeLine].
- services size > maybeLine ifTrue: [extraLines add: services size].
- aMenu
- addServices: services
- for: self
- extraLines: extraLines].
- ^ aMenu
- !
Item was removed:
- ----- Method: FileList>>servicesFromSelectorSpecs: (in category 'own services') -----
- servicesFromSelectorSpecs: symbolArray
- "Answer an array of services represented by the incoming symbols, eliminating any that do not have a currently-registered service. Pass the symbol #- along unchanged to serve as a separator between services"
-
- "FileList new servicesFromSelectorSpecs: #(fileIn: fileIntoNewChangeSet: browseChangesFile:)"
-
- | services col |
- col := OrderedCollection new.
- services := FileServices allRegisteredServices, (self myServicesForFile: #dummy suffix: '*').
- symbolArray do:
- [:sel | | res |
- sel == #-
- ifTrue:
- [col add: sel]
- ifFalse:
- [res := services
- detect: [:each | each selector = sel] ifNone: [nil].
- res notNil
- ifTrue: [col add: res]]].
- ^ col!
Item was removed:
- ----- Method: FileList>>servicesVolumeMenu: (in category 'volume menu') -----
- servicesVolumeMenu: aMenu
- <volumeMenu>
- aMenu
- addServices: (self itemsForDirectory: self directory)
- for: self
- extraLines: #().
- ^aMenu.!
Item was removed:
- ----- Method: FileList>>setDefaultEncoderFor: (in category 'private') -----
- setDefaultEncoderFor: fileStream
- "Based on former #defaultEncoderFor:."
-
- | l |
- l := fileStream fullName asLowercase.
- " ((l endsWith: FileStream multiCs) or: [
- l endsWith: FileStream multiSt]) ifTrue: [
- ^ UTF8TextConverter new.
- ].
- "
- ((l endsWith: FileStream cs) or: [l endsWith: FileStream st])
- ifTrue: [fileStream setConverterForCode]
- ifFalse: [fileStream converter: ISO88591TextConverter new].!
Item was removed:
- ----- Method: FileList>>setDirectoryTo: (in category 'directory tree') -----
- setDirectoryTo: dir
- "Set the current directory shown in the FileList.
- Does not allow setting the directory to nil since this blows up in various places."
- dir ifNil:[^self].
- self directory: dir.
- brevityState := #FileList.
- self changed: #fileList.
- self changed: #contents.
- self changed: #pathAndPattern.!
Item was removed:
- ----- Method: FileList>>setFileStream: (in category 'initialization') -----
- setFileStream: aStream
- "Used to initialize a spawned file editor. Sets directory too."
- self directory: aStream directory.
- fileName := aStream localName.
- pattern := '*'.
- listIndex := 1. "pretend a file is selected"
- aStream close.
- brevityState := #needToGetBrief.
- self
- changed: #contents ;
- changed: #labelString!
Item was removed:
- ----- Method: FileList>>shiftedFileContentsMenu: (in category 'file list menu') -----
- shiftedFileContentsMenu: aMenu
- "Delegate the shifted menu to the default shifted menu"
- <fileContentsMenuShifted: true>
- ^ aMenu addList: self class shiftedYellowButtonMenuItems; yourself
- !
Item was removed:
- ----- Method: FileList>>sortBlock (in category 'private') -----
- sortBlock
- "Answer block to decide what order to display the directory entries."
-
- ^ [ :x :y |
- (x isDirectory = y isDirectory)
- ifTrue: [
- "sort by user-specified criterion"
- sortMode = #name
- ifTrue: [(x name compare: y name) <= 2]
- ifFalse: [ sortMode = #date
- ifTrue: [ x modificationTime = y modificationTime
- ifTrue: [ (x name compare: y name) <= 2 ]
- ifFalse: [ x modificationTime > y modificationTime ] ]
- ifFalse: [ "size"
- x fileSize = y fileSize
- ifTrue: [ (x name compare: y name) <= 2 ]
- ifFalse: [ x fileSize > y fileSize ] ] ] ]
- ifFalse: [
- "directories always precede files"
- x isDirectory ] ]!
Item was removed:
- ----- Method: FileList>>sortByDate (in category 'file menu action') -----
- sortByDate
- self resort: #date!
Item was removed:
- ----- Method: FileList>>sortByName (in category 'file menu action') -----
- sortByName
- self resort: #name!
Item was removed:
- ----- Method: FileList>>sortBySize (in category 'file menu action') -----
- sortBySize
- self resort: #size!
Item was removed:
- ----- Method: FileList>>sortingByDate (in category 'private') -----
- sortingByDate
- ^ sortMode == #date!
Item was removed:
- ----- Method: FileList>>sortingByName (in category 'private') -----
- sortingByName
- ^ sortMode == #name!
Item was removed:
- ----- Method: FileList>>sortingBySize (in category 'private') -----
- sortingBySize
- ^ sortMode == #size!
Item was removed:
- ----- Method: FileList>>spawn: (in category 'file menu action') -----
- spawn: code
- "Open a simple Edit window"
-
- listIndex = 0 ifTrue: [^ self].
- self class openEditorOn: (directory readOnlyFileNamed: fileName)
- "read only just for initial look"
- editString: code!
Item was removed:
- ----- Method: FileList>>step (in category 'private') -----
- step
- | ext |
- brevityState = #graphic ifTrue: [
- ext := self availableGraphicsExtent.
- ext = lastGraphicsExtent ifFalse: [
- lastGraphicsExtent := ext.
- brevityState := #needToGetGraphic.
- self changed: #contents]]!
Item was removed:
- ----- Method: FileList>>stepTimeIn: (in category 'private') -----
- stepTimeIn: aWindow
- ^500!
Item was removed:
- ----- Method: FileList>>subDirectoriesOf: (in category 'directory tree') -----
- subDirectoriesOf: aDirectory
- "provide a list of subdirectory names sorted alphnum-no-case"
-
- ^(aDirectory directoryNames sorted: [:a :b| (a compare: b) <= 2]) collect:[:each| aDirectory directoryNamed: each].!
Item was removed:
- ----- Method: FileList>>suffixOfSelectedFile (in category 'file list menu') -----
- suffixOfSelectedFile
- "Answer the file extension of the receiver's selected file"
- ^ FileServices suffixOf: self fullName.!
Item was removed:
- ----- Method: FileList>>topConstantHeightFrame:fromLeft:width: (in category 'toolbuilder') -----
- topConstantHeightFrame: height fromLeft: leftFraction width: rightFraction
- ^LayoutFrame new
- topFraction: 0 offset: 0;
- leftFraction: leftFraction offset: 0;
- rightFraction: (leftFraction + rightFraction) offset: 0;
- bottomFraction: 0 offset: height;
- yourself.!
Item was removed:
- ----- Method: FileList>>universalButtonServices (in category 'initialization') -----
- universalButtonServices
- "Answer a list of services underlying the universal buttons in their initial inception. For the moment, only the sorting buttons are shown."
-
- ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize}!
Item was removed:
- ----- Method: FileList>>update: (in category 'updating') -----
- update: aParameter
- "Receive a change notice from an object of whom the receiver is a dependent"
-
- (aParameter == #fileListChanged) ifTrue: [self updateFileList].
- super update: aParameter!
Item was removed:
- ----- Method: FileList>>updateButtonRow (in category 'initialization') -----
- updateButtonRow
- "Dynamically update the contents of the button row, if any."
- self changed: #getButtonRow.!
Item was removed:
- ----- Method: FileList>>updateFileList (in category 'private') -----
- updateFileList
- "Update my files list with file names in the current directory
- that match the pattern.
- The pattern string may have embedded newlines or semicolons; these separate different patterns."
- | patterns |
- patterns := OrderedCollection new.
- Cursor wait showWhile: [
- (pattern findTokens: (String with: Character cr with: Character lf with: $;))
- do: [ :each |
- (each includes: $*) | (each includes: $#)
- ifTrue: [ patterns add: each]
- ifFalse: [each isEmpty
- ifTrue: [ patterns add: '*']
- ifFalse: [ patterns add: '*' , each , '*']]].
-
- list := self listForPatterns: patterns.
- listIndex := 0.
- volListIndex := volList size.
- fileName := nil.
- contents := ''.
- self changed: #volumeListIndex.
- self changed: #fileList.
- self updateButtonRow]!
Item was removed:
- ----- Method: FileList>>veryDeepFixupWith: (in category 'volume list and pattern') -----
- veryDeepFixupWith: deepCopier
- super veryDeepFixupWith: deepCopier.
- volListIndex := 1.
- self directory: FileDirectory default.
- self updateFileList!
Item was removed:
- ----- Method: FileList>>viewContentsInWorkspace (in category 'own services') -----
- viewContentsInWorkspace
- "View the contents of my selected file in a new workspace."
-
- | fileContents workspace lineEndConvention |
- fileContents := self directory
- readOnlyFileNamed: self fileName
- do: [:fileStream |
- fileStream
- setConverterForCode;
- wantsLineEndConversion: true.
- lineEndConvention := fileStream detectLineEndConvention.
- fileStream contents].
- workspace := (Project uiManager edit: fileContents label: nil shouldStyle: Workspace shouldStyle) model.
-
- "Remember certain information to allow edits in the same file."
- workspace
- windowTitle: (self directory localNameFor: self fileName);
- fileDirectory: self directory;
- fileLineEndConvention: lineEndConvention;
- saveContentsInFileOnAccept.
- !
Item was removed:
- ----- Method: FileList>>volumeList (in category 'volume list and pattern') -----
- volumeList
- "Answer the current list of volumes."
-
- ^ volList
- !
Item was removed:
- ----- Method: FileList>>volumeListIndex (in category 'volume list and pattern') -----
- volumeListIndex
- "Answer the index of the currently selected volume."
-
- ^ volListIndex
- !
Item was removed:
- ----- Method: FileList>>volumeListIndex: (in category 'volume list and pattern') -----
- volumeListIndex: index
- "Select the volume name having the given index."
-
- | delim path |
- volListIndex := index.
- index = 1
- ifTrue: [self directory: (FileDirectory on: '')]
- ifFalse: [delim := directory pathNameDelimiter.
- path := String streamContents: [:strm |
- 2 to: index do: [:i |
- strm nextPutAll: (volList at: i) withBlanksTrimmed.
- i < index ifTrue: [strm nextPut: delim]]].
- self directory: (FileDirectory on: path)].
- brevityState := #FileList.
- self addPath: path.
- self changed: #fileList.
- self changed: #contents.
- self updateButtonRow.!
Item was removed:
- ----- Method: FileList>>volumeMenu: (in category 'volume menu') -----
- volumeMenu: aMenu
- ^ self menu: aMenu for: #(volumeMenu volumeMenuShifted:)
- !
Item was removed:
- ----- Method: FileList>>wantsDraggedObject: (in category 'drag''n''drop') -----
- wantsDraggedObject: anObject
-
- ^ anObject class == DirectoryEntryFile!
Item was removed:
- ----- Method: FileList>>wantsSteps (in category 'private') -----
- wantsSteps
- ^true!
Item was removed:
- FileList subclass: #FileList2
- instanceVariableNames: 'showDirsInFileList currentDirectorySelected fileSelectionBlock dirSelectionBlock optionalButtonSpecs modalView directoryChangeBlock ok'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-FileList'!
- FileList2 class
- instanceVariableNames: 'lastSelDir'!
-
- !FileList2 commentStamp: 'BJP 11/19/2003 21:13' prior: 0!
- Some variations on FileList that
- - use a hierarchical pane to show folder structure
- - use different pane combinations, button layouts and prefiltering for specific uses
-
- FileList2 morphicView openInWorld "an alternative to the standard FileList"
- FileList2 morphicViewNoFile openInWorld "useful for selecting, but not viewing"
- FileList2 morphicViewProjectLoader openInWorld "useful for finding and loading projects"
- FileList2 modalFolderSelector "allows the user to select a folder"
-
-
-
- !
- FileList2 class
- instanceVariableNames: 'lastSelDir'!
Item was removed:
- ----- Method: FileList2 class>>addFullPanesTo:from: (in category 'utility') -----
- addFullPanesTo: window from: aCollection
-
-
-
- aCollection do: [ :each | | frame |
- frame := LayoutFrame
- fractions: each second
- offsets: each third.
- window addMorph: each first fullFrame: frame.
- ]!
Item was removed:
- ----- Method: FileList2 class>>blueButtonText:textColor:color:inWindow: (in category 'blue ui') -----
- blueButtonText: aString textColor: textColor color: aColor inWindow: window
- | result |
- result := window
- fancyText: aString translated
- font: Preferences standardEToysFont
- color: textColor.
- result setProperty: #buttonText toValue: aString;
- hResizing: #rigid;
- extent: 100 @ 20;
- layoutInset: 4;
- borderWidth: 1;
- useRoundedCorners.
- aColor isNil
- ifFalse: [""result color: aColor. result borderColor: aColor muchDarker].
- ^ result!
Item was removed:
- ----- Method: FileList2 class>>blueButtonText:textColor:color:inWindow:balloonText:selector:recipient: (in category 'blue ui') -----
- blueButtonText: aString textColor: textColor color: aColor inWindow: window balloonText: balloonText selector: sel recipient: recip
- | result |
- result := window
- fancyText: aString translated
- font: Preferences standardEToysFont
- color: textColor.
- result setProperty: #buttonText toValue: aString;
- hResizing: #rigid;
- extent: 100 @ 20;
- layoutInset: 4;
- borderWidth: 1;
- useRoundedCorners;
- setBalloonText: balloonText.
- result
- on: #mouseUp
- send: sel
- to: recip.
- aColor isNil
- ifFalse: [""
- result color: aColor.
- result borderColor: aColor muchDarker].
- ^ result!
Item was removed:
- ----- Method: FileList2 class>>blueButtonText:textColor:inWindow: (in category 'blue ui') -----
- blueButtonText: aString textColor: textColor inWindow: window
- ^ self
- blueButtonText: aString
- textColor: textColor
- color: nil
- inWindow: window!
Item was removed:
- ----- Method: FileList2 class>>blueButtonText:textColor:inWindow:balloonText:selector:recipient: (in category 'blue ui') -----
- blueButtonText: aString textColor: textColor inWindow: window balloonText: balloonText selector: sel recipient: recip
- ^ self
- blueButtonText: aString
- textColor: textColor
- color: nil
- inWindow: window
- balloonText: balloonText
- selector: sel
- recipient: recip !
Item was removed:
- ----- Method: FileList2 class>>enableTypeButtons:info:forDir: (in category 'blue ui') -----
- enableTypeButtons: typeButtons info: fileTypeInfo forDir: aDirectory
-
- | foundSuffixes firstEnabled |
-
- firstEnabled := nil.
- foundSuffixes := (aDirectory ifNil: [ #()] ifNotNil: [ aDirectory fileNames]) collect: [ :each | (each findTokens: '.') last asLowercase].
- foundSuffixes := foundSuffixes asSet.
- fileTypeInfo with: typeButtons do: [ :info :button | | enableIt fileSuffixes |
- fileSuffixes := info second.
- enableIt := fileSuffixes anySatisfy: [ :patt | foundSuffixes includes: patt].
- button
- setProperty: #enabled
- toValue: enableIt.
- enableIt ifTrue: [firstEnabled ifNil: [firstEnabled := button]].
- ].
- firstEnabled ifNotNil: [^firstEnabled mouseUp: nil].
- typeButtons do: [ :each | each color: Color gray].
-
- !
Item was removed:
- ----- Method: FileList2 class>>endingSpecs (in category 'blue ui') -----
- endingSpecs
- "Answer a collection of specs to build the selective 'find anything' tool called by the Navigator. This version uses the services registry to do so."
- "FileList2 morphicViewGeneralLoaderInWorld: Project current world"
- | specs rejects |
- rejects := #(addFileToNewZip: compressFile: openInZipViewer: extractAllFrom: openOn:).
- specs := OrderedCollection new.
- self fileExtensionsByCategory keysAndValuesDo: [:category :extensions |
- | services okExtensions |
- services := Dictionary new.
- okExtensions := Set new.
-
- extensions do: [:ext |
- (FileServices itemsForFile: (FileDirectory default fullPathFor: 'fred.' , ext))
- reject: [:service | rejects includes: service selector]
- thenDo: [:service |
- services at: service label put: service.
- okExtensions add: ext]].
- services isEmpty ifFalse: [
- specs add: {
- category.
- okExtensions.
- services values }]].
- ^ specs!
Item was removed:
- ----- Method: FileList2 class>>fileExtensionsByCategory (in category 'blue ui') -----
- fileExtensionsByCategory
-
- ^ OrderedDictionary new
- at: 'Art' put: ImageReadWriter allTypicalFileExtensions;
- at: 'Morphs' put: #('morph' 'morphs' 'sp');
- at: 'Projects' put: #('extseg' 'project' 'pr');
- at: 'MIDI' put: #('mid' 'midi');
- at: 'Music' put: #('mp3');
- at: 'Movies' put: #('movie' 'mpg' 'mpeg' 'qt' 'mov');
- at: 'Flash' put: #('swf');
- "at: 'Books' put: #('bo');
- at: 'Code' put: #('st' 'cs');
- at: 'TrueType' put: #('ttf');
- at: '3ds' put: #('3ds');
- at: 'Tape' put: #('tape');
- at: 'Wonderland' put: #('wrl');
- at: 'HTML' put: #('htm' 'html');"
- yourself!
Item was removed:
- ----- Method: FileList2 class>>hideSqueakletDirectoryBlock (in category 'blocks') -----
- hideSqueakletDirectoryBlock
- ^[:dirName| (dirName sameAs: 'Squeaklets') not]!
Item was removed:
- ----- Method: FileList2 class>>lastSelDir (in category 'accessing') -----
- lastSelDir
- "Return the last selected directory or the default directory if no directory was selected so far."
-
- ^lastSelDir ifNil: [ lastSelDir := FileDirectory default ]!
Item was removed:
- ----- Method: FileList2 class>>lastSelDir: (in category 'accessing') -----
- lastSelDir: aFileDirectory
- "Store the last selected directory. This will be selected as default in newly opened file or folder selectors"
-
- ^lastSelDir := aFileDirectory!
Item was removed:
- ----- Method: FileList2 class>>modalFileSelector (in category 'modal dialogs') -----
- modalFileSelector
-
- | window |
-
- window := self morphicViewFileSelector.
- window openCenteredInWorld.
- UserInterfaceTheme current applyTo: window allMorphs.
- self modalLoopOn: window.
- ^(window valueOfProperty: #fileListModel) getSelectedFile!
Item was removed:
- ----- Method: FileList2 class>>modalFileSelectorForSuffixes: (in category 'modal dialogs') -----
- modalFileSelectorForSuffixes: aList
-
- | window aFileList |
-
- window := self morphicViewFileSelectorForSuffixes: aList.
- aFileList := window valueOfProperty: #fileListModel.
- aFileList resort: #name.
- window openCenteredInWorld.
- UserInterfaceTheme current applyTo: window allMorphs.
- self modalLoopOn: window.
- ^aFileList getSelectedFile!
Item was removed:
- ----- Method: FileList2 class>>modalFileSelectorForSuffixes:directory: (in category 'modal dialogs') -----
- modalFileSelectorForSuffixes: aList directory: aDirectory
-
- | window aFileList |
-
- window := self morphicViewFileSelectorForSuffixes: aList directory: aDirectory.
- aFileList := window valueOfProperty: #fileListModel.
- window openCenteredInWorld.
- UserInterfaceTheme current applyTo: window allMorphs.
- self modalLoopOn: window.
- ^aFileList getSelectedFile!
Item was removed:
- ----- Method: FileList2 class>>modalFolderSelector (in category 'modal dialogs') -----
- modalFolderSelector
-
- ^self modalFolderSelector: self lastSelDir
- !
Item was removed:
- ----- Method: FileList2 class>>modalFolderSelector: (in category 'modal dialogs') -----
- modalFolderSelector: aDir
-
- | window fileModel |
- window := self morphicViewFolderSelector: aDir.
- fileModel := window model.
- window openInWorld: self currentWorld extent: 300@400.
- UserInterfaceTheme current applyTo: window allMorphs.
- self modalLoopOn: window.
- ^fileModel getSelectedDirectory withoutListWrapper!
Item was removed:
- ----- Method: FileList2 class>>modalFolderSelectorForProject: (in category 'modal dialogs') -----
- modalFolderSelectorForProject: aProject
- "
- FileList2 modalFolderSelectorForProject: Project current
- "
- "Not currently being converted to FileSaverDialog etc because it implements the decidedly outre looking 'blue ui' Project dialog. "
- | window fileModel w |
-
- window := FileList2 morphicViewProjectSaverFor: aProject.
- fileModel := window valueOfProperty: #FileList.
- w := self currentWorld.
- window position: w topLeft + (w extent - window extent // 2).
- w addMorphInLayer: window.
- w startSteppingSubmorphsOf: window.
- UserInterfaceTheme current applyTo: window allMorphs.
- self modalLoopOn: window.
- ^fileModel getSelectedDirectory withoutListWrapper!
Item was removed:
- ----- Method: FileList2 class>>modalFolderSelectorForProjectLoad (in category 'modal dialogs') -----
- modalFolderSelectorForProjectLoad
-
- | window fileModel w |
-
- window := self morphicViewProjectLoader2InWorld: self currentWorld reallyLoad: false.
- fileModel := window valueOfProperty: #FileList.
- w := self currentWorld.
- window position: w topLeft + (w extent - window extent // 2).
- window openInWorld: w.
- UserInterfaceTheme current applyTo: window allMorphs.
- self modalLoopOn: window.
- ^fileModel getSelectedDirectory withoutListWrapper!
Item was removed:
- ----- Method: FileList2 class>>modalLoopOn: (in category 'utility') -----
- modalLoopOn: aMorph
- [aMorph world notNil] whileTrue: [
- aMorph outermostWorldMorph doOneCycle.
- ].!
Item was removed:
- ----- Method: FileList2 class>>morphicView (in category 'morphic ui') -----
- morphicView
- ^ self morphicViewOnDirectory: FileDirectory default!
Item was removed:
- ----- Method: FileList2 class>>morphicViewFileSelector (in category 'morphic ui') -----
- morphicViewFileSelector
-
- ^self morphicViewFileSelectorForSuffixes: nil
- !
Item was removed:
- ----- Method: FileList2 class>>morphicViewFileSelectorForSuffixes: (in category 'morphic ui') -----
- morphicViewFileSelectorForSuffixes: aList
- "Answer a morphic file-selector tool for the given suffix list."
-
- ^self morphicViewFileSelectorForSuffixes: aList directory: self lastSelDir!
Item was removed:
- ----- Method: FileList2 class>>morphicViewFileSelectorForSuffixes:directory: (in category 'morphic ui') -----
- morphicViewFileSelectorForSuffixes: aList directory: dir
- "Answer a morphic file-selector tool for the given suffix list and the given directory."
-
- | aFileList window fixedSize midLine gap |
- aFileList := self new directory: dir.
- aFileList optionalButtonSpecs: aFileList okayAndCancelServices.
- aList ifNotNil:
- [aFileList fileSelectionBlock: [:entry :myPattern |
- entry isDirectory
- ifTrue:
- [false]
- ifFalse:
- [aList includes: (FileDirectory extensionFor: entry name asLowercase)]]].
- window := BorderedMorph new
- layoutPolicy: ProportionalLayout new;
- color: Color lightBlue;
- borderColor: Color blue;
- borderWidth: 4;
- layoutInset: 4;
- extent: 600@400;
- useRoundedCorners.
- window setProperty: #fileListModel toValue: aFileList.
- aFileList modalView: window.
- midLine := 0.4.
- fixedSize := 25.
- gap := 5.
- self addFullPanesTo: window from: {
- {self textRow: 'Please select a file'. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}.
- {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@fixedSize corner: 0@(fixedSize * 2)}.
- {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1.
- gap @(fixedSize * 2) corner: gap negated@0}.
- {aFileList morphicFileListPane. midLine @ 0 corner: 1@1.
- gap@(fixedSize * 2) corner: gap negated@0}.
- }.
-
- aFileList postOpen.
-
- ^ window !
Item was removed:
- ----- Method: FileList2 class>>morphicViewFolderSelector (in category 'morphic ui') -----
- morphicViewFolderSelector
-
- ^self morphicViewFolderSelector: FileDirectory default!
Item was removed:
- ----- Method: FileList2 class>>morphicViewFolderSelector: (in category 'morphic ui') -----
- morphicViewFolderSelector: aDir
- "Answer a tool that allows the user to select a folder"
-
- | aFileList window fixedSize |
- aFileList := self new directory: aDir.
- aFileList optionalButtonSpecs: aFileList servicesForFolderSelector.
- window := (SystemWindow labelled: aDir pathName) model: aFileList.
- aFileList modalView: window.
-
- fixedSize := 25.
- self addFullPanesTo: window from: {
- {self textRow: 'Please select a folder'. 0 @ 0 corner: 1 @ 0.
- 0@0 corner: 0@fixedSize}.
- {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0.
- 0@fixedSize corner: 0@(fixedSize * 2)}.
- {aFileList morphicDirectoryTreePane. 0@0 corner: 1@1.
- 0@(fixedSize * 2) corner: 0@0}.
- }.
- aFileList postOpen.
- ^ window !
Item was removed:
- ----- Method: FileList2 class>>morphicViewGeneralLoaderInWorld: (in category 'blue ui') -----
- morphicViewGeneralLoaderInWorld: aWorld
- "
- FileList2 morphicViewGeneralLoaderInWorld: self currentWorld
- "
- | window aFileList buttons treePane textColor1 fileListPane pane2a pane2b fileTypeInfo fileTypeButtons fileTypeRow actionRow |
-
- fileTypeInfo := self endingSpecs.
- window := AlignmentMorphBob1 newColumn.
- window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
- textColor1 := Color r: 0.742 g: 0.839 b: 1.0.
- aFileList := self new directory: FileDirectory default.
- aFileList
- fileSelectionBlock: self projectOnlySelectionBlock;
- modalView: window.
- window
- setProperty: #FileList toValue: aFileList;
- wrapCentering: #center; cellPositioning: #topCenter;
- borderWidth: 1;
- borderColor: (Color r: 0.9 g: 0.801 b: 0.2);
- useRoundedCorners.
-
- fileTypeButtons := fileTypeInfo collect: [ :each |
- (self blueButtonText: each first textColor: Color gray inWindow: window)
- setProperty: #enabled toValue: true;
- hResizing: #shrinkWrap;
- useSquareCorners
- ].
- buttons := {{'OK'. Color lightGreen}. {'Cancel'. Color lightRed}} collect: [ :each |
- self blueButtonText: each first textColor: textColor1 color: each second inWindow: window
- ].
-
- treePane := aFileList morphicDirectoryTreePane
- extent: 250@300;
- retractable: false;
- borderWidth: 0.
- fileListPane := aFileList morphicFileListPane
- extent: 350@300;
- retractable: false;
- borderWidth: 0.
- window addARow: {window fancyText: 'Find...' translated font: Preferences standardEToysTitleFont color: textColor1}.
- fileTypeRow := window addARowCentered: fileTypeButtons cellInset: 2.
- actionRow := window addARowCentered: {
- buttons first.
- (Morph new extent: 30@5) color: Color transparent.
- buttons second
- } cellInset: 2.
- window
- addARow: {
- (window inAColumn: {(pane2a := window inARow: {window inAColumn: {treePane}})
- useRoundedCorners;
- layoutInset: 0;
- borderWidth: 1;
- borderColor: (Color r: 0.6 g: 0.7 b: 1)
- }) layoutInset: 10.
- (window inAColumn: {(pane2b := window inARow: {window inAColumn: {fileListPane}})
- useRoundedCorners;
- layoutInset: 0;
- borderWidth: 1;
- borderColor: (Color r: 0.6 g: 0.7 b: 1)
- }) layoutInset: 10.
- }.
- window fullBounds.
- window fillWithRamp: (Color r: 1 g: 0.85 b: 0.975) oriented: 0.65.
- pane2a fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35).
- pane2b fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35).
- "
- buttons do: [ :each |
- each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0).
- ].
- "
- fileTypeButtons do: [ :each |
- each
- on: #mouseUp
- send: #value:value:
- to: [ :evt :morph |
- self update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph.
- ]
- ].
- buttons first on: #mouseUp send: #okHit to: aFileList.
- buttons second on: #mouseUp send: #cancelHit to: aFileList.
- aFileList postOpen.
- window position: aWorld topLeft + (aWorld extent - window extent // 2).
- aFileList directoryChangeBlock: [ :newDir |
- self update: actionRow in: window fileTypeRow: fileTypeRow morphUp: nil.
- self enableTypeButtons: fileTypeButtons info: fileTypeInfo forDir: newDir.
- ].
- aFileList directory: aFileList directory.
- window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
- ^ window openInWorld: aWorld.!
Item was removed:
- ----- Method: FileList2 class>>morphicViewImageViewer (in category 'morphic ui') -----
- morphicViewImageViewer
-
- | dir aFileList window midLine fixedSize |
-
- dir := FileDirectory default.
- aFileList := self new directory: dir.
- aFileList optionalButtonSpecs: aFileList specsForImageViewer.
- aFileList fileSelectionBlock: [ :entry :myPattern |
- entry isDirectory ifTrue: [
- false
- ] ifFalse: [
- #('bmp' 'gif' 'jpg' 'form' 'png') includes:
- (FileDirectory extensionFor: entry name asLowercase)
- ]
- ].
- window := (SystemWindow labelled: dir pathName) model: aFileList.
-
- fixedSize := 25.
- midLine := 0.4.
- self addFullPanesTo: window from: {
- {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0.
- 0@0 corner: 0@fixedSize}.
- {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1.
- 0@fixedSize corner: 0@0}.
- {aFileList morphicFileListPane. midLine @ 0 corner: 1@1.
- 0@fixedSize corner: 0@0}.
- }.
- aFileList postOpen.
- ^ window !
Item was removed:
- ----- Method: FileList2 class>>morphicViewNoFile (in category 'morphic ui') -----
- morphicViewNoFile
-
- | dir aFileList window midLine fixedSize |
-
- dir := FileDirectory default.
- aFileList := self new directory: dir.
- window := (SystemWindow labelled: dir pathName) model: aFileList.
-
- fixedSize := 25.
- midLine := 0.4.
- self addFullPanesTo: window from: {
- {aFileList morphicPatternPane. 0@0 corner: 0.3@0. 0@0 corner: 0@fixedSize}.
- {aFileList optionalButtonRow. 0.3 @ 0 corner: 1@0. 0@0 corner: 0@fixedSize}.
- {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}.
- {aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}.
- }.
- aFileList postOpen.
- ^ window !
Item was removed:
- ----- Method: FileList2 class>>morphicViewProjectLoader (in category 'morphic ui') -----
- morphicViewProjectLoader
-
- | dir aFileList window midLine fixedSize |
-
- dir := FileDirectory default.
- aFileList := self new directory: dir.
- aFileList optionalButtonSpecs: aFileList servicesForProjectLoader.
- aFileList fileSelectionBlock: self projectOnlySelectionBlock.
- window := (SystemWindow labelled: dir pathName) model: aFileList.
-
- fixedSize := 25.
- midLine := 0.4.
- self addFullPanesTo: window from: {
- {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}.
- {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}.
- {aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}.
- }.
- aFileList postOpen.
- ^ window !
Item was removed:
- ----- Method: FileList2 class>>morphicViewProjectLoader2InWorld: (in category 'blue ui') -----
- morphicViewProjectLoader2InWorld: aWorld
-
- ^self morphicViewProjectLoader2InWorld: aWorld reallyLoad: true!
Item was removed:
- ----- Method: FileList2 class>>morphicViewProjectLoader2InWorld:reallyLoad: (in category 'blue ui') -----
- morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean
-
- ^self
- morphicViewProjectLoader2InWorld: aWorld
- reallyLoad: aBoolean
- dirFilterType: #initialDirectoryList
- !
Item was removed:
- ----- Method: FileList2 class>>morphicViewProjectLoader2InWorld:reallyLoad:dirFilterType: (in category 'blue ui') -----
- morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean dirFilterType: aSymbol
-
- | window aFileList buttons treePane textColor1 fileListPane pane2a pane2b treeExtent filesExtent |
-
- window := AlignmentMorphBob1 newColumn.
- window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
- textColor1 := Color r: 0.742 g: 0.839 b: 1.0.
- aFileList := self new.
- aFileList
- optionalButtonSpecs: aFileList servicesForProjectLoader;
- fileSelectionBlock: (
- aSymbol == #limitedSuperSwikiDirectoryList ifTrue: [
- MessageSend receiver: Project current selector: #latestProjectVersionsFromFileEntries:
- ] ifFalse: [
- self projectOnlySelectionBlock
- ]
- );
- "dirSelectionBlock: self hideSqueakletDirectoryBlock;"
- modalView: window.
- aFileList directory: FileDirectory default.
- window
- setProperty: #FileList toValue: aFileList;
- wrapCentering: #center; cellPositioning: #topCenter;
- borderWidth: 1;
- borderColor: (Color r: 0.9 g: 0.801 b: 0.2);
- useRoundedCorners.
- buttons := {{'OK'. Color lightGreen}. {'Cancel'. Color lightRed}} collect: [ :each |
- self blueButtonText: each first textColor: textColor1 color: each second inWindow: window
- ].
-
- aWorld width < 800 ifTrue: [
- treeExtent := 150@300.
- filesExtent := 350@300.
- ] ifFalse: [
- treeExtent := 350@500.
- filesExtent := 550@500.
- ].
- (treePane := aFileList morphicDirectoryTreePaneFiltered: aSymbol)
- extent: treeExtent;
- retractable: false;
- borderWidth: 0.
- fileListPane := aFileList morphicFileListPane
- extent: filesExtent;
- retractable: false;
- borderWidth: 0.
- window
- addARow: {
- window fancyText: 'Load A Project' translated font: Preferences standardEToysTitleFont color: textColor1
- };
- addARowCentered: {
- buttons first.
- (Morph new extent: 30@5) color: Color transparent.
- buttons second
- };
- addARow: {
- window fancyText: 'Please select a project' translated font: Preferences standardEToysFont color: textColor1
- };
- addARow: {
- (window inAColumn: {(pane2a := window inARow: {window inAColumn: {treePane}})
- useRoundedCorners;
- layoutInset: 0;
- borderWidth: 1;
- borderColor: (Color r: 0.6 g: 0.7 b: 1)
- }) layoutInset: 10.
- (window inAColumn: {(pane2b := window inARow: {window inAColumn: {fileListPane}})
- useRoundedCorners;
- layoutInset: 0;
- borderWidth: 1;
- borderColor: (Color r: 0.6 g: 0.7 b: 1)
- }) layoutInset: 10.
- }.
- window fullBounds.
- window fillWithRamp: (Color r: 1 g: 0.85 b: 0.975) oriented: 0.65.
- pane2a fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35).
- pane2b fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35).
- "
- buttons do: [ :each |
- each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0).
- ].
- "
- buttons first
- on: #mouseUp
- send: (aBoolean ifTrue: [#okHitForProjectLoader] ifFalse: [#okHit])
- to: aFileList.
- buttons second on: #mouseUp send: #cancelHit to: aFileList.
- aFileList postOpen.
- window position: aWorld topLeft + (aWorld extent - window extent // 2).
- window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
- ^ window openInWorld: aWorld.!
Item was removed:
- ----- Method: FileList2 class>>morphicViewProjectSaverFor: (in category 'blue ui') -----
- morphicViewProjectSaverFor: aProject
- "
- (FileList2 morphicViewProjectSaverFor: Project current) openInWorld
- "
- | window aFileList buttons treePane pane2 textColor1 option treeExtent buttonData buttonRow |
-
- textColor1 := Color r: 0.742 g: 0.839 b: 1.0.
- aFileList := self new directory: ServerDirectory projectDefaultDirectory.
- aFileList dirSelectionBlock: self hideSqueakletDirectoryBlock.
- window := AlignmentMorphBob1 newColumn.
- window hResizing: #shrinkWrap; vResizing: #shrinkWrap.
- aFileList modalView: window.
- window
- setProperty: #FileList toValue: aFileList;
- wrapCentering: #center; cellPositioning: #topCenter;
- borderWidth: 1;
- borderColor: (Color r: 0.9 g: 0.801 b: 0.2);
- useRoundedCorners.
-
- buttonData := Preferences enableLocalSave
- ifTrue: [{
- {'Save'. #okHit. 'Save in the place specified below, and in the Squeaklets folder on your local disk'. Color lightGreen}.
- {'Save on local disk only'. #saveLocalOnlyHit. 'saves in the Squeaklets folder'. Color lightGreen}.
- {'Cancel'. #cancelHit. 'return without saving'. Color lightRed}
- }]
- ifFalse: [{
- {'Save'. #okHit. 'Save in the place specified below, and in the Squeaklets folder on your local disk'. Color lightGreen}.
- {'Cancel'. #cancelHit. 'return without saving'. Color lightRed}
- }].
- buttons := buttonData collect: [ :each |
- (self blueButtonText: each first textColor: textColor1 color: each fourth inWindow: window)
- setBalloonText: each third translated;
- hResizing: #shrinkWrap;
- on: #mouseUp send: each second to: aFileList
- ].
-
- option := aProject world
- valueOfProperty: #SuperSwikiPublishOptions
- ifAbsent: [#initialDirectoryList].
- aProject world removeProperty: #SuperSwikiPublishOptions.
-
- treeExtent := Project current world height < 500
- ifTrue: [ 350@150 ]
- ifFalse: [ 350@300 ].
-
- (treePane := aFileList morphicDirectoryTreePaneFiltered: option)
- extent: treeExtent;
- retractable: false;
- borderWidth: 0.
- window
- addARowCentered: {
- window fancyText: 'Publish This Project' translated font: Preferences standardEToysTitleFont color: textColor1
- }.
- buttonRow := OrderedCollection new.
- buttons do: [:button | buttonRow add: button] separatedBy: [buttonRow add: ((Morph new extent: 30@5) color: Color transparent)].
-
- " addARowCentered: {
- buttons first.
- (Morph new extent: 30@5) color: Color transparent.
- buttons second.
- (Morph new extent: 30@5) color: Color transparent.
- buttons third
- };"
- window
- addARowCentered: buttonRow;
- addARowCentered: { (window inAColumn: {(ProjectViewMorph on: aProject) lock}) layoutInset: 4};
- addARowCentered: {
- window fancyText: 'Please select a folder' translated font: Preferences standardEToysFont color: textColor1
- };
- addARow: {
- (
- window inAColumn: {
- (pane2 := window inARow: {window inAColumn: {treePane}})
- useRoundedCorners;
- layoutInset: 0;
- borderWidth: 1;
- borderColor: (Color r: 0.6 g: 0.7 b: 1)
- }
- ) layoutInset: 10
- }.
- window fullBounds.
- window fillWithRamp: (Color r: 1 g: 0.85 b: 0.975) oriented: 0.65.
- pane2 fillWithRamp: (Color r: 0.85 g: 0.9 b: 1) oriented: (0.7 @ 0.35).
- "
- buttons do: [ :each |
- each fillWithRamp: ColorTheme current dialogButtonsRampOrColor oriented: (0.75 @ 0).
- ].
- "
- window morphicLayerNumber: window class dialogLayer.
- aFileList postOpen.
- window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0).
- ^ window !
Item was removed:
- ----- Method: FileList2 class>>openMorphicViewInWorld (in category 'instance creation') -----
- openMorphicViewInWorld
- "FileList2 openMorphicViewInWorld"
- ^self morphicView openInWorld!
Item was removed:
- ----- Method: FileList2 class>>projectOnlySelectionBlock (in category 'blocks') -----
- projectOnlySelectionBlock
-
- ^[ :entry :myPattern |
- entry isDirectory ifTrue: [
- false
- ] ifFalse: [
- #('*.pr' '*.pr.gz' '*.project') anySatisfy: [ :each | each match: entry name]
- ]
- ]!
Item was removed:
- ----- Method: FileList2 class>>prototypicalToolWindow (in category 'instance creation') -----
- prototypicalToolWindow
- "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
-
- ^ self morphicView applyModelExtent!
Item was removed:
- ----- Method: FileList2 class>>selectionBlockForSuffixes: (in category 'blocks') -----
- selectionBlockForSuffixes: anArray
-
- ^[ :entry :myPattern |
- entry isDirectory ifTrue: [
- false
- ] ifFalse: [
- anArray anySatisfy: [ :each | each match: entry name]
- ]
- ]!
Item was removed:
- ----- Method: FileList2 class>>textRow: (in category 'utility') -----
- textRow: aString
-
- ^AlignmentMorph newRow
- wrapCentering: #center; cellPositioning: #leftCenter;
- color: Color transparent;
- layoutInset: 0;
- addMorph: (
- AlignmentMorph newColumn
- wrapCentering: #center; cellPositioning: #topCenter;
- color: Color transparent;
- vResizing: #shrinkWrap;
- layoutInset: 0;
- addMorph: (
- AlignmentMorph newRow
- wrapCentering: #center; cellPositioning: #leftCenter;
- color: Color transparent;
- hResizing: #shrinkWrap;
- vResizing: #shrinkWrap;
- layoutInset: 0;
- addMorph: ((StringMorph contents: aString) color: ((UserInterfaceTheme current get: #textColor for: #PluggableTextMorph) ifNil: [Color black])) asMorph
- )
- )!
Item was removed:
- ----- Method: FileList2 class>>update:in:fileTypeRow:morphUp: (in category 'morphic ui') -----
- update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph
-
- | fileTypeInfo info2 buttons textColor1 fileSuffixes fileActions aFileList fileTypeString |
- (morph notNil and: [(morph valueOfProperty: #enabled) not]) ifTrue: [^ self].
-
- fileTypeRow submorphsDo: [:sub |
- sub color: (
- sub == morph
- ifTrue: [Color white]
- ifFalse: [(sub valueOfProperty: #enabled)
- ifTrue: [Color transparent]
- ifFalse: [Color gray]])].
- fileTypeString := morph isNil
- ifTrue: ['xxxx']
- ifFalse: [morph valueOfProperty: #buttonText].
-
- aFileList := window valueOfProperty: #FileList.
- textColor1 := Color r: 0.742 g: 0.839 b: 1.0.
- actionRow removeAllMorphs.
- fileTypeInfo := self endingSpecs.
- info2 := fileTypeInfo
- detect: [:each | each first = fileTypeString]
- ifNone: [nil].
- info2
- ifNil: [
- buttons := OrderedCollection new]
- ifNotNil: [
- fileSuffixes := info2 second.
- fileActions := info2 third.
- buttons := fileActions
- collect: [ :each | aFileList blueButtonForService: each textColor: textColor1 inWindow: window ]
- as: OrderedCollection.
- buttons do: [ :each |
- each fillWithRamp: Color lightGreen oriented: (0.75 @ 0)]].
- buttons addLast: (self
- blueButtonText: 'Cancel'
- textColor: textColor1
- color: Color lightRed
- inWindow: window
- balloonText: 'Cancel this search'
- selector: #cancelHit
- recipient: aFileList).
- buttons do: [:each | actionRow addMorphBack: each].
- window fullBounds.
- fileSuffixes ifNotNil: [
- aFileList fileSelectionBlock: (
- self selectionBlockForSuffixes: (fileSuffixes collect: [ :each | '*.',each]))].
- aFileList updateFileList.!
Item was removed:
- ----- Method: FileList2>>addNewDirectory (in category 'own services') -----
- addNewDirectory
- super addNewDirectory.
- self updateDirectory.!
Item was removed:
- ----- Method: FileList2>>blueButtonForService:textColor:inWindow: (in category 'user interface') -----
- blueButtonForService: aService textColor: textColor inWindow: window
- | block result |
- block := [self fullName isNil
- ifTrue: [self inform: 'Please select a file' translated]
- ifFalse: [aService performServiceFor: self]].
- result := window
- fancyText: aService buttonLabel capitalized translated
- font: Preferences standardEToysFont
- color: textColor.
- result setProperty: #buttonText toValue: aService buttonLabel capitalized;
- hResizing: #rigid;
- extent: 100 @ 20;
- layoutInset: 4;
- borderWidth: 1;
- useRoundedCorners;
- setBalloonText: aService label.
- result
- on: #mouseUp
- send: #value
- to: block.
- ^ result!
Item was removed:
- ----- Method: FileList2>>cancelHit (in category 'private') -----
- cancelHit
-
- modalView delete.
- directory := fileName := currentDirectorySelected := nil.!
Item was removed:
- ----- Method: FileList2>>changeDirectoryTo: (in category 'volume list and pattern') -----
- changeDirectoryTo: aFileDirectory
- "Change directory as requested."
-
- self directory: aFileDirectory.
- self updateDirectory!
Item was removed:
- ----- Method: FileList2>>currentDirectorySelected (in category 'private') -----
- currentDirectorySelected
- ^ currentDirectorySelected
- !
Item was removed:
- ----- Method: FileList2>>deleteDirectory (in category 'own services') -----
- deleteDirectory
- super deleteDirectory.
- self updateDirectory.!
Item was removed:
- ----- Method: FileList2>>dirSelectionBlock: (in category 'initialization') -----
- dirSelectionBlock: aBlock
- dirSelectionBlock := aBlock!
Item was removed:
- ----- Method: FileList2>>directory (in category 'volume list and pattern') -----
- directory
-
- ^directory!
Item was removed:
- ----- Method: FileList2>>directory: (in category 'initialization') -----
- directory: dir
- "Set the path of the volume to be displayed."
-
- self okToChange ifFalse: [^ self].
-
- self modelSleep.
- directory := dir.
- self modelWakeUp.
-
- sortMode == nil ifTrue: [sortMode := #date].
- volList := Array with: '[]'.
- directory ifNotNil: [
- volList := volList, directory pathParts. "Nesting suggestion from RvL"
- ].
- volList := volList withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each].
- self changed: #relabel.
- self changed: #volumeList.
- self pattern: pattern.
- directoryChangeBlock ifNotNil: [directoryChangeBlock value: directory].!
Item was removed:
- ----- Method: FileList2>>directoryChangeBlock: (in category 'initialization') -----
- directoryChangeBlock: aBlockOrNil
-
- directoryChangeBlock := aBlockOrNil.!
Item was removed:
- ----- Method: FileList2>>directoryNamesFor: (in category 'private') -----
- directoryNamesFor: item
- "item may be file directory or server directory"
- | entries |
- entries := item directoryNames.
- dirSelectionBlock ifNotNil:[entries := entries select: dirSelectionBlock].
- ^entries!
Item was removed:
- ----- Method: FileList2>>fileSelectionBlock: (in category 'initialization') -----
- fileSelectionBlock: aBlock
-
- fileSelectionBlock := aBlock!
Item was removed:
- ----- Method: FileList2>>getSelectedDirectory (in category 'private') -----
- getSelectedDirectory
- ok == true ifFalse: [^ nil].
- ^ currentDirectorySelected
- !
Item was removed:
- ----- Method: FileList2>>getSelectedFile (in category 'private') -----
- getSelectedFile
- "Answer a filestream on the selected file. If it cannot be opened for read/write, try read-only before giving up; answer nil if unsuccessful"
-
- ok == true ifFalse: [^ nil].
- directory ifNil: [^ nil].
- fileName ifNil: [^ nil].
- ^ (directory oldFileNamed: fileName) ifNil:
- [directory readOnlyFileNamed: fileName]!
Item was removed:
- ----- Method: FileList2>>importImage (in category 'own services') -----
- importImage
- "Import the given image file and store the resulting Form in the default Imports"
-
- | fname image |
- fname := fileName sansPeriodSuffix.
- image := Form fromFileNamed: self fullName.
- Imports default importImage: image named: fname.
- !
Item was removed:
- ----- Method: FileList2>>initialDirectoryList (in category 'initialization') -----
- initialDirectoryList
-
- | dirList |
- dirList := (FileDirectory on: '') directoryNames collect: [ :each |
- FileDirectoryWrapper with: (FileDirectory on: each) name: each model: self].
- dirList isEmpty ifTrue:[
- dirList := Array with: (FileDirectoryWrapper
- with: FileDirectory default
- name: FileDirectory default localName
- model: self)].
- dirList := dirList,(
- ServerDirectory serverNames collect: [ :n | | nameToShow dir |
- dir := ServerDirectory serverNamed: n.
- nameToShow := n.
- (dir directoryWrapperClass with: dir name: nameToShow model: self)
- balloonText: dir realUrl
- ]
- ).
- ^dirList!
Item was removed:
- ----- Method: FileList2>>initialize (in category 'initialize-release') -----
- initialize
-
- super initialize.
- showDirsInFileList := false.
- fileSelectionBlock := [ :entry :myPattern |
- entry isDirectory ifTrue: [
- showDirsInFileList
- ] ifFalse: [
- myPattern = '*' or: [myPattern match: entry name]
- ]
- ].
- dirSelectionBlock := [ :dirName | true].!
Item was removed:
- ----- Method: FileList2>>isDirectoryList: (in category 'drag''n''drop') -----
- isDirectoryList: aMorph
- ^aMorph isKindOf: SimpleHierarchicalListMorph!
Item was removed:
- ----- Method: FileList2>>labelString (in category 'initialization') -----
- labelString
- ^ (directory ifNil: [^'[]']) pathName contractTo: 50!
Item was removed:
- ----- Method: FileList2>>limitedSuperSwikiDirectoryList (in category 'initialization') -----
- limitedSuperSwikiDirectoryList
-
- | dirList localDirName localDir |
-
- dirList := OrderedCollection new.
- ServerDirectory serverNames do: [ :n | | dir nameToShow |
- dir := ServerDirectory serverNamed: n.
- dir isProjectSwiki ifTrue: [
- nameToShow := n.
- dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self)
- balloonText: dir realUrl)
- ].
- ].
- ServerDirectory localProjectDirectories do: [ :each |
- dirList add: (FileDirectoryWrapper with: each name: each localName model: self)
- ].
- "Make sure the following are always shown, but not twice"
- localDirName := SecurityManager default untrustedUserDirectory.
- localDir := FileDirectory on: localDirName.
- ((ServerDirectory localProjectDirectories collect: [:each | each pathName]) includes: localDirName)
- ifFalse: [dirList add: (FileDirectoryWrapper with: localDir name: localDir localName model: self)].
- FileDirectory default pathName = localDirName
- ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)].
- (dirList anySatisfy: [:each | each withoutListWrapper acceptsUploads])
- ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)].
- ^dirList!
Item was removed:
- ----- Method: FileList2>>limitedSuperSwikiPublishDirectoryList (in category 'initialization') -----
- limitedSuperSwikiPublishDirectoryList
-
- | dirList localDirName localDir |
-
- dirList := self publishingServers.
- ServerDirectory localProjectDirectories do: [ :each |
- dirList add: (FileDirectoryWrapper with: each name: each localName model: self)].
-
- "Make sure the following are always shown, but not twice"
- localDirName := SecurityManager default untrustedUserDirectory.
- localDir := FileDirectory on: localDirName.
- ((ServerDirectory localProjectDirectories collect: [:each | each pathName]) includes: localDirName)
- ifFalse: [dirList add: (FileDirectoryWrapper with: localDir name: localDir localName model: self)].
- FileDirectory default pathName = localDirName
- ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)].
- ^dirList!
Item was removed:
- ----- Method: FileList2>>listForPattern: (in category 'volume list and pattern') -----
- listForPattern: pat
- "Make the list be those file names which match the pattern."
-
- | sizePad newList entries |
- directory ifNil: [^#()].
- entries := (Preferences eToyLoginEnabled
- and: [Utilities authorNamePerSe notNil])
- ifTrue: [directory matchingEntries: {'submittedBy: ' , Utilities authorName.} ]
- ifFalse: [directory entries].
- (fileSelectionBlock isKindOf: MessageSend) ifTrue: [
- fileSelectionBlock arguments: {entries}.
- newList := fileSelectionBlock value.
- fileSelectionBlock arguments: #().
- ] ifFalse: [
- newList := entries select: [:entry | fileSelectionBlock value: entry value: pat].
- ].
- newList := newList asArray sort: self sortBlock.
- sizePad := (newList inject: 0 into: [:mx :entry | mx max: entry fileSize])
- asStringWithCommas size - 1.
- ^newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]!
Item was removed:
- ----- Method: FileList2>>listForPatterns: (in category 'volume list and pattern') -----
- listForPatterns: anArray
- "Make the list be those file names which match the patterns."
-
- | sizePad newList |
- directory ifNil: [^#()].
- (fileSelectionBlock isKindOf: MessageSend) ifTrue: [
- fileSelectionBlock arguments: {directory entries}.
- newList := fileSelectionBlock value.
- fileSelectionBlock arguments: #().
- ] ifFalse: [
- newList := Set new.
- anArray do: [ :pat |
- newList addAll: (directory entries select: [:entry | fileSelectionBlock value: entry value: pat]) ].
- ].
- newList := newList asArray sort: self sortBlock.
- sizePad := (newList inject: 0 into: [:mx :entry | mx max: entry fileSize])
- asStringWithCommas size.
- ^newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]!
Item was removed:
- ----- Method: FileList2>>modalView: (in category 'private') -----
- modalView: aSystemWindowOrSuch
-
- modalView := aSystemWindowOrSuch!
Item was removed:
- ----- Method: FileList2>>morphicDirectoryTreePane (in category 'user interface') -----
- morphicDirectoryTreePane
-
- ^self morphicDirectoryTreePaneFiltered: #initialDirectoryList
- !
Item was removed:
- ----- Method: FileList2>>morphicDirectoryTreePaneFiltered: (in category 'user interface') -----
- morphicDirectoryTreePaneFiltered: aSymbol
- ^(SimpleHierarchicalListMorph
- on: self
- list: aSymbol
- selected: #currentDirectorySelected
- changeSelected: #setSelectedDirectoryTo:
- menu: #volumeMenu:
- keystroke: nil)
- autoDeselect: false;
- enableDrag: false;
- enableDrop: true;
- yourself
-
- !
Item was removed:
- ----- Method: FileList2>>morphicFileContentsPane (in category 'user interface') -----
- morphicFileContentsPane
-
- ^PluggableTextMorph
- on: self
- text: #contents
- accept: #put:
- readSelection: #contentsSelection
- menu: #fileContentsMenu:shifted:
- !
Item was removed:
- ----- Method: FileList2>>morphicFileListPane (in category 'user interface') -----
- morphicFileListPane
-
- ^(PluggableListMorph
- on: self
- list: #fileList
- selected: #fileListIndex
- changeSelected: #fileListIndex:
- menu: #fileListMenu:)
- enableDrag: true;
- enableDrop: false;
- yourself
-
- !
Item was removed:
- ----- Method: FileList2>>morphicPatternPane (in category 'user interface') -----
- morphicPatternPane
- | pane |
- pane := PluggableTextMorph
- on: self
- text: #pattern
- accept: #pattern:.
- pane acceptOnCR: true.
- ^pane
-
- !
Item was removed:
- ----- Method: FileList2>>okHit (in category 'private') -----
- okHit
-
- ok := true.
- currentDirectorySelected
- ifNil: [ Beeper beep ]
- ifNotNil: [
- self class lastSelDir: directory.
- modalView delete ]!
Item was removed:
- ----- Method: FileList2>>okHitForProjectLoader (in category 'private') -----
- okHitForProjectLoader
-
- | areaOfProgress |
- fileName ifNil: [^ self].
- ok := true.
- areaOfProgress := modalView firstSubmorph.
- [
- areaOfProgress setProperty: #deleteOnProgressCompletion toValue: modalView.
- self openProjectFromFile.
- modalView delete. "probably won't get here"
- ]
- on: ProgressTargetRequestNotification
- do: [ :ex | ex resume: areaOfProgress].
-
-
- !
Item was removed:
- ----- Method: FileList2>>okayAndCancelServices (in category 'own services') -----
- okayAndCancelServices
- "Answer ok and cancel services"
-
- ^ {self serviceOkay. self serviceCancel}!
Item was removed:
- ----- Method: FileList2>>openImageInWindow (in category 'own services') -----
- openImageInWindow
- "Handle five file formats: GIF, JPG, PNG, Form stoteOn: (run coded), and BMP.
- Fail if file format is not recognized."
-
- | image myStream |
- myStream := (directory readOnlyFileNamed: fileName) binary.
- [image := Form fromBinaryStream: myStream.
- Project current openImage: image name: fileName saveResource: false]
- ensure: [myStream close]
- !
Item was removed:
- ----- Method: FileList2>>openProjectFromFile (in category 'own services') -----
- openProjectFromFile
- "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."
-
- Project canWeLoadAProjectNow ifFalse: [^ self].
- ProjectViewMorph
- openFromDirectory: directory
- andFileName: fileName
- !
Item was removed:
- ----- Method: FileList2>>optionalButtonRow (in category 'initialization') -----
- optionalButtonRow
- "Answer the button row associated with a file list"
-
- | aRow |
- aRow := AlignmentMorph newRow beSticky.
- aRow color: Color transparent.
- aRow clipSubmorphs: true.
- aRow layoutInset: 5@1; cellGap: 6.
- self universalButtonServices do: "just the three sort-by items"
- [:service |
- aRow addMorphBack: (service buttonToTriggerIn: self).
- (service selector == #sortBySize)
- ifTrue:
- [aRow addTransparentSpacerOfSize: (4@0)]].
- aRow setNameTo: 'buttons'.
- aRow setProperty: #buttonRow toValue: true. "Used for dynamic retrieval later on"
- ^ aRow!
Item was removed:
- ----- Method: FileList2>>optionalButtonSpecs (in category 'initialization') -----
- optionalButtonSpecs
-
- ^optionalButtonSpecs ifNil: [super optionalButtonSpecs]!
Item was removed:
- ----- Method: FileList2>>optionalButtonSpecs: (in category 'initialization') -----
- optionalButtonSpecs: anArray
-
- optionalButtonSpecs := anArray!
Item was removed:
- ----- Method: FileList2>>postOpen (in category 'private') -----
- postOpen
-
- directory ifNotNil: [
- self changed: #(openPath) , directory pathParts.
- ].
- !
Item was removed:
- ----- Method: FileList2>>publishingServers (in category 'initialization') -----
- publishingServers
-
- | dirList |
-
- dirList := OrderedCollection new.
- ServerDirectory serverNames do: [ :n | | dir nameToShow |
- dir := ServerDirectory serverNamed: n.
- (dir isProjectSwiki and: [dir acceptsUploads])
- ifTrue: [
- nameToShow := n.
- dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self)
- balloonText: dir realUrl)]].
- ^dirList!
Item was removed:
- ----- Method: FileList2>>removeLinefeeds (in category 'own services') -----
- removeLinefeeds
- "Remove any line feeds by converting to CRs instead. This is a temporary implementation for 3.6 only... should be removed during 3.7alpha."
- | fileContents |
- fileContents := ((FileStream readOnlyFileNamed: self fullName) wantsLineEndConversion: true) contentsOfEntireFile.
- (FileStream newFileNamed: self fullName)
- nextPutAll: fileContents;
- close.!
Item was removed:
- ----- Method: FileList2>>saveLocalOnlyHit (in category 'private') -----
- saveLocalOnlyHit
- ok := true.
- modalView delete.
- directory := fileName := nil.
- currentDirectorySelected := #localOnly.!
Item was removed:
- ----- Method: FileList2>>serviceCancel (in category 'own services') -----
- serviceCancel
- "Answer a service for hitting the cancel button"
-
- ^ (SimpleServiceEntry new
- provider: self
- label: 'cancel' translatedNoop
- selector: #cancelHit
- description: 'hit here to cancel ' translatedNoop)
- buttonLabel: 'cancel' translatedNoop!
Item was removed:
- ----- Method: FileList2>>serviceOkay (in category 'own services') -----
- serviceOkay
- "Answer a service for hitting the okay button"
-
- ^ (SimpleServiceEntry new
- provider: self
- label: 'okay' translatedNoop
- selector: #okHit
- description: 'hit here to accept the current selection' translatedNoop)
- buttonLabel: 'ok' translatedNoop!
Item was removed:
- ----- Method: FileList2>>serviceOpenProjectFromFile (in category 'own services') -----
- serviceOpenProjectFromFile
- "Answer a service for opening a .pr project file"
-
- ^ SimpleServiceEntry
- provider: self
- label: 'load as project' translatedNoop
- selector: #openProjectFromFile
- description: 'open project from file' translatedNoop
- buttonLabel: 'load' translatedNoop!
Item was removed:
- ----- Method: FileList2>>servicesForFolderSelector (in category 'own services') -----
- servicesForFolderSelector
- "Answer the ok and cancel servies for the folder selector"
-
- ^ self okayAndCancelServices!
Item was removed:
- ----- Method: FileList2>>servicesForProjectLoader (in category 'own services') -----
- servicesForProjectLoader
- "Answer the services to show in the button pane for the project loader"
-
- ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize. self serviceOpenProjectFromFile}!
Item was removed:
- ----- Method: FileList2>>setSelectedDirectoryTo: (in category 'private') -----
- setSelectedDirectoryTo: aFileDirectoryWrapper
- currentDirectorySelected := aFileDirectoryWrapper.
- self directory: aFileDirectoryWrapper withoutListWrapper.
- brevityState := #FileList.
- "self addPath: path."
- self changed: #fileList.
- self changed: #contents.
- self changed: #currentDirectorySelected.!
Item was removed:
- ----- Method: FileList2>>specsForImageViewer (in category 'user interface') -----
- specsForImageViewer
-
- ^{self serviceSortByName. self serviceSortByDate. self serviceSortBySize }!
Item was removed:
- ----- Method: FileList2>>universalButtonServices (in category 'initialization') -----
- universalButtonServices
- "Answer the services to be reflected in the receiver's buttons"
-
- ^ self optionalButtonSpecs!
Item was removed:
- ----- Method: FileList2>>updateDirectory (in category 'initialization') -----
- updateDirectory
- "directory has been changed externally, by calling directory:.
- Now change the view to reflect the change."
- self changed: #currentDirectorySelected.
- self postOpen.!
Item was removed:
- ----- Method: FileStream class>>edit: (in category '*Tools-Changes') -----
- edit: fullNameOrStream
-
- ^ (fullNameOrStream isString
- ifTrue: [self fileNamed: fullNameOrStream]
- ifFalse: [fullNameOrStream]) edit!
Item was removed:
- ----- Method: FileStream class>>serviceEditFile (in category '*Tools-Changes') -----
- serviceEditFile
-
- ^ SimpleServiceEntry
- provider: self
- label: 'edit as text file'
- selector: #edit:
- description: 'edit as text file'
- buttonLabel: 'edit'!
Item was removed:
- ----- Method: FileStream class>>serviceEditFileSuffixes (in category '*Tools-Changes') -----
- serviceEditFileSuffixes
-
- ^ #('*')!
Item was removed:
- ----- Method: FileStream>>edit (in category '*Tools-Changes') -----
- edit
- "Create and schedule an editor on this file."
-
- FileList openEditorOn: self editString: nil.
- !
Item was removed:
- ----- Method: FileStream>>fileIntoNewChangeSet (in category '*Tools-Changes') -----
- fileIntoNewChangeSet
- "File all of my contents into a new change set."
-
- self readOnly.
- ChangesOrganizer newChangesFromStream: self named: self localName!
Item was removed:
- ----- Method: Form>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
-
- ^ FormInspector!
Item was removed:
- Inspector subclass: #FormInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
Item was removed:
- ----- Method: FormInspector>>embedForm:inText: (in category 'support') -----
- embedForm: aForm inText: stringOrText
-
- ^ stringOrText asText
- , ((' (hash: {1})' translated format: {aForm bits hash})
- flag: #workaround "ct: Currently, text equality ignores attributes. Add a hash of the form's bits to the text to ensure that it will be re-rendered in Morphic inspectors. In the long term, we should redefine Text >> #= instead. See: http://lists.squeakfoundation.org/pipermail/squeak-dev/2020-September/21135…";
- yourself)
- , String cr
- , (Text string: ' ' attribute:
- (TextFontReference toFont:
- (FormSetFont new
- fromFormArray: (Array with: (aForm copy offset: 0@0))
- asciiStart: Character space asInteger
- ascent: aForm height)))!
Item was removed:
- ----- Method: FormInspector>>fieldPixels (in category 'fields') -----
- fieldPixels
-
- ^ (self newFieldForType: #misc key: #pixels)
- name: 'pixels' translated; emphasizeName;
- printValueAsIs;
- valueGetter: [:form | self embedForm: form inText: form printString];
- yourself!
Item was removed:
- ----- Method: FormInspector>>streamBaseFieldsOn: (in category 'fields - streaming') -----
- streamBaseFieldsOn: aStream
-
- super streamBaseFieldsOn: aStream.
- aStream nextPut: self fieldPixels.!
Item was removed:
- ----- Method: FutureMaker>>defaultLabelForInspector (in category '*Tools-Inspector') -----
- defaultLabelForInspector
- "Answer the default label to be used for an Inspector window on the receiver."
- ^self class name!
Item was removed:
- ----- Method: FutureMaker>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
- "Answer the class of the inspector to be used on the receiver. Called by inspect;
- use basicInspect to get a normal (less useful) type of inspector."
-
- ^ Inspector!
Item was removed:
- ----- Method: HashedCollection>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Dictionary'!
Item was removed:
- Browser subclass: #HierarchyBrowser
- instanceVariableNames: 'classDisplayList centralClass'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !HierarchyBrowser commentStamp: 'fbs 3/9/2011 12:02' prior: 0!
- I provide facilities to explore classes in the context of their subclass hierarchy.
-
- My classDisplayList instvar uses indentation to show the subclassing relationship between the displayed classes.
- !
Item was removed:
- ----- Method: HierarchyBrowser class>>openBrowser (in category 'instance creation') -----
- openBrowser
- "Open a default hierarchy browser on Object - ie the entire class tree, so it may take a moment - with class/protocol/message lists"
- "HierarchyBrowser openBrowser"
- | newBrowser |
- newBrowser := self new initHierarchyForClass: Object.
- ^ newBrowser buildAndOpenBrowserLabel: nil
- !
Item was removed:
- ----- Method: HierarchyBrowser>>allAncestorsOfClass:withLevelDo: (in category 'hierarchy - classes') -----
- allAncestorsOfClass: class withLevelDo: classAndLevelBlock
-
- self
- allAncestorsOfClass: class
- withLevelDo: classAndLevelBlock
- startingLevel: 1.!
Item was removed:
- ----- Method: HierarchyBrowser>>allAncestorsOfClass:withLevelDo:startingLevel: (in category 'hierarchy - classes') -----
- allAncestorsOfClass: class withLevelDo: classAndLevelBlock startingLevel: level
-
- (class superclass ifNil: [#()] ifNotNil: [:c | {c}]), class traits
- do: [:ancestor |
- ancestor isTrait
- ifTrue: [
- self
- allAncestorsOfTrait: ancestor
- withLevelDo: classAndLevelBlock
- startingLevel: level + 1]
- ifFalse: [
- self
- allAncestorsOfClass: ancestor
- withLevelDo: classAndLevelBlock
- startingLevel: level + 1].
- classAndLevelBlock value: ancestor value: level].!
Item was removed:
- ----- Method: HierarchyBrowser>>allAncestorsOfTrait:withLevelDo: (in category 'hierarchy - traits') -----
- allAncestorsOfTrait: trait withLevelDo: traitAndLevelBlock
-
- self
- allAncestorsOfTrait: trait
- withLevelDo: traitAndLevelBlock
- startingLevel: 1.!
Item was removed:
- ----- Method: HierarchyBrowser>>allAncestorsOfTrait:withLevelDo:startingLevel: (in category 'hierarchy - traits') -----
- allAncestorsOfTrait: trait withLevelDo: traitAndLevelBlock startingLevel: level
-
- trait traitComposition asTraitComposition traits
- do: [:ancestor |
- self
- allAncestorsOfTrait: ancestor
- withLevelDo: traitAndLevelBlock
- startingLevel: level + 1.
- traitAndLevelBlock value: ancestor value: level].!
Item was removed:
- ----- Method: HierarchyBrowser>>allSuccessorsOfClass:withLevelDo:startingLevel: (in category 'hierarchy - classes') -----
- allSuccessorsOfClass: class withLevelDo: classAndLevelBlock startingLevel: level
-
- classAndLevelBlock value: class value: level.
- (class subclasses sorted: #name ascending)
- do: [:successor |
- self
- allSuccessorsOfClass: successor
- withLevelDo: classAndLevelBlock
- startingLevel: level + 1].!
Item was removed:
- ----- Method: HierarchyBrowser>>allSuccessorsOfTrait:withLevelDo:startingLevel: (in category 'hierarchy - traits') -----
- allSuccessorsOfTrait: trait withLevelDo: traitAndLevelBlock startingLevel: level
-
- traitAndLevelBlock value: trait value: level.
- (trait users "includes classes and traits" sorted: #name ascending)
- do: [:user |
- self
- allSuccessorsOfTrait: user
- withLevelDo: traitAndLevelBlock
- startingLevel: level + 1].!
Item was removed:
- ----- Method: HierarchyBrowser>>buildAndOpenBrowserLabel: (in category 'toolbuilder') -----
- buildAndOpenBrowserLabel: aLabelString
- "assemble the spec for a class list/hierarchy browser, build it and open it"
-
- | builder window |
- builder := ToolBuilder default.
-
- window := self buildDefaultBrowserWith: builder.
- aLabelString ifNotNil: [:str | window label: str].
-
- builder open: window.!
Item was removed:
- ----- Method: HierarchyBrowser>>buildClassBrowserEditString: (in category 'menu messages') -----
- buildClassBrowserEditString: aString
- "Open a hierarchy browser on the currently selected class; the string has to be ignored in this case"
-
- self spawnHierarchy!
Item was removed:
- ----- Method: HierarchyBrowser>>buildDefaultBrowserWith: (in category 'toolbuilder') -----
- buildDefaultBrowserWith: builder
- "assemble the spec for a hierarchical browser, build it and return the built but not opened morph"
- "this build-but-don't-open phase is factored out to support the prototypicalToolWindow facility"
-
- | max windowSpec |
-
-
- self setupIfNotInitialisedYet.
- max := self wantsOptionalButtons ifTrue:[0.32] ifFalse:[0.4].
-
- windowSpec := self buildWindowWith: builder specs: {
- (self classListFrame: max fromTop: 0 fromLeft: 0 width: 0.333) -> [self buildClassListWith: builder].
- (self switchesFrame: max fromLeft: 0 width: 0.333) -> [self buildSwitchesWith: builder].
- (LayoutFrame fractions: (0.333@0 corner: 0.666@max) offsets: (0@0 corner: 0@0)) -> [self buildMessageCategoryListWith: builder].
- (LayoutFrame fractions: (0.666@0 corner: 1@max) offsets: (0@0 corner: 0@0)) -> [self buildMessageListWith: builder].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
- self setMultiWindowFor:windowSpec.
- windowSpec defaultFocus: #classList.
-
- ^builder build: windowSpec!
Item was removed:
- ----- Method: HierarchyBrowser>>classList (in category 'class list') -----
- classList
- "each time we update the class list make sure to check that all the classes we think we should display are in fact in the environment"
- classDisplayList := classDisplayList select: [:each | (self environment valueOf: each withBlanksTrimmed asSymbol) notNil].
- ^ classDisplayList!
Item was removed:
- ----- Method: HierarchyBrowser>>classListIndex: (in category 'initialization') -----
- classListIndex: newIndex
- "Cause system organization to reflect appropriate category"
- | newClassName ind |
- newIndex ~= 0 ifTrue:
- [newClassName := (classDisplayList at: newIndex) copyWithout: $ .
- selectedSystemCategory := (systemOrganizer categories at:
- (systemOrganizer numberOfCategoryOfElement: newClassName)
- ifAbsent: [nil])].
- ind := super classListIndex: newIndex.
-
- "What I'd like to write:"
- "self selectedClassName ifNotNil:
- [ selectedSystemCategory := self selectedClass category ]."
- self changed: #systemCategorySingleton.
- ^ ind!
Item was removed:
- ----- Method: HierarchyBrowser>>copyClass (in category 'class functions') -----
- copyClass
-
- super copyClass.
- self updateAfterClassChange.!
Item was removed:
- ----- Method: HierarchyBrowser>>defaultBrowserTitle (in category 'initialization') -----
- defaultBrowserTitle
- ^ self selectedSystemCategoryName ifNil: [ 'Hierarchy Browser' ]!
Item was removed:
- ----- Method: HierarchyBrowser>>defineClass:notifying: (in category 'hierarchy - classes') -----
- defineClass: defString notifying: aController
-
- super defineClass: defString notifying: aController.
- self updateAfterClassChange.!
Item was removed:
- ----- Method: HierarchyBrowser>>defineTrait:notifying: (in category 'hierarchy - traits') -----
- defineTrait: defString notifying: aController
-
- super defineTrait: defString notifying: aController.
- self updateAfterClassChange.!
Item was removed:
- ----- Method: HierarchyBrowser>>initHierarchyFor: (in category 'initialization') -----
- initHierarchyFor: classOrTrait
-
- classOrTrait isTrait
- ifTrue: [self initHierarchyForTrait: classOrTrait]
- ifFalse: [self initHierarchyForClass: classOrTrait].!
Item was removed:
- ----- Method: HierarchyBrowser>>initHierarchyForClass: (in category 'hierarchy - classes') -----
- initHierarchyForClass: aClassOrMetaClass
-
- | nonMetaClass baseLevel |
- centralClass := aClassOrMetaClass.
- nonMetaClass := aClassOrMetaClass theNonMetaClass.
- self selectEnvironment: aClassOrMetaClass environment.
- metaClassIndicated := aClassOrMetaClass isMeta.
- classDisplayList := OrderedCollection new.
- baseLevel := 0.
- self
- allAncestorsOfClass: nonMetaClass
- withLevelDo: [ : each : level | baseLevel := baseLevel max: level ].
- self
- allAncestorsOfClass: nonMetaClass
- withLevelDo:
- [ : classOrTrait : level | | label |
- label := (String streamContents:
- [:stream | baseLevel - level timesRepeat: [ stream nextPutAll: ' ' ].
- stream nextPutAll: classOrTrait name ]).
- classOrTrait isTrait
- ifTrue: [ label := label asText addAttribute: TextEmphasis italic ].
- classDisplayList add: label ].
- self
- allSuccessorsOfClass: nonMetaClass
- withLevelDo:
- [ : each : level | classDisplayList add:
- (String streamContents:
- [ : stream | level timesRepeat: [ stream nextPutAll: ' ' ].
- stream nextPutAll: each name ]) ]
- startingLevel: baseLevel.
-
- self changed: #classList.
- self selectClass: nonMetaClass.!
Item was removed:
- ----- Method: HierarchyBrowser>>initHierarchyForTrait: (in category 'hierarchy - traits') -----
- initHierarchyForTrait: baseTraitOrClassTrait
-
- | baseTrait baseLevel |
- centralClass := baseTraitOrClassTrait.
- baseTrait := baseTraitOrClassTrait baseTrait.
- self selectEnvironment: baseTraitOrClassTrait environment.
- metaClassIndicated := baseTraitOrClassTrait isClassTrait.
- classDisplayList := OrderedCollection new.
- baseLevel := 0.
- self
- allAncestorsOfTrait: baseTrait
- withLevelDo: [ : each : level | baseLevel := baseLevel max: level ].
- self
- allAncestorsOfTrait: baseTrait
- withLevelDo:
- [:each :level | classDisplayList add:
- (String streamContents:
- [ : stream | baseLevel - level timesRepeat: [ stream nextPutAll: ' ' ].
- stream nextPutAll: each name ]) ].
- self
- allSuccessorsOfTrait: baseTrait
- withLevelDo:
- [:classOrTrait :level | | label |
- label := (String streamContents:
- [ : stream | level timesRepeat: [ stream nextPutAll: ' ' ].
- stream nextPutAll: classOrTrait name ]).
- classOrTrait isTrait
- ifFalse: [ label := label asText addAttribute: TextEmphasis italic ].
- classDisplayList add: label ]
- startingLevel: baseLevel.
-
- self changed: #classList.
- self selectClass: baseTrait.!
Item was removed:
- ----- Method: HierarchyBrowser>>isHierarchy (in category 'multi-window support') -----
- isHierarchy
- "This almost certainly needs implementing in ClassListBrowser to return false"
- ^true!
Item was removed:
- ----- Method: HierarchyBrowser>>postAcceptBrowseFor: (in category 'morphic ui') -----
- postAcceptBrowseFor: aHierarchyBrowser
- (aHierarchyBrowser selectedClass ~= self selectedClass or: [ aHierarchyBrowser selectedMessageName notNil ]) ifTrue: [ self selectMessageCategoryNamed: nil ].
- aHierarchyBrowser instanceMessagesIndicated
- ifTrue: [ self indicateInstanceMessages ]
- ifFalse: [ self indicateClassMessages ].
- self
- selectClass: aHierarchyBrowser selectedClass ;
- selectedMessageName: aHierarchyBrowser selectedMessageName ;
- showHomeCategory!
Item was removed:
- ----- Method: HierarchyBrowser>>removeSystemCategory (in category 'menu messages') -----
- removeSystemCategory
- "If a class category is selected, create a Confirmer so the user can
- verify that the currently selected class category and all of its classes
- should be removed from the system. If so, remove it."
-
- self inform: 'Use a normal Browser, in which you can see
- the entire category you are trying to remove.'!
Item was removed:
- ----- Method: HierarchyBrowser>>renameClass (in category 'class functions') -----
- renameClass
-
- super renameClass.
- self updateAfterClassChange.!
Item was removed:
- ----- Method: HierarchyBrowser>>representsSameBrowseeAs: (in category 'morphic ui') -----
- representsSameBrowseeAs: anotherModel
- ^ self hasUnacceptedEdits not
- and: [ classDisplayList size = anotherModel classList size
- and: [ classDisplayList includesAllOf: anotherModel classList ] ]!
Item was removed:
- ----- Method: HierarchyBrowser>>selectClassNamed: (in category 'initialization') -----
- selectClassNamed: aSymbolOrString
- | newClassName |
- newClassName := aSymbolOrString ifNotNil: [ aSymbolOrString asSymbol ].
- selectedSystemCategory := (systemOrganizer categories at:
- (systemOrganizer numberOfCategoryOfElement: newClassName) ifAbsent: [ nil ]).
-
- super selectClassNamed: newClassName.
- self changed: #systemCategorySingleton.
-
- ^ newClassName.!
Item was removed:
- ----- Method: HierarchyBrowser>>selectedClassName (in category 'initialization') -----
- selectedClassName
- "Answer the name of the class currently selected. di
- bug fix for the case where name cannot be found -- return nil rather than halt"
-
- | aName |
- aName := super selectedClassName.
- aName ifNil: [ ^ nil ].
- ^ (aName copyWithout: Character space) asSymbol!
Item was removed:
- ----- Method: HierarchyBrowser>>setClass: (in category 'initialization') -----
- setClass: aClassOrTrait
- self initHierarchyFor: (centralClass ifNil: [ aClassOrTrait ]).
- super setClass: aClassOrTrait!
Item was removed:
- ----- Method: HierarchyBrowser>>setupIfNotInitialisedYet (in category 'toolbuilder') -----
- setupIfNotInitialisedYet
- "HierarchyBrowser needs some initialisation to work in the ToolBuilder>build: world since there has to be a list of classes ready to be listed. As a default we use the full Object class tree"
- classDisplayList ifNil:[ self initHierarchyForClass: Object]!
Item was removed:
- ----- Method: HierarchyBrowser>>spawnOrNavigateTo: (in category 'private') -----
- spawnOrNavigateTo: aClass
- (aClass inheritsFrom: centralClass)
- ifTrue: [ super spawnOrNavigateTo: aClass ]
- ifFalse: [ self systemNavigation browseHierarchy: aClass ]!
Item was removed:
- ----- Method: HierarchyBrowser>>systemCatSingletonKey:from: (in category 'menu messages') -----
- systemCatSingletonKey: aChar from: aView
- "This appears to be obsolete now that the hierarchybrowser has not category view"
- ^ self systemCatListKey: aChar from: aView!
Item was removed:
- ----- Method: HierarchyBrowser>>systemCatSingletonMenu: (in category 'menu messages') -----
- systemCatSingletonMenu: aMenu
- "This appears to be obsolete now that the hierarchybrowser has not category view"
- ^ aMenu labels:
- 'find class... (f)
- browse
- printOut
- fileOut
- update
- rename...
- remove'
- lines: #(1 4)
- selections:
- #(findClass buildSystemCategoryBrowser
- printOutSystemCategory fileOutSystemCategory updateSystemCategories
- renameSystemCategory removeSystemCategory )
- !
Item was removed:
- ----- Method: HierarchyBrowser>>systemCategorySingleton (in category 'initialization') -----
- systemCategorySingleton
-
- | cls |
- cls := self selectedClass.
- ^ cls ifNil: [Array new]
- ifNotNil: [Array with: cls category]!
Item was removed:
- ----- Method: HierarchyBrowser>>updateAfterClassChange (in category 'initialization') -----
- updateAfterClassChange
- "It is possible that some the classes comprising the hierarchy have changed, so reinitialize the entire browser."
-
- | priorSelection |
- priorSelection := self selectedClassName.
-
- (centralClass notNil and: [centralClass isObsolete not])
- ifTrue: [self initHierarchyFor: centralClass].
-
- (self classListIndexOf: priorSelection) > 0
- ifTrue: [self selectClassNamed: priorSelection].!
Item was removed:
- StringHolder subclass: #Inspector
- instanceVariableNames: 'object context fields customFields selectionIndex expression contentsTyped fieldListStyler shouldStyleValuePane selectionUpdateTime'
- classVariableNames: 'CachedAllInstVarsLabel CurrentLocale'
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !Inspector commentStamp: 'mt 4/6/2020 15:16' prior: 0!
- I am a tool that allows to inspect and modify the internal representation of an object. As a StringHolder, the string I represent is the value of the currently selected inspector field, which may be an instance variable, of the observed object.
-
- Beside the #contents in my value pane, I have an extra code pane that holds an #expression to be evaluated on the inspected object -- not the currently selected inspector field.
-
- Take a look at my "fields ..." protocols as well as InspectorField.
-
- (Note that the idea of "elements" from the CollectionInspector bleeds a little bit down into this interface to simplify the implementation of field truncation as well as #inspectOne. Sorry for that. Usually, the inspected object will only produce "fields" to display, and maybe "items" in a pop-up menu. Only collections have "elements".)!
Item was removed:
- ----- Method: Inspector class>>inspect: (in category 'instance creation') -----
- inspect: anObject
- "Answer a new (sub)instance of me to provide an inspector for anObject."
-
- ^ self new inspect: anObject!
Item was removed:
- ----- Method: Inspector class>>on: (in category 'instance creation') -----
- on: anObject
- "Answer a new instance of me to provide an inspector for anObject."
-
- ^ self new object: anObject!
Item was removed:
- ----- Method: Inspector class>>openOn: (in category 'instance creation') -----
- openOn: anObject
- "Open an inspector for anObject."
-
- ^ ToolBuilder open: (self on: anObject)!
Item was removed:
- ----- Method: Inspector class>>openOn:withLabel: (in category 'instance creation') -----
- openOn: anObject withLabel: label
- "Open an inspector with a specific label. Use this to set the inspector into context to explain why that object is inspected."
-
- ^ ToolBuilder open: (self on: anObject) label: label!
Item was removed:
- ----- Method: Inspector>>aboutToStyle:requestor: (in category 'user interface - styling') -----
- aboutToStyle: aStyler requestor: anObject
- "We have two text fields in this tool: code pane and value pane. Do always style the code pane."
-
- self updateStyler: aStyler requestor: anObject.
-
- ^ (anObject knownName = #valuePane)
- ==> [shouldStyleValuePane == true
- "Fields can override styling so that contents are always styled."
- or: [self selectedField notNil ==> [self selectedField shouldStyleValue]]]!
Item was removed:
- ----- Method: Inspector>>addClassItemsTo: (in category 'menu - construction') -----
- addClassItemsTo: aMenu
-
- aMenu addTranslatedList: #(
- -
- ('browse full (b)' browseClass)
- ('browse hierarchy (h)' browseClassHierarchy)
- ('browse protocol (p)' browseFullProtocol)).
-
- self typeOfSelection = #self ifFalse: [^ self].
-
- aMenu addTranslatedList: #(
- -
- ('references... (r)' browseVariableReferences)
- ('assignments... (a)' browseVariableAssignments)
- ('class refs (N)' browseClassRefs)).!
Item was removed:
- ----- Method: Inspector>>addCollectionItemsTo: (in category 'menu - construction') -----
- addCollectionItemsTo: aMenu
-
- aMenu
- add: 'inspect element...' translated
- target: self
- selector: #inspectOne.!
Item was removed:
- ----- Method: Inspector>>addCustomField (in category 'fields - custom') -----
- addCustomField
-
- ^ self addCustomField: (self requestCustomFieldOrCancel: [^ self])!
Item was removed:
- ----- Method: Inspector>>addCustomField: (in category 'fields - custom') -----
- addCustomField: aField
-
- aField type: #custom.
- self customFields add: aField.
- self updateFields.
- self selectField: aField.!
Item was removed:
- ----- Method: Inspector>>addEtoysItemsTo: (in category 'menu - construction') -----
- addEtoysItemsTo: aMenu
-
- aMenu addLine; addTranslatedList: {
- { 'tile for this value (t)'. [self selectionOrObject tearOffTile] }.
- { 'viewer for this value (v)'. [self selectionOrObject beViewed] }}.!
Item was removed:
- ----- Method: Inspector>>addFieldItemsTo: (in category 'menu - construction') -----
- addFieldItemsTo: aMenu
-
- aMenu addTranslatedList: #(
- -
- ('copy name (c)' copyName)
- ('copy expression' copyExpression 'Copy a code snippet that returns the field''s value when evaluated on the inspected object.')).!
Item was removed:
- ----- Method: Inspector>>addInstVarItemsTo: (in category 'menu - construction') -----
- addInstVarItemsTo: aMenu
-
- aMenu addTranslatedList: #(
- -
- ('references (r)' browseVariableReferences)
- ('assignments (a)' browseVariableAssignments)).!
Item was removed:
- ----- Method: Inspector>>addObjectItemsTo: (in category 'menu - construction') -----
- addObjectItemsTo: aMenu
- "The following menu items trigger actions appropricate to all kinds of objects."
-
- self typeOfSelection = #ellipsis ifTrue: [^ self].
-
- aMenu addTranslatedList: {
- {'inspect (i)'. #inspectSelection}.
- {'explore (I)'. #exploreSelection}.
- {'basic inspect'. #inspectSelectionBasic.
- 'Inspect all instvars of the object, regardless of\any possible specialized Inspector for this type' withCRs}}.
-
- aMenu addTranslatedList: {
- #-.
- {'inspect pointers'. #objectReferencesToSelection. 'objects pointing to this value'}.
- {'chase pointers'. #chaseSelectionPointers}.
- {'explore pointers'. #exploreSelectionPointers} }.!
Item was removed:
- ----- Method: Inspector>>allInstVarsTranslated (in category 'private') -----
- allInstVarsTranslated
- "Alas translation is slow enough that we notice the slow down in trying to step in the debugger..."
- (CurrentLocale ~= Locale current
- or: [CachedAllInstVarsLabel isNil]) ifTrue:
- [CurrentLocale := Locale current.
- CachedAllInstVarsLabel := 'all inst vars' translated].
- ^CachedAllInstVarsLabel!
Item was removed:
- ----- Method: Inspector>>applyUserInterfaceTheme (in category 'user interface') -----
- applyUserInterfaceTheme
-
- super applyUserInterfaceTheme.
-
- self fieldListStyler ifNotNil: [:styler |
- styler reset.
- self updateFieldList].!
Item was removed:
- ----- Method: Inspector>>browseClass (in category 'menu - commands') -----
- browseClass
- "Open a full browser on the class of the selected item"
-
- ^ ToolSet browseClass: self classOfSelection!
Item was removed:
- ----- Method: Inspector>>browseClassHierarchy (in category 'menu - commands') -----
- browseClassHierarchy
- "Open a class list browser on the receiver's hierarchy."
-
- ^ self systemNavigation browseHierarchy: self classOfSelection!
Item was removed:
- ----- Method: Inspector>>browseVariableAssignments (in category 'menu - commands') -----
- browseVariableAssignments
-
- ^ self selectedInstVarName
- ifNotNil: [:instVar | self systemNavigation
- browseAllStoresInto: instVar
- from: self object class]
- ifNil: [self systemNavigation browseVariableAssignments: self object class]!
Item was removed:
- ----- Method: Inspector>>browseVariableReferences (in category 'menu - commands') -----
- browseVariableReferences
-
- ^ self selectedInstVarName
- ifNotNil: [:instVar | self systemNavigation
- browseAllAccessesTo: instVar
- from: self object class]
- ifNil: [self systemNavigation browseVariableReferences: self object class]!
Item was removed:
- ----- Method: Inspector>>buildCodePaneWith: (in category 'toolbuilder') -----
- buildCodePaneWith: builder
- "Overridden. Note that I do not hold #contents in my code pane. See my value pane for that."
-
- ^ builder pluggableCodePaneSpec new
- model: self;
- getText: #expression;
- editText: #expression:;
- help: 'Evaluate expressions on inspected object' translated;
- menu: #codePaneMenu:shifted:;
- askBeforeDiscardingEdits: false;
- yourself!
Item was removed:
- ----- Method: Inspector>>buildExploreButtonWith: (in category 'toolbuilder') -----
- buildExploreButtonWith: builder
-
- ^ builder pluggableButtonSpec new
- model: self;
- label: 'explore' translated;
- action: #replaceInspectorWithExplorer;
- help: 'Switch to an explorer tool' translated;
- yourself!
Item was removed:
- ----- Method: Inspector>>buildFieldListWith: (in category 'toolbuilder') -----
- buildFieldListWith: builder
-
- ^ builder pluggableListSpec new
- model: self;
- list: #fieldList;
- getIndex: #selectionIndex;
- setIndex: #selectionIndex:;
- autoDeselect: true;
- menu: #fieldListMenu:shifted:;
- dragItem: #dragFromFieldList:;
- dropItem: #dropOnFieldList:at:shouldCopy:;
- keyPress: #inspectorKey:from:;
- yourself!
Item was removed:
- ----- Method: Inspector>>buildValuePaneWith: (in category 'toolbuilder') -----
- buildValuePaneWith: builder
- "The value pane holds this StringHolder's contents."
-
- ^ builder pluggableCodePaneSpec new
- model: self;
- name: #valuePane;
- getText: #contents;
- setText: #contents:notifying:;
- editText: #typeValue:; "Turn on code styling as you type."
- help: 'Selected field''s value' translated;
- menu: #codePaneMenu:shifted:; "Share the menu with the code pane."
- yourself!
Item was removed:
- ----- Method: Inspector>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- "Inspector openOn: SystemOrganization"
-
- | windowSpec buttonOffset |
- buttonOffset := (Preferences standardButtonFont widthOfString: 'explore') * 3/2.
- windowSpec := self buildWindowWith: builder specs: {
- (0@0 corner: 0.3(a)0.71)
- -> [self buildFieldListWith: builder].
- (0.3(a)0.0 corner: 1(a)0.71)
- -> [self buildValuePaneWith: builder].
- (LayoutFrame fractions: (0(a)0.71 corner: 1@1) offsets: (0@0 corner: buttonOffset negated@0))
- -> [self buildCodePaneWith: builder].
- (LayoutFrame fractions: (1(a)0.71 corner: 1@1) offsets: (buttonOffset negated@0 corner: 0 @ 0))
- -> [self buildExploreButtonWith: builder].
- }.
- ^ builder build: windowSpec!
Item was removed:
- ----- Method: Inspector>>chaseSelectionPointers (in category 'menu - commands') -----
- chaseSelectionPointers
-
- | selected saved |
- self hasSelection ifFalse: [^ self changed: #flash].
- selected := self selectionOrObject.
- saved := self object.
- self object: nil.
- ^ [(selected respondsTo: #chasePointers)
- flag: #ct "Do we indeed need to isolate Tools-Inspector and Tools-Debugger?";
- flag: #ct "ToolSet";
- ifTrue: [selected chasePointers]
- ifFalse: [selected inspectPointers]]
- ensure: [self object: saved]!
Item was removed:
- ----- Method: Inspector>>classOfSelection (in category 'selection - convenience') -----
- classOfSelection
- "Answer the class of the receiver's current selection"
-
- ^ self selectionOrObject class!
Item was removed:
- ----- Method: Inspector>>contents:notifying: (in category 'accessing - contents') -----
- contents: aString notifying: aController
- "Try to change the contents of the selected field. This is the usual callback for all string holders."
-
- | result |
- result := self object class evaluatorClass new
- evaluate: aString
- in: self doItContext
- to: self doItReceiver
- notifying: aController
- ifFail: [^ false].
-
- ^ self replaceSelectionValue: result!
Item was removed:
- ----- Method: Inspector>>contentsForErrorDoing: (in category 'fields - error handling') -----
- contentsForErrorDoing: aBlock
-
- ^ 'An error occurred while inspecting this object. {1} to debug the error.'
- translated asText format: {
- Text
- string: 'Click here' translated
- attributes: { TextEmphasis bold. PluggableTextAttribute evalBlock: aBlock }}!
Item was removed:
- ----- Method: Inspector>>contentsForTruncationOf: (in category 'fields - truncation') -----
- contentsForTruncationOf: truncatedKeys
-
- ^ ('<Fields named {1} to {2} are not shown. {3} to inspect one of those fields or select "inspect element" from the field list menu.>' translated asText
- addAttribute: TextEmphasis italic;
- format: {
- truncatedKeys first storeString.
- truncatedKeys last storeString.
- 'Click here' translated asText
- addAttribute: (PluggableTextAttribute evalBlock: [self inspectOneOf: truncatedKeys]);
- yourself. })!
Item was removed:
- ----- Method: Inspector>>contentsTyped (in category 'accessing - contents') -----
- contentsTyped
-
- ^ contentsTyped!
Item was removed:
- ----- Method: Inspector>>contentsTyped: (in category 'accessing - contents') -----
- contentsTyped: aStringOrText
-
- contentsTyped := aStringOrText.!
Item was removed:
- ----- Method: Inspector>>context (in category 'accessing') -----
- context
-
- ^ context!
Item was removed:
- ----- Method: Inspector>>context: (in category 'accessing') -----
- context: ctxt
- "Set the context of inspection, which is used for syntax highlighting and code evaluation."
-
- context := ctxt.!
Item was removed:
- ----- Method: Inspector>>copyExpression (in category 'menu - commands') -----
- copyExpression
- "From the selected field, copy the code expression that returns the contents of the value pane into the clipboard."
-
- (self expressionForField: self selectedField)
- ifNil: [self error: 'Cannot determine field expression' translated]
- ifNotNil: [:fieldExpression | Clipboard clipboardText: fieldExpression].!
Item was removed:
- ----- Method: Inspector>>copyName (in category 'menu - commands') -----
- copyName
- "Copy the name of the selected field into clipboard."
-
- self selectedFieldName
- ifNil: [self error: 'Cannot determine field name.' translated]
- ifNotNil: [:name | Clipboard clipboardText: name].!
Item was removed:
- ----- Method: Inspector>>customFields (in category 'accessing') -----
- customFields
-
- ^ customFields!
Item was removed:
- ----- Method: Inspector>>defaultIntegerBase (in category 'user interface') -----
- defaultIntegerBase
- "Answer the default base in which to print integers.
- Defer to the class of the instance."
-
- ^ (self object class respondsTo: #defaultIntegerBaseInDebugger)
- ifTrue: [self object class perform: #defaultIntegerBaseInDebugger]
- ifFalse: [10]!
Item was removed:
- ----- Method: Inspector>>doItContext (in category 'accessing') -----
- doItContext
- "Answer the context in which a text selection can be evaluated."
-
- ^ self context!
Item was removed:
- ----- Method: Inspector>>doItReceiver (in category 'accessing') -----
- doItReceiver
- "Answer the object that should be informed of the result of evaluating a text selection."
-
- ^ self object!
Item was removed:
- ----- Method: Inspector>>dragFromFieldList: (in category 'fields - drag and drop') -----
- dragFromFieldList: index
-
- ^ (self fields at: index ifAbsent: [nil])
- ifNotNil: [:fieldToDrag | fieldToDrag rememberInspector]!
Item was removed:
- ----- Method: Inspector>>dropOnFieldList:at:shouldCopy: (in category 'fields - drag and drop') -----
- dropOnFieldList: anObjectOrField at: index shouldCopy: shouldCopyField
- "Drop an object to change a field's value or drop a field to add it to the list of custom fields."
-
- (shouldCopyField and: [anObjectOrField isKindOf: self fieldClass])
- ifTrue: [
- self flag: #refactor. "mt: Instead of abusing #shouldCopy, write a separate hook for dropping fields between list items to insert fields."
- self addCustomField: anObjectOrField forgetInspector copy]
- ifFalse: [
- self selectionIndex: index.
- self replaceSelectionValue: anObjectOrField value].!
Item was removed:
- ----- Method: Inspector>>elementAt: (in category 'private - collections') -----
- elementAt: indexOrKey
- "Backstop to simplify #inspectOne for all kinds of inspectors."
-
- ^ (self elementGetterAt: indexOrKey) value: self object!
Item was removed:
- ----- Method: Inspector>>elementGetterAt: (in category 'private - collections') -----
- elementGetterAt: indexOrKey
- "Backstop to simplify #inspectOne for all kinds of inspectors."
-
- ^ [:object | object basicAt: indexOrKey]!
Item was removed:
- ----- Method: Inspector>>emphasizeError: (in category 'fields - error handling') -----
- emphasizeError: errorMessage
-
- ^ ('<{1}>' asText format: { errorMessage })
- addAttribute: self textColorForError;
- yourself!
Item was removed:
- ----- Method: Inspector>>ensureSelectedField (in category 'selection') -----
- ensureSelectedField
- "If there is no field selected, try to select the first one."
-
- self hasSelection
- ifFalse: [self selectionIndex: 1].
-
- ^ self selectedField!
Item was removed:
- ----- Method: Inspector>>exploreSelection (in category 'menu - commands') -----
- exploreSelection
-
- ^ self selectionOrObject explore!
Item was removed:
- ----- Method: Inspector>>exploreSelectionPointers (in category 'menu - commands') -----
- exploreSelectionPointers
-
- ^ self selectionOrObject explorePointers!
Item was removed:
- ----- Method: Inspector>>expression (in category 'accessing - contents') -----
- expression
- "The code string in the code pane. Recorded for Inspector/Explorer switching. See #replaceInspectorWithExplorer."
-
- ^ expression ifNil: ['']!
Item was removed:
- ----- Method: Inspector>>expression: (in category 'accessing - contents') -----
- expression: aStringOrText
- "The code string in the code pane. Recorded for Inspector/Explorer switching. See #replaceInspectorWithExplorer."
-
- expression := aStringOrText.!
Item was removed:
- ----- Method: Inspector>>expressionForField: (in category 'fields') -----
- expressionForField: anInspectorField
- "Subclasses can override this to configure the way to retrieve the source-code expression for the field."
-
- ^ anInspectorField valueGetterExpression!
Item was removed:
- ----- Method: Inspector>>fieldAllInstVars (in category 'fields') -----
- fieldAllInstVars
-
- ^ (self newFieldForType: #all key: #allInstVars)
- name: self allInstVarsTranslated; emphasizeName;
- valueGetter: [:obj | obj longPrintString]; printValueAsIs;
- yourself!
Item was removed:
- ----- Method: Inspector>>fieldClass (in category 'initialization') -----
- fieldClass
-
- ^ InspectorField!
Item was removed:
- ----- Method: Inspector>>fieldList (in category 'user interface') -----
- fieldList
- "Return a list of texts that identify the fields for the object under inspection so that the user can make an informed decision on what to inspect."
-
- ^ self fieldListStyler
- ifNil: [self fields collect: [:field | field name]]
- ifNotNil: [:styler |
- self updateStyler: styler.
- self fields collect: [:field |
- field shouldStyleName
- ifTrue: [styler styledTextFor: field name asText]
- ifFalse: [field name]]]!
Item was removed:
- ----- Method: Inspector>>fieldListMenu: (in category 'menu') -----
- fieldListMenu: aMenu
- "Arm the supplied menu with items for the field-list of the receiver"
- ^ self menu: aMenu for: #(fieldListMenu fieldListMenuShifted:)
- !
Item was removed:
- ----- Method: Inspector>>fieldListMenu:shifted: (in category 'menu') -----
- fieldListMenu: aMenu shifted: shifted
- "Arm the supplied menu with items for the field-list of the receiver"
- ^ self
- menu: aMenu
- for: #(fieldListMenu fieldListMenuShifted:)
- shifted: shifted!
Item was removed:
- ----- Method: Inspector>>fieldListStyler (in category 'user interface - styling') -----
- fieldListStyler
- "This is an extra styler to style the items in the field list. Note that both code and value pane use their own styler."
-
- ^ fieldListStyler!
Item was removed:
- ----- Method: Inspector>>fieldSelf (in category 'fields') -----
- fieldSelf
-
- ^ (self newFieldForType: #self key: #self)
- name: 'self'; styleName: ((UserInterfaceTheme current get: #self for: #SHTextStylerST80) ifNil: [#()]);
- valueGetter: [:obj | obj];
- valueSetter: [:obj :value | self object: value]; "Switch to another object-under-inspection."
- yourself!
Item was removed:
- ----- Method: Inspector>>fields (in category 'accessing') -----
- fields
-
- ^ fields ifNil: [#()]!
Item was removed:
- ----- Method: Inspector>>getContents (in category 'user interface') -----
- getContents
-
- | newContents |
- selectionUpdateTime := 0.
-
- self hasSelection ifFalse: [^ ''].
-
- selectionUpdateTime := [
- newContents := self selection in: [:object |
- self selectedField shouldPrintValueAsIs
- ifTrue: [object asStringOrText] "Show strings and texts without quoting and without ellipsis."
- ifFalse: [
- object isInteger
- ifTrue: [object storeStringBase: self defaultIntegerBase]
- ifFalse: [object printString]]].
- ] timeToRun.
-
- ^ newContents!
Item was removed:
- ----- Method: Inspector>>hasCustomFields (in category 'fields - custom') -----
- hasCustomFields
-
- ^ self customFields notEmpty!
Item was removed:
- ----- Method: Inspector>>hasSelection (in category 'selection') -----
- hasSelection
- "Use #selectedField instead of #selectionIndex to guard against invalid #selectionIndex. Can happen, for example, when adding elements to sets."
-
- ^ self selectedField notNil!
Item was removed:
- ----- Method: Inspector>>initialExtent (in category 'initialization') -----
- initialExtent
- "Answer the desired extent for the receiver when it is first opened on the screen. "
-
- ^ 350 @ 250!
Item was removed:
- ----- Method: Inspector>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
-
- customFields := OrderedCollection new.
- selectionIndex := 0.
-
- fieldListStyler := (TextStyler for: #Smalltalk)
- ifNotNil: [:class | class new].!
Item was removed:
- ----- Method: Inspector>>inspect: (in category 'initialization') -----
- inspect: anObject
- "Reinitialize the receiver so that it is inspecting anObject. Become an instance of the appropriate inspectorClass.
-
- Normally the receiver will be of the correct class (as defined by anObject inspectorClass), because it will have just been created by sending inspect to anObject. However, the debugger uses two embedded inspectors, which are re-targetted on the current receiver each time the stack frame changes. The left-hand inspector in the debugger has its class changed by the code here."
-
- | inspectorClass |
- inspectorClass := anObject inspectorClass.
- self class ~= inspectorClass ifTrue: [
- self class format = inspectorClass format
- ifTrue: [self primitiveChangeClassTo: inspectorClass basicNew]
- ifFalse: [self becomeForward: (self as: inspectorClass)]].
-
- self object: anObject.!
Item was removed:
- ----- Method: Inspector>>inspectOne (in category 'menu - commands') -----
- inspectOne
- "This is the most generic case to inspect a specific element from the inspected object. Since trunction of fields is a generic feature, support lookup for those truncated objects also for non-collections."
-
- self inspectOneOf: (1 to: self object basicSize).!
Item was removed:
- ----- Method: Inspector>>inspectOneOf: (in category 'menu - commands') -----
- inspectOneOf: someKeys
-
- | elements labels choice |
- someKeys size = 0 ifTrue: [^ self inform: 'Nothing to inspect.' translated].
- someKeys size = 1 ifTrue: [^ (self elementAt: someKeys first) inspect].
- someKeys size > 50 ifTrue: [^ self inspectOneOfFrom: someKeys first to: someKeys last].
-
- elements := someKeys collect: [:key | [self elementAt: key] ifError: ['<???>']].
- labels := someKeys with: elements collect: [:key :element |
- '{1} -> {2}' format: {
- key printString.
- [element printString withoutLineEndings withBlanksCondensed truncateWithElipsisTo: 75]
- ifError: ['<???>']}].
- choice := Project uiManager chooseFrom: labels title: 'Inspect which field?' translated.
- choice = 0 ifTrue: [^ self].
-
- (elements at: choice) inspect.!
Item was removed:
- ----- Method: Inspector>>inspectOneOfFrom:to: (in category 'menu - commands') -----
- inspectOneOfFrom: firstKey to: lastKey
- "Let the user specify the desired field's key in the form of a Smalltalk literal or otherwise simple code expression."
-
- | choiceString |
- choiceString := Project uiManager
- request: ('Enter the name of the field to inspect.\Names range from {1} to {2}.' translated withCRs
- format: {firstKey storeString. lastKey storeString})
- initialAnswer: firstKey storeString.
- choiceString isEmptyOrNil ifTrue: [^ self].
-
- (self elementAt: (Compiler evaluate: choiceString)) inspect.!
Item was removed:
- ----- Method: Inspector>>inspectSelection (in category 'menu - commands') -----
- inspectSelection
- "Create and schedule an Inspector on the receiver's model's currently selected object."
-
- self hasSelection ifFalse: [^ self changed: #flash].
- ^ self selectionOrObject inspect!
Item was removed:
- ----- Method: Inspector>>inspectSelectionBasic (in category 'menu - commands') -----
- inspectSelectionBasic
- "Bring up an inspector that focuses on the very basics of an object."
-
- ^ ToolSet basicInspect: self selectionOrObject!
Item was removed:
- ----- Method: Inspector>>inspectorKey:from: (in category 'menu') -----
- inspectorKey: aChar from: view
- "Respond to a Command key issued while the cursor is over my field list"
-
- ^ aChar
- caseOf: {
- [$x] -> [self removeSelection].
-
- [$i] -> [self inspectSelection].
- [$I] -> [self exploreSelection].
- [$b] -> [self browseClass].
- [$h] -> [self browseClassHierarchy].
- [$p] -> [self browseFullProtocol].
- [$r] -> [self browseVariableReferences].
- [$a] -> [self browseVariableAssignments].
- [$N] -> [self browseClassRefs].
- [$c] -> [self copyName].
- [$t] -> [self tearOffTile].
- [$v] -> [self viewerForValue] }
- otherwise: [self arrowKey: aChar from: view]!
Item was removed:
- ----- Method: Inspector>>labelString (in category 'user interface - window') -----
- labelString
- "See #windowTitle. All tools chose to implement #labelString."
-
- ^ '{1}{2}' format: {
- self object defaultLabelForInspector.
- self object isReadOnlyObject
- ifTrue: [' (read-only)' translated]
- ifFalse: ['']}!
Item was removed:
- ----- Method: Inspector>>mainFieldListMenu: (in category 'menu') -----
- mainFieldListMenu: aMenu
- "Arm the supplied menu with items for the field-list of the receiver"
- <fieldListMenu>
- aMenu addStayUpItemSpecial.
-
- self addObjectItemsTo: aMenu.
-
- (#(self ellipsis element nil) includes: self typeOfSelection)
- ifTrue: [self addCollectionItemsTo: aMenu].
-
- self typeOfSelection = #instVar
- ifTrue: [self addInstVarItemsTo: aMenu].
-
- self addFieldItemsTo: aMenu.
- self addClassItemsTo: aMenu.
-
- Smalltalk isMorphic ifTrue: [
- self flag: #refactor. "mt: Extract Etoys-specific extension."
- "ct: We could use the <fieldListMenu> pragma if it had a priority argument!!"
- self addEtoysItemsTo: aMenu].
-
- ^ aMenu!
Item was removed:
- ----- Method: Inspector>>metaFieldListMenu: (in category 'menu') -----
- metaFieldListMenu: aMenu
- <fieldListMenu"Shifted: true">
- self flag: #ct "we need keyboard support for shifted menus. Maybe add an item 'More...'?".
-
- aMenu addLine.
- aMenu addTranslatedList: #(
- ('add field...' #addCustomField)).
- self selectedField ifNotNil: [:field |
- field isCustom ifTrue: [
- field addCustomItemsFor: self to: aMenu]].
- ^ aMenu!
Item was removed:
- ----- Method: Inspector>>modelWakeUpIn: (in category 'updating - steps') -----
- modelWakeUpIn: aWindow
-
- self updateFields.!
Item was removed:
- ----- Method: Inspector>>newCustomField (in category 'fields - custom') -----
- newCustomField
-
- ^ (self newFieldForType: #custom)
- valueGetterExpression: 'self yourself';
- yourself!
Item was removed:
- ----- Method: Inspector>>newFieldForType: (in category 'fields') -----
- newFieldForType: aSymbol
-
- ^ self fieldClass type: aSymbol!
Item was removed:
- ----- Method: Inspector>>newFieldForType:key: (in category 'fields') -----
- newFieldForType: aSymbol key: anObject
-
- ^ self fieldClass type: aSymbol key: anObject!
Item was removed:
- ----- Method: Inspector>>noteSelectionIndex:for: (in category 'selection') -----
- noteSelectionIndex: anInteger for: aSymbol
-
- self flag: #mvcOnly.
- aSymbol == #fieldList ifTrue:
- [selectionIndex := anInteger].!
Item was removed:
- ----- Method: Inspector>>object (in category 'accessing') -----
- object
- "Answer the object being inspected by the receiver."
-
- ^object!
Item was removed:
- ----- Method: Inspector>>object: (in category 'accessing') -----
- object: anObject
- "Set anObject to be the object being inspected by the receiver. The current contents, including edits, in the value pane become void because the new object is likely to have new fields with different contents."
-
- self object == anObject ifTrue: [^ self].
- self resetContents.
-
- object := anObject.
- self changed: #object.
-
- self changed: #windowTitle.
-
- self updateFields.!
Item was removed:
- ----- Method: Inspector>>objectOkToClose (in category 'user interface - window') -----
- objectOkToClose
-
- ^ (self object respondsTo: #inspectorOkToClose)
- ==> [(self object perform: #inspectorOkToClose) == true]!
Item was removed:
- ----- Method: Inspector>>objectReferencesToSelection (in category 'menu - commands') -----
- objectReferencesToSelection
- "Open a list inspector on all the objects that point to the value of the selected object."
-
- ^ self systemNavigation
- browseAllObjectReferencesTo: self selectionOrObject
- except: (Array with: self with: self object)
- ifNone: [:obj | self changed: #flash]!
Item was removed:
- ----- Method: Inspector>>okToClose (in category 'user interface - window') -----
- okToClose
- "Check custom fields and give the object-under-inspection a chance to react. Maybe this explorer is an important reference to the object and the user needs to be informed about this fact."
-
- ^ super okToClose
- and: [self okToDiscardCustomFields
- and: [self objectOkToClose]]!
Item was removed:
- ----- Method: Inspector>>okToDiscardCustomFields (in category 'user interface - window') -----
- okToDiscardCustomFields
-
- ^ self hasCustomFields ==> [self confirm: (String streamContents: [:s |
- s nextPutAll: 'All custom fields will be discarded:' translated.
- self customFields do: [:field |
- s crtab; nextPutAll: field name] ])]!
Item was removed:
- ----- Method: Inspector>>okToRevertChanges: (in category 'user edits') -----
- okToRevertChanges: aspect
- "Clear caches since we use #textEdited: callback from view."
-
- aspect = #expression: ifTrue: [
- expression := ''].
- aspect = #typeValue: ifTrue: [
- contentsTyped := nil.
- shouldStyleValuePane := false].
- ^ true!
Item was removed:
- ----- Method: Inspector>>removeCustomField: (in category 'fields - custom') -----
- removeCustomField: aField
-
- aField isCustom
- ifFalse: [^ self changed: #flash].
- (self customFields includes: aField)
- ifFalse: [^ self changed: #flash].
-
- (self confirm: ('Do you really want to remove the field ''{1}''?' translated format: {aField name}))
- ifFalse: [^ self].
-
- self customFields remove: aField.
- self updateFields.!
Item was removed:
- ----- Method: Inspector>>removeSelection (in category 'menu - commands') -----
- removeSelection
- "In general, we can always remove custom fields. Specialized inspectors can offer to remove other fields such as those representing collection elements."
-
- self selectedField ifNotNil: [:field |
- field isCustom ifTrue: [self removeCustomField: field]].!
Item was removed:
- ----- Method: Inspector>>replaceInspectorWithExplorer (in category 'toolbuilder') -----
- replaceInspectorWithExplorer
- "Switch to an explorer tool. If there are custom fields, the user can choose to not discard them, which will just spawn a new explorer tool besides this inspector."
-
- | window currentBounds |
- self flag: #todo. "ct: In the long term, we should try to communicate specific selectors (here: #expression) along the observer pattern for requests such as #acceptChanges or #wantToChange instead of exploiting contentsTyped etc."
-
- (self okToDiscardCustomFields and: [contentsTyped notNil ==> [self confirm:
- 'Changes have not been saved.
- Is it OK to cancel those changes?' translated orCancel: [^ self]]])
- ifFalse: [^ self object explore].
-
- self customFields removeAll.
- self changed: #contents. "Reset value pane contents before accepting all contents"
- self changed: #acceptChanges. "We copy the current state anyway. See below."
- currentBounds := ToolBuilder default class getBoundsForWindow: self containingWindow.
-
- "Close first because MVC fiddles around with processes."
- self changed: #close.
-
- window := ToolSet explore: self object.
-
- "---- In MVC, the lines after this will not be executed ---"
-
- window model setExpression: self expression.
- ToolBuilder default class setBoundsForWindow: window to: currentBounds.!
Item was removed:
- ----- Method: Inspector>>replaceSelectionValue: (in category 'selection') -----
- replaceSelectionValue: anObject
- "Set the value of the selected field to anObject. We have to answer whether this replacement worked or not."
-
- | target |
- (target := self ensureSelectedField) ifNil: [^ false].
-
- target type = #self ifTrue: [
- ^ (self confirm: 'This will exchange the inspected object.' translated)
- ifTrue: [self inspect: anObject. true]
- ifFalse: [false]].
-
- target isReadOnly ifTrue: [
- self inform: 'You cannot replace the selected field because\it is read-only. Try to add a field setter.' withCRs.
- ^ false].
-
- self contentsTyped: nil. "Ensure to refresh the contents view."
-
- target
- setValueFor: self
- to: anObject.
-
- ^ true!
Item was removed:
- ----- Method: Inspector>>representsSameBrowseeAs: (in category 'user interface') -----
- representsSameBrowseeAs: anotherInspector
-
- ^ self object == anotherInspector object!
Item was removed:
- ----- Method: Inspector>>requestCustomFieldOrCancel: (in category 'fields - custom') -----
- requestCustomFieldOrCancel: aBlock
-
- ^ self newCustomField
- requestCustomFor: self
- orCancel: aBlock!
Item was removed:
- ----- Method: Inspector>>resetContents (in category 'initialization') -----
- resetContents
-
- self setContents: nil.!
Item was removed:
- ----- Method: Inspector>>resetFields (in category 'initialization') -----
- resetFields
-
- "1) Discard existing fields."
- fields ifNotNil: [
- fields do: [:field | field removeDependent: self].
- fields := nil "Just in case there is an error in the following calls."].
-
- "2a) Create new fields."
- fields := Array streamContents: [:stream |
- | workBlock |
- workBlock := [self streamFieldsOn: stream].
- workBlock ifError: [self streamErrorDoing: workBlock on: stream]].
-
- "2b) Establish field dependency."
- fields do: [:field | field addDependent: self].
-
- "3) Tell the views."
- self updateFieldList.!
Item was removed:
- ----- Method: Inspector>>selectField: (in category 'selection') -----
- selectField: aField
-
- self selectionIndex: (self fields indexOf: aField ifAbsent: [0])!
Item was removed:
- ----- Method: Inspector>>selectFieldNamed: (in category 'selection') -----
- selectFieldNamed: aString
- "Select the field that is labeled aFieldName, or nothing, is there is no match."
-
- self selectFieldSuchThat: [:field | field name = aString].!
Item was removed:
- ----- Method: Inspector>>selectFieldSuchThat: (in category 'selection') -----
- selectFieldSuchThat: aBlock
- "Select the first field for which aBlock evaluates to true."
-
- self selectionIndex: (self fields findFirst: aBlock).!
Item was removed:
- ----- Method: Inspector>>selectedClass (in category 'selection - convenience') -----
- selectedClass
-
- ^ self object class!
Item was removed:
- ----- Method: Inspector>>selectedField (in category 'selection') -----
- selectedField
-
- ^ self fields
- at: self selectionIndex
- ifAbsent: [nil]!
Item was removed:
- ----- Method: Inspector>>selectedFieldName (in category 'selection') -----
- selectedFieldName
-
- ^ self selectedField ifNotNil: [:field | field name]!
Item was removed:
- ----- Method: Inspector>>selectedInstVarName (in category 'selection - convenience') -----
- selectedInstVarName
-
- ^ self selectedField ifNotNil: [:field |
- field type = #instVar
- ifTrue: [field key]
- ifFalse: [nil]].!
Item was removed:
- ----- Method: Inspector>>selection (in category 'selection') -----
- selection
- "Answer the value of the selected variable slot, that is an object."
-
- ^ self selectedField getValueFor: self!
Item was removed:
- ----- Method: Inspector>>selectionIndex (in category 'accessing') -----
- selectionIndex
-
- ^ selectionIndex!
Item was removed:
- ----- Method: Inspector>>selectionIndex: (in category 'accessing') -----
- selectionIndex: anInteger
- "Changes the index to determine the currently selected field. If the field is already selected, update the fields contents in the value pane."
-
- self selectionIndex = anInteger
- ifTrue: [^ self updateContentsSafely].
-
- selectionIndex := anInteger.
- self changed: #selectionIndex.
-
- self updateContentsSafely.!
Item was removed:
- ----- Method: Inspector>>selectionIsReadOnly (in category 'selection - convenience') -----
- selectionIsReadOnly
- "Answer if the current selected variable is not modifiable via acceptance in the code pane. For example, a selection of 'all inst vars' is unmodifiable."
-
- ^ self selectedField
- ifNil: [true]
- ifNotNil: [:field | field isReadOnly]!
Item was removed:
- ----- Method: Inspector>>selectionOrObject (in category 'selection - convenience') -----
- selectionOrObject
- "My selection. If nothing useful is selected, return the inspected object instead."
-
- self hasSelection ifFalse: [^ self object].
- self typeOfSelection = #ellipsis ifTrue: [^ self object].
-
- ^ self selection!
Item was removed:
- ----- Method: Inspector>>setContents: (in category 'initialization') -----
- setContents: aStringOrText
- "Do not style the value pane anymore. Clear the #contentsTyped buffer."
-
- shouldStyleValuePane := false.
- super setContents: aStringOrText.
- self contentsTyped: nil.!
Item was removed:
- ----- Method: Inspector>>setContentsTyped: (in category 'initialization') -----
- setContentsTyped: aStringOrText
- "Simulate typing."
-
- shouldStyleValuePane := true.
- self contentsTyped: aStringOrText.
-
- self flag: #refactor. "mt: #changed: is not able to specify the receiver ..."
- self valuePane ifNotNil: [:pane |
- pane update: #editString with: aStringOrText].!
Item was removed:
- ----- Method: Inspector>>setExpression: (in category 'initialization') -----
- setExpression: aString
- "Set the code string in the code pane after switching between Inspector/Explorer. See #replaceInspectorWithExplorer."
-
- self expression: aString.
- self changed: #expression.!
Item was removed:
- ----- Method: Inspector>>stepAt:in: (in category 'updating - steps') -----
- stepAt: millisecondClockValue in: aWindow
-
- self updateFields.!
Item was removed:
- ----- Method: Inspector>>stepTimeIn: (in category 'updating - steps') -----
- stepTimeIn: aWindow
- "Minimum step time is 1 second. If the fetching of contents takes more than 100 milliseconds, increase the step time accordingly to keep the system responsive."
-
- ^ (selectionUpdateTime ifNil: [0]) * 10 max: 1000!
Item was removed:
- ----- Method: Inspector>>streamBaseFieldsOn: (in category 'fields - streaming') -----
- streamBaseFieldsOn: aStream
-
- aStream
- nextPut: self fieldSelf;
- nextPut: self fieldAllInstVars.!
Item was removed:
- ----- Method: Inspector>>streamCustomFieldsOn: (in category 'fields - streaming') -----
- streamCustomFieldsOn: aStream
-
- aStream nextPutAll: self customFields.!
Item was removed:
- ----- Method: Inspector>>streamError:on: (in category 'fields - error handling') -----
- streamError: aMessageString on: aStream
-
- aStream nextPut: ((self newFieldForType: #error)
- name: (Text
- string: '<error>' translated
- attribute: self textColorForError);
- valueGetter: [:object | self emphasizeError: aMessageString];
- printValueAsIs;
- yourself)!
Item was removed:
- ----- Method: Inspector>>streamErrorDoing:on: (in category 'fields - error handling') -----
- streamErrorDoing: aBlock on: aStream
-
- self
- streamError: (self contentsForErrorDoing: aBlock)
- on: aStream.!
Item was removed:
- ----- Method: Inspector>>streamFieldsOn: (in category 'fields - streaming') -----
- streamFieldsOn: aStream
-
- self
- streamBaseFieldsOn: aStream;
- streamVariableFieldsOn: aStream;
- streamCustomFieldsOn: aStream.!
Item was removed:
- ----- Method: Inspector>>streamIndexedVariablesOn: (in category 'fields - streaming') -----
- streamIndexedVariablesOn: aStream
- "Truncate indexed variables if there are too many of them."
-
- self
- streamOn: aStream
- truncate: (1 to: self object basicSize)
- collectFields: [:index |
- (self newFieldForType: #indexed key: index)
- valueGetter: [:object | object basicAt: index];
- valueSetter: [:object :value | object basicAt: index put: value];
- yourself]!
Item was removed:
- ----- Method: Inspector>>streamInstanceVariablesOn: (in category 'fields - streaming') -----
- streamInstanceVariablesOn: aStream
-
- | attributesForInstVars |
- attributesForInstVars := (UserInterfaceTheme current get: #instVar for: #SHTextStylerST80) ifNil: [#()].
-
- (self object perform: #class "do not inline send of #class, receiver could be a proxy") allInstVarNames withIndexDo: [:name :index |
- aStream nextPut: ((self newFieldForType: #instVar key: name)
- name: name; styleName: attributesForInstVars;
- valueGetter: [:obj | obj instVarNamed: name];
- valueSetter: [:obj :value | obj instVarNamed: name put: value];
- yourself)].!
Item was removed:
- ----- Method: Inspector>>streamOn:truncate:collectFields: (in category 'fields - truncation') -----
- streamOn: aStream truncate: aList collectFields: aBlock
-
- ^ self
- streamOn: aStream
- truncate: aList
- collectFields: aBlock
- ellipsisFrom: [:truncatedObjects | (self newFieldForType: #ellipsis)
- name: '...';
- valueGetter: [:object | self contentsForTruncationOf: truncatedObjects];
- printValueAsIs;
- yourself]!
Item was removed:
- ----- Method: Inspector>>streamOn:truncate:collectFields:ellipsisFrom: (in category 'fields - truncation') -----
- streamOn: aStream truncate: someObjects collectFields: fieldBlock ellipsisFrom: ellipsisBlock
- "Create fields for someObjects using fieldBlock. Using the current #truncationLimit, create an extra ellipsis field to hide objects that go beyond this limit."
-
- (someObjects size <= self truncationLimit or: [self truncationLimit < 0])
- ifTrue: [^ aStream nextPutAll: (someObjects withIndexCollect: [:each :index | fieldBlock cull: each cull: index])].
-
- someObjects readStream in: [:readStream | | offset |
- offset := readStream size - self truncationTail.
- aStream
- nextPutAll: ((readStream next: self truncationLimit - self truncationTail - 1)
- withIndexCollect: [:each :index | fieldBlock cull: each cull: index]);
- nextPut: (ellipsisBlock value: (readStream upToPosition: offset));
- nextPutAll: (readStream upToEnd
- withIndexCollect: [:each :index | fieldBlock cull: each cull: index + offset])].!
Item was removed:
- ----- Method: Inspector>>streamVariableFieldsOn: (in category 'fields - streaming') -----
- streamVariableFieldsOn: aStream
-
- self
- streamInstanceVariablesOn: aStream;
- streamIndexedVariablesOn: aStream.!
Item was removed:
- ----- Method: Inspector>>textColorForError (in category 'user interface') -----
- textColorForError
-
- ^ TextColor color: ((UserInterfaceTheme current get: #errorColor for: #TestRunner) ifNil: [Color red])!
Item was removed:
- ----- Method: Inspector>>truncationLimit (in category 'fields - truncation') -----
- truncationLimit
- "The maximum number of fields to show when truncating a list of objects. For example, collections can have a very big number of indexed variables and the inspecter would become slow without this limit. Keep the system responsive. Note that there is an extra ellipsis field for the truncated items so that users can manually select the (truncated) indexed variable to inspect.
-
- Choose a limit < 0 to not truncate any fields."
-
- ^ 100!
Item was removed:
- ----- Method: Inspector>>truncationTail (in category 'fields - truncation') -----
- truncationTail
- "The number of fields to show at the end of a truncated field run."
-
- ^ 10!
Item was removed:
- ----- Method: Inspector>>typeOfSelection (in category 'selection - convenience') -----
- typeOfSelection
-
- ^ self selectedField ifNotNil: [:field | field type]!
Item was removed:
- ----- Method: Inspector>>typeValue: (in category 'user interface - styling') -----
- typeValue: aTextOrString
- "Style field value contents only after the user typed."
-
- contentsTyped := aTextOrString.
-
- shouldStyleValuePane == true ifFalse: [
- shouldStyleValuePane := true.
- self changed: #style].!
Item was removed:
- ----- Method: Inspector>>update (in category 'updating') -----
- update
- "For convenience."
-
- self updateFields.!
Item was removed:
- ----- Method: Inspector>>update: (in category 'updating') -----
- update: what
-
- what = #field ifTrue: [
- self updateFieldList.
- self updateContentsSafely].
-
- ^ super update: what!
Item was removed:
- ----- Method: Inspector>>update:with: (in category 'updating') -----
- update: what with: parameter
-
- what = #deleteField
- ifTrue: [self removeCustomField: parameter].
-
- ^ super update: what with: parameter!
Item was removed:
- ----- Method: Inspector>>updateContentsSafely (in category 'updating') -----
- updateContentsSafely
- "Force update contents of selected field. Do not style the contents anymore. Discard unaccepted changes in text fields."
-
- | workBlock |
- workBlock := [self getContents].
- self setContents: (workBlock
- ifError: [self emphasizeError: (self contentsForErrorDoing: workBlock)]).!
Item was removed:
- ----- Method: Inspector>>updateFieldList (in category 'updating') -----
- updateFieldList
-
- self changed: #fieldList.
- self changed: #selectionIndex. "In case a field got renamed, tell the view that the selection did not change at all. The view would otherwise assume it is gone after updating the list and clear the selection. That's a little interference with the built-in list filtering mechanism in the view."!
Item was removed:
- ----- Method: Inspector>>updateFields (in category 'updating') -----
- updateFields
- "Reset the collection of fields. Since amount and content my change, try to keep the current selection by field identity or field name."
-
- | field edits |
- field := self hasSelection ifTrue: [self selectedField]. "Save user selection"
- edits := self contentsTyped. "Save user edits"
-
- self resetFields.
-
- "Restore user selection"
- field ifNotNil: [
- (self fields identityIncludes: field)
- ifTrue: [self selectField: field]
- ifFalse: [self selectFieldNamed: field name]].
-
- "Restore user edits only if selection was restored."
- (edits notNil and: [self selectedField = field or: [self selectedFieldName = field name]])
- ifTrue: [self setContentsTyped: edits].
- !
Item was removed:
- ----- Method: Inspector>>updateListsAndCodeIn: (in category 'updating - steps') -----
- updateListsAndCodeIn: aWindow
- "Not needed. We have everything in place to update from here. See #updateFields. No need to update through views."!
Item was removed:
- ----- Method: Inspector>>updateStyler: (in category 'user interface - styling') -----
- updateStyler: aStyler
-
- self updateStyler: aStyler requestor: self.!
Item was removed:
- ----- Method: Inspector>>updateStyler:requestor: (in category 'user interface - styling') -----
- updateStyler: aStyler requestor: anObject
- "Use this method to update our fieldListStyler and all view stylers."
-
- aStyler
- environment: self environment;
- classOrMetaClass: (self doItReceiver perform: #class "do not inline send of #class, receiver could be a proxy");
- context: self doItContext;
- parseAMethod: false;
- workspace: nil "Normally we don't need this, but probably a workspace has been specified when the receiver was belonging to another class. See #inspect: and BlockClosureInspector >> #updateStyler:requestor:.".!
Item was removed:
- ----- Method: Inspector>>valuePane (in category 'user interface') -----
- valuePane
- "Private. This is a workaround to interact with the value pane directly and not interfere with the code pane."
-
- ^ self dependents
- detect: [:object | object knownName = #valuePane]
- ifNone: []!
Item was removed:
- ----- Method: Inspector>>veryDeepInner: (in category 'copying') -----
- veryDeepInner: aDeepCopier
- super veryDeepInner: aDeepCopier.
- expression := expression veryDeepCopyWith: aDeepCopier.
- contentsTyped := contentsTyped veryDeepCopyWith: aDeepCopier!
Item was removed:
- ----- Method: Inspector>>wantsStepsIn: (in category 'updating - steps') -----
- wantsStepsIn: aWindow
- "Independent of #smartUpdating preference".
-
- ^ true!
Item was removed:
- Model subclass: #InspectorBrowser
- instanceVariableNames: 'inspector browser'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !InspectorBrowser commentStamp: 'tcj 3/12/2018 07:55' prior: 0!
- I am an inspector that also shows all messages the inspected objects can understand. I combine inspector and code browser.
-
- InspectorBrowser openOn: Smalltalk!
Item was removed:
- ----- Method: InspectorBrowser class>>basicInspect: (in category 'inspector compatibility') -----
- basicInspect: anObject
- "ToolBuilder open: (self basicInspect: Morph new)"
-
- ^ self new
- setInspectorClass: BasicInspector;
- object: anObject;
- yourself!
Item was removed:
- ----- Method: InspectorBrowser class>>inspect: (in category 'inspector compatibility') -----
- inspect: anObject
- "ToolBuilder open: (self inspect: 42)"
-
- ^ self new inspect: anObject!
Item was removed:
- ----- Method: InspectorBrowser class>>on: (in category 'instance creation') -----
- on: anObject
- "We have to call #inspect: instead of #object: to choose the correct #inspectorClass."
-
- ^ self new inspect: anObject!
Item was removed:
- ----- Method: InspectorBrowser class>>openOn: (in category 'instance creation') -----
- openOn: anObject
-
- ^ ToolBuilder open: (self on: anObject)!
Item was removed:
- ----- Method: InspectorBrowser class>>openOn:withLabel: (in category 'instance creation') -----
- openOn: anObject withLabel: label
-
- ^ ToolBuilder open: (self on: anObject) label: label!
Item was removed:
- ----- Method: InspectorBrowser>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
-
- | windowSpec |
- windowSpec := self buildWindowWith: builder specs: {
- (0@0 corner: 0.3(a)0.3) -> [inspector buildFieldListWith: builder].
- (0.3@0 corner: 1.0(a)0.3) -> [inspector buildValuePaneWith: builder].
- (0(a)0.3 corner: 0.3(a)1.0) -> [browser buildMessageListWith: builder].
- (0.3(a)0.3 corner: 1.0(a)1.0) -> [browser buildCodePaneWith: builder].
- }.
- ^ builder build: windowSpec!
Item was removed:
- ----- Method: InspectorBrowser>>initialExtent (in category 'initialization') -----
- initialExtent
-
- ^ (inspector initialExtent x max: browser initialExtent x)
- @ ((inspector initialExtent y * 2/3) + browser initialExtent y)!
Item was removed:
- ----- Method: InspectorBrowser>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
-
- self setInspectorClass: Inspector.
- self setBrowserClass: Browser.!
Item was removed:
- ----- Method: InspectorBrowser>>inspect: (in category 'initialization') -----
- inspect: anObject
- "Reinitialize the inspector so that it is inspecting anObject."
-
- inspector inspect: anObject.
- browser setClass: anObject class.!
Item was removed:
- ----- Method: InspectorBrowser>>labelString (in category 'toolbuilder') -----
- labelString
- "The window title"
-
- ^ 'Inspector Browser: ', inspector labelString!
Item was removed:
- ----- Method: InspectorBrowser>>modelWakeUpIn: (in category 'stepping') -----
- modelWakeUpIn: aWindow
-
- inspector modelWakeUpIn: aWindow.
- browser modelWakeUpIn: aWindow.!
Item was removed:
- ----- Method: InspectorBrowser>>object (in category 'accessing') -----
- object
-
- ^ inspector object!
Item was removed:
- ----- Method: InspectorBrowser>>object: (in category 'accessing') -----
- object: anObject
- "Set anObject to be the object being inspected by the receiver."
-
- inspector object: anObject.
- browser setClass: anObject class.!
Item was removed:
- ----- Method: InspectorBrowser>>setBrowserClass: (in category 'initialization') -----
- setBrowserClass: aClass
-
- browser := aClass new.!
Item was removed:
- ----- Method: InspectorBrowser>>setInspectorClass: (in category 'initialization') -----
- setInspectorClass: aClass
-
- inspector := aClass new.
- inspector addDependent: self.!
Item was removed:
- ----- Method: InspectorBrowser>>stepAt:in: (in category 'stepping') -----
- stepAt: millisecondClockValue in: aWindow
-
- inspector stepAt: millisecondClockValue in: aWindow.
- browser stepAt: millisecondClockValue in: aWindow.!
Item was removed:
- ----- Method: InspectorBrowser>>stepTimeIn: (in category 'stepping') -----
- stepTimeIn: aWindow
-
- ^ (inspector stepTimeIn: aWindow)
- max: (browser stepTimeIn: aWindow)!
Item was removed:
- ----- Method: InspectorBrowser>>update: (in category 'updating') -----
- update: anAspect
- "When the inspector exchanges the object-under-inspection, reset the class of my browser."
-
- anAspect = #object ifTrue: [
- browser setClass: inspector object class].
- anAspect = #windowTitle ifTrue: [
- self changed: #windowTitle].
- super update: anAspect.!
Item was removed:
- ----- Method: InspectorBrowser>>updateListsAndCodeIn: (in category 'stepping') -----
- updateListsAndCodeIn: aWindow
-
- inspector updateListsAndCodeIn: aWindow.
- browser updateListsAndCodeIn: aWindow.!
Item was removed:
- ----- Method: InspectorBrowser>>wantsStepsIn: (in category 'stepping') -----
- wantsStepsIn: aWindow
-
- ^ (inspector wantsStepsIn: aWindow)
- or: [browser wantsStepsIn: aWindow]!
Item was removed:
- Object subclass: #InspectorField
- instanceVariableNames: 'key valueGetter valueGetterExpression valueSetter valueSetterExpression name shouldStyleName shouldStyleValue shouldPrintValueAsIs type inspector'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !InspectorField commentStamp: 'mt 3/9/2020 14:34' prior: 0!
- I represent a single field of an Inspector in which I am composed.
-
- I am basically a pair of #key and #value, but may have an extra human-readable #name to be shown in the Inspector's views. My #value can only be accessed in scope of an Inspector because I need an #object to work with.!
Item was removed:
- ----- Method: InspectorField class>>generateExpressionFrom:argumentNames: (in category 'support') -----
- generateExpressionFrom: aBlock argumentNames: argumentNames
-
- | blockNode arguments variables context receiver |
- self flag: #experimental.
- blockNode := aBlock decompile veryDeepCopy. "some literals are singletons, see #becomeForward: below"
- arguments := blockNode arguments collect: #name.
- variables := Dictionary new.
- variables
- at: #true put: true;
- at: #false put: false;
- at: #nil put: nil.
- receiver := aBlock receiver.
- receiver class allInstVarNames
- withIndexDo: [:name :index |
- variables at: name put: (receiver instVarAt: index)].
- context := aBlock outerContext.
- context tempNames
- withIndexDo: [:name :index |
- variables at: name put: (context namedTempAt: index)].
- blockNode nodesDo: [:node |
- self flag: #ct. "Should we introduce #nodesCollect: instead of using dangerous #becomeForward:?"
- {
- [node isVariableNode not].
- [| argumentIndex |
- argumentIndex := arguments indexOf: node name.
- argumentIndex isZero
- ifFalse: [node name: (argumentNames at: argumentIndex)];
- not].
- [variables at: node name
- ifPresent: [:value |
- value isLiteral
- ifTrue: [node becomeForward: (LiteralNode new key: value)];
- yourself]
- ifAbsent: [^ nil]].
- } detect: #value ifNone: [^ nil]].
- ^ String streamContents: [:stream |
- blockNode
- printStatementsOn: stream
- indent: 0].!
Item was removed:
- ----- Method: InspectorField class>>type: (in category 'instance creation') -----
- type: aSymbol
-
- ^ self new
- type: aSymbol;
- yourself!
Item was removed:
- ----- Method: InspectorField class>>type:key: (in category 'instance creation') -----
- type: aSymbol key: anObject
-
- ^ (self type: aSymbol)
- key: anObject
- yourself!
Item was removed:
- ----- Method: InspectorField>>addCustomItemsFor:to: (in category 'menu - construction') -----
- addCustomItemsFor: anInspector to: aMenu
-
- aMenu
- addLine;
- add: 'edit field name...' translated target: self selector: #editName;
- add: 'edit field getter...' translated target: self selector: #editGetterFor: argument: anInspector;
- add: (self valueSetter ifNil: ['add field setter...' translated] ifNotNil: ['edit field setter...' translated])
- target: self selector: #editSetterFor: argument: anInspector;
- addLine;
- add: ('remove field ''{1}'' (x)' translated format: {self name}) target: self selector: #delete.!
Item was removed:
- ----- Method: InspectorField>>deEmphasizeName (in category 'initialization') -----
- deEmphasizeName
-
- self flag: #hardcoded.
- self styleName:
- {TextColor color:
- ((UserInterfaceTheme current get: #balloonTextColor for: #PluggableTextMorphPlus)
- ifNil: [Color gray])}.!
Item was removed:
- ----- Method: InspectorField>>delete (in category 'custom - actions') -----
- delete
- "Request the deletion of this field in my inspector's list of (custom) fields."
-
- self changed: #deleteField with: self.!
Item was removed:
- ----- Method: InspectorField>>editGetterFor: (in category 'custom - actions') -----
- editGetterFor: aStringHolder
-
- ^ self editGetterFor: aStringHolder orCancel: []!
Item was removed:
- ----- Method: InspectorField>>editGetterFor:orCancel: (in category 'custom - actions') -----
- editGetterFor: anInspector orCancel: aBlock
-
- | code |
- code := Project uiManager
- request: 'Please enter an evaluable expression<br>to <b>get</b> this field''s value:' translated asTextFromHtml
- initialAnswer: self valueGetterExpression.
- code isEmptyOrNil ifTrue: [^ aBlock value].
-
- ^ self setGetterFor: anInspector to: code ifFail: aBlock!
Item was removed:
- ----- Method: InspectorField>>editName (in category 'custom - actions') -----
- editName
-
- ^ self editNameOrCancel: []!
Item was removed:
- ----- Method: InspectorField>>editNameOrCancel: (in category 'custom - actions') -----
- editNameOrCancel: aBlock
-
- | newTitle |
- newTitle := Project uiManager
- request: 'Please enter a new name for this field:' translated withCRs
- initialAnswer: self name asString.
- newTitle isEmptyOrNil ifTrue: [^ aBlock value].
- self name: newTitle; emphasizeName.
- self changed: #field.!
Item was removed:
- ----- Method: InspectorField>>editSetterFor: (in category 'custom - actions') -----
- editSetterFor: anInspector
-
- ^ self editSetterFor: anInspector orCancel: []!
Item was removed:
- ----- Method: InspectorField>>editSetterFor:orCancel: (in category 'custom - actions') -----
- editSetterFor: anInspector orCancel: aBlock
-
- | code |
- code := Project uiManager
- request: 'Please enter an evaluable expression<br>to <b>set</b> this field''s value:' translated asTextFromHtml
- initialAnswer: (self valueSetterExpression ifNil: '[:value | self ___: value]').
- code isEmptyOrNil ifTrue: [^ aBlock value].
- ^ self setSetterFor: anInspector to: code ifFail: aBlock!
Item was removed:
- ----- Method: InspectorField>>emphasizeName (in category 'initialization') -----
- emphasizeName
-
- self flag: #hardcoded.
- self styleName: {
- self isCustom
- ifFalse: [TextEmphasis italic]
- ifTrue: [TextColor color:
- ((UserInterfaceTheme current get: #highlightTextColor for: #SimpleHierarchicalListMorph)
- ifNil: [Color red])]}!
Item was removed:
- ----- Method: InspectorField>>expressionWithReceiverName: (in category 'accessing - code') -----
- expressionWithReceiverName: receiverName
- "The code string to run for getting the receiver's value. The receiver's name, which is usually #self, can be replaced to fit specific debugging scenarios such as ThisContext."
-
- ^ valueGetterExpression ifNil: [
- self valueGetter isCompiledCode
- ifTrue: [ "precompiled user code"
- self valueGetter getSource ]
- ifFalse: [ "evaluable"
- self class
- generateExpressionFrom: self valueGetter
- argumentNames: {receiverName} ] ]!
Item was removed:
- ----- Method: InspectorField>>forgetInspector (in category 'private') -----
- forgetInspector
-
- inspector := nil.!
Item was removed:
- ----- Method: InspectorField>>getValueFor: (in category 'evaluating') -----
- getValueFor: anInspector
-
- ^ self valueGetter isCompiledCode
- ifTrue: [ "precompiled user code"
- self valueGetter
- valueWithReceiver: anInspector doItReceiver
- arguments: ({anInspector doItContext} first: self valueGetter numArgs)]
- ifFalse: [ "evaluable"
- self valueGetter value: anInspector object ]!
Item was removed:
- ----- Method: InspectorField>>inspector (in category 'private') -----
- inspector
-
- ^ inspector ifNil: [self dependents
- detect: [:object | object isKindOf: Inspector]
- ifNone: [nil]]!
Item was removed:
- ----- Method: InspectorField>>isCustom (in category 'testing') -----
- isCustom
-
- ^ self type = #custom!
Item was removed:
- ----- Method: InspectorField>>isReadOnly (in category 'testing') -----
- isReadOnly
-
- ^ self valueSetter isNil!
Item was removed:
- ----- Method: InspectorField>>key (in category 'accessing') -----
- key
-
- ^ key!
Item was removed:
- ----- Method: InspectorField>>key: (in category 'accessing') -----
- key: anObject
-
- self key = anObject ifTrue: [^ self].
- key := anObject.
- self changed: #field.!
Item was removed:
- ----- Method: InspectorField>>name (in category 'accessing') -----
- name
- "Answers most human-readable name for this field. Not that the key can be any kind of object but this message should answer something that is already printable such as String or Text. If the sender could not rely on this, quoted strings could be confused with regular strings."
-
- ^ name ifNil: [valueGetterExpression ifNil: [key ifNil: [''] ifNotNil: [key asString]]]!
Item was removed:
- ----- Method: InspectorField>>name: (in category 'accessing') -----
- name: aString
-
- name = aString ifTrue: [^ self].
- name := aString.
- self changed: #field.!
Item was removed:
- ----- Method: InspectorField>>printOn: (in category 'printing') -----
- printOn: aStream
-
- super printOn: aStream.
- aStream
- nextPut: $<;
- print: self type;
- nextPut: $>.
- aStream
- nextPutAll: ' named ';
- print: self name asString.!
Item was removed:
- ----- Method: InspectorField>>printValueAsIs (in category 'initialization') -----
- printValueAsIs
-
- self shouldPrintValueAsIs: true.!
Item was removed:
- ----- Method: InspectorField>>rememberInspector (in category 'private') -----
- rememberInspector
-
- inspector := self inspector.!
Item was removed:
- ----- Method: InspectorField>>requestCustomFor:orCancel: (in category 'custom') -----
- requestCustomFor: anInspector orCancel: aBlock
-
- self setGetterFor: anInspector to: 'self yourself' ifFail: [^ self].
- self editGetterFor: anInspector orCancel: aBlock.
- self emphasizeName.!
Item was removed:
- ----- Method: InspectorField>>setGetterFor:to:ifFail: (in category 'custom') -----
- setGetterFor: anInspector to: code ifFail: aBlock
-
- | getter |
- getter := Compiler new
- compiledMethodFor: code
- in: anInspector doItContext
- to: anInspector doItReceiver
- notifying: nil
- ifFail: [^ aBlock value].
-
- self valueGetterExpression: code.
- self valueGetter: getter.
-
- self changed: #field.!
Item was removed:
- ----- Method: InspectorField>>setSetterFor:to:ifFail: (in category 'custom') -----
- setSetterFor: anInspector to: code ifFail: aBlock
-
- | setter |
- setter := Compiler new
- evaluate: code
- in: anInspector doItContext
- to: anInspector doItReceiver
- environment: anInspector environment
- notifying: nil
- ifFail: [^ aBlock value]
- logged: false.
-
- self
- flag: #experimental; "ct: We might want to change this when input-request dialogs can work with source code. See also http://forum.world.st/Changeset-requestCode-cs-td5110502.html for this proposal."
- assert: [setter respondsTo: #value:]
- description: 'Setter must be evaluable like a block with one argument' translated.
-
- self valueSetterExpression: code.
- self valueSetter: [:object :value | setter value: value].
-
- self changed: #field.!
Item was removed:
- ----- Method: InspectorField>>setValueFor:to: (in category 'evaluating') -----
- setValueFor: anInspector to: value
-
- self valueSetter isCompiledCode
- ifTrue: [ "precompiled user code"
- self valueSetter
- valueWithReceiver: anInspector doItReceiver
- arguments: ({value. anInspector doItContext} first: self valueSetter numArgs)]
- ifFalse: [ "evaluable"
- self valueSetter value: anInspector object value: value ].
- self changed: #field.!
Item was removed:
- ----- Method: InspectorField>>shouldPrintValueAsIs (in category 'accessing - printing') -----
- shouldPrintValueAsIs
- "Whether to call #asString or #printString on this field's value."
-
- ^ shouldPrintValueAsIs ifNil: [false]!
Item was removed:
- ----- Method: InspectorField>>shouldPrintValueAsIs: (in category 'accessing - printing') -----
- shouldPrintValueAsIs: aBoolean
- "Whether to call #asString or #printString on this field's value."
-
- shouldPrintValueAsIs := aBoolean.!
Item was removed:
- ----- Method: InspectorField>>shouldStyleName (in category 'accessing - printing') -----
- shouldStyleName
-
- ^ shouldStyleName ifNil: [false]!
Item was removed:
- ----- Method: InspectorField>>shouldStyleName: (in category 'accessing - printing') -----
- shouldStyleName: aBoolean
-
- self shouldStyleName = aBoolean ifTrue: [^ self].
- shouldStyleName := aBoolean.
- self changed: #field.!
Item was removed:
- ----- Method: InspectorField>>shouldStyleValue (in category 'accessing - printing') -----
- shouldStyleValue
-
- ^ shouldStyleValue ifNil: [false]!
Item was removed:
- ----- Method: InspectorField>>shouldStyleValue: (in category 'accessing - printing') -----
- shouldStyleValue: aBoolean
-
- self shouldStyleValue = aBoolean ifTrue: [^ self].
- shouldStyleValue := aBoolean.
- self changed: #field.!
Item was removed:
- ----- Method: InspectorField>>styleName: (in category 'initialization') -----
- styleName: someTextAttributesOrColors
-
- self name: (self name asText
- addAllAttributes: (someTextAttributesOrColors
- collect: [:ea | ea isColor ifTrue: [TextColor color: ea] ifFalse: [ea]]);
- yourself).!
Item was removed:
- ----- Method: InspectorField>>type (in category 'accessing') -----
- type
-
- ^ type!
Item was removed:
- ----- Method: InspectorField>>type: (in category 'accessing') -----
- type: aSymbol
-
- type := aSymbol!
Item was removed:
- ----- Method: InspectorField>>value (in category 'accessing') -----
- value
- "For convenience only. If you have an #inspector, call #getValueFor: directly. It may be faster."
-
- ^ self getValueFor: self inspector!
Item was removed:
- ----- Method: InspectorField>>value: (in category 'accessing') -----
- value: anObject
- "For convenience only. If you have an #inspector, call #setValueFor:to: directly. It may be faster."
-
- ^ self setValueFor: self inspector to: anObject!
Item was removed:
- ----- Method: InspectorField>>valueGetter (in category 'accessing - code') -----
- valueGetter
- "The valueGetter will be used to fetch a value for this field. See comment in #valueGetter:."
-
- ^ valueGetter!
Item was removed:
- ----- Method: InspectorField>>valueGetter: (in category 'accessing - code') -----
- valueGetter: evaluable
- "The valueGetter will be used to fetch a value for this field. The corresponding inspctor will provide an object to fetch the value from.
-
- Here are some examples:
-
- [:object | object size] -- The most basic case.
- #negated --- A convenient shortcut.
- [:object | self print: object] --- A closured helper to fetch the value.
-
- It is also possible to store a compiled method as a valueGetter. Then, the corresponding inspector will provide both #doItReceiver and #doItContext to execute that method to fetch the value for this field. So, this is like storing a compiled do-it expression."
-
- valueGetter := evaluable.!
Item was removed:
- ----- Method: InspectorField>>valueGetterExpression (in category 'accessing - code') -----
- valueGetterExpression
- "The code string to run for getting the receiver's value."
-
- ^ self expressionWithReceiverName: #self!
Item was removed:
- ----- Method: InspectorField>>valueGetterExpression: (in category 'accessing - code') -----
- valueGetterExpression: aString
-
- valueGetterExpression := aString.!
Item was removed:
- ----- Method: InspectorField>>valueSetter (in category 'accessing - code') -----
- valueSetter
- "The valueSetter will be used to manipulate the value for this field. See comment in #valueSetter:."
-
- ^ valueSetter!
Item was removed:
- ----- Method: InspectorField>>valueSetter: (in category 'accessing - code') -----
- valueSetter: oneArgEvaluable
- "The valueSetter will be used to manipulate the value for this field. It follows the same semantics as the valueGetter, but expects one more argument, which is the new value to set. See also comment in #valueGetter:.
-
- Here are some examples:
-
- [:object :value | object someProperty: value] -- The most basic case.
- #someProperty: --- A convenient shortcut.
- [:object :value | self setProperty: value in: object] --- A closured helper to set the value."
-
- valueSetter := oneArgEvaluable!
Item was removed:
- ----- Method: InspectorField>>valueSetterExpression (in category 'accessing - code') -----
- valueSetterExpression
-
- ^ valueSetterExpression!
Item was removed:
- ----- Method: InspectorField>>valueSetterExpression: (in category 'accessing - code') -----
- valueSetterExpression: aString
-
- valueSetterExpression := aString.!
Item was removed:
- ----- Method: InstructionStream>>abstractPC (in category '*Tools-Debugger-support') -----
- abstractPC
- ^self method abstractPCForConcretePC: pc!
Item was removed:
- ----- Method: InstructionStream>>debuggerMap (in category '*Tools-Debugger-support') -----
- debuggerMap
- ^self method debuggerMap!
Item was removed:
- ----- Method: Integer>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Integer'!
Item was removed:
- ----- Method: Magnitude class>>toolIcon (in category '*Tools-icons') -----
- toolIcon
-
- ^ #magnitude!
Item was removed:
- ----- Method: Message>>createStubMethod (in category '*Tools-Debugger') -----
- createStubMethod
- | argNames |
- argNames := Set new.
- ^ String streamContents: [ :s |
- self selector keywords withIndexDo: [ :key :i |
- | aOrAn argName arg argClassName |
- s nextPutAll: key.
- ((key last = $:) or: [self selector isInfix]) ifTrue: [
- arg := self arguments at: i.
- argClassName := arg canonicalArgumentName.
- aOrAn := argClassName first isVowel ifTrue: ['an'] ifFalse: ['a'].
- argName := aOrAn, argClassName.
- [argNames includes: argName] whileTrue: [argName := argName, i asString].
- argNames add: argName.
- s nextPutAll: ' '; nextPutAll: argName; space
- ].
- ].
- s cr; tab.
- s nextPutAll: 'self shouldBeImplemented'
- ].!
Item was removed:
- MessageSet subclass: #MessageNames
- instanceVariableNames: 'searchString selectorList selectorListIndex'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
Item was removed:
- ----- Method: MessageNames class>>methodBrowserSearchingFor: (in category 'instance creation') -----
- methodBrowserSearchingFor: searchString
- "Answer an method-browser window whose search-string is initially as indicated"
-
- | aWindow |
- aWindow := self new searchString: searchString.
- ^ToolBuilder default build: aWindow!
Item was removed:
- ----- Method: MessageNames class>>openMessageNames (in category 'instance creation') -----
- openMessageNames
- "Open a new instance of the receiver in the active world"
- ^(ToolBuilder open: self new) model
-
- "MessageNames openMessageNames"
- !
Item was removed:
- ----- Method: MessageNames class>>prototypicalToolWindow (in category 'instance creation') -----
- prototypicalToolWindow
- "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
-
- ^ self methodBrowserSearchingFor: ''!
Item was removed:
- ----- Method: MessageNames>>buildSearchPaneWith: (in category 'toolbuilder') -----
- buildSearchPaneWith: builder
-
- | panelSpec textSpec buttonSpec |
- panelSpec := builder pluggablePanelSpec new
- layout: #horizontal;
- children: OrderedCollection new;
- yourself.
-
- textSpec := builder pluggableInputFieldSpec new.
- textSpec
- model: searchString;
- help: 'Type here, then hit Search.' translated;
- getText: #contents;
- setText: #contents:;
- softLineWrap: true.
- panelSpec children add: textSpec.
-
- buttonSpec := builder pluggableActionButtonSpec new.
- buttonSpec
- model: self;
- label: 'Search';
- action: #doSearch;
- horizontalResizing: #shrinkWrap.
- panelSpec children add: buttonSpec.
-
- ^ panelSpec!
Item was removed:
- ----- Method: MessageNames>>buildSelectorListWith: (in category 'toolbuilder') -----
- buildSelectorListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #selectorList;
- getIndex: #selectorListIndex;
- setIndex: #selectorListIndex:;
- menu: #selectorListMenu:;
- keyPress: #selectorListKey:from:.
- ^listSpec
- !
Item was removed:
- ----- Method: MessageNames>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- "ToolBuilder open: MessageNames new"
-
- | windowSpec max searchHeight |
- max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5].
- searchHeight := Preferences standardDefaultTextFont height * 2.
-
- windowSpec := self buildWindowWith: builder specs: {
- (0@0 corner: 0.5(a)0.1) -> [self buildSearchPaneWith: builder].
- (0(a)0.1 corner: 0.5 @ max) -> [self buildSelectorListWith: builder].
- (0.5(a)0.0 corner: 1.0@max) -> [self buildMessageListWith: builder].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
-
- ^ builder build: windowSpec!
Item was removed:
- ----- Method: MessageNames>>computeMessageList (in category 'search') -----
- computeMessageList
-
- ^ selectorListIndex = 0
- ifTrue: [#()]
- ifFalse: [self systemNavigation
- allImplementorsOf: (selectorList at: selectorListIndex)]!
Item was removed:
- ----- Method: MessageNames>>computeSelectorListFrom: (in category 'search') -----
- computeSelectorListFrom: searchString
- "Compute selector list from search string. The searchString is a list of expressions separated by ;. Each expression is matched individually. An expression can be a simple string (same as *expression*), a string with double quotes (exact match) or a match expression (see String >> #match:)."
- | selectors |
- selectors := Set new.
- (searchString findBetweenSubStrs: ';') do:
- [ :selPat |
- (selPat first = $" and: [ selPat last = $" and: [ selPat size > 2 ] ])
- ifTrue:
- [(Symbol lookup: (selPat copyFrom: 2 to: selPat size - 1))
- ifNotNil: [ :sym | selectors add: sym ] ]
- ifFalse:
- [| n m |
- n := selPat occurrencesOf: $*.
- m := selPat occurrencesOf: $#.
- selectors addAll:
- (((n > 0 or: [ m > 0 ]) and: [ selPat size > (n + m) ])
- ifTrue: [ Symbol selectorsMatching: selPat ]
- ifFalse: [ Symbol selectorsContaining: selPat ]) ] ].
- ^selectors sorted: [ :x :y | x caseInsensitiveLessOrEqual: y ]!
Item was removed:
- ----- Method: MessageNames>>copyName (in category 'message list menu') -----
- copyName
- "Copy the current selector to the clipboard"
-
- | selector |
- (selector := self selectorList at: selectorListIndex ifAbsent: [nil]) ifNotNil:
- [Clipboard clipboardText: selector asString asText]!
Item was removed:
- ----- Method: MessageNames>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.639 g: 0.9 b: 0.497)!
Item was removed:
- ----- Method: MessageNames>>doSearch (in category 'search') -----
- doSearch
- "The user hit the Search button -- treat it as a synonym for the user having hit the Return or Enter (or cmd-s) in the type-in pane"
-
- searchString changed: #acceptChanges.!
Item was removed:
- ----- Method: MessageNames>>doSearch: (in category 'search') -----
- doSearch: aSearchString
-
- | normalizedSearchString |
- normalizedSearchString := aSearchString asString copyWithout: Character space.
-
- Cursor wait showWhile: [
- self selectorList: (self computeSelectorListFrom: normalizedSearchString)].
-
- ^ true!
Item was removed:
- ----- Method: MessageNames>>frameOffsetFromTop:fromLeft:width:bottomFraction: (in category 'toolbuilder') -----
- frameOffsetFromTop: height fromLeft: leftFraction width: rightFraction bottomFraction: bottomFraction
- ^LayoutFrame new
- topFraction: 0 offset: height;
- leftFraction: leftFraction offset: 0;
- rightFraction: (leftFraction + rightFraction) offset: 0;
- bottomFraction: bottomFraction offset: 0;
- yourself.!
Item was removed:
- ----- Method: MessageNames>>initialize (in category 'initialization') -----
- initialize
-
- super initialize.
-
- searchString := ValueHolder new contents: ''.
- searchString addDependent: self.
-
- selectorList := #().
- selectorListIndex := 0.
-
- self messageListIndex: 0.!
Item was removed:
- ----- Method: MessageNames>>labelString (in category 'initialization') -----
- labelString
-
- ^ self searchString
- ifEmpty: ['Message Names']
- ifNotEmpty: [:s | 'Message names containing "', s asString asLowercase, '"']!
Item was removed:
- ----- Method: MessageNames>>mainSelectorListMenu: (in category 'selector list') -----
- mainSelectorListMenu: aMenu
- "Answer the menu associated with the selectorList"
- <selectorListMenu>
- aMenu addList: #(
- ('senders (n)' browseSenders 'browse senders of the chosen selector')
- ('copy selector to clipboard' copyName 'copy the chosen selector to the clipboard, for subsequent pasting elsewhere')
- -
- ('show only implemented selectors' showOnlyImplementedSelectors 'remove from the selector-list all symbols that do not represent implemented methods')).
-
- ^ aMenu!
Item was removed:
- ----- Method: MessageNames>>messageList: (in category 'message list') -----
- messageList: someObjects
-
- messageList := someObjects.
- self changed: #messageList.
-
- self messageListIndex: (messageList size > 0
- ifTrue: [1]
- ifFalse: [0]).!
Item was removed:
- ----- Method: MessageNames>>postAcceptBrowseFor: (in category 'morphic ui') -----
- postAcceptBrowseFor: anotherModel
-
- self searchString: anotherModel searchString.!
Item was removed:
- ----- Method: MessageNames>>searchString (in category 'search') -----
- searchString
-
- ^ searchString contents!
Item was removed:
- ----- Method: MessageNames>>searchString: (in category 'search') -----
- searchString: aString
-
- searchString contents: aString.!
Item was removed:
- ----- Method: MessageNames>>selectedClassOrMetaClass (in category 'class list') -----
- selectedClassOrMetaClass
- "Answer the currently selected class (or metaclass)."
- self hasMessageSelected ifTrue:
- [ ^ self setClassAndSelectorIn: [:c :s | ^c] ].
-
- (selectorListIndex isNil not and: [selectorListIndex > 0]) ifTrue: [^Smalltalk classNamed: (self selectorList at: selectorListIndex)].
-
- ^ nil.
- !
Item was removed:
- ----- Method: MessageNames>>selectedMessageName (in category 'message list') -----
- selectedMessageName
- selectorList basicSize = 0 ifTrue: [^ nil]. "Deals with selectorList nil or empty"
- ^selectorList at: (selectorListIndex max: 1) ifAbsent: [nil] "If no selection we can still find a selector"!
Item was removed:
- ----- Method: MessageNames>>selectorList (in category 'selector list') -----
- selectorList
-
- ^ selectorList!
Item was removed:
- ----- Method: MessageNames>>selectorList: (in category 'selector list') -----
- selectorList: someObjects
- "Answer the selectorList"
-
- selectorList := someObjects.
- self changed: #selectorList.
-
- "Select first result if any."
- self selectorListIndex: (selectorList size > 0
- ifTrue: [1]
- ifFalse: [0]).!
Item was removed:
- ----- Method: MessageNames>>selectorListFrame:fromTop: (in category 'toolbuilder') -----
- selectorListFrame: max fromTop: topOffset
- ^LayoutFrame new
- leftFraction: 0 offset: 0;
- topFraction: 0 offset: topOffset;
- rightFraction: 0.5 offset: 0;
- bottomFraction: max offset: 0.!
Item was removed:
- ----- Method: MessageNames>>selectorListIndex (in category 'selector list') -----
- selectorListIndex
- "Answer the selectorListIndex"
-
- ^ selectorListIndex!
Item was removed:
- ----- Method: MessageNames>>selectorListIndex: (in category 'selector list') -----
- selectorListIndex: anInteger
- "Set the selectorListIndex as specified, and propagate consequences"
- | methodClass index |
- methodClass := currentCompiledMethod ifNotNil: [currentCompiledMethod methodClass].
- selectorListIndex := anInteger.
- self changed: #selectorListIndex.
-
- messageList := self computeMessageList.
- self changed: #messageList.
- messageList size > 1 ifTrue:
- [methodClass ifNotNil: [index := messageList findFirst: [:methodRef| methodRef actualClass = methodClass]]].
-
- "If a method of the same class exists, select that, otherwise select the first message if any."
- self messageListIndex: (index ifNil: [1 min: messageList size])!
Item was removed:
- ----- Method: MessageNames>>selectorListKey:from: (in category 'selector list') -----
- selectorListKey: aChar from: view
- "Respond to a Command key in the message-list pane."
-
- aChar == $n ifTrue: [^ self browseSenders].
- aChar == $c ifTrue: [^ self copyName].
- aChar == $b ifTrue: [^ self browseMethodFull].
- !
Item was removed:
- ----- Method: MessageNames>>selectorListMenu: (in category 'selector list') -----
- selectorListMenu: aMenu
- "Answer the menu associated with the selectorList"
- ^ self menu: aMenu for: #(selectorListMenu selectorListMenuShifted:)
- !
Item was removed:
- ----- Method: MessageNames>>selectorListMenuTitle (in category 'selector list') -----
- selectorListMenuTitle
- "Answer the title to supply for the menu belonging to the selector-list pane"
-
- ^ 'Click on any item in the list
- to see all implementors of it'!
Item was removed:
- ----- Method: MessageNames>>showOnlyImplementedSelectors (in category 'search') -----
- showOnlyImplementedSelectors
- "Caution -- can be slow!! Filter my selector list down such that it only
- shows selectors that are actually implemented somewhere in the system."
- self okToChange ifFalse: [^ self].
-
- Cursor wait showWhile: [
- self selectorList: (self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList)].!
Item was removed:
- ----- Method: MessageNames>>topConstantHeightFrame:fromLeft:width: (in category 'toolbuilder') -----
- topConstantHeightFrame: height fromLeft: leftFraction width: rightFraction
- ^LayoutFrame new
- topFraction: 0 offset: 0;
- leftFraction: leftFraction offset: 0;
- rightFraction: (leftFraction + rightFraction) offset: 0;
- bottomFraction: 0 offset: height;
- yourself.!
Item was removed:
- ----- Method: MessageNames>>update: (in category 'updating') -----
- update: aspect
-
- aspect == #contents
- ifTrue: [
- self changed: #labelString.
- self doSearch: self searchString].
-
- super update: aspect.!
Item was removed:
- ----- Method: MessageNames>>windowTitle (in category 'toolbuilder') -----
- windowTitle
-
- ^ 'Message Names'!
Item was removed:
- CodeHolder subclass: #MessageSet
- instanceVariableNames: 'growable messageList messageListFormatted autoSelectString messageListIndex editSelection windowLabel'
- classVariableNames: 'UseUnifiedMessageLabels'
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !MessageSet commentStamp: '<historical>' prior: 0!
- I represent a query path of the retrieval result of making a query about methods in the system. The result is a set of methods, denoted by a message selector and the class in which the method was found. As a StringHolder, the string I represent is the source code of the currently selected method. I am typically viewed in a Message Set Browser consisting of a MessageListView and a BrowserCodeView.!
Item was removed:
- ----- Method: MessageSet class>>extantMethodsIn: (in category 'utilities') -----
- extantMethodsIn: aListOfMethodRefs
- "Answer the subset of the incoming list consisting only of those message markers that refer to methods actually in the current image"
-
-
- self flag: #mref. "may be removed in second round"
-
-
- ^ aListOfMethodRefs select: [:aToken |
- self
- parse: aToken
- toClassAndSelector: [ :aClass :aSelector |
- aClass notNil and: [aClass includesSelector: aSelector]
- ]
- ]!
Item was removed:
- ----- Method: MessageSet class>>isPseudoSelector: (in category 'utilities') -----
- isPseudoSelector: aSelector
- "Answer whether the given selector is a special marker"
-
- ^ #(Comment Definition Hierarchy) includes: aSelector!
Item was removed:
- ----- Method: MessageSet class>>messageList: (in category 'instance creation') -----
- messageList: anArray
- "Answer an instance of me with message list anArray."
-
- ^self new initializeMessageList: anArray!
Item was removed:
- ----- Method: MessageSet class>>open:name: (in category 'instance creation') -----
- open: aMessageSet name: aString
- "Create a standard system view for the messageSet, aMessageSet, whose label is aString."
- ^ToolBuilder open: aMessageSet label: aString!
Item was removed:
- ----- Method: MessageSet class>>openMessageList:name: (in category 'instance creation') -----
- openMessageList: messageList name: labelString
- "Create a standard system view for the message set on the list, anArray.
- The label of the view is aString."
-
- self openMessageList: messageList name: labelString autoSelect: nil!
Item was removed:
- ----- Method: MessageSet class>>openMessageList:name:autoSelect: (in category 'instance creation') -----
- openMessageList: messageList name: labelString autoSelect: autoSelectString
- "Open a system view for a MessageSet on messageList.
- The labelString is passed to the model to use as a base label, depending on the selection state"
-
- | messageSet |
- messageSet := self messageList: messageList.
- messageSet
- autoSelectString: autoSelectString;
- setInitialLabel: labelString.
- ^ToolBuilder open: messageSet!
Item was removed:
- ----- Method: MessageSet class>>parse:toClassAndSelector: (in category 'utilities') -----
- parse: codeReferenceOrString toClassAndSelector: csBlock
- "Decode strings of the form <className> [class] <selectorName>."
-
- | tuple cl |
- codeReferenceOrString ifNil: [^ csBlock value: nil value: nil].
- codeReferenceOrString isCodeReference ifTrue:
- [^codeReferenceOrString setClassAndSelectorIn: csBlock].
- codeReferenceOrString isEmpty ifTrue:
- [^csBlock value: nil value: nil].
- tuple := (codeReferenceOrString asString includesSubstring: '>>')
- ifTrue: [(codeReferenceOrString findTokens: '>>') fold: [:a :b| (a findTokens: ' '), {b first = $# ifTrue: [b allButFirst] ifFalse: [b]}]]
- ifFalse: [codeReferenceOrString asString findTokens: ' .'].
- self flag: #environments. "missing information about the class environment"
- cl := Smalltalk at: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil].
- ^(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']])
- ifTrue: [csBlock value: cl value: (tuple at: 2) asSymbol]
- ifFalse: [csBlock value: cl class value: (tuple at: 3) asSymbol]!
Item was removed:
- ----- Method: MessageSet class>>useUnifiedMessageLabels (in category 'preferences') -----
- useUnifiedMessageLabels
- <preference: 'Use unified message labels'
- categoryList: #(Tools tools)
- description: 'In all message set browsers such as senders and implementors, show a unified, textual representation of all method references (or messages).'
- type: #Boolean>
- ^ UseUnifiedMessageLabels ifNil: [true]!
Item was removed:
- ----- Method: MessageSet class>>useUnifiedMessageLabels: (in category 'preferences') -----
- useUnifiedMessageLabels: aBoolean
-
- UseUnifiedMessageLabels := aBoolean.!
Item was removed:
- ----- Method: MessageSet>>aboutToStyle: (in category 'code pane') -----
- aboutToStyle: styler
- "This is a notification that aPluggableShoutMorphOrView is about to re-style its text.
- Set the classOrMetaClass in aPluggableShoutMorphOrView, so that identifiers will be resolved correctly.
- Answer true to allow styling to proceed, or false to veto the styling."
-
- | selectedMessageName |
- self isModeStyleable ifFalse: [^ false].
-
- selectedMessageName := self selectedMessageName.
- styler classOrMetaClass: self selectedClassOrMetaClass.
- styler parseAMethod: (#(Comment Definition Hierarchy) includes: selectedMessageName) not.
- ^ (#(Comment Hierarchy) includes: selectedMessageName) not!
Item was removed:
- ----- Method: MessageSet>>addExtraShiftedItemsTo: (in category 'message list') -----
- addExtraShiftedItemsTo: aMenu
- "The shifted selector-list menu is being built. Add items specific to MessageSet"
- self growable ifTrue:
- [aMenu addList: #(
- -
- ('remove from this browser (d)' removeMessageFromBrowser)
- ('filter message list...' filterMessageList))].
- aMenu
- add: 'sort by date'
- action: #sortByDate!
Item was removed:
- ----- Method: MessageSet>>addItem: (in category 'message list') -----
- addItem: classAndMethod
- "Append a classAndMethod string to the list. Select the new item."
-
- "Do some checks on the input?"
- self okToChange ifFalse: [^ self].
- messageList add: classAndMethod.
- self changed: #messageList.
- self messageListIndex: messageList size.!
Item was removed:
- ----- Method: MessageSet>>adjustWindowTitleAfterFiltering (in category 'private') -----
- adjustWindowTitleAfterFiltering
- "Set the title of the receiver's window, if any, to reflect the just-completed filtering. Avoid re-doing it if fitering is re-done"
-
- (windowLabel endsWith: 'Filtered')
- ifFalse: [windowLabel := windowLabel , ' Filtered'.
- self changed: #windowTitle]!
Item was removed:
- ----- Method: MessageSet>>autoSelectString (in category 'private') -----
- autoSelectString
- "Return the string to be highlighted when making new selections. For actual keyword selectors, only select the first keyword."
-
- ^ autoSelectString ifNotNil: [:stringOrSelector |
- (Symbol lookup: stringOrSelector)
- ifNil: [stringOrSelector "no change"]
- ifNotNil: [:selector | selector precedence = 3
- "only the first part of the keyword message"
- ifTrue: [selector copyFrom: 1 to: (selector indexOf: $:)]
- "no change"
- ifFalse: [stringOrSelector]]]
- !
Item was removed:
- ----- Method: MessageSet>>autoSelectString: (in category 'private') -----
- autoSelectString: aString
- "Set the string to be highlighted when making new selections"
- autoSelectString := aString!
Item was removed:
- ----- Method: MessageSet>>browseAllImplementorsOf: (in category 'message functions') -----
- browseAllImplementorsOf: selectorSymbol
- self systemNavigation browseAllImplementorsOf: selectorSymbol!
Item was removed:
- ----- Method: MessageSet>>browseLocalSendersOfMessages (in category 'message functions') -----
- browseLocalSendersOfMessages
- "Override so that if no method is selected it searches for senders local to the current list."
-
- self selectedClass ifNotNil:
- [^super browseLocalSendersOfMessages].
-
- self getSelectorAndSendQuery: #value:value:
- to: [:literal :label|
- self systemNavigation browseAllCallsOn: literal fromMethodReferences: messageList labelled: label]
- with: { 'messages' }!
Item was removed:
- ----- Method: MessageSet>>buildMessageListWith: (in category 'toolbuilder') -----
- buildMessageListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #messageListFormatted;
- getIndex: #messageListIndex;
- setIndex: #messageListIndex:;
- icon: #messageIconAt:;
- helpItem: #messageHelpAt:;
- menu: #messageListMenu:shifted:;
- keyPress: #messageListKey:from:.
- SystemBrowser browseWithDragNDrop ifTrue: [
- listSpec
- dragItem: #dragFromMessageList:;
- dragType: #dragTypeForMessageListAt:].
- ^ listSpec
- !
Item was removed:
- ----- Method: MessageSet>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- | windowSpec max result |
- self wantsOptionalButtons ifTrue:[max := 0.3] ifFalse:[max := 0.3].
- windowSpec := self buildWindowWith: builder specs: {
- (0@0 corner: 1@max) -> [self buildMessageListWith: builder].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
- result := builder build: windowSpec.
- autoSelectString ifNotNil:[self changed: #autoSelect].
- ^result!
Item was removed:
- ----- Method: MessageSet>>canShowMultipleMessageCategories (in category 'message category functions') -----
- canShowMultipleMessageCategories
- "Answer whether the receiver is capable of showing multiple message categories"
-
- ^ false!
Item was removed:
- ----- Method: MessageSet>>changed: (in category 'updating') -----
- changed: aspect
-
- super changed: aspect.
-
- aspect = #messageList ifTrue: [
- messageListFormatted := nil.
- self changed: #messageListFormatted].!
Item was removed:
- ----- Method: MessageSet>>classCommentIndicated (in category 'metaclass') -----
- classCommentIndicated
- "Answer true iff we're viewing the class comment."
-
- ^ editSelection == #editComment or: [ self selectedMessageName == #Comment ]!
Item was removed:
- ----- Method: MessageSet>>contents (in category 'contents') -----
- contents
- "Answer the contents of the receiver"
-
- ^ contents == nil
- ifTrue: [currentCompiledMethod := nil. '']
- ifFalse: [self hasMessageSelected
- ifTrue: [self editContents]
- ifFalse: [currentCompiledMethod := nil. contents]]!
Item was removed:
- ----- Method: MessageSet>>contents:notifying: (in category 'private') -----
- contents: aString notifying: aController
- "Compile the code in aString. Notify aController of any syntax errors.
- Answer false if the compilation fails. Otherwise, if the compilation
- created a new method, deselect the current selection. Then answer true."
-
- | category class oldSelector |
- self okayToAccept ifFalse: [^ false].
- class := self targetForContents: aString.
- class ifNil: [^ false].
- self setClassAndSelectorIn: [:c :os | oldSelector := os].
- (self contents: aString specialSelector: oldSelector in: class notifying: aController)
- ifTrue: [^ false].
- "Normal method accept"
- category := self selectedMessageCategoryName.
- ^ self contents: aString
- oldSelector: oldSelector
- in: class
- classified: category
- notifying: aController!
Item was removed:
- ----- Method: MessageSet>>contents:oldSelector:in:classified:notifying: (in category 'private') -----
- contents: aString oldSelector: oldSelector in: aClass classified: category notifying: aController
- "Compile the code in aString. Notify aController of any syntax errors.
- Answer false if the compilation fails. Otherwise, if the compilation
- created a new method, deselect the current selection. Then answer true."
- | selector |
- selector := aClass compile: aString
- classified: category
- notifying: aController.
- selector == nil ifTrue: [^ false].
- self noteAcceptanceOfCodeFor: selector.
- selector == oldSelector ifFalse:
- [self reformulateListNoting: selector].
- contents := aString copy.
- self changed: #annotation.
- ^ true!
Item was removed:
- ----- Method: MessageSet>>contents:specialSelector:in:notifying: (in category 'private') -----
- contents: aString specialSelector: oldSelector in: aClass notifying: aController
- "If the selector is a fake to denote a different definition than that of a method,
- try to change that different object. Answer whether a special selector was found and
- handled."
- (oldSelector ~~ nil and: [oldSelector first isUppercase]) ifFalse: [^ false].
- oldSelector = #Comment ifTrue:
- [aClass comment: aString stamp: Utilities changeStamp.
- self changed: #annotation.
- self clearUserEditFlag.
- ^ true].
- oldSelector = #Definition ifTrue:
- ["self defineClass: aString notifying: aController."
- aClass subclassDefinerClass
- evaluate: aString
- notifying: aController
- logged: true.
- self clearUserEditFlag.
- ^ true].
- oldSelector = #Hierarchy ifTrue:
- [self inform: 'To change the hierarchy, edit the class definitions'.
- ^ true].
- ^ false!
Item was removed:
- ----- Method: MessageSet>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.719 g: 0.9 b: 0.9)!
Item was removed:
- ----- Method: MessageSet>>deleteAllFromMessageList: (in category 'message functions') -----
- deleteAllFromMessageList: aCollection
- "Delete the given messages from the receiver's message list"
- | currIdx |
- currIdx := self messageListIndex.
- messageList := messageList copyWithoutAll: aCollection.
- messageList ifNotEmpty: [self messageListIndex: {currIdx. messageList size.} min]!
Item was removed:
- ----- Method: MessageSet>>deleteFromMessageList: (in category 'message functions') -----
- deleteFromMessageList: aMessage
- "Delete the given message from the receiver's message list"
- | currIdx |
- currIdx := self messageListIndex.
- messageList := messageList copyWithout: aMessage.
- messageList ifNotEmpty: [self messageListIndex: {currIdx. messageList size.} min]!
Item was removed:
- ----- Method: MessageSet>>deselectAll (in category 'private') -----
- deselectAll
- self messageListIndex: 0!
Item was removed:
- ----- Method: MessageSet>>dragFromMessageList: (in category 'drag and drop') -----
- dragFromMessageList: index
-
- ^ self messageList at: index!
Item was removed:
- ----- Method: MessageSet>>dragTypeForMessageListAt: (in category 'drag and drop') -----
- dragTypeForMessageListAt: index
-
- ^ #sourceCode!
Item was removed:
- ----- Method: MessageSet>>editSelection: (in category 'accessing') -----
- editSelection: aSelection
- "Set the editSelection as requested."
-
- editSelection := aSelection.
- self changed: #editSelection.!
Item was removed:
- ----- Method: MessageSet>>fileOutMessage (in category 'message functions') -----
- fileOutMessage
- "Put a description of the selected method on a file, or all methods if none selected."
-
- | fileName |
- self selectedMessageName ifNotNil:
- [^super fileOutMessage].
- fileName := UIManager default saveFilenameRequest: 'File out on which file?' initialAnswer: 'methods'.
- fileName isEmptyOrNil ifTrue: [^self].
- Cursor write showWhile:
- [| internalStream |
- internalStream := WriteStream on: (String new: 1000).
- internalStream header; timeStamp.
- messageList do:
- [:methodRef|
- methodRef methodSymbol == #Comment
- ifTrue:
- [methodRef actualClass organization
- putCommentOnFile: internalStream
- numbered: 1
- moveSource: false
- forClass: methodRef actualClass]
- ifFalse:
- [methodRef actualClass
- printMethodChunk: methodRef methodSymbol
- withPreamble: true
- on: internalStream
- moveSource: false
- toFile: nil]].
- FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true useHtml: false]!
Item was removed:
- ----- Method: MessageSet>>filterFrom: (in category 'filtering') -----
- filterFrom: aBlock
- "Filter the receiver's list down to only those items that satisfy aBlock, which takes a class an a selector as its arguments."
-
- | newList |
- newList := messageList select:
- [:anElement |
- self class parse: anElement toClassAndSelector: [ :cls :sel |
- (self class isPseudoSelector: sel) not and: [ aBlock value: cls value: sel ]]].
- self setFilteredList: newList!
Item was removed:
- ----- Method: MessageSet>>filterMessageList (in category 'filtering') -----
- filterMessageList
- "Allow the user to refine the list of messages."
- | builder menuSpec |
- builder := ToolBuilder default.
- menuSpec := builder pluggableMenuSpec new
- model: self;
- yourself.
- menuSpec addList:
- #(
- ('unsent messages' filterToUnsentMessages 'filter to show only messages that have no senders')
- -
- ('messages that send...' filterToSendersOf 'filter to show only messages that send a selector I specify')
- ('messages that do not send...' filterToNotSendersOf 'filter to show only messages that do not send a selector I specify')
- -
- ('messages whose selector is...' filterToImplementorsOf 'filter to show only messages with a given selector I specify')
- ('messages whose selector is NOT...' filterToNotImplementorsOf 'filter to show only messages whose selector is NOT a seletor I specify')
- -
- ('messages in current change set' filterToCurrentChangeSet 'filter to show only messages that are in the current change set')
- ('messages not in current change set' filterToNotCurrentChangeSet 'filter to show only messages that are not in the current change set')
- -
- ('messages in any change set' filterToAnyChangeSet 'filter to show only messages that occur in at least one change set')
- ('messages not in any change set' filterToNotAnyChangeSet 'filter to show only messages that do not occur in any change set in the system')
- -
- ('messages authored by me' filterToCurrentAuthor 'filter to show only messages whose authoring stamp has my initials')
- ('messages not authored by me' filterToNotCurrentAuthor 'filter to show only messages whose authoring stamp does not have my initials')
- -
- ('messages logged in .changes file' filterToMessagesInChangesFile 'filter to show only messages whose latest source code is logged in the .changes file')
- ('messages only in .sources file' filterToMessagesInSourcesFile 'filter to show only messages whose latest source code is logged in the .sources file')
- -
- ('messages with prior versions' filterToMessagesWithPriorVersions 'filter to show only messages that have at least one prior version')
- ('messages without prior versions' filterToMessagesWithoutPriorVersions 'filter to show only messages that have no prior versions')
- -
- ('uncommented messages' filterToUncommentedMethods 'filter to show only messages that do not have comments at the beginning')
- ('commented messages' filterToCommentedMethods 'filter to show only messages that have comments at the beginning')
- -
- ('messages in hardened classes' filterToMessagesWithHardenedClasses 'filter to show only messages of established classes (as opposed to Uniclasses such as Player23)') -
- ('methods in classes with matching names' filterToMatchingClassesNames 'filter to show only methods of classes with names that match the given criteria (wildcards are allowed)')
- ('methods in package...' filterToPackage 'filter to show only methods of a given package')
- ('methods not in package...' filterToNotPackage 'filter to show only methods not of a given package')
- -
- ('messages that...' filterToMessagesThat 'let me type in a block taking a class and a selector, which will specify yea or nay concerning which elements should remain in the list')).
- builder runModal: (builder open: menuSpec).!
Item was removed:
- ----- Method: MessageSet>>filterToAnyChangeSet (in category 'filtering') -----
- filterToAnyChangeSet
- "Filter down only to messages present in ANY change set"
-
- self filterFrom:
- [:aClass :aSelector |
- ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aSelector]
- !
Item was removed:
- ----- Method: MessageSet>>filterToCommentedMethods (in category 'filtering') -----
- filterToCommentedMethods
- "Filter the receiver's list down to only those items which have comments"
-
- self filterFrom:
- [:aClass :aSelector |
- (aClass includesSelector: aSelector) and:
- [(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil not]]!
Item was removed:
- ----- Method: MessageSet>>filterToCurrentAuthor (in category 'filtering') -----
- filterToCurrentAuthor
- "Filter down only to messages with my initials as most recent author"
- self filterFrom:
- [:aClass :aSelector | | aMethod aTimeStamp |
- (aClass notNil and: [aSelector notNil]) and:
- [aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil].
- aMethod notNil and:
- [(aTimeStamp := aMethod timeStamp) notNil and:
- [aTimeStamp beginsWith: Utilities authorInitials]]]]!
Item was removed:
- ----- Method: MessageSet>>filterToCurrentChangeSet (in category 'filtering') -----
- filterToCurrentChangeSet
- "Filter the receiver's list down to only those items in the current change set"
-
- self filterFrom:
- [:aClass :aSelector |
- (aClass notNil and: [aSelector notNil]) and:
- [(ChangeSet current atSelector: aSelector class: aClass) ~~ #none]]!
Item was removed:
- ----- Method: MessageSet>>filterToImplementorsOf (in category 'filtering') -----
- filterToImplementorsOf
- "Filter the receiver's list down to only those items with a given selector"
-
- | aFragment inputWithBlanksTrimmed |
-
- aFragment := self request: 'type selector:' initialAnswer: ''.
- aFragment isEmptyOrNil ifTrue: [^ self].
- inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
- (Symbol lookup: inputWithBlanksTrimmed) ifNotNil:
- [:aSymbol |
- self filterFrom:
- [:aClass :aSelector |
- aSelector == aSymbol]]!
Item was removed:
- ----- Method: MessageSet>>filterToMatchingClassesNames (in category 'filtering') -----
- filterToMatchingClassesNames
-
- | reply |
-
- reply := UIManager default
- request: 'Type the string to match'
- initialAnswer: 'ClassName*'
- centerAt: Sensor cursorPoint.
- reply isEmptyOrNil ifTrue: [^ self].
-
- self filterFrom: [:aClass :aSelector | reply match: aClass name asString]
- !
Item was removed:
- ----- Method: MessageSet>>filterToMessagesInChangesFile (in category 'filtering') -----
- filterToMessagesInChangesFile
- "Filter down only to messages whose source code risides in the Changes file. This allows one to ignore long-standing methods that live in the .sources file."
-
-
- self filterFrom:
- [:aClass :aSelector | | cm |
- aClass notNil and: [aSelector notNil and:
- [(self class isPseudoSelector: aSelector) not and:
- [(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and:
- [cm fileIndex ~= 1]]]]]!
Item was removed:
- ----- Method: MessageSet>>filterToMessagesInSourcesFile (in category 'filtering') -----
- filterToMessagesInSourcesFile
- "Filter down only to messages whose source code resides in the .sources file."
-
-
- self filterFrom: [:aClass :aSelector | | cm |
- (aClass notNil and: [aSelector notNil]) and:
- [(self class isPseudoSelector: aSelector) not and:
- [(cm := aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and:
- [cm fileIndex = 1]]]]!
Item was removed:
- ----- Method: MessageSet>>filterToMessagesThat (in category 'filtering') -----
- filterToMessagesThat
- "Allow the user to type in a block which will be"
-
- | reply |
- reply := UIManager default
- multiLineRequest: 'Type your block here'
- centerAt: Sensor cursorPoint
- initialAnswer: '[:aClass :aSelector |
-
- ]'
- answerHeight: 200.
- reply isEmptyOrNil ifTrue: [^ self].
- self filterFrom: (Compiler evaluate: reply)
- !
Item was removed:
- ----- Method: MessageSet>>filterToMessagesWithHardenedClasses (in category 'filtering') -----
- filterToMessagesWithHardenedClasses
- "Filter the receiver's list down to only those items representing methods of hardened classes, as opposed to uniclasses"
-
- self filterFrom:
- [:aClass :aSelector |
- (aClass notNil and: [aSelector notNil]) and:
- [aClass isUniClass not]]!
Item was removed:
- ----- Method: MessageSet>>filterToMessagesWithPriorVersions (in category 'filtering') -----
- filterToMessagesWithPriorVersions
- "Filter down only to messages which have at least one prior version"
-
- self filterFrom:
- [:aClass :aSelector |
- (aClass notNil and: [aSelector notNil]) and:
- [(self class isPseudoSelector: aSelector) not and:
- [(VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1]]]!
Item was removed:
- ----- Method: MessageSet>>filterToMessagesWithoutPriorVersions (in category 'filtering') -----
- filterToMessagesWithoutPriorVersions
- "Filter down only to messages which have no prior version stored"
-
- self filterFrom:
- [:aClass :aSelector |
- (aClass notNil and: [aSelector notNil]) and:
- [(self class isPseudoSelector: aSelector) not and:
- [(VersionsBrowser versionCountForSelector: aSelector class: aClass) <= 1]]]!
Item was removed:
- ----- Method: MessageSet>>filterToNotAnyChangeSet (in category 'filtering') -----
- filterToNotAnyChangeSet
- "Filter down only to messages present in NO change set"
-
- self filterFrom:
- [:aClass :aSelector |
- (ChangesOrganizer doesAnyChangeSetHaveClass: aClass andSelector: aSelector) not]
- !
Item was removed:
- ----- Method: MessageSet>>filterToNotCurrentAuthor (in category 'filtering') -----
- filterToNotCurrentAuthor
- "Filter down only to messages not stamped with my initials"
- self filterFrom:
- [:aClass :aSelector | | aTimeStamp aMethod |
- (aClass notNil and: [aSelector notNil]) and:
- [aMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil].
- aMethod notNil and:
- [(aTimeStamp := aMethod timeStamp) isNil or:
- [(aTimeStamp beginsWith: Utilities authorInitials) not]]]]!
Item was removed:
- ----- Method: MessageSet>>filterToNotCurrentChangeSet (in category 'filtering') -----
- filterToNotCurrentChangeSet
- "Filter the receiver's list down to only those items not in the current change set"
-
- self filterFrom:
- [:aClass :aSelector |
- (aClass notNil and: [aSelector notNil]) and:
- [(ChangeSet current atSelector: aSelector class: aClass) == #none]]!
Item was removed:
- ----- Method: MessageSet>>filterToNotImplementorsOf (in category 'filtering') -----
- filterToNotImplementorsOf
- "Filter the receiver's list down to only those items whose selector is NOT one solicited from the user."
-
- | aFragment inputWithBlanksTrimmed |
-
- aFragment := self request: 'type selector: ' initialAnswer: ''.
- aFragment isEmptyOrNil ifTrue: [^ self].
- inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
- (Symbol lookup: inputWithBlanksTrimmed) ifNotNil:
- [:aSymbol |
- self filterFrom:
- [:aClass :aSelector |
- aSelector ~~ aSymbol]]!
Item was removed:
- ----- Method: MessageSet>>filterToNotPackage (in category 'filtering') -----
- filterToNotPackage
- self requestPackageSelection ifNotNil:
- [ : selectedPackage | self filterFrom:
- [ : aClass : aSelector | (selectedPackage
- includesMethod: aSelector
- ofClass: aClass) not ] ]!
Item was removed:
- ----- Method: MessageSet>>filterToNotSendersOf (in category 'filtering') -----
- filterToNotSendersOf
- "Filter the receiver's list down to only those items which do not send a given selector"
-
- | aFragment inputWithBlanksTrimmed |
-
- aFragment := self request: 'type selector:' initialAnswer: ''.
- aFragment isEmptyOrNil ifTrue: [^ self].
- inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
- (Symbol lookup: inputWithBlanksTrimmed) ifNotNil:
- [:aSymbol |
- self filterFrom:
- [:aClass :aSelector | | aMethod |
- (aMethod := aClass compiledMethodAt: aSelector) isNil or:
- [(aMethod hasLiteral: aSymbol) not]]]!
Item was removed:
- ----- Method: MessageSet>>filterToPackage (in category 'filtering') -----
- filterToPackage
- self requestPackageSelection ifNotNil:
- [ : selectedPackage | self filterFrom:
- [ : aClass : aSelector | selectedPackage
- includesMethod: aSelector
- ofClass: aClass ] ]!
Item was removed:
- ----- Method: MessageSet>>filterToSendersOf (in category 'filtering') -----
- filterToSendersOf
- "Filter the receiver's list down to only those items which send a given selector"
-
- | aFragment inputWithBlanksTrimmed |
-
- aFragment := self request: 'type selector:' initialAnswer: ''.
- aFragment isEmptyOrNil ifTrue: [^ self].
- inputWithBlanksTrimmed := aFragment withBlanksTrimmed.
- (Symbol lookup: inputWithBlanksTrimmed) ifNotNil:
- [:aSymbol |
- self filterFrom:
- [:aClass :aSelector | | aMethod |
- (aMethod := aClass compiledMethodAt: aSelector) notNil and:
- [aMethod hasLiteral: aSymbol]]]
-
- !
Item was removed:
- ----- Method: MessageSet>>filterToUncommentedMethods (in category 'filtering') -----
- filterToUncommentedMethods
- "Filter the receiver's list down to only those items which lack comments"
-
- self filterFrom:
- [:aClass :aSelector |
- (aClass includesSelector: aSelector) and:
- [(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil]]!
Item was removed:
- ----- Method: MessageSet>>filterToUnsentMessages (in category 'filtering') -----
- filterToUnsentMessages
- "Filter the receiver's list down to only those items which have no
- senders"
- self
- filterFrom: [:aClass :aSelector | (self systemNavigation allCallsOn: aSelector) isEmpty]!
Item was removed:
- ----- Method: MessageSet>>formattedLabel: (in category 'message list') -----
- formattedLabel: aStringOrCodeReference
-
- self class parse: aStringOrCodeReference toClassAndSelector: [:cls :sel |
- ^ self
- formattedLabel: aStringOrCodeReference asString
- forSelector: sel
- inClass: cls]!
Item was removed:
- ----- Method: MessageSet>>growable (in category 'message list') -----
- growable
- "Answer whether the receiver is capable of growing/shrinking dynamically"
-
- ^ growable ~~ false!
Item was removed:
- ----- Method: MessageSet>>growable: (in category 'message list') -----
- growable: aBoolean
- "Give or take away the growable trait; when a message set is growable, methods submitted within it will be added to its message list"
-
- growable := aBoolean!
Item was removed:
- ----- Method: MessageSet>>hasMessageSelected (in category 'message list') -----
- hasMessageSelected
- ^ messageListIndex ~= 0.!
Item was removed:
- ----- Method: MessageSet>>indentionPrefixOfSize: (in category 'indenting') -----
- indentionPrefixOfSize: levelInteger
-
- | answer |
- answer := String new: levelInteger * self indentionSize.
- answer atAllPut: $ . "space"
- ^answer
- !
Item was removed:
- ----- Method: MessageSet>>indentionSize (in category 'indenting') -----
- indentionSize
-
- ^2 "that is, 2 spaces.."
- !
Item was removed:
- ----- Method: MessageSet>>indentionsIn: (in category 'indenting') -----
- indentionsIn: aString
-
- aString
- withIndexDo:
- [ :eachChar :index |
- eachChar = $ "space" ifFalse: [ ^(index-1) / self indentionSize ] ].
- ^0
- !
Item was removed:
- ----- Method: MessageSet>>initialize (in category 'initialize-release') -----
- initialize
-
- super initialize.
-
- messageList := OrderedCollection new.
- windowLabel := ''.!
Item was removed:
- ----- Method: MessageSet>>initializeMessageList: (in category 'private') -----
- initializeMessageList: anArray
- "Initialize my messageList from the given list of MethodReference or string objects. NB: special handling for uniclasses.
- Do /not/ replace the elements of anArray if they are already MethodReferences, so as to allow users to construct richer systems, such as differencers between existing and edited versions of code.
- NOTE THAT we must support anArray to already have the desired amount and order of elements such as for the 'method inheritance' view, where all elements are prefixed with spaces to indicate the inheritance tree."
-
- | isOrdered |
- isOrdered := anArray size > 1
- and: [anArray second isMethodReference]
- and: [anArray second stringVersion first = Character space].
- messageList := isOrdered
- ifTrue: [OrderedCollection new]
- ifFalse: [Set new].
- anArray do:
- [:each | each isMethodReference
- ifTrue: [messageList add: each]
- ifFalse:
- [ MessageSet
- parse: each
- toClassAndSelector:
- [ : class : sel | class ifNotNil: [ messageList add: (MethodReference class: class selector: sel) ] ] ] ].
- isOrdered ifFalse: [messageList := messageList asOrderedCollection sort].
- "Unify labels if wanted."
- self class useUnifiedMessageLabels ifTrue:
- [ messageList withIndexDo:
- [ : each : index | | cls |
- cls := each actualClass.
- each stringVersion:
- (self indentionPrefixOfSize: (self indentionsIn: each stringVersion))
- , (cls
- ifNil: [each asString]
- ifNotNil:
- [cls isUniClass
- ifTrue: [cls typicalInstanceName, ' ', each selector]
- ifFalse:
- [ cls name , ' ' , each selector , ' {'
- , ((cls organization categoryOfElement: each selector) ifNil: ['']) , '}'
- , ' {', cls category, '}' ] ]) ] ].
- messageListIndex := messageList isEmpty ifTrue: [0] ifFalse: [1].
- contents := String empty!
Item was removed:
- ----- Method: MessageSet>>isClassDefinition: (in category 'message list') -----
- isClassDefinition: messageListItemOrSymbol
- "Answer whether this item from the message list (or its extracted selector) indicates a
- class definition."
- ^ messageListItemOrSymbol selector = #Definition!
Item was removed:
- ----- Method: MessageSet>>isComment: (in category 'message list') -----
- isComment: messageListItemOrSymbol
- "Answer whether this item from the message list (or its extracted selector) indicates a
- class comment."
- ^ messageListItemOrSymbol selector = #Comment!
Item was removed:
- ----- Method: MessageSet>>isHierarchy: (in category 'message list') -----
- isHierarchy: messageListItemOrSymbol
- "Answer whether this item from the message list (or its extracted selector) indicates a
- class hierarchy."
- ^ messageListItemOrSymbol selector = #Hierarchy!
Item was removed:
- ----- Method: MessageSet>>lastMessageName (in category 'message list') -----
- lastMessageName
- ^ self messageList last selector.!
Item was removed:
- ----- Method: MessageSet>>mainMessageListMenu: (in category 'message list') -----
- mainMessageListMenu: aMenu
- <messageListMenuShifted: false>
-
- ^ aMenu
- addTranslatedList: #(
- ('what to show...' offerWhatToShowMenu));
- add: (self isBreakOnEntry ifTrue: ['<on>'] ifFalse: ['<off>']) , 'break on entry' translated
- action: #toggleBreakOnEntry;
- addTranslatedList: #(
- -
- ('browse full (b)' browseMethodFull)
- ('browse hierarchy (h)' browseClassHierarchy)
- ('browse protocol (p)' browseFullProtocol)
- -
- ('fileOut' fileOutMessage)
- ('printOut' printOutMessage)
- ('copy selector (c)' copySelector)
- ('copy reference (C)' copyReference)
- -
- ('senders of... (n)' browseSendersOfMessages)
- ('implementors of... (m)' browseMessages)
- ('inheritance (i)' methodHierarchy)
- ('versions (v)' browseVersions)
- -
- ('references... (r)' browseVariableReferences)
- ('assignments... (a)' browseVariableAssignments)
- ('class refs (N)' browseClassRefs)
- -
- ('remove method (x)' removeMessage)
- ('explore method' exploreMethod)
- ('inspect method' inspectMethod));
- yourself!
Item was removed:
- ----- Method: MessageSet>>messageHelpAt: (in category 'message list') -----
- messageHelpAt: anIndex
- "Show the first n lines of the sources code of the selected message."
-
- | reference |
- Preferences balloonHelpInMessageLists ifFalse: [^ nil].
- self messageList size < anIndex ifTrue: [^ nil].
-
- reference := self messageList at: anIndex.
- reference isValid ifFalse: [^ nil].
- (self isComment: reference) ifTrue: [^ self messageHelpForComment: reference].
- (self isClassDefinition: reference) ifTrue: [^ self messageHelpForClassDefinition: reference].
- (self isHierarchy: reference) ifTrue: [^ self messageHelpForClassHierarchy: reference].
- ^ self messageHelpForMethod: reference compiledMethod!
Item was removed:
- ----- Method: MessageSet>>messageHelpForClassDefinition: (in category 'message list') -----
- messageHelpForClassDefinition: aMethodReference
- "Answer the formatted help text for a class definition."
- ^ aMethodReference setClassAndSelectorIn: [:class :sel | class definition]!
Item was removed:
- ----- Method: MessageSet>>messageHelpForClassHierarchy: (in category 'message list') -----
- messageHelpForClassHierarchy: aMethodReference
- "Answer the formatted help text for a class hierarchy."
- "Show the first n lines of the class hierarchy."
- | source |
- source := aMethodReference setClassAndSelectorIn: [:class :sel | class printHierarchy].
- ^ self messageHelpTruncated: source asText!
Item was removed:
- ----- Method: MessageSet>>messageHelpForComment: (in category 'message list') -----
- messageHelpForComment: aMethodReference
- "Answer the formatted help text for a class comment."
- "Show the first n lines of the class comment."
- | source |
- source := aMethodReference setClassAndSelectorIn: [:class :sel | class comment].
- ^ self messageHelpTruncated: source asText!
Item was removed:
- ----- Method: MessageSet>>messageIconAt: (in category 'message list') -----
- messageIconAt: anIndex
-
- Browser showMessageIcons
- ifFalse: [^ nil].
-
- ^ ToolIcons iconNamed: (ToolIcons
- iconForClass: (self messageList at: anIndex) actualClass
- selector: (self messageList at: anIndex) selector)!
Item was removed:
- ----- Method: MessageSet>>messageList (in category 'message list') -----
- messageList
- "Answer the current list of messages."
-
- ^messageList!
Item was removed:
- ----- Method: MessageSet>>messageListFormatted (in category 'message list') -----
- messageListFormatted
-
- ^ messageListFormatted ifNil: [
- messageListFormatted := messageList collect: [:ea | self formattedLabel: ea]]!
Item was removed:
- ----- Method: MessageSet>>messageListIndex (in category 'message list') -----
- messageListIndex
- ^messageListIndex ifNil: [0]!
Item was removed:
- ----- Method: MessageSet>>messageListIndex: (in category 'message list') -----
- messageListIndex: anInteger
- "Set the index of the selected item to be anInteger.
- Update the message list morph, the text edit morph and the assorted buttons"
-
- messageListIndex := anInteger.
- contents :=
- messageListIndex ~= 0
- ifTrue: [self selectedMessage]
- ifFalse: [''].
- self changed: #messageListIndex. "update my selection"
- self editSelection: #editMessage.
- self contentsChanged.
- (messageListIndex ~= 0 and: [ autoSelectString notNil and: [ self contents notEmpty ] ]) ifTrue: [ self changed: #autoSelect ].
- self decorateButtons
- !
Item was removed:
- ----- Method: MessageSet>>messageListIndexOf: (in category 'message list') -----
- messageListIndexOf: aString
- ^ (self messageList collect: [:each | each selector]) indexOf: aString.!
Item was removed:
- ----- Method: MessageSet>>messageListMenu:shifted: (in category 'message list') -----
- messageListMenu: aMenu shifted: shifted
- "Answer the message-list menu"
- ^ self menu: aMenu for: #(messageListMenu messageListMenuShifted:) shifted: shifted
- !
Item was removed:
- ----- Method: MessageSet>>messageListMenuHook:shifted: (in category 'pluggable menus - hooks') -----
- messageListMenuHook: aMenu shifted: aBoolean
- <messageListMenu>
- ^ self menuHook: aMenu named: #messageListMenu shifted: aBoolean.
- !
Item was removed:
- ----- Method: MessageSet>>metaClassIndicated (in category 'class list') -----
- metaClassIndicated
- "Answer the boolean flag that indicates whether
- this is a class method."
-
- ^ self selectedClassOrMetaClass isMeta!
Item was removed:
- ----- Method: MessageSet>>methodCategoryChanged (in category 'message functions') -----
- methodCategoryChanged
- self changed: #annotation!
Item was removed:
- ----- Method: MessageSet>>modelWakeUp (in category 'user interface') -----
- modelWakeUp
- "A window with me as model has been activated."
-
- super modelWakeUp.
- (self canDiscardEdits and: [autoSelectString notNil]) ifTrue: [
- self codeTextMorph ifNotNil: [:tm |
- (tm hasProperty: #launched) ifFalse: [
- tm scrollSelectionIntoView.
- tm setProperty: #launched toValue: true] ] ]!
Item was removed:
- ----- Method: MessageSet>>optionalButtonHeight (in category 'message list') -----
- optionalButtonHeight
-
- ^ 15!
Item was removed:
- ----- Method: MessageSet>>reformulateList (in category 'message functions') -----
- reformulateList
- "The receiver's messageList has been changed; rebuild it"
- super reformulateList.
- self
- changed: #messageList ;
- changed: #messageListIndex.
- self contentsChanged.
- autoSelectString ifNotNil: [ self changed: #autoSelect ]!
Item was removed:
- ----- Method: MessageSet>>removeMessage (in category 'message functions') -----
- removeMessage
-
- self hasMessageSelected ifFalse: [^ false].
-
- super removeMessage ifFalse: [^ false].
- self deleteFromMessageList: self selection.
- self reformulateList.
-
- ^ true!
Item was removed:
- ----- Method: MessageSet>>removeMessageFromBrowser (in category 'message functions') -----
- removeMessageFromBrowser
- "Remove the selected message from the browser."
-
- self hasMessageSelected ifFalse: [^ self].
- self deleteFromMessageList: self selection.
- self reformulateList.
- self adjustWindowTitleAfterFiltering
- !
Item was removed:
- ----- Method: MessageSet>>representsSameBrowseeAs: (in category 'morphic ui') -----
- representsSameBrowseeAs: anotherModel
- ^ self hasUnacceptedEdits not
- and: [ messageList = anotherModel messageList ]!
Item was removed:
- ----- Method: MessageSet>>request:initialAnswer: (in category 'user interface') -----
- request: prompt initialAnswer: initialAnswer
-
- ^ UIManager default
- request: prompt
- initialAnswer: initialAnswer!
Item was removed:
- ----- Method: MessageSet>>requestPackageSelection (in category 'private') -----
- requestPackageSelection
- | packages selectedIndex |
- packages := PackageOrganizer default packages sort:
- [ : a : b | a packageName <= b packageName ].
- selectedIndex := UIManager default
- chooseFrom: (packages collect: [ : each | each packageName ])
- lines: Array empty
- title: 'Select a package...'.
- ^ packages at: selectedIndex ifAbsent: [ nil ]!
Item was removed:
- ----- Method: MessageSet>>selectedClass (in category 'class list') -----
- selectedClass
- "Return the base class for the current selection. 1/17/96 sw fixed up so that it doesn't fall into a debugger in a msg browser that has no message selected"
-
- | aClass |
- ^ (aClass := self selectedClassOrMetaClass) == nil
- ifTrue:
- [nil]
- ifFalse:
- [aClass theNonMetaClass]!
Item was removed:
- ----- Method: MessageSet>>selectedClassName (in category 'class list') -----
- selectedClassName
- "Answer the name of class of the currently selected message. Answer nil if no selection
- exists."
-
- | cls |
- (cls := self selectedClass) ifNil: [^ nil].
- ^ cls name!
Item was removed:
- ----- Method: MessageSet>>selectedClassOrMetaClass (in category 'class list') -----
- selectedClassOrMetaClass
- "Answer the currently selected class (or metaclass)."
- self hasMessageSelected ifFalse: [^nil].
- self setClassAndSelectorIn: [:c :s | ^c]!
Item was removed:
- ----- Method: MessageSet>>selectedMessage (in category 'message list') -----
- selectedMessage
- "Answer the source method for the currently selected message."
-
-
- self setClassAndSelectorIn: [:class :selector | | source |
- class ifNil: [^ 'Class vanished'].
- selector first isUppercase ifTrue:
- [selector == #Comment ifTrue:
- [currentCompiledMethod := class organization commentRemoteStr.
- ^ class comment].
- selector == #Definition ifTrue:
- [^ class definition].
- selector == #Hierarchy ifTrue: [^ class printHierarchy]].
- source := class sourceMethodAt: selector ifAbsent:
- [currentCompiledMethod := nil.
- ^ 'Missing'].
-
- self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].
-
- currentCompiledMethod := class compiledMethodAt: selector ifAbsent: [nil].
- self showingDocumentation ifTrue: [^ self commentContents].
-
- source := self sourceStringPrettifiedAndDiffed.
- ^ source asText makeSelectorBoldIn: class]!
Item was removed:
- ----- Method: MessageSet>>selectedMessageCategoryName (in category 'class list') -----
- selectedMessageCategoryName
- "Answer the name of the selected message category or nil."
- | cls |
- self hasMessageSelected ifFalse: [^ nil].
- cls := self selectedClassOrMetaClass.
-
- cls ifNil: [^ nil].
-
- ^ cls organization categoryOfElement: self selectedMessageName!
Item was removed:
- ----- Method: MessageSet>>selectedMessageName (in category 'message list') -----
- selectedMessageName
- "Answer the name of the currently selected message."
- "wod 6/16/1998: answer nil if none are selected."
-
- messageListIndex = 0 ifTrue: [^ nil].
- ^ self setClassAndSelectorIn: [:class :selector | ^ selector]!
Item was removed:
- ----- Method: MessageSet>>selection (in category 'private') -----
- selection
- "Answer the item in the list that is currently selected, or nil if no selection is present"
-
- ^ self messageList at: (self messageListIndex) ifAbsent: [nil]!
Item was removed:
- ----- Method: MessageSet>>setClassAndSelectorIn: (in category 'private') -----
- setClassAndSelectorIn: csBlock
- "Decode strings of the form <className> [class] <selectorName>."
-
- | sel |
- sel := self selection.
- ^ sel isCodeReference
- ifTrue: [sel setClassAndSelectorIn: csBlock]
- ifFalse: [self class parse: sel toClassAndSelector: csBlock]!
Item was removed:
- ----- Method: MessageSet>>setContentsToForceRefetch (in category 'contents') -----
- 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 := ''!
Item was removed:
- ----- Method: MessageSet>>setFilteredList: (in category 'private') -----
- setFilteredList: newList
- "Establish newList as the new list if appropriate, and adjust the window title accordingly; if the new list is of the same size as the old, warn and do nothing"
-
- | currentSelection |
- newList size = 0 ifTrue:
- [ self inform: 'Nothing would be left in the list if you did that'.
- ^false ].
- newList size = messageList size ifTrue:
- [ self inform: 'That leaves the list unchanged'.
- ^false ].
-
- messageListIndex > 0 ifTrue:
- [currentSelection := messageList at: messageListIndex].
-
- self
- initializeMessageList: newList ;
- adjustWindowTitleAfterFiltering.
-
- currentSelection ifNotNil:
- [messageListIndex := messageList indexOf: currentSelection ifAbsent: [1]].
-
- self
- changed: #messageList;
- changed: #messageListIndex.
-
- ^true!
Item was removed:
- ----- Method: MessageSet>>setInitialLabel: (in category 'accessing') -----
- setInitialLabel: aString
- "set the base label for the window, as returned by #windowTitle"
-
- windowLabel := aString!
Item was removed:
- ----- Method: MessageSet>>shiftedMessageListMenu: (in category 'message list') -----
- shiftedMessageListMenu: aMenu
- "Fill aMenu with the items appropriate when the shift key is held down"
- <messageListMenuShifted: true>
-
- aMenu addStayUpItem.
- aMenu addList: #(
- ('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)).
- ^ aMenu
- !
Item was removed:
- ----- Method: MessageSet>>sortByDate (in category 'message list') -----
- sortByDate
- "Sort the message-list by date of time-stamp"
-
- | associations |
- associations := messageList collect:
- [:aRef | | aDate aCompiledMethod |
- aDate := aRef methodSymbol == #Comment
- ifTrue:
- [aRef actualClass organization dateCommentLastSubmitted]
- ifFalse:
- [aCompiledMethod := aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: [nil].
- aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]].
- aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])]. "The dawn of Squeak history"
- messageList := associations
- sort: #value asSortFunction;
- replace: [ :association | association key ];
- yourself.
- self changed: #messageList!
Item was removed:
- ----- Method: MessageSet>>systemOrganizer: (in category 'initialize-release') -----
- systemOrganizer: aSystemOrganizer
-
- messageListIndex := 0.
- ^ super systemOrganizer: aSystemOrganizer.!
Item was removed:
- ----- Method: MessageSet>>targetForContents: (in category 'private') -----
- targetForContents: aString
- "Answer the behavior into which the contents will be accepted."
- self setClassAndSelectorIn: [:c :os | ^ c].
- ^ nil "fail safe for overriding implementations of setClassAndSelectorIn:"!
Item was removed:
- ----- Method: MessageSet>>veryDeepInner: (in category 'copying') -----
- veryDeepInner: deepCopier
- super veryDeepInner: deepCopier.
- messageList := messageList veryDeepCopyWith: deepCopier.
- editSelection := editSelection veryDeepCopyWith: deepCopier.!
Item was removed:
- ----- Method: MessageSet>>windowTitle (in category 'user interface') -----
- windowTitle
- "just return the basic label for now"
-
- ^String streamContents:
- [:str| str nextPutAll: windowLabel;
- space;
- nextPut: $[;
- nextPutAll: messageList size asString;
- nextPut: $]
- ]!
Item was removed:
- MessageSet subclass: #MessageTrace
- instanceVariableNames: 'autoSelectStrings messageSelections anchorIndex'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !MessageTrace commentStamp: 'cmm 3/2/2010 20:26' prior: 0!
- A MessageTrace is a MessageSet allowing efficient sender/implementor message following. With implementors indented below, and senders outdended above, message flow is succinctly expressed, hierarchically.
-
- My autoSelectStrings and messageSelections are Arrays of Booleans, parallel to my messageList. Each boolean indicates whether that message is selected. Each autoSelectStrings indicates which string should be highlighted in the code for each method in my messageList.!
Item was removed:
- ----- Method: MessageTrace class>>initialize (in category 'initializing') -----
- initialize
-
- self setUpPreferencesPanel!
Item was removed:
- ----- Method: MessageTrace class>>setUpPreferencesPanel (in category 'initializing') -----
- setUpPreferencesPanel
- Preferences
- addPreference: #traceMessages
- category: #browsing
- default: false
- balloonHelp: 'If true, browsing senders or implementors in a methods browser will add to the methods in that browser instead of opening a new browser.'
- !
Item was removed:
- ----- Method: MessageTrace>>addChildMessages:autoSelectString: (in category 'building') -----
- addChildMessages: methodReferences autoSelectString: aString
- | currentIndentionLevel addables selectables selectableString newAnchor |
- selectableString := aString keywords
- ifEmpty: [ String empty ]
- ifNotEmptyDo: [ : keywords |
- "we can probably do something more precise here; perhaps recombining the extracted keywords into a single selector? Then again all usages of this method seem to already enforce use of a selector"
- aString ].
- [ (messageListIndex between: 1 and: autoSelectStrings size) ]
- whileFalse: [ autoSelectStrings add: selectableString ].
- currentIndentionLevel := self currentIndentionLevel.
- "Don't add mulitple copies of the same method, if a method is already in the list we will merely select it."
- addables := methodReferences reject: [ : each | messageList includes: each ].
- addables do:
- [ : each |
- each stringVersion: (self indentionPrefixOfSize: currentIndentionLevel + 1) , each asStringOrText.
- messageList
- add: each
- afterIndex: self messageListIndex.
- autoSelectStrings
- add: nil
- afterIndex: self messageListIndex.
- messageSelections
- add: false
- afterIndex: self messageListIndex ].
- selectables :=
- addables copy
- addAll: (methodReferences select: [ : each | messageList includes: each ]) ;
- yourself.
- self deselectAll.
- anchorIndex := nil.
- selectables do:
- [ : each |
- self
- messageAt: (newAnchor := messageList indexOf: each)
- beSelected: true.
- anchorIndex ifNil: [ anchorIndex := newAnchor ] ].
- self changed: #messageList.
- "Select the first child method."
- self messageListIndex:
- (selectables size > 0
- ifTrue: [ messageList indexOf: selectables last ]
- ifFalse: [ messageList ifEmpty: [ 0 ] ifNotEmpty: [ 1 ] ])!
Item was removed:
- ----- Method: MessageTrace>>addChildMethodsNamed: (in category 'building') -----
- addChildMethodsNamed: selectorSymbol
-
- | methodsReferences |
-
- messageListIndex = 0
- ifTrue:
- [ ^(PopUpMenu labels: ' OK ')
- startUpWithCaption: 'Please reselect a method.' ].
- (methodsReferences := self filteredSelectorsNamed: selectorSymbol) isEmpty
- ifTrue:
- [ ^(PopUpMenu labels: ' OK ')
- startUpWithCaption: 'There are no methods named ', selectorSymbol ]
- ifFalse:
- [ self
- addChildMessages: methodsReferences
- autoSelectString: selectorSymbol ]
- !
Item was removed:
- ----- Method: MessageTrace>>addExtraShiftedItemsTo: (in category 'message list') -----
- addExtraShiftedItemsTo: aMenu
- "The shifted selector-list menu is being built. Add items specific to MessageTrace."
- super addExtraShiftedItemsTo: aMenu.
- aMenu addList: #(#('invert level selection (I)' #invertLevelSelection) )!
Item was removed:
- ----- Method: MessageTrace>>addParentMessages:autoSelectString: (in category 'building') -----
- addParentMessages: methodReferences autoSelectString: aString
- | currentIndentionLevel addables selectables |
- addables := methodReferences reject: [ : each | messageList includes: each ].
- "we may need to process aString here in a similar manner to that in #addChildMessages:autoSelectString:"
- selectables := addables copy
- addAll: (methodReferences select: [ : each | messageList includes: each ]) ;
- yourself.
- currentIndentionLevel := self currentIndentionLevel.
- (currentIndentionLevel = 0 and: [ addables notEmpty ]) ifTrue:
- [ self indentEverything.
- currentIndentionLevel := 1 ].
- addables do:
- [ : each |
- each stringVersion: (self indentionPrefixOfSize: currentIndentionLevel - 1) , each asStringOrText.
- messageList
- add: each
- afterIndex: self messageListIndex - 1.
- autoSelectStrings
- add: aString
- afterIndex: self messageListIndex - 1.
- messageSelections
- add: false
- afterIndex: self messageListIndex - 1 ].
- self deselectAll.
- selectables do:
- [ : each | | messageIndex |
- messageIndex := messageList indexOf: each.
- self
- messageAt: messageIndex
- beSelected: true.
- autoSelectStrings
- at: messageIndex
- put: aString ].
- self changed: #messageList.
- anchorIndex := messageListIndex.
- selectables size > 0 ifTrue:
- [ self messageListIndex: (messageList indexOf: selectables first) ]!
Item was removed:
- ----- Method: MessageTrace>>addParentMethodsSending: (in category 'building') -----
- addParentMethodsSending: selectorSymbol
-
- | methodsList |
- (methodsList := self systemNavigation allCallsOn: selectorSymbol) isEmpty
- ifTrue:
- [ ^(PopUpMenu labels: ' OK ')
- startUpWithCaption: 'There are no methods that send ', selectorSymbol ]
- ifFalse:
- [ self
- addParentMessages: methodsList
- autoSelectString: selectorSymbol asString]!
Item was removed:
- ----- Method: MessageTrace>>autoSelectString: (in category 'building') -----
- autoSelectString: aString
-
- super autoSelectString: aString.
- autoSelectStrings := messageList collect: [ :each | aString ]
- !
Item was removed:
- ----- Method: MessageTrace>>browseAllCallsOn:requestor: (in category 'actions') -----
- browseAllCallsOn: selectorSymbol requestor: anObject
- "Overwritten to modify the trace if the request origins from a model-menu command such as the message-list menu (shortcut)."
-
- (selectorSymbol = self selectedMessageName
- and: [ Preferences traceMessages ] and: [ self hasUnacceptedEdits not ])
- ifTrue: [ self addParentMethodsSending: selectorSymbol ]
- ifFalse: [ super browseAllCallsOn: selectorSymbol requestor: anObject ].!
Item was removed:
- ----- Method: MessageTrace>>browseAllImplementorsOf:requestor: (in category 'actions') -----
- browseAllImplementorsOf: selectorSymbol requestor: anObject
- "Overwritten to modify the trace if the request origins from a model-menu command such as the message-list menu (shortcut)."
-
- | selectorToBrowse |
- selectorToBrowse := self selection
- ifNil: [ selectorSymbol ]
- ifNotNil: [ self getImplementorNamed: selectorSymbol asSymbol "since we can get passed literals"].
- (Preferences traceMessages and: [ self hasUnacceptedEdits not ])
- ifTrue: [ self addChildMethodsNamed: selectorToBrowse ]
- ifFalse: [ super browseAllImplementorsOf: selectorToBrowse requestor: anObject ].!
Item was removed:
- ----- Method: MessageTrace>>buildMessageListWith: (in category 'private initializing') -----
- buildMessageListWith: builder
- | listSpec |
- listSpec := builder pluggableAlternateMultiSelectionListSpec new.
- listSpec
- model: self ;
- list: #messageListFormatted ;
- getIndex: #messageListIndex ;
- setIndex: #toggleSelectionAt:shifted:controlled: ;
- icon: #messageIconAt:;
- helpItem: #messageHelpAt:;
- menu: #messageListMenu:shifted: ;
- getSelectionList: #isMessageSelectedAt: ;
- setSelectionList: #messageAt:beSelected: ;
- keyPress: #messageListKey:from:.
- SystemBrowser browseWithDragNDrop
- ifTrue: [ listSpec dragItem: #dragFromMessageList: ].
- ^ listSpec!
Item was removed:
- ----- Method: MessageTrace>>copySelector (in category 'menus') -----
- copySelector
- Clipboard clipboardText:
- (String streamContents:
- [ : stream | self selectedMessages
- do: [ : each | stream nextPutAll: each selector asString ]
- separatedBy: [ stream space ] ])!
Item was removed:
- ----- Method: MessageTrace>>currentIndentionLevel (in category 'private accessing') -----
- currentIndentionLevel
- ^ messageListIndex isZero ifFalse: [ self indentionLevelAt: messageListIndex ]!
Item was removed:
- ----- Method: MessageTrace>>deleteAllFromMessageList: (in category 'building') -----
- deleteAllFromMessageList: aCollection
- "Delete the given messages from the receiver's message list"
-
- | newAutoSelectStrings newMessageSelections newSize set |
- newSize := self messageList size - aCollection size.
- newAutoSelectStrings := OrderedCollection new: newSize.
- newMessageSelections := OrderedCollection new: newSize.
- set := aCollection asSet.
- self messageList withIndexDo: [:each :index |
- (set includes: each) ifFalse:
- [newAutoSelectStrings add: (autoSelectStrings at: index).
- newMessageSelections add: (messageSelections at: index)]].
- super deleteAllFromMessageList: aCollection.
- autoSelectStrings := newAutoSelectStrings.
- messageSelections := newMessageSelections.
- anchorIndex ifNotNil:
- [ anchorIndex := anchorIndex min: messageList size ]!
Item was removed:
- ----- Method: MessageTrace>>deleteFromMessageList: (in category 'building') -----
- deleteFromMessageList: aMethodReference
- "Delete the given message from the receiver's message list"
-
- | index |
- autoSelectStrings removeAt: (index := messageList indexOf: aMethodReference).
- messageSelections removeAt: index.
- super deleteFromMessageList: aMethodReference.
- anchorIndex ifNotNil:
- [ anchorIndex := anchorIndex min: messageList size ]
- !
Item was removed:
- ----- Method: MessageTrace>>deselectAll (in category 'actions') -----
- deselectAll
- super deselectAll.
- 1 to: messageSelections size do: [ :index | messageSelections at: index put: false ]
- !
Item was removed:
- ----- Method: MessageTrace>>deselectAllBetweenLastSelectionAnd: (in category 'private actions') -----
- deselectAllBetweenLastSelectionAnd: indexPosition
-
- | lower higher |
- lower := messageListIndex min: indexPosition.
- higher := messageListIndex max: indexPosition.
- lower = 0 ifTrue: [ ^nil ].
- lower to: higher do:
- [ :index | messageSelections at: index put: false ]
- !
Item was removed:
- ----- Method: MessageTrace>>filterFrom: (in category 'filtering') -----
- filterFrom: aBlock
- "Filter the receiver's list down to only those items that satisfy aBlock, which takes a class an a selector as its arguments."
- | newList newAutoSelectStrings newMessageSelections oldList |
- oldList := Dictionary new.
- messageList do: [ : each | oldList at: each put: each ].
- newList := messageList class new.
- newAutoSelectStrings := autoSelectStrings class new.
- newMessageSelections := messageSelections class new.
- messageList withIndexDo:
- [ : each : index | (self class
- parse: each
- toClassAndSelector: aBlock) ifTrue:
- [ newList add: each.
- newAutoSelectStrings add: (autoSelectStrings at: index).
- newMessageSelections add: (messageSelections at: index) ] ].
- (self setFilteredList: newList) ifTrue:
- [ autoSelectStrings := newAutoSelectStrings.
- messageList do:
- [ : each | each stringVersion: (oldList at: each) asString ] ]!
Item was removed:
- ----- Method: MessageTrace>>filteredSelectorsNamed: (in category 'filtering') -----
- filteredSelectorsNamed: selectorSymbol
-
- ^(SystemNavigation for: self environment) allImplementorsOf: selectorSymbol
- !
Item was removed:
- ----- Method: MessageTrace>>getImplementorNamed: (in category 'private accessing') -----
- getImplementorNamed: selectorSymbol
- | allPossibilities |
- allPossibilities := (((self selection compiledMethod messages
- select: [ :eachSelector | eachSelector beginsWith: selectorSymbol ])
- copyWith: selectorSymbol)
- select: [ :each | (Symbol lookup: each) notNil ])
- asSet asOrderedCollection sort.
- (allPossibilities includes: selectorSymbol) ifTrue:
- [ allPossibilities addFirst: (allPossibilities remove: selectorSymbol) ].
- ^allPossibilities size > 1
- ifTrue:
- [ | selectionIndex |
- selectionIndex := (PopUpMenu labelArray: allPossibilities lines: #(1))
- startUpWithCaption:
- 'Browse implementors of
- which message?'.
- selectionIndex = 0 ifTrue: [ selectorSymbol ] ifFalse: [ allPossibilities at: selectionIndex ] ]
- ifFalse: [ allPossibilities isEmpty
- ifTrue: [ selectorSymbol ]
- ifFalse: [ allPossibilities first ] ]
- !
Item was removed:
- ----- Method: MessageTrace>>indentEverything (in category 'indenting') -----
- indentEverything
-
- messageList do: [ :each | each stringVersion: (self indentionPrefixOfSize: 1), each asString ]
- !
Item was removed:
- ----- Method: MessageTrace>>indentionLevelAt: (in category 'private accessing') -----
- indentionLevelAt: msgListIndex
- ^ self indentionsIn: (messageList at: msgListIndex) asString!
Item was removed:
- ----- Method: MessageTrace>>initialize (in category 'private initializing') -----
- initialize
-
- super initialize.
- messageSelections := OrderedCollection new.
- autoSelectStrings := OrderedCollection new
- !
Item was removed:
- ----- Method: MessageTrace>>initializeMessageList: (in category 'private initializing') -----
- initializeMessageList: anArray
- super initializeMessageList: anArray.
- messageSelections := (Array new: messageList size withAll: false) asOrderedCollection.
- self
- messageAt: messageListIndex
- beSelected: true.
- "autoSelectStrings is initialized right after this method, in autoSelectString:"
- !
Item was removed:
- ----- Method: MessageTrace>>invertLevelSelection (in category 'actions') -----
- invertLevelSelection
- "The user wants to be able to quickly and easily assemble message-traces. When browsing senders or implementors of a heavily overloaded selector, typically just one or two messages are relevant out of several. In that situation, the user need merely select the range of relevant methods to arrive within two gestures of trimming the irrelevant methods: Command+I (capital eye) to invert the selection within the local group followed by Command+d to remove that selection from the browser."
- | index currentLevel start |
- currentLevel := self currentIndentionLevel ifNil:
- [ | possibilities |
- possibilities := ((1 to: messageSelections size) select:
- [ : idx | messageSelections at: idx ]) collect:
- [ : eachSelectedIndex | self indentionLevelAt: eachSelectedIndex ].
- possibilities asSet size > 1
- ifTrue: [ ^ self ]
- ifFalse:
- [ possibilities ifEmpty: [ ^ self ].
- start := messageSelections indexOf: true.
- possibilities anyOne ] ].
- "First invert at messageListIndex then crawl up and down from there until a different level is reached, inverting as we go."
- messageListIndex > 0 ifTrue: [ start := messageListIndex ].
- self toggleMessageSelectionAt: start.
- index := start.
- [ index := index - 1.
- index > 0 and: [ (self indentionLevelAt: index) = currentLevel ] ] whileTrue: [ self toggleMessageSelectionAt: index ].
- index := start.
- [ index := index + 1.
- index <= messageList size and: [ (self indentionLevelAt: index) = currentLevel ] ] whileTrue: [ self toggleMessageSelectionAt: index ].
- self
- messageListIndex: 0 ;
- changed: #messageList!
Item was removed:
- ----- Method: MessageTrace>>isMessageSelectedAt: (in category 'testing') -----
- isMessageSelectedAt: anInteger
-
- ^messageSelections at: anInteger ifAbsent: [ false ]!
Item was removed:
- ----- Method: MessageTrace>>messageAt:beSelected: (in category 'actions') -----
- messageAt: indexInteger beSelected: aBoolean
- ^ indexInteger isZero ifFalse:
- [ messageSelections
- at: indexInteger
- put: aBoolean ]!
Item was removed:
- ----- Method: MessageTrace>>messageListIndex: (in category 'actions') -----
- messageListIndex: anInteger
- "Set the index of the selected item to be anInteger.
- Find the relevant auto select string to use, do my superclass' work and update the window title"
-
- autoSelectStrings ifNotEmpty:
- [ autoSelectString :=
- anInteger = 0
- ifTrue: [ "clear the autoSelectString"
- String empty ]
- ifFalse: [autoSelectStrings at: anInteger]
- ].
-
- anInteger > 0 ifTrue: [ self
- messageAt: anInteger
- beSelected: true
- ].
- super messageListIndex: anInteger.
- self changed: #windowTitle
- !
Item was removed:
- ----- Method: MessageTrace>>messageListKey:from: (in category 'message list') -----
- messageListKey: aChar from: view
- aChar == $I ifTrue: [ ^ self invertLevelSelection ].
- ^ super messageListKey: aChar from: view!
Item was removed:
- ----- Method: MessageTrace>>noteSelectionIndex:for: (in category 'accessing') -----
- noteSelectionIndex: anInteger for: aSymbol
- aSymbol == #messageList
- ifTrue:
- [ messageListIndex := anInteger.
- self
- messageAt: messageListIndex
- beSelected: true ].
- super
- noteSelectionIndex: anInteger
- for: aSymbol!
Item was removed:
- ----- Method: MessageTrace>>removeFromCurrentChanges (in category 'message list') -----
- removeFromCurrentChanges
- "Tell the changes mgr to forget that the selected messages were changed."
-
- self selectedMessages do: [:each |
- each setClassAndSelectorIn: [:class :selector |
- ChangeSet current removeSelectorChanges: selector class: class]].
- self changed: #annotation!
Item was removed:
- ----- Method: MessageTrace>>removeMessage (in category 'actions') -----
- removeMessage
- "Remove the selected messages from the system."
- self selectedMessages size = 0 ifTrue: [ ^self ].
- self selectedMessages size = 1 ifTrue: [ ^super removeMessage ].
- (self confirm: ('Are you certain you want to remove all the {1} selected methods from the image?' translated format: {self selectedMessages size})) ifFalse: [ ^self ].
- self selectedMessages do:
- [ :each |
- each actualClass removeSelector: each methodSymbol.
- self deleteFromMessageList: each ]!
Item was removed:
- ----- Method: MessageTrace>>removeMessageFromBrowser (in category 'building') -----
- removeMessageFromBrowser
- | indexToSelect |
- "Try to keep the same selection index."
- indexToSelect := (messageSelections indexOf: true) max: 1.
- self deleteAllFromMessageList: self selectedMessages.
- self deselectAll.
- messageSelections ifNotEmpty:
- [ messageSelections
- at: (indexToSelect min: messageSelections size) "safety"
- put: true ].
- anchorIndex := indexToSelect min: messageSelections size.
- self
- messageListIndex: anchorIndex ;
- reformulateList!
Item was removed:
- ----- Method: MessageTrace>>selectAllBetweenAnchorAnd: (in category 'private actions') -----
- selectAllBetweenAnchorAnd: indexPosition
-
- | lower higher |
- self deselectAllBetweenLastSelectionAnd: indexPosition.
- anchorIndex ifNil: [ anchorIndex := indexPosition ].
- lower := anchorIndex min: indexPosition.
- higher := anchorIndex max: indexPosition.
- lower to: higher do:
- [ :index | messageSelections at: index put: true ]
- !
Item was removed:
- ----- Method: MessageTrace>>selectedMessages (in category 'private actions') -----
- selectedMessages
-
- | answer |
- answer := OrderedCollection new.
- messageSelections withIndexDo:
- [ :eachSelection :index |
- eachSelection ifTrue: [ answer add: (messageList at: index) ] ].
- ^answer
- !
Item was removed:
- ----- Method: MessageTrace>>toggleMessageSelectionAt: (in category 'private actions') -----
- toggleMessageSelectionAt: anInteger
-
- messageSelections
- at: anInteger
- put: (messageSelections at: anInteger) not
- !
Item was removed:
- ----- Method: MessageTrace>>toggleSelectionAt: (in category 'actions') -----
- toggleSelectionAt: currentPosition
- "Compatibility with MVC"
-
- ^ self
- toggleSelectionAt: currentPosition
- shifted: false
- controlled: false!
Item was removed:
- ----- Method: MessageTrace>>toggleSelectionAt:shifted:controlled: (in category 'actions') -----
- toggleSelectionAt: anInteger shifted: isShifted controlled: isMouseDragging
- anInteger = 0 ifTrue: [ ^ nil ].
- (isMouseDragging not and: [anInteger = anchorIndex and: [ (messageSelections occurrencesOf: true) = 1 ]])
- ifTrue:
- [ self toggleMessageSelectionAt: anInteger.
- anchorIndex := nil.
- self messageListIndex: 0 ]
- ifFalse:
- [ self deselectAll.
- isShifted
- ifTrue: [ self selectAllBetweenAnchorAnd: anInteger ]
- ifFalse:
- [ self
- messageAt: anInteger
- beSelected: true.
- anchorIndex := anInteger ].
- self messageListIndex: anInteger ]!
Item was removed:
- ----- Method: MessageTrace>>veryDeepInner: (in category 'copying') -----
- veryDeepInner: aDeepCopier
- super veryDeepInner: aDeepCopier.
- autoSelectStrings := autoSelectStrings veryDeepCopyWith: aDeepCopier.
- messageSelections := messageSelections veryDeepCopyWith: aDeepCopier!
Item was removed:
- ----- Method: MessageTrace>>windowLabelAt: (in category 'private accessing') -----
- windowLabelAt: anInteger
- "return a suitable window label when there is an actual list item selected; work out what it should be based upon the array of autoSelectStrings or the current selection"
-
- ^(autoSelectStrings at: anInteger)
- ifNil:
- ['Implementors of ',
- (self class
- parse: self selection
- toClassAndSelector: [ :class :selector | selector ])]
- ifNotNil:
- [:str| (windowLabel endsWith: str)
- ifTrue: [windowLabel]
- ifFalse: ['Senders of ', str]]!
Item was removed:
- ----- Method: MessageTrace>>windowTitle (in category 'building') -----
- windowTitle
- "set the window label to suit the selection state;
- if no selection, use saved widow label and add the number of items in the messageList
- if something is selected, use the relevant string provided by windowLabelAt: which considers the index"
-
- ^messageListIndex = 0
- ifTrue:[String streamContents: [:str| str nextPutAll: windowLabel;
- space;
- nextPut: $[;
- nextPutAll: messageList size asString;
- nextPut: $]
- ]
- ]
- ifFalse: [self windowLabelAt: messageListIndex]!
Item was removed:
- Object subclass: #MethodFinder
- instanceVariableNames: 'data answers selector argMap thisData mapStage mapList expressions cachedClass cachedArgNum cachedSelectorLists'
- classVariableNames: 'AddAndRemove Approved Blocks Dangerous'
- poolDictionaries: ''
- category: 'Tools-MethodFinder'!
-
- !MethodFinder commentStamp: '<historical>' prior: 0!
- Find a method in the system from a set of examples. Done by brute force, trying every possible selector. Errors are skipped over using ( [3 + 'xyz'] ifError: [^ false] ).
- Submit an array of the form ((data1 data2) answer (data1 data2) answer).
-
- MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10).
-
- answer: 'data1 + data2'
-
- More generally, use the brace notation to construct live examples.
-
- The program tries data1 as the receiver, and
- tries all other permutations of the data for the receiver and args, and
- tries leaving out one argument, and
- uses all selectors data understands, and
- uses all selectors in all od data's superclasses.
-
- Floating point values must be precise to 0.01 percent, or (X * 0.0001).
-
- If you get an error, you have probably discovered a selector that needs to be removed from the Approved list. See MethodFinder.initialize. Please email the Squeak Team.
-
- Only considers 0, 1, 2, and 3 argument messages. The argument data may have 1 to 5 entries, but only a max of 4 used at a time. For now, we only test messages that use given number of args or one fewer. For example, this data (100 true 0.6) would test the receiver plus two args, and the receiver plus one arg, but not any other patterns.
-
- Three sets of selectors: Approved, AddAndRemove, and Blocks selectors. When testing a selector in AddAndRemove, deepCopy the receiver. We do not handle selectors that modify an argument (printOn: etc.). Blocks is a set of (selector argNumber) where that argument must be a block.
-
- For perform, the selector is tested. It must be in the Approved list.
-
- do: is not on the Approved list. It does not produce a result that can be tested. Type 'do' into the upper pane of the Selector Finder to find messages list that.
-
- [Later, allow the user to supply a block that tests the answer, not just the literal answer.]
- MethodFinder methodFor: { { true. [3]. [4]}. 3}.
- Later allow this to work without the blocks around 3 and 4.!
Item was removed:
- ----- Method: MethodFinder class>>cleanUp: (in category 'class initialization') -----
- cleanUp: aggressive
-
- Approved := nil.
- AddAndRemove := nil.
- Blocks := nil.!
Item was removed:
- ----- Method: MethodFinder class>>methodFor: (in category 'utility') -----
- methodFor: dataAndAnswers
- "Return a Squeak expression that computes these answers. (This method is called by the comment in the bottom pane of a MethodFinder. Do not delete this method.)"
-
- | resultOC resultString |
- resultOC := (self new) load: dataAndAnswers; findMessage.
- resultString := String streamContents: [:strm |
- resultOC do: [:exp | strm nextPut: $(; nextPutAll: exp; nextPut: $); space]].
- ^ resultString!
Item was removed:
- ----- Method: MethodFinder>>allNumbers (in category 'find a constant') -----
- allNumbers
- "Return true if all answers and all data are numbers."
-
- answers do: [:aa | aa isNumber ifFalse: [^ false]].
- thisData do: [:vec |
- vec do: [:nn | nn isNumber ifFalse: [^ false]]].
- ^ true!
Item was removed:
- ----- Method: MethodFinder>>answers (in category 'access') -----
- answers
-
- ^ answers!
Item was removed:
- ----- Method: MethodFinder>>argMap (in category 'arg maps') -----
- argMap
- ^ argMap !
Item was removed:
- ----- Method: MethodFinder>>cleanInputs: (in category 'initialize') -----
- cleanInputs: dataAndAnswerString
- "Find an remove common mistakes. Complain when ill formed."
-
- | fixed ddd rs places |
- ddd := dataAndAnswerString.
- fixed := false.
-
- rs := ReadStream on: ddd, ' '.
- places := OrderedCollection new.
- [rs upToAll: '#true'. rs atEnd] whileFalse: [places addFirst: rs position-4].
- places do: [:pos | ddd := ddd copyReplaceFrom: pos to: pos with: ''.
- fixed := true]. "remove #"
-
- rs := ReadStream on: ddd.
- places := OrderedCollection new.
- [rs upToAll: '#false'. rs atEnd] whileFalse: [places addFirst: rs position-5].
- places do: [:pos | ddd := ddd copyReplaceFrom: pos to: pos with: ''.
- fixed := true]. "remove #"
-
- fixed ifTrue: [self inform: '#(true false) are Symbols, not Booleans.
- Next time use { true. false }.'].
-
- fixed := false.
- rs := ReadStream on: ddd.
- places := OrderedCollection new.
- [rs upToAll: '#nil'. rs atEnd] whileFalse: [places addFirst: rs position-3].
- places do: [:pos | ddd := ddd copyReplaceFrom: pos to: pos with: ''.
- fixed := true]. "remove #"
-
- fixed ifTrue: [self inform: '#nil is a Symbol, not the authentic UndefinedObject.
- Next time use nil instead of #nil'].
-
- ^ ddd
- !
Item was removed:
- ----- Method: MethodFinder>>const (in category 'find a constant') -----
- const
- | const |
- "See if (^ constant) is the answer"
-
- "quick test"
- ((const := answers at: 1) closeTo: (answers at: 2)) ifFalse: [^ false].
- 3 to: answers size do: [:ii | (const closeTo: (answers at: ii)) ifFalse: [^ false]].
- expressions add: '^ ', const printString.
- selector add: #yourself.
- ^ true!
Item was removed:
- ----- Method: MethodFinder>>constDiv (in category 'find a constant') -----
- constDiv
- | const subTest got |
- "See if (data1 // C) is the answer"
-
- const := ((thisData at: 1) at: 1) // (answers at: 1). "May not be right!!"
- got := (subTest := MethodFinder new copy: self addArg: const)
- searchForOne isEmpty not.
- got ifFalse: [^ false].
-
- "replace data2 with const in expressions"
- subTest expressions do: [:exp |
- expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
- selector addAll: subTest selectors.
- ^ true!
Item was removed:
- ----- Method: MethodFinder>>constEquiv (in category 'find a constant') -----
- constEquiv
- | const subTest got jj |
- "See if (data1 = C) or (data1 ~= C) is the answer"
-
- "quick test"
- ((answers at: 1) class superclass == Boolean) ifFalse: [^ false].
- 2 to: answers size do: [:ii |
- ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]].
-
- const := (thisData at: 1) at: 1.
- got := (subTest := MethodFinder new copy: self addArg: const)
- searchForOne isEmpty not.
- got ifFalse: ["try other polarity for ~~ "
- (jj := answers indexOf: (answers at: 1) not) > 0 ifTrue: [
- const := (thisData at: jj) at: 1.
- got := (subTest := MethodFinder new copy: self addArg: const)
- searchForOne isEmpty not]].
- got ifFalse: [^ false].
-
- "replace data2 with const in expressions"
- subTest expressions do: [:exp |
- expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
- selector addAll: subTest selectors.
- ^ true!
Item was removed:
- ----- Method: MethodFinder>>constLinear (in category 'find a constant') -----
- constLinear
- | const subTest got denom num slope offset |
- "See if (data1 * C1) + C2 is the answer. In the form #(C2 C1) polynomialEval: data1 "
-
- denom := ((thisData at: 2) at: 1) - ((thisData at: 1) at: 1).
- denom = 0 ifTrue: [^ false]. "will divide by it"
- num := (answers at: 2) - (answers at: 1).
-
- slope := (num asFloat / denom) reduce.
- offset := ((answers at: 2) - (((thisData at: 2) at: 1) * slope)) reduce.
-
- const := Array with: offset with: slope.
- got := (subTest := MethodFinder new copy: self addArg: const)
- searchForOne isEmpty not.
- got ifFalse: [^ false].
-
- "replace data2 with const in expressions"
- subTest expressions do: [:exp |
- expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
- selector addAll: subTest selectors.
- ^ true!
Item was removed:
- ----- Method: MethodFinder>>constMod (in category 'find a constant') -----
- constMod
- | subTest low |
- "See if mod, (data1 \\ C) is the answer"
-
- low := answers max.
- low+1 to: low+20 do: [:const |
- subTest := MethodFinder new copy: self addArg: const.
- (subTest testPerfect: #\\) ifTrue: [
- expressions add: 'data1 \\ ', const printString.
- selector add: #\\.
- ^ true]].
- ^ false!
Item was removed:
- ----- Method: MethodFinder>>constMult (in category 'find a constant') -----
- constMult
- | const subTest got |
- "See if (data1 * C) is the answer"
-
- ((thisData at: 1) at: 1) = 0 ifTrue: [^ false].
- const := ((answers at: 1) asFloat / ((thisData at: 1) at: 1)) reduce.
- got := (subTest := MethodFinder new copy: self addArg: const)
- searchForOne isEmpty not.
- got ifFalse: [^ false].
-
- "replace data2 with const in expressions"
- subTest expressions do: [:exp |
- expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
- selector addAll: subTest selectors.
- ^ true!
Item was removed:
- ----- Method: MethodFinder>>constPlus (in category 'find a constant') -----
- constPlus
- | const subTest got |
- "See if (data1 + C) is the answer"
-
- const := (answers at: 1) - ((thisData at: 1) at: 1).
- got := (subTest := MethodFinder new copy: self addArg: const)
- searchForOne isEmpty not.
- got ifFalse: [^ false].
-
- "replace data2 with const in expressions"
- subTest expressions do: [:exp |
- expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
- selector addAll: subTest selectors.
- ^ true!
Item was removed:
- ----- Method: MethodFinder>>constUsingData1Value (in category 'find a constant') -----
- constUsingData1Value
- | subTest |
- "See if (data1 <= C) or (data1 >= C) is the answer"
-
- "quick test"
- ((answers at: 1) class superclass == Boolean) ifFalse: [^ false].
- 2 to: answers size do: [:ii |
- ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]].
-
- thisData do: [:datums | | got const |
- const := datums first. "use data as a constant!!"
- got := (subTest := MethodFinder new copy: self addArg: const)
- searchForOne isEmpty not.
- got ifTrue: [
- "replace data2 with const in expressions"
- subTest expressions do: [:exp |
- expressions add: (exp copyReplaceAll: 'data2' with: const printString)].
- selector addAll: subTest selectors.
- ^ true]].
- ^ false!
Item was removed:
- ----- Method: MethodFinder>>copy:addArg: (in category 'initialize') -----
- copy: mthFinder addArg: aConstant
- | more |
- "Copy inputs and answers, add an additional data argument to the inputs. The same constant for every example"
-
- more := Array with: aConstant.
- data := mthFinder data collect: [:argList | argList, more].
- answers := mthFinder answers.
- self load: nil.
- !
Item was removed:
- ----- Method: MethodFinder>>data (in category 'access') -----
- data
-
- ^ data!
Item was removed:
- ----- Method: MethodFinder>>exceptions (in category 'search') -----
- exceptions
- "Handle some very slippery selectors.
- asSymbol -- want to be able to produce it, but do not want to make every string submitted into a Symbol!!"
-
- | aSel |
- answers first isSymbol ifFalse: [^ self].
- thisData first first isString ifFalse: [^ self].
- aSel := #asSymbol.
- (self testPerfect: aSel) ifTrue: [
- selector add: aSel.
- expressions add: (String streamContents: [:strm |
- strm nextPutAll: 'data', argMap first printString.
- aSel keywords withIndexDo: [:key :ind |
- strm nextPutAll: ' ',key.
- (key last == $:) | (key first isLetter not)
- ifTrue: [strm nextPutAll: ' data',
- (argMap at: ind+1) printString]]])].
- !
Item was removed:
- ----- Method: MethodFinder>>expressions (in category 'access') -----
- expressions
- ^ expressions!
Item was removed:
- ----- Method: MethodFinder>>findMessage (in category 'search') -----
- findMessage
- "Control the search."
-
- data do: [:alist |
- (alist isKindOf: SequenceableCollection) ifFalse: [
- ^ OrderedCollection with: 'first and third items are not Arrays']].
- Approved ifNil: [self initialize]. "Sets of allowed selectors"
- expressions := OrderedCollection new.
- self search: true. "multi"
- expressions isEmpty ifTrue: [^ OrderedCollection with: 'no single method does that function'].
- expressions isString ifTrue: [^ OrderedCollection with: expressions].
- ^ expressions!
Item was removed:
- ----- Method: MethodFinder>>initialize (in category 'initialize') -----
- initialize
- "The methods we are allowed to use. (MethodFinder new initialize) "
-
- Approved := Set new.
- AddAndRemove := Set new.
- Blocks := Set new.
- "These modify an argument and are not used by the MethodFinder: longPrintOn: printOn: storeOn: sentTo: storeOn:base: printOn:base: absPrintExactlyOn:base: absPrintOn:base: absPrintOn:base:digitCount: writeOn: writeScanOn: possibleVariablesFor:continuedFrom: printOn:format:"
-
- "Object"
- #("in class, instance creation" categoryForUniclasses chooseUniqueClassName initialInstance isSystemDefined newFrom: officialClass readCarefullyFrom:
- "accessing" at: basicAt: basicSize bindWithTemp: in: size yourself
- "testing" basicType ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isColor isFloat isFraction isInMemory isInteger isMorph isNil isNumber isPoint isText isTransparent isWebBrowser knownName notNil pointsTo: wantsSteps
- "comparing" = == closeTo: hash identityHash identityHashPrintString ~= ~~
- "copying" copy shallowCopy
- "dependents access" canDiscardEdits dependents hasUnacceptedEdits
- "updating" changed changed: okToChange update: windowIsClosing
- "printing" fullPrintString isLiteral longPrintString printString storeString stringForReadout stringRepresentation
- "class membership" class isKindOf: isKindOf:orOf: isMemberOf: respondsTo: xxxClass
- "error handling"
- "user interface" addModelMenuItemsTo:forMorph:hand: defaultLabelForInspector fullScreenSize initialExtent modelWakeUp mouseUpBalk: newTileMorphRepresentative windowActiveOnFirstClick windowReqNewLabel:
- "system primitives" asOop instVarAt: instVarNamed:
- "private"
- "associating" ->
- "converting" as: asOrderedCollection asString
- "casing" caseOf: caseOf:otherwise:
- "binding" bindingOf:
- "macpal" contentsChanged currentEvent currentHand currentWorld flash instanceVariableValues scriptPerformer
- "flagging" flag:
- "translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel].
- #(at:add: at:modify: at:put: basicAt:put: "NOT instVar:at:"
- "message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass:
- ) do: [:sel | AddAndRemove add: sel].
-
- "Boolean, True, False, UndefinedObject"
- #("logical operations" & eqv: not xor: |
- "controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or:
- "copying"
- "testing" isEmptyOrNil) do: [:sel | Approved add: sel].
-
- "Behavior"
- #("initialize-release"
- "accessing" compilerClass decompilerClass evaluatorClass format methodDict parserClass sourceCodeTemplate subclassDefinerClass
- "testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords
- "copying"
- "printing" defaultNameStemForInstances printHierarchy
- "creating class hierarchy"
- "creating method dictionary"
- "instance creation" basicNew basicNew: new new:
- "accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses
- "accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent:
- "accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames
- "testing class hierarchy" inheritsFrom: kindOfSubclass
- "testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichMethodsStoreInto:
- "enumerating"
- "user interface") do: [:sel | Approved add: sel].
-
- "ClassDescription"
- #("initialize-release"
- "accessing" classVersion isMeta name theNonMetaClass
- "copying"
- "printing" classVariablesString instanceVariablesString sharedPoolsString
- "instance variables" checkForInstVarsOK:
- "method dictionary"
- "organization" category organization whichCategoryIncludesSelector:
- "compiling" acceptsLoggingOfCompilation wantsChangeSetLogging
- "fileIn/Out" definition
- "private" ) do: [:sel | Approved add: sel].
-
- "Class"
- #("initialize-release"
- "accessing" classPool
- "testing"
- "copying"
- "class name"
- "instance variables"
- "class variables" classVarAt: classVariableAssociationAt:
- "pool variables"
- "compiling"
- "subclass creation"
- "fileIn/Out" ) do: [:sel | Approved add: sel].
-
- "Metaclass"
- #("initialize-release"
- "accessing" isSystemDefined soleInstance
- "copying" "instance creation" "instance variables" "pool variables" "class hierarchy" "compiling"
- "fileIn/Out" nonTrivial ) do: [:sel | Approved add: sel].
-
- "Context, BlockContext"
- #(receiver client method receiver tempAt:
- "debugger access" pc selector sender shortStack sourceCode tempNames tempsAndValues
- "controlling" "printing" "system simulation"
- "initialize-release"
- "accessing" hasMethodReturn home numArgs
- "evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments:
- "controlling" "scheduling" "instruction decoding" "printing" "private" "system simulation" ) do: [:sel | Approved add: sel].
- #(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel].
-
- "Message"
- #("inclass, instance creation" selector: selector:argument: selector:arguments:
- "accessing" argument argument: arguments sends:
- "printing" "sending" ) do: [:sel | Approved add: sel].
- #("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel].
-
- "Magnitude"
- #("comparing" < <= > >= between:and:
- "testing" max: min: min:max: ) do: [:sel | Approved add: sel].
-
- "Date, Time"
- #("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today
- "in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth:
- "accessing" day leap monthIndex monthName weekday year
- "arithmetic" addDays: subtractDate: subtractDays:
- "comparing"
- "inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous:
- "converting" asSeconds
- "printing" mmddyyyy printFormat:
- "private" weekdayIndex
- "in class, instance creation" fromSeconds: now
- "in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds
- "accessing" hours minutes seconds
- "arithmetic" addTime: subtractTime:
- "comparing"
- "printing" intervalString print24
- "converting") do: [:sel | Approved add: sel].
- #("private"
- ) do: [:sel | AddAndRemove add: sel].
-
- "Number"
- #("in class" readFrom:base:
- "arithmetic" * + - / // \\ abs negated quo: reciprocal rem:
- "mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan
- "truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated
- "comparing"
- "testing" even isDivisibleBy: isInfinite isNaN isZero negative odd positive sign strictlyPositive
- "converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees
- "intervals" to: to:by:
- "printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel].
-
- "Integer"
- #("in class" primesUpTo:
- "testing" isPowerOfTwo
- "arithmetic" alignedTo:
- "comparing"
- "truncation and round off" atRandom normalize
- "enumerating" timesRepeat:
- "mathematical functions" degreeCos degreeSin factorial gcd: lcm: take:
- "bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask:
- "converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit
- "printing" asStringWithCommas hex hex8 radix:
- "system primitives" lastDigit replaceFrom:to:with:startingAt:
- "private" "benchmarks" ) do: [:sel | Approved add: sel].
-
- "SmallInteger, LargeNegativeInteger, LargePositiveInteger"
- #("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing"
- "system primitives" digitAt: digitLength
- "private" fromString:radix: ) do: [:sel | Approved add: sel].
- #(digitAt:put: ) do: [:sel | AddAndRemove add: sel].
-
- "Float"
- #("arithmetic"
- "mathematical functions" reciprocalLogBase2 timesTwoPower:
- "comparing" "testing"
- "truncation and round off" exponent fractionPart integerPart significand significandAsInteger
- "converting" asApproximateFraction asIEEE32BitWord asTrueFraction
- "copying") do: [:sel | Approved add: sel].
-
- "Fraction, Random"
- #(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel].
- #(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel].
-
- "Collection"
- #("accessing" anyOne
- "testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf:
- "enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect: intersection:
- "converting" asBag asCharacterSet asSet asSortedArray asSortedCollection asSortedCollection:
- "printing"
- "private" maxSize
- "arithmetic"
- "math functions" average max median min range sum) do: [:sel | Approved add: sel].
- #("adding" add: addAll: addIfNotPresent:
- "removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel].
-
- "SequenceableCollection"
- #("comparing" hasEqualElements:
- "accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atRandom: atWrap: fifth first fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third
- "removing"
- "copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sorted:
- "enumerating" withIndexCollect: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval:
- "converting" asArray asDictionary asFloat32Array asFloat64Array asIntegerArray asStringWithCr asWordArray reversed
- "private" copyReplaceAll:with:asTokens: ) do: [:sel | Approved add: sel].
- #( swap:with:) do: [:sel | AddAndRemove add: sel].
-
- "ArrayedCollection, Bag"
- #("private" defaultElement
- "sorting" isSorted
- "accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating"
- ) do: [:sel | Approved add: sel].
- #( mergeSortFrom:to:by: sort sort: add: add:withOccurrences:
- "private" setDictionary ) do: [:sel | AddAndRemove add: sel].
-
- "Other messages that modify the receiver"
- #(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with: removeFirst removeLast) do: [:sel | AddAndRemove add: sel].
-
- self initialize2.
-
- "
- MethodFinder new initialize.
- MethodFinder new organizationFiltered: Set
- "
-
- !
Item was removed:
- ----- Method: MethodFinder>>initialize2 (in category 'initialize') -----
- initialize2
- "The methods we are allowed to use. (MethodFinder new initialize) "
-
- "Set"
- #("in class" sizeFor:
- "testing" "adding" "removing" "enumerating"
- "private" array scanFor:
- "accessing" someElement) do: [:sel | Approved add: sel].
-
- "Dictionary, IdentityDictionary, IdentitySet"
- #("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys
- "testing" includesKey: ) do: [:sel | Approved add: sel].
- #(removeKey: removeKey:ifAbsent:
- ) do: [:sel | AddAndRemove add: sel].
-
- "LinkedList, Interval, MappedCollection"
- #("in class" from:to: from:to:by:
- "accessing" contents) do: [:sel | Approved add: sel].
- #(
- "adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel].
-
- "OrderedCollection, SortedCollection"
- #("accessing" after: before:
- "copying" copyEmpty
- "adding" growSize
- "removing" "enumerating" "private"
- "accessing" sortBlock) do: [:sel | Approved add: sel].
- #("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast:
- "removing" removeAt: removeFirst removeLast
- "accessing" sortBlock:) do: [:sel | AddAndRemove add: sel].
-
- "Character"
- #("in class, instance creation" allByteCharacters digitValue: new separators
- "accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab
- "constants" alphabet characterTable
- "accessing" asciiValue digitValue
- "comparing"
- "testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish
- "copying"
- "converting" asIRCLowercase asLowercase asUppercase
- ) do: [:sel | Approved add: sel].
-
- "String"
- #("in class, instance creation" crlf fromPacked:
- "primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: "internet" valueOfHtmlEntity:
- "accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: includesSubstring: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit
- "comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt:
- "copying" copyReplaceTokens:with: padded:to:with:
- "converting" asByteArray asDate asDisplayText asFileName asHtml asLegalSelector asPacked asParagraph asText asTime asUnHtml asUrl asUrlRelativeTo: capitalized compressWithTable: contractTo: correctAgainst: encodeForHTTP initialIntegerOrNil keywords quoted sansPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: withBlanksTrimmed withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits withoutTrailingBlanks
- "displaying" "printing"
- "system primitives" compare:with:collated:
- "Celeste" withCRs
- "internet" decodeMimeHeader decodeQuotedPrintable unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting
- "testing" isAllSeparators lastSpacePosition
- "paragraph support" indentationIfBlank:
- "arithmetic" ) do: [:sel | Approved add: sel].
- #(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel].
-
- "Symbol"
- #("in class, private" hasInterned:ifTrue:
- "access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping:
- "accessing" "comparing" "copying" "converting" "printing"
- "testing" isInfix isKeyword isPvtSelector isUnary) do: [:sel | Approved add: sel].
-
- "Array"
- #("comparing" "converting" evalStrings
- "printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel].
-
- "Array2D"
- #("access" at:at: atCol: atCol:put: atRow: extent extent:fromArray: height width width:height:type:) do: [:sel | Approved add: sel].
- #(at:at:add: at:at:put: atRow:put: ) do: [:sel | AddAndRemove add: sel].
-
- "ByteArray"
- #("accessing" doubleWordAt: wordAt:
- "platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian:
- "converting") do: [:sel | Approved add: sel].
- #(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian:
- ) do: [:sel | AddAndRemove add: sel].
-
- "FloatArray" "Dont know what happens when prims not here"
- false ifTrue: [#("accessing" "arithmetic" *= += -= /=
- "comparing"
- "primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar:
- "primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to:
- "converting" "private" "user interface") do: [:sel | Approved add: sel].
- ].
-
- "IntegerArray, WordArray"
- "RunArray"
- #("in class, instance creation" runs:values: scanFrom:
- "accessing" runLengthAt:
- "adding" "copying"
- "private" runs values) do: [:sel | Approved add: sel].
- #(coalesce repeatLast:ifEmpty: repeatLastIfEmpty:
- ) do: [:sel | AddAndRemove add: sel].
-
- "Stream -- many operations change its state"
- #("testing" atEnd) do: [:sel | Approved add: sel].
- #("accessing" next: nextMatchAll: nextMatchFor: upToEnd
- next:put: nextPut: nextPutAll: "printing" print: printHtml:
- ) do: [:sel | AddAndRemove add: sel].
-
- "PositionableStream"
- #("accessing" contentsOfEntireFile originalContents peek peekFor: "testing"
- "positioning" position ) do: [:sel | Approved add: sel].
- #(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel].
- "Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics. We want to find the messages that convert Streams to other things."
-
- "ReadWriteStream"
- #("file status" closed) do: [:sel | Approved add: sel].
- #("accessing" next: on: ) do: [:sel | AddAndRemove add: sel].
-
- "WriteStream"
- #("in class, instance creation" on:from:to: with: with:from:to:
- ) do: [:sel | Approved add: sel].
- #("positioning" resetToStart
- "character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel].
-
- "LookupKey, Association, Link"
- #("accessing" key nextLink) do: [:sel | Approved add: sel].
- #(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel].
-
- "Point"
- #("in class, instance creation" r:degrees: x:y:
- "accessing" x y "comparing" "arithmetic" "truncation and round off"
- "polar coordinates" degrees r theta
- "point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector
- "converting" asFloatPoint asIntegerPoint corner: extent: rect:
- "transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying"
- "interpolating" interpolateTo:at:) do: [:sel | Approved add: sel].
-
- "Rectangle"
- #("in class, instance creation" center:extent: encompassing: left:right:top:bottom:
- merging: origin:corner: origin:extent:
- "accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight
- "comparing"
- "rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth:
- "testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide
- "truncation and round off"
- "transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying"
- ) do: [:sel | Approved add: sel].
-
- "Color"
- #("in class, instance creation" colorFrom: colorFromPixelValue:depth: fromRgbTriplet: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range:
- "named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow
- "other" colorNames indexedColors pixelScreenForDepth: quickHighLight:
- "access" alpha blue brightness green hue luminance red saturation
- "equality"
- "queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor
- "transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with:
- "groups of shades" darkShades: lightShades: mix:shades: wheel:
- "printing" shortPrintString
- "other" colorForInsets rgbTriplet
- "conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32
- "private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying"
- ) do: [:sel | Approved add: sel].
-
- " For each selector that requires a block argument, add (selector argNum)
- to the set Blocks."
- "ourClasses := #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color).
- ourClasses do: [:clsName | cls := Smalltalk at: clsName.
- (cls selectors) do: [:aSel |
- ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [
- (cls formalParametersAt: aSel) withIndexDo: [:tName :ind |
- (tName endsWith: 'Block') ifTrue: [
- Blocks add: (Array with: aSel with: ind)]]]]].
- "
- #((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1 ) (at:modify: 2 ) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFal
se:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sorted: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (compiledMethodAt:ifAbsent: 2 ) (bindWithTemp: 1 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray |
- Blocks add: anArray].
-
- self initialize3.
-
- "
- MethodFinder new initialize.
- MethodFinder new organizationFiltered: TranslucentColor class
- "
- "Do not forget class messages for each of these classes"
- !
Item was removed:
- ----- Method: MethodFinder>>initialize3 (in category 'initialize') -----
- initialize3
- "additional selectors to consider"
-
- #(asWords threeDigitName ) do: [:sel | Approved add: sel].!
Item was removed:
- ----- Method: MethodFinder>>insertConstants (in category 'search') -----
- insertConstants
- "see if one of several known expressions will do it. C is the constant we discover here."
- "C data1+C data1*C data1//C (data1*C1 + C2) (data1 = C) (data1 ~= C) (data1 <= C) (data1 >= C)
- (data1 mod C)"
-
- thisData size >= 2 ifFalse: [^ false]. "need 2 examples"
- (thisData at: 1) size = 1 ifFalse: [^ false]. "only one arg, data1"
-
- self const ifTrue: [^ true].
- self constUsingData1Value ifTrue: [^ true].
- "(data1 ?? const), where const is one of the values of data1"
- " == ~~ ~= = <= >= "
-
- self allNumbers ifFalse: [^ false].
- self constMod ifTrue: [^ true].
- self constPlus ifTrue: [^ true].
- self constMult ifTrue: [^ true].
- self constDiv ifTrue: [^ true].
- self constLinear ifTrue: [^ true].
- ^ false!
Item was removed:
- ----- Method: MethodFinder>>load: (in category 'initialize') -----
- load: dataWithAnswers
- "Find a function that takes the data and gives the answers. Odd list entries are data for it, even ones are the answers. nil input means data and answers were supplied already."
- " (MethodFinder new) load: #( (4 3) 7 (-10 5) -5 (-3 11) 8);
- findMessage "
-
- dataWithAnswers ifNotNil: [
- data := Array new: dataWithAnswers size // 2.
- 1 to: data size do: [:ii | data at: ii put: (dataWithAnswers at: ii*2-1)].
- answers := Array new: data size.
- 1 to: answers size do: [:ii | answers at: ii put: (dataWithAnswers at: ii*2)]].
- data do: [:list |
- (list isKindOf: SequenceableCollection) ifFalse: [
- ^ self inform: 'first and third items are not Arrays'].
- ].
- argMap := (1 to: data first size) asArray.
- data do: [:list | list size = argMap size ifFalse: [
- self inform: 'data arrays must all be the same size']].
- argMap size > 4 ifTrue: [self inform: 'No more than a receiver and
- three arguments allowed'].
- "Really only test receiver and three args."
- thisData := data copy.
- mapStage := mapList := nil.
- !
Item was removed:
- ----- Method: MethodFinder>>makeAllMaps (in category 'arg maps') -----
- makeAllMaps
- "Make a giant list of all permutations of the args. To find the function, we will try these permutations of the input data. receiver, args."
-
- | ii |
- mapList := Array new: argMap size factorial.
- ii := 1.
- argMap permutationsDo: [:perm |
- mapList at: ii put: perm copy.
- ii := ii + 1].
- mapStage := 1. "about to be bumped"!
Item was removed:
- ----- Method: MethodFinder>>mapData (in category 'arg maps') -----
- mapData
- "Force the data through the map (permutation) to create the data to test."
-
- thisData := data collect: [:realData |
- argMap collect: [:ind | realData at: ind]].
- !
Item was removed:
- ----- Method: MethodFinder>>noteDangerous (in category 'initialize') -----
- noteDangerous
- "Remember the methods with really bad side effects."
-
- Dangerous := Set new.
- "Object accessing, testing, copying, dependent access, macpal, flagging"
- #(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit)
- do: [:sel | Dangerous add: sel].
-
- "Object error handling"
- #(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility)
- do: [:sel | Dangerous add: sel].
-
- "Object user interface"
- #(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement )
- do: [:sel | Dangerous add: sel].
-
- "Object system primitives"
- #(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:)
- do: [:sel | Dangerous add: sel].
-
- "Object private"
- #(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:)
- do: [:sel | Dangerous add: sel].
-
- "Object, translation support"
- #(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:)
- do: [:sel | Dangerous add: sel].
-
- "Object, objects from disk, finalization. And UndefinedObject"
- #(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until: suspend)
- do: [:sel | Dangerous add: sel].
-
- "No Restrictions: Boolean, False, True, "
-
- "Morph"
- #()
- do: [:sel | Dangerous add: sel].
-
- "Behavior"
- #(obsolete confirmRemovalOf: copyOfMethodDictionary storeLiteral:on: addSubclass: removeSubclass: superclass:
- "creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo:
- "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables
- "private" flushCache format:variable:words:pointers: format:variable:words:pointers:weak: format:variable:bitsUnitSize:pointers:weak: printSubclassesOn:level: basicRemoveSelector: addSelector:withMethod:notifying: addSelectorSilently:withMethod:)
- do: [:sel | Dangerous add: sel].
-
- "CompiledMethod"
- #(defaultSelector)
- do: [:sel | Dangerous add: sel].
-
- "Others "
- #("no tangible result" do: associationsDo:
- "private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser)
- do: [:sel | Dangerous add: sel].
-
-
- #( fileOutPrototype addSpareFields makeFileOutFile )
- do: [:sel | Dangerous add: sel].
- #(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: instanceVariableNames: )
- do: [:sel | Dangerous add: sel].
-
- !
Item was removed:
- ----- Method: MethodFinder>>organizationFiltered: (in category 'initialize') -----
- organizationFiltered: aClass
- "Return the organization of the class with all selectors defined in superclasses removed. (except those in Object)"
-
- | org str |
- org := aClass organization deepCopy.
- Dangerous do: [:sel |
- org removeElement: sel].
- Approved do: [:sel |
- org removeElement: sel].
- AddAndRemove do: [:sel |
- org removeElement: sel].
- str := org printString copyWithout: $(.
- str := '(', (str copyWithout: $) ).
- str := str replaceAll: $' with: $".
- ^ str
- !
Item was removed:
- ----- Method: MethodFinder>>permuteArgs (in category 'arg maps') -----
- permuteArgs
- "Run through ALL the permutations. First one was as presented."
-
- data first size <= 1 ifTrue: [^ false]. "no other way"
- mapList ifNil: [self makeAllMaps].
- mapStage := mapStage + 1.
- mapStage > mapList size ifTrue: [^ false].
- argMap := mapList at: mapStage.
- self mapData.
- ^ true
- !
Item was removed:
- ----- Method: MethodFinder>>search: (in category 'search') -----
- search: multi
- "if Multi is true, collect all selectors that work."
- selector := OrderedCollection new. "list of them"
- self simpleSearch.
- multi not & (selector isEmpty not) ifTrue:[^ selector].
-
- [self permuteArgs] whileTrue:
- [self simpleSearch.
- multi not & (selector isEmpty not) ifTrue: [^ selector]].
-
- self insertConstants.
- "(selector isEmpty not) ifTrue: [^ selector]]. expression is the answer, not a selector"
- ^ #()!
Item was removed:
- ----- Method: MethodFinder>>searchForOne (in category 'search') -----
- searchForOne
- "Look for and return just one answer"
-
- expressions := OrderedCollection new.
- self search: false. "non-multi"
- ^ expressions
- !
Item was removed:
- ----- Method: MethodFinder>>selectors (in category 'access') -----
- selectors
- "Note the inst var does not have an S on the end"
-
- ^ selector!
Item was removed:
- ----- Method: MethodFinder>>simpleSearch (in category 'search') -----
- simpleSearch
- "Run through first arg's class' selectors, looking for one that works."
-
- | class supers listOfLists |
- self exceptions.
- class := thisData first first class.
- "Cache the selectors for the receiver class"
- (class == cachedClass and: [cachedArgNum = ((argMap size) - 1)])
- ifTrue: [listOfLists := cachedSelectorLists]
- ifFalse: [supers := class withAllSuperclasses.
- listOfLists := OrderedCollection new.
- supers do: [:cls |
- listOfLists add: (cls selectorsWithArgs: (argMap size) - 1)].
- cachedClass := class.
- cachedArgNum := (argMap size) - 1.
- cachedSelectorLists := listOfLists].
- listOfLists do: [:selectorList |
- selectorList do: [:aSel |
- (selector includes: aSel) ifFalse: [
- ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [
- (self testPerfect: aSel) ifTrue: [
- selector add: aSel.
- expressions add: (String streamContents: [:strm |
- strm nextPutAll: 'data', argMap first printString.
- aSel keywords withIndexDo: [:key :ind |
- strm nextPutAll: ' ',key.
- (key last == $:) | (key first isLetter not)
- ifTrue: [strm nextPutAll: ' data',
- (argMap at: ind+1) printString]]])
- ]]]]].
- !
Item was removed:
- ----- Method: MethodFinder>>test2: (in category 'initialize') -----
- test2: anArray
- "look for bad association"
-
- anArray do: [:sub |
- sub class == Association ifTrue: [
- (#('true' '$a' '2' 'false') includes: sub value printString) ifFalse: [
- self error: 'bad assn'].
- (#('3' '5.6' 'x' '''abcd''') includes: sub key printString) ifFalse: [
- self error: 'bad assn'].
- ].
- sub class == Array ifTrue: [
- sub do: [:element |
- element isString ifTrue: [element first asciiValue < 32 ifTrue: [
- self error: 'store into string in data']].
- element class == Association ifTrue: [
- element value class == Association ifTrue: [
- self error: 'bad assn']]]].
- sub class == Date ifTrue: [sub year isInteger ifFalse: [
- self error: 'stored into input date!!!!']].
- sub class == Dictionary ifTrue: [
- sub size > 0 ifTrue: [
- self error: 'store into dictionary']].
- sub class == OrderedCollection ifTrue: [
- sub size > 4 ifTrue: [
- self error: 'store into OC']].
- ].!
Item was removed:
- ----- Method: MethodFinder>>test3 (in category 'initialize') -----
- test3
- "find the modification of the caracter table"
-
- (#x at: 1) asciiValue = 120 ifFalse: [self error: 'Character table mod'].!
Item was removed:
- ----- Method: MethodFinder>>testFromTuple: (in category 'initialize') -----
- testFromTuple: nth
- "verify that the methods allowed don't crash the system. Try N of each of the fundamental types. up to 4 of each kind."
-
- | objects nonRepeating even other aa cnt |
- objects := #((1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four')
- (x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3)
- ).
-
- objects := objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}.
- {Point class. SmallInteger class. Association class. Array class}.
- "{ 4 blocks }."
- {Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}.
- {'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}.
- {Dictionary new. Dictionary new. Dictionary new. Dictionary new}.
- {#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection.
- #($a 3 d) asOrderedCollection. #() asOrderedCollection}.
- {3 -> true. 5.6 -> $a. #x -> 2. 'abcd' -> false}.
- {9 @ 3 extent: 5 @ 4. 0 @ 0 extent: 45 @ 9. -3 @ -7 extent: 2 @ 2. 4 @ 4 extent: 16 @ 16}.
- {Color red. Color blue. Color black. Color gray}}.
-
- self test2: objects.
- "rec+0, rec+1, rec+2, rec+3 need to be tested. "
- cnt := 0.
- nth to: 4 do: [:take |
- nonRepeating := OrderedCollection new.
- objects do: [:each |
- nonRepeating addAll: (each copyFrom: 1 to: take)].
- "all combinations of take, from nonRepeating"
- even := true.
- nonRepeating combinations: take atATimeDo: [:tuple |
- even ifTrue: [other := tuple shallowCopy]
- ifFalse: [self load: (aa := Array with: tuple with: 1 with: other with: 7).
- (cnt := cnt + 1) \\ 50 = 0 ifTrue: [
- Transcript cr; show: aa first printString].
- self search: true.
- self test2: aa.
- self test2: nonRepeating.
- "self test2: objects"].
- even := even not].
- ].!
Item was removed:
- ----- Method: MethodFinder>>testPerfect: (in category 'search') -----
- testPerfect: aSelector
- "Try this selector!! Return true if it answers every example perfectly. Take the args in the order they are. Do not permute them. Survive errors. later cache arg lists."
-
- | sz argList val rec activeSel perform |
- "Transcript cr; show: aSelector. debug"
- perform := aSelector beginsWith: 'perform:'.
- sz := argMap size.
- 1 to: thisData size do: [:ii | "each example set of args"
- argList := (thisData at: ii) copyFrom: 2 to: sz.
- perform
- ifFalse: [activeSel := aSelector]
- ifTrue: [activeSel := argList first. "what will be performed"
- ((Approved includes: activeSel) or: [AddAndRemove includes: activeSel])
- ifFalse: [^ false]. "not approved"
- aSelector == #perform:withArguments:
- ifTrue: [activeSel numArgs = (argList at: 2) basicSize "avoid error"
- ifFalse: [^ false]]
- ifFalse: [activeSel numArgs = (aSelector numArgs - 1)
- ifFalse: [^ false]]].
- 1 to: sz do: [:num |
- (Blocks includes: (Array with: activeSel with: num)) ifTrue: [
- (argList at: num) isBlock ifFalse: [^ false]]].
- rec := (AddAndRemove includes: activeSel)
- ifTrue: [(thisData at: ii) first isSymbol ifTrue: [^ false].
- "vulnerable to modification"
- (thisData at: ii) first copyTwoLevel] "protect from damage"
- ifFalse: [(thisData at: ii) first].
- val := [[rec perform: aSelector withArguments: argList]
- on: Deprecation do: [ :ex | ex resume ]]
- ifError: [:aString :aReceiver |
- "self test3."
- "self test2: (thisData at: ii)."
- ^ false].
- "self test3."
- "self test2: (thisData at: ii)."
- ((answers at: ii) closeTo: val) ifFalse: [^ false].
- ].
- ^ true!
Item was removed:
- ----- Method: MethodFinder>>testRandom (in category 'initialize') -----
- testRandom
- "verify that the methods allowed don't crash the system. Pick 3 or 4 from a mixed list of the fundamental types."
-
- | objects other aa cnt take tuple fName sss random |
- objects := #(
- (1 4 17 42) ($a $b $c $d) ('one' 'two' 'three' 'four')
- (x + rect: new) ((a b 1 4) (c 1 5) ($a 3 d) ()) (4.5 0.0 3.2 100.3)
- ).
-
- objects := objects, {{true. false. true. false}. {Point. SmallInteger. Association. Array}.
- {Point class. SmallInteger class. Association class. Array class}.
- "{ 4 blocks }."
- {Date today. '1 Jan 1950' asDate. '25 Aug 1987' asDate. '1 Jan 2000' asDate}.
- {'15:16' asTime. '1:56' asTime. '4:01' asTime. '6:23' asTime}.
- {Dictionary new. Dictionary new. Dictionary new. Dictionary new}.
- {#(a b 1 4) asOrderedCollection. #(c 1 5) asOrderedCollection.
- #($a 3 d) asOrderedCollection. #() asOrderedCollection}.
- {3 -> true. 5.6 -> $a. #x -> 2. 'abcd' -> false}.
- {9 @ 3 extent: 5 @ 4. 0 @ 0 extent: 45 @ 9. -3 @ -7 extent: 2 @ 2. 4 @ 4 extent: 16 @ 16}.
- {Color red. Color blue. Color black. Color gray}}.
-
- self test2: objects.
- "rec+0, rec+1, rec+2, rec+3 need to be tested. "
- fName := (FileDirectory default fileNamesMatching: '*.ran') first.
- sss := fName splitInteger first.
- random := Random seed: sss.
- cnt := 0.
-
- [take := #(3 4) atRandom: random.
- tuple := (1 to: take) collect: [:ind | (objects atRandom: random) atRandom: random].
- other := (1 to: take) collect: [:ind | (objects atRandom: random) atRandom: random].
- self load: (aa := Array with: tuple with: 1 with: other with: 7).
- ((cnt := cnt + 1) \\ 10 = 0) " | (cnt > Skip)" ifTrue:
- [Transcript cr; show: cnt printString; tab; tab; show: aa first printString].
- cnt > (Smalltalk at: #StopHere) ifTrue: [self halt]. "stop just before crash"
- cnt > (Smalltalk at: #Skip)
- ifTrue:
- ["skip this many at start"
- self search: true.
- self test2: aa first. self test2: (aa at: 3).
- "self test2: objects"]] repeat.
- !
Item was removed:
- ----- Method: MethodFinder>>thisData (in category 'arg maps') -----
- thisData
- ^ thisData !
Item was removed:
- ----- Method: MethodFinder>>verify (in category 'initialize') -----
- verify
- "Test a bunch of examples"
- " MethodFinder new verify "
- Approved ifNil: [self initialize]. "Sets of allowed selectors"
- (MethodFinder new load: #( (0) 0 (30) 0.5 (45) 0.707106 (90) 1)
- ) searchForOne asArray = #('data1 degreeSin') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: { { true. [3]. [4]}. 3. { false. [0]. [6]}. 6}
- ) searchForOne asArray = #('data1 ifTrue: data2 ifFalse: data3') ifFalse: [
- self error: 'should have found it'].
- (MethodFinder new load: {#(1). true. #(2). false. #(5). true. #(10). false}
- ) searchForOne asArray = #('data1 odd') ifFalse: [self error: 'should have found it'].
- "will correct the date type of #true, and complain"
- (MethodFinder new load: #((4 2) '2r100' (255 16) '16rFF' (14 8) '8r16')
- ) searchForOne asArray =
- #('data1 radix: data2' 'data1 printStringBase: data2' 'data1 storeStringBase: data2')
- ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: {{Point x: 3 y: 4}. 4. {Point x: 1 y: 5}. 5}
- ) searchForOne asArray = #('data1 y') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #(('abcd') $a ('TedK') $T)
- ) searchForOne asArray = #('data1 asCharacter' 'data1 first' 'data1 anyOne')
- ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #(('abcd' 1) $a ('Ted ' 3) $d )
- ) searchForOne asArray = #('data1 at: data2' 'data1 atPin: data2' 'data1 atWrap: data2')
- ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #(((12 4 8)) 24 ((1 3 6)) 10 )
- ) searchForOne asArray= #('data1 sum') ifFalse: [self error: 'should have found it'].
- "note extra () needed for an Array object as an argument"
-
- (MethodFinder new load: #((14 3) 11 (-10 5) -15 (4 -3) 7)
- ) searchForOne asArray = #('data1 - data2') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #((4) 4 (-10) 10 (-3) 3 (2) 2 (-6) 6 (612) 612)
- ) searchForOne asArray = #('data1 abs') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: {#(4 3). true. #(-7 3). false. #(5 1). true. #(5 5). false}
- ) searchForOne asArray = #('data1 > data2') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #((5) 0.2 (2) 0.5)
- ) searchForOne asArray = #('data1 reciprocal') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #((12 4 8) 2 (1 3 6) 2 (5 2 16) 8)
- ) searchForOne asArray = #() " '(data3 / data2) ' want to be able to leave out args"
- ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #((0.0) 0.0 (1.5) 0.997495 (0.75) 0.681639)
- ) searchForOne asArray = #('data1 sin') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #((7 5) 2 (4 5) 4 (-9 4) 3)
- ) searchForOne asArray = #('data1 \\ data2') ifFalse: [self error: 'should have found it'].
-
- (MethodFinder new load: #((7) 2 (4) 2 )
- ) searchForOne asArray = #('^ 2') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: {#(7). true. #(4.1). true. #(1.5). false}
- ) searchForOne asArray = #('data1 >= 4.1') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #((35) 3 (17) 1 (5) 5)
- ) searchForOne asArray = #('data1 \\ 8') ifFalse: [self error: 'should have found it'].
- (MethodFinder new load: #((36) 7 (50) 10 )
- ) searchForOne asArray = #('data1 quo: 5' 'data1 // 5') ifFalse: [
- self error: 'should have found it'].
- (MethodFinder new load: #( ((2 3) 2) 8 ((2 3) 5) 17 )
- ) searchForOne asArray = #('data1 polynomialEval: data2') ifFalse: [
- self error: 'should have found it'].
- (MethodFinder new load: #((2) 8 (5) 17 )
- ) searchForOne asArray = #('#(2 3) polynomialEval: data1') ifFalse: [
- self error: 'should have found it'].
- !
Item was removed:
- CodeHolder subclass: #MethodHolder
- instanceVariableNames: 'methodClass methodSelector'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Base'!
Item was removed:
- ----- Method: MethodHolder>>addModelMenuItemsTo:forMorph:hand: (in category 'menu') -----
- addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph
- aCustomMenu addLine.
- aCustomMenu add: 'whose script is this?' translated target: self action: #identifyScript
- !
Item was removed:
- ----- Method: MethodHolder>>changeMethodSelectorTo: (in category 'miscellaneous') -----
- changeMethodSelectorTo: aSelector
- "Change my method selector as noted. Reset currentCompiledMethod"
-
- methodSelector := aSelector.
- currentCompiledMethod := methodClass compiledMethodAt: aSelector ifAbsent: [nil]!
Item was removed:
- ----- Method: MethodHolder>>compiledMethod (in category 'miscellaneous') -----
- compiledMethod
-
- ^ methodClass compiledMethodAt: methodSelector!
Item was removed:
- ----- Method: MethodHolder>>contents (in category 'contents') -----
- contents
- "Answer the contents, with due respect for my contentsSymbol"
-
- contents := methodClass sourceCodeAt: methodSelector ifAbsent: [''].
- currentCompiledMethod := methodClass compiledMethodAt: methodSelector ifAbsent: [nil].
-
- self showingDecompile ifTrue: [^ self decompiledSourceIntoContents].
- self showingDocumentation ifTrue: [^ self commentContents].
- ^ contents := self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: methodClass!
Item was removed:
- ----- Method: MethodHolder>>contents:notifying: (in category 'contents') -----
- contents: input notifying: aController
- | selector |
- (selector := methodClass newParser parseSelector: input asText) ifNil:
- [self inform: 'Sorry - invalid format for the
- method name and arguments -- cannot accept.'.
- ^ false].
-
- selector == methodSelector ifFalse:
- [self inform:
- 'You cannot change the name of
- the method here -- it must continue
- to be ', methodSelector.
- ^ false].
-
- selector := methodClass
- compile: input asText
- classified: self selectedMessageCategoryName
- notifying: aController.
- selector == nil ifTrue: [^ false].
- contents := input asString copy.
- currentCompiledMethod := methodClass compiledMethodAt: methodSelector.
- ^ true!
Item was removed:
- ----- Method: MethodHolder>>identifyScript (in category 'miscellaneous') -----
- identifyScript
- | msg aPlayer |
- msg := methodClass isUniClass
- ifTrue:
- [aPlayer := methodClass someInstance.
- aPlayer costume
- ifNotNil:
- ['This holds code for a script
- named ', methodSelector, ' belonging
- to an object named ', aPlayer externalName]
- ifNil:
- ['This formerly held code for a script
- named ', methodSelector, ' for a Player
- who once existed but now is moribund.']]
- ifFalse:
- ['This holds code for the method
- named ', methodSelector, '
- for class ', methodClass name].
- self inform: msg!
Item was removed:
- ----- Method: MethodHolder>>methodClass:methodSelector: (in category 'miscellaneous') -----
- methodClass: aClass methodSelector: aSelector
- methodClass := aClass.
- methodSelector := aSelector.
- currentCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [nil]!
Item was removed:
- ----- Method: MethodHolder>>selectedClass (in category 'selection') -----
- selectedClass
- ^ methodClass theNonMetaClass!
Item was removed:
- ----- Method: MethodHolder>>selectedClassOrMetaClass (in category 'selection') -----
- selectedClassOrMetaClass
- ^ methodClass!
Item was removed:
- ----- Method: MethodHolder>>selectedMessageCategoryName (in category 'selection') -----
- selectedMessageCategoryName
- ^ methodClass organization categoryOfElement: methodSelector!
Item was removed:
- ----- Method: MethodHolder>>selectedMessageName (in category 'selection') -----
- selectedMessageName
- ^ methodSelector!
Item was removed:
- ----- Method: MethodHolder>>versions (in category 'miscellaneous') -----
- versions
- "Return a VersionsBrowser (containing a list of ChangeRecords) of older versions of this method."
-
- ^ VersionsBrowser new scanVersionsOf: self compiledMethod
- class: self selectedClass
- meta: methodClass isMeta
- category: self selectedMessageCategoryName
- "(classOfMethod whichCategoryIncludesSelector: selectorOfMethod)"
- selector: methodSelector!
Item was removed:
- ----- Method: MethodReference>>browse (in category '*Tools-Browsing') -----
- browse
-
- ^ ToolSet browse: self actualClass selector: self selector!
Item was removed:
- ----- Method: Model>>addItem: (in category '*Tools') -----
- addItem: classAndMethod
- "Open a browser directly on the given class and method
-
- Model new addItem: 'Model addItem:'
- Model new addItem: 'Model>>addItem:'
- "
-
- self flag: #mref. "classAndMethod is a String"
- MessageSet
- parse: classAndMethod
- toClassAndSelector: [ :class :sel |
- class ifNil: [^self].
- sel = #Comment ifTrue: [^ Browser fullOnClassComment: class].
- sel = #Definition ifTrue: [^ Browser newOnClass: class].
- sel = #Hierarchy ifTrue: [^ HierarchyBrowser fullOnClass: class].
- sel = #Help ifTrue: [^HelpBrowser openOn: class].
- Browser newOnClass: class selector: sel
- ]
-
- !
Item was removed:
- ----- Method: Model>>anyTextPaneWithSelector: (in category '*Tools') -----
- anyTextPaneWithSelector: aSelector
- "Try to find the text pane for aSelector in my dependents or my window. Note that this is a hack only and violates the original idea of the model-view pattern. Usually, the communication should come from the view instead, e.g., via a pluggable selector."
-
- ^ (self dependentTextPaneWithSelector: aSelector)
- ifNil: [self textMorphWithSelector: aSelector]!
Item was removed:
- ----- Method: Model>>arrowKey:from: (in category '*Tools-keyboard') -----
- arrowKey: aChar from: view
- "backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys."
- ^false!
Item was removed:
- ----- Method: Model>>buildMenu:withBuilders:shifted: (in category '*Tools-pluggable menus') -----
- buildMenu: aMenu withBuilders: builders shifted: aBoolean
- " We let every builder modify the menu. Skip erroneous builders silently.
- The builder should indicate whether to abort by returning nil."
- | menu |
- menu := aMenu.
- builders do: [:builder | | buildBlock |
- buildBlock := [menu := self perform: builder method selector withEnoughArguments: {menu . aBoolean}].
- buildBlock
- on: Error, Warning, Halt do: [:ex |
- menu add: ('<menu builder failed: {1}>' translated format: {ex}) action: buildBlock]].
- ^ menu!
Item was removed:
- ----- Method: Model>>cleanFileNameForSave: (in category '*Tools-file out') -----
- cleanFileNameForSave: aString
- "Removes selected decoration (i.e., leader+trailer) of aString. This decoration usually comes from window titles and the desire to reuse those titles as a file name.
- NOTE THAT if only the decoration's leader matches, any existing file extension will be removed.
- NOTE THAT if no decoration matches, the '.text' extension is appended if there is none.
- SEE #defaultFileNameForSave."
-
- | cleanFileName |
- self flag: #discuss. "mt: Rename 'save' to 'fileOut'?"
- cleanFileName := aString.
-
- #( " 'leader' 'trailer' "
- 'Decompressed contents of: ' '.gz'
- "Add more here..."
- ) groupsDo: [:leader :trailer |
- self flag: #discuss. "mt: Maybe extract this feature into String and Text? See #withoutLeading* and #withoutTrailing*."
- (cleanFileName beginsWith: leader) ifTrue: [
- cleanFileName := cleanFileName allButFirst: leader size.
- (cleanFileName endsWith: trailer)
- ifTrue: [cleanFileName := cleanFileName allButLast: trailer size]
- ifFalse: [
- | lastIndex |
- lastIndex := cleanFileName lastIndexOf: $. ifAbsent: [0].
- lastIndex > 1 ifTrue: [
- cleanFileName := cleanFileName copyFrom: 1 to: lastIndex - 1]] ]].
-
- (cleanFileName = aString and: [(cleanFileName includes: $.) not])
- ifTrue: [cleanFileName := cleanFileName, '.text'].
-
- ^ cleanFileName!
Item was removed:
- ----- Method: Model>>defaultFileNameForSave (in category '*Tools-file out') -----
- defaultFileNameForSave
- "Answer a label that should be used as a file name when saving the receivers textual contents to disk. Note that the answer can also be a relative or absolute file path."
-
- self flag: #discuss. "mt: Rename 'save' to 'fileOut'?"
- ^ self containingWindow
- ifNil: ['Untitled']
- ifNotNil: [:window | window label]!
Item was removed:
- ----- Method: Model>>dependentTextPaneWithSelector: (in category '*Tools-private') -----
- dependentTextPaneWithSelector: selector
-
- ^ self dependents
- detect: [:dependent | dependent isTextView and:
- [dependent getTextSelector == selector]]
- ifNone: [nil]!
Item was removed:
- ----- Method: Model>>environment (in category '*Tools') -----
- environment
- ^ (self selectedClass ifNil: [self class]) environment!
Item was removed:
- ----- Method: Model>>menu:for: (in category '*Tools-pluggable menus') -----
- menu: aMenu for: aMenuSymbolOrCollection
-
- ^ self menu: aMenu for: aMenuSymbolOrCollection shifted: false!
Item was removed:
- ----- Method: Model>>menu:for:shifted: (in category '*Tools-pluggable menus') -----
- menu: aMenu for: aMenuSymbolOrCollection shifted: aBoolean
-
- | builders |
- builders := self menuBuildersFor: aMenuSymbolOrCollection in: self class shifted: aBoolean.
- builders := self sortMenuBuilders: builders.
- ^ self buildMenu: aMenu withBuilders: builders shifted: aBoolean
- !
Item was removed:
- ----- Method: Model>>menuBuildersFor:in:shifted: (in category '*Tools-pluggable menus') -----
- menuBuildersFor: someMenus in: aClass shifted: aBoolean
- "Find all builders but reject the ones not matching the shift state "
- | pragmas |
- pragmas := (self menuPragmasFor: someMenus in: aClass) .
- ^ aBoolean
- ifTrue: [pragmas reject: [:builder | builder arguments = #(false)]]
- ifFalse: [pragmas reject: [:builder | builder arguments = #(true)]].
- !
Item was removed:
- ----- Method: Model>>menuPragmasFor:in: (in category '*Tools-pluggable menus') -----
- menuPragmasFor: aMenuSymbolOrCollection in: aClass
-
- ^ aMenuSymbolOrCollection isSymbol
- ifFalse: [aMenuSymbolOrCollection gather: [:aMenuSymbol |
- Pragma allNamed: aMenuSymbol from: aClass to: Object]]
- ifTrue: [Pragma allNamed: aMenuSymbolOrCollection from: aClass to: Object]!
Item was removed:
- ----- Method: Model>>methodMenuPriority: (in category '*Tools-pluggable menus') -----
- methodMenuPriority: aMethod
- "The pirority of a menu method indicated by a <menuPriority: ...> pragma.
- Defaults to 500"
- ^ (aMethod pragmas detect: [:p | p keyword == #menuPriority: ] ifNone: [^ 500])
- argumentAt: 1
- !
Item was removed:
- ----- Method: Model>>saveContents: (in category '*Tools-file out') -----
- saveContents: stringContents
- "Interactive. See #saveContents:accessMode:."
-
- ^ self
- saveContents: stringContents
- accessMode: #create!
Item was removed:
- ----- Method: Model>>saveContents:accessMode: (in category '*Tools-file out') -----
- saveContents: stringContents accessMode: accessMode
- "Interactive callback from TextEditor. Ask the user for a file name/path, suggesting a (cleaned-up) default name to accept. Answers whether the save request was successful."
-
- ^ (Project uiManager
- saveFilenameRequest: 'Save text contents in file...' translated
- initialAnswer: self suggestedFileNameForSave)
- ifNil: [false] ifNotNil: [:answer | answer ifEmpty: [false]
- ifNotEmpty: [:fileName |
- self
- saveContents: stringContents
- onFileNamed: fileName
- accessMode: accessMode]].!
Item was removed:
- ----- Method: Model>>saveContents:onFileNamed:accessMode: (in category '*Tools-file out') -----
- saveContents: stringContents onFileNamed: fileName accessMode: accessMode
-
- ^ self
- saveContents: stringContents
- onFileNamed: fileName
- accessMode: accessMode
- workBlock: [:fileStream | fileStream nextPutAll: stringContents]!
Item was removed:
- ----- Method: Model>>saveContents:onFileNamed:accessMode:workBlock: (in category '*Tools-file out') -----
- saveContents: stringContents onFileNamed: fileName accessMode: accessMode workBlock: workBlock
- "Save stringContents on fileName. Answers whether the save request was successful. On success, fileName will exist, including any new directories in the relative/absolute path.
-
- accessMode
- #create ... Prompt the user if file exists.
- #update ... Replace all contents if file exists.
- #append ... Append new contents if file exists."
-
- (FileDirectory default on: fileName) containingDirectory assureExistence.
- accessMode caseOf: {
- [#create] -> [FileStream newFileNamed: fileName do: workBlock].
- [#update] -> [FileStream forceNewFileNamed: fileName do: workBlock].
- [#append] -> [FileStream fileNamed: fileName do: [:s | s setToEnd. workBlock value: s]] }
- otherwise: [
- self error: ('Unknown file access mode: {1}' translated format: {accessMode printString}).
- ^ false].
-
- Transcript showln: ('{1} contents saved (via {2}) to: {3}' format: { self class. accessMode printString. fileName }).
- ^ true!
Item was removed:
- ----- Method: Model>>selectedClass (in category '*Tools') -----
- selectedClass
- "All owners of TextViews are asked this during a doIt"
- ^ nil!
Item was removed:
- ----- Method: Model>>sortMenuBuilders: (in category '*Tools-pluggable menus') -----
- sortMenuBuilders: builders
- " Sort them by
- 1. Priority (default 500)
- 2. selector name
- "
- ^ builders sorted: [:a :b |
- | ma mb pa pb |
- ma := a method.
- mb := b method.
- pa := self methodMenuPriority: ma.
- pb := self methodMenuPriority: mb.
- pa < pb or: [pa = pb and: [ma selector <= mb selector]]]
- !
Item was removed:
- ----- Method: Model>>spawn: (in category '*Tools') -----
- spawn: contentsString
-
- UIManager default edit: contentsString label: nil!
Item was removed:
- ----- Method: Model>>suggestedFileNameForSave (in category '*Tools-file out') -----
- suggestedFileNameForSave
-
- ^ self cleanFileNameForSave: self defaultFileNameForSave!
Item was removed:
- ----- Method: Model>>textMorphWithSelector: (in category '*Tools-private') -----
- textMorphWithSelector: aSelector
- "If, among my window's paneMorphs, there is a text pane defined with aSelector as its retriever, answer it, else answer nil. Morphic only."
-
- | aWindow |
- Smalltalk isMorphic ifFalse: [^ nil].
- ^ (aWindow := self containingWindow) ifNotNil:
- [aWindow paneMorphSatisfying:
- [:aMorph | (aMorph isKindOf: PluggableTextMorph) and:
- [aMorph getTextSelector == aSelector]]]!
Item was removed:
- ----- Method: Model>>trash (in category '*Tools-menus') -----
- trash
- "What should be displayed if a trash pane is restored to initial state"
-
- ^ ''!
Item was removed:
- ----- Method: Model>>trash: (in category '*Tools-menus') -----
- trash: ignored
- "Whatever the user submits to the trash, it need not be saved."
-
- ^ true!
Item was removed:
- ----- Method: Morph class>>toolIcon (in category '*Tools-icons') -----
- toolIcon
-
- ^ #morph!
Item was removed:
- ----- Method: Number>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Number'!
Item was removed:
- ----- Method: Object>>basicInspect (in category '*Tools-Inspector') -----
- basicInspect
- "Create and schedule an Inspector in which the user can examine the
- receiver's variables. This method should not be overriden."
- ToolSet basicInspect: self!
Item was removed:
- ----- Method: Object>>browse (in category '*Tools-Browsing') -----
- browse
- ToolSet browseClass: self class!
Item was removed:
- ----- Method: Object>>browseAllCallsOn: (in category '*Tools-MessageSets') -----
- browseAllCallsOn: selectorSymbol
- "A tool's widget/view (i.e., 'requestor') requested to browse the calls on selectorSymbol. By default, let #systemNavigation handle it."
-
- self flag: #todo. "mt: Push down to Model but check non-Model tools such as TranscriptStream."
- self systemNavigation browseAllCallsOn: selectorSymbol!
Item was removed:
- ----- Method: Object>>browseAllCallsOn:requestor: (in category '*Tools-MessageSets') -----
- browseAllCallsOn: selectorSymbol requestor: anObject
- "A tool's widget/view (i.e., 'requestor') requested to browse the calls on selectorSymbol. By default, let #systemNavigation handle it."
-
- self flag: #todo. "mt: Push down to Model but check non-Model tools such as TranscriptStream."
- self browseAllCallsOn: selectorSymbol!
Item was removed:
- ----- Method: Object>>browseAllImplementorsOf: (in category '*Tools-MessageSets') -----
- browseAllImplementorsOf: selectorSymbol
- "A tool's widget/view (i.e., 'requestor') requested to browse the implementors of selectorSymbol. By default, let #systemNavigation handle it."
-
- self flag: #todo. "mt: Push down to Model but check non-Model tools such as TranscriptStream."
- self systemNavigation browseAllImplementorsOf: selectorSymbol.!
Item was removed:
- ----- Method: Object>>browseAllImplementorsOf:requestor: (in category '*Tools-MessageSets') -----
- browseAllImplementorsOf: selectorSymbol requestor: anObject
- "A tool's widget/view (i.e., 'requestor') requested to browse the implementors of selectorSymbol. By default, let #systemNavigation handle it."
-
- self flag: #todo. "mt: Push down to Model but check non-Model tools such as TranscriptStream."
- self browseAllImplementorsOf: selectorSymbol.!
Item was removed:
- ----- Method: Object>>browseHierarchy (in category '*tools-browser') -----
- browseHierarchy
- self systemNavigation browseHierarchy: self class!
Item was removed:
- ----- Method: Object>>canHaveUnacceptedEdits (in category '*Tools-multi-window support') -----
- canHaveUnacceptedEdits
- "Answer if the receiver is an object that can hold unaccepted edits (such as a text editor widget)"
-
- ^false!
Item was removed:
- ----- Method: Object>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- "Answer a name that describes the type or class of this object for creating
- an argument name for an argument of similar type in a stub method."
-
- ^ self class name!
Item was removed:
- ----- Method: Object>>chasePointers (in category '*Tools-Debugger') -----
- chasePointers
- PointerFinder on: self!
Item was removed:
- ----- Method: Object>>environment (in category '*Tools') -----
- environment
- "This is a fallback for models that do not inherit from Model or something else that provides
- a useful Environment answer. You should consider copying this method to (base) classes of
- objects from which you expect exactly the behavior below.
- Absolutely feel free to override this method for objects that have or operate on a dedicated
- environment, such as references to classes, code loaders, or tools."
- ^ self class environment!
Item was removed:
- ----- Method: Object>>explore (in category '*Tools-Explorer') -----
- explore
- ToolSet explore: self!
Item was removed:
- ----- Method: Object>>explorePointers (in category '*Tools-Debugger') -----
- explorePointers
- PointerExplorer openOn: self!
Item was removed:
- ----- Method: Object>>exploreWithLabel: (in category '*Tools-Explorer') -----
- exploreWithLabel: label
- ToolSet explore: self label: label!
Item was removed:
- ----- Method: Object>>inspect (in category '*Tools-Inspector') -----
- inspect
- "Create and schedule an Inspector in which the user can examine the receiver's variables."
- ToolSet inspect: self!
Item was removed:
- ----- Method: Object>>inspectWithLabel: (in category '*Tools-Inspector') -----
- inspectWithLabel: aLabel
- "Create and schedule an Inspector in which the user can examine the receiver's variables."
- ToolSet inspect: self label: aLabel!
Item was removed:
- ----- Method: Object>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
- "Answer the class of the inspector to be used on the receiver. Called by inspect;
- use basicInspect to get a normal (less useful) type of inspector."
-
- ^ Inspector!
Item was removed:
- ----- Method: Object>>shouldFollowOutboundPointers (in category '*Tools-Debugger') -----
- shouldFollowOutboundPointers
- "Allow other subclasses of ProtoObject to hook this method."
- (self class isPointers or: [ self isCompiledCode ]) ifFalse: [ ^ false ].
- ^ (self class isWeak not or: [ self class instSize > 0 ]) and: [ self isLiteral not ]!
Item was removed:
- AbstractHierarchicalList subclass: #ObjectExplorer
- instanceVariableNames: 'root currentParent inspector monitorList expression'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Explorer'!
-
- !ObjectExplorer commentStamp: '<historical>' prior: 0!
- ObjectExplorer provides a hierarchical alternative to #inspect. Simply evaluate an expression like:
-
- World explore
-
- and enjoy.!
Item was removed:
- ----- Method: ObjectExplorer class>>about (in category 'defaults') -----
- about
-
- StringHolder new textContents: self comment; openLabel: 'about ',self asString!
Item was removed:
- ----- Method: ObjectExplorer class>>explore: (in category 'instance creation') -----
- explore: anObject
-
- ^ self new explore: anObject!
Item was removed:
- ----- Method: ObjectExplorer class>>nodeClass (in category 'defaults') -----
- nodeClass
-
- ^ ObjectExplorerWrapper!
Item was removed:
- ----- Method: ObjectExplorer class>>openOn: (in category 'instance creation') -----
- openOn: anObject
-
- ^ ToolBuilder open: (self explore: anObject)!
Item was removed:
- ----- Method: ObjectExplorer class>>openOn:withLabel: (in category 'instance creation') -----
- openOn: anObject withLabel: label
- "ObjectExplorer openOn: Smalltalk withLabel: 'Smalltalk'"
-
- ^ ToolBuilder open: (self explore: anObject) label: label!
Item was removed:
- ----- Method: ObjectExplorer>>aboutToStyle: (in category 'styling') -----
- aboutToStyle: aStyler
-
- aStyler
- classOrMetaClass: self object class;
- environment: self environment;
- parseAMethod: false.
- ^true!
Item was removed:
- ----- Method: ObjectExplorer>>browseClassHierarchy (in category 'menus - actions') -----
- browseClassHierarchy
- "Create and schedule a class list browser on the receiver's hierarchy."
-
- self systemNavigation
- spawnHierarchyForClass: self selectedClass
- selector: nil.!
Item was removed:
- ----- Method: ObjectExplorer>>browseClassRefs (in category 'menus - actions') -----
- browseClassRefs
-
- self selectedClass ifNotNil: [:cls |
- cls isTrait ifFalse: [self systemNavigation browseAllCallsOnClass: cls]]!
Item was removed:
- ----- Method: ObjectExplorer>>browseFull (in category 'menus - actions') -----
- browseFull
-
- ^ self selectedClass ifNotNil: [:cls | ToolSet browseClass: cls]!
Item was removed:
- ----- Method: ObjectExplorer>>browseVariableAssignments (in category 'menus - actions') -----
- browseVariableAssignments
-
- (self selectedClass notNil and: [self selectedClass isTrait not])
- ifTrue: [self systemNavigation browseVariableAssignments: self selectedClass].!
Item was removed:
- ----- Method: ObjectExplorer>>browseVariableReferences (in category 'menus - actions') -----
- browseVariableReferences
-
- (self selectedClass notNil and: [self selectedClass isTrait not])
- ifTrue: [self systemNavigation browseVariableReferences: self selectedClass].!
Item was removed:
- ----- Method: ObjectExplorer>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
-
- | windowSpec treeSpec textSpec buttonSpec buttonOffset tool |
- windowSpec := builder pluggableWindowSpec new.
- windowSpec
- model: self;
- children: OrderedCollection new;
- label: #label;
- extent: self initialExtent.
-
- treeSpec := builder pluggableTreeSpec new.
- treeSpec
- model: self;
- nodeClass: self class nodeClass;
- roots: #getList;
- keyPress: #explorerKey:from:event:;
- getSelected: #currentSelection;
- setSelected: #currentSelection:;
- setSelectedParent: #currentParent:;
- menu: #genericMenu:;
- dragItem: #getDragItem:;
- autoDeselect: false;
- columns: (ObjectExplorerWrapper showContentsInColumns
- ifTrue: [{
- [:listMorph | (listMorph filteredItems collect: [:item |
- item preferredWidthOfColumn: 1]) max].
- nil "take all the space"}]);
- frame: (0@0 corner: 1(a)0.71).
- windowSpec children add: treeSpec.
-
- buttonOffset := (Preferences standardButtonFont widthOfString: 'inspect') * 3/2.
-
- textSpec := builder pluggableCodePaneSpec new.
- textSpec
- model: self;
- getText: #expression;
- editText: #expression:;
- menu: #codePaneMenu:shifted:;
- help: 'Evaluate expressions for the current tree selection...' translated;
- frame: (LayoutFrame fractions: (0(a)0.71 corner: 1@1) offsets: (0@0 corner: buttonOffset negated@0)).
- windowSpec children add: textSpec.
-
- buttonSpec := builder pluggableButtonSpec new
- model: self;
- label: 'inspect';
- action: #inspectObject;
- help: 'Switch to an inspector tool';
- frame: (LayoutFrame fractions: (1(a)0.71 corner: 1@1) offsets: (buttonOffset negated@0 corner: 0 @ 0)).
- windowSpec children add: buttonSpec.
-
- tool := builder build: windowSpec.
- self changed: #expandRootsRequested.
- ^ tool!
Item was removed:
- ----- Method: ObjectExplorer>>chasePointersForSelection (in category 'menus - actions') -----
- chasePointersForSelection
-
- PointerFinder on: self object except: self possibleReferencesToSelection!
Item was removed:
- ----- Method: ObjectExplorer>>codePaneMenu:shifted: (in category 'menus') -----
- codePaneMenu: aMenu shifted: shifted
- "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items"
- ^ StringHolder codePaneMenu: aMenu shifted: shifted
- !
Item was removed:
- ----- Method: ObjectExplorer>>copyName (in category 'menus - actions') -----
- copyName
- "Copy the name of the current variable, so the user can paste it into the window below and work with it."
-
- Clipboard clipboardText: self currentSelection key. !
Item was removed:
- ----- Method: ObjectExplorer>>copyValue (in category 'menus - actions') -----
- copyValue
- "Copy a description of the value of the current variable, so the user can paste it into the window below and work with it."
-
- Clipboard clipboardText: self currentSelection value asStringOrText. !
Item was removed:
- ----- Method: ObjectExplorer>>currentParent (in category 'accessing') -----
- currentParent
- ^ currentParent!
Item was removed:
- ----- Method: ObjectExplorer>>currentParent: (in category 'accessing') -----
- currentParent: anObject
- currentParent := anObject.!
Item was removed:
- ----- Method: ObjectExplorer>>currentSelection (in category 'accessing') -----
- currentSelection
-
- ^ currentSelection!
Item was removed:
- ----- Method: ObjectExplorer>>currentSelection: (in category 'accessing') -----
- currentSelection: anObject
-
- self currentSelection == anObject ifTrue: [
- self changed: #objectChanged with: anObject.
- ^ self].
-
- currentSelection := anObject.
-
- self changed: #currentSelection.
- self changed: #style.!
Item was removed:
- ----- Method: ObjectExplorer>>defsOfSelection (in category 'menus - actions') -----
- defsOfSelection
- "Open a browser on all defining references to the selected instance variable, if that's what currently selected. "
-
- self selectedParentClass ifNil: [^ self changed: #flash].
- self selectedParentClass isVariable ifTrue: [^ self changed: #flash].
- self selectedInstVarName ifNil: [^ self changed: #flash].
-
- self systemNavigation browseAllStoresInto: self selectedInstVarName from: self selectedParentClass.!
Item was removed:
- ----- Method: ObjectExplorer>>doItContext (in category 'accessing') -----
- doItContext
- "Answer the context in which a text selection can be evaluated."
-
- ^nil!
Item was removed:
- ----- Method: ObjectExplorer>>doItReceiver (in category 'accessing') -----
- doItReceiver
- "Answer the object that should be informed of the result of evaluating a
- text selection."
-
- ^ self object!
Item was removed:
- ----- Method: ObjectExplorer>>explore: (in category 'user interface') -----
- explore: anObject
-
- self rootObject: anObject.!
Item was removed:
- ----- Method: ObjectExplorer>>explorePointersForSelection (in category 'menus - actions') -----
- explorePointersForSelection
-
- self flag: #tooMany. "mt: Note that we might want to ignore references caused by this tool."
- self object explorePointers.!
Item was removed:
- ----- Method: ObjectExplorer>>exploreSelection (in category 'menus - actions') -----
- exploreSelection
-
- self object explore.!
Item was removed:
- ----- Method: ObjectExplorer>>explorerKey:from:event: (in category 'menus') -----
- explorerKey: aChar from: view event: event
-
- event anyModifierKeyPressed ifFalse: [^ false].
-
- self object ifNotNil: [
- aChar == $i ifTrue: [self inspectSelection. ^ true].
- aChar == $I ifTrue: [self exploreSelection. ^ true].
-
- aChar == $b ifTrue: [self browseFull. ^ true].
- aChar == $h ifTrue: [self browseClassHierarchy. ^ true].
- aChar == $c ifTrue: [self copyName. ^ true].
- aChar == $p ifTrue: [self browseFullProtocol. ^ true].
- aChar == $N ifTrue: [self browseClassRefs. ^ true].
- aChar == $v ifTrue: [self viewerForValue. ^ true]].
-
- ^ false!
Item was removed:
- ----- Method: ObjectExplorer>>expression (in category 'accessing') -----
- expression
-
- ^ expression!
Item was removed:
- ----- Method: ObjectExplorer>>expression: (in category 'accessing') -----
- expression: aString
-
- expression := aString.!
Item was removed:
- ----- Method: ObjectExplorer>>findDeepSubmorphsIn:that: (in category 'accessing - view') -----
- findDeepSubmorphsIn: aMorph that: aBlock
-
- | selectedSubmorphs |
- selectedSubmorphs := aMorph submorphs select: aBlock.
- ^ selectedSubmorphs, (aMorph submorphs collect: [:each |
- self findDeepSubmorphsIn: each that: aBlock]) flatten!
Item was removed:
- ----- Method: ObjectExplorer>>genericMenu: (in category 'menus') -----
- genericMenu: aMenu
-
- ^ self menu: aMenu for: #(treeListMenu treeListMenuShifted:)!
Item was removed:
- ----- Method: ObjectExplorer>>getDragItem: (in category 'user interface') -----
- getDragItem: binding
-
- ^ binding value!
Item was removed:
- ----- Method: ObjectExplorer>>getList (in category 'accessing') -----
- getList
- "This explorer shows bindings in a tree structure. Create the root binding here."
-
- ^ {self root}!
Item was removed:
- ----- Method: ObjectExplorer>>initialExtent (in category 'user interface') -----
- initialExtent
-
- ^350@250!
Item was removed:
- ----- Method: ObjectExplorer>>inspectBasic (in category 'menus - actions') -----
- inspectBasic
- "Bring up a non-special inspector"
-
- self object basicInspect.!
Item was removed:
- ----- Method: ObjectExplorer>>inspectObject (in category 'toolbuilder') -----
- inspectObject
- "Switch to an inspector tool."
-
- | window currentBounds |
- currentBounds := ToolBuilder findDefault getBoundsForWindow: self containingWindow.
-
- "Close first because MVC fiddles around with processes."
- self changed: #close.
-
- window := ToolSet inspect: self rootObject.
-
- "---- In MVC, the lines after this will not be executed ---"
-
- window model setExpression: self expression.
- ToolBuilder findDefault setBoundsForWindow: window to: currentBounds.!
Item was removed:
- ----- Method: ObjectExplorer>>inspectSelection (in category 'menus - actions') -----
- inspectSelection
-
- self object inspect.!
Item was removed:
- ----- Method: ObjectExplorer>>inspector (in category 'accessing - other') -----
- inspector
-
- ^ inspector ifNil: [inspector := Inspector new]!
Item was removed:
- ----- Method: ObjectExplorer>>label (in category 'accessing') -----
- label
-
- ^ [self rootObject printStringLimitedTo: 40] ifError: ['a ' , self rootObject class]!
Item was removed:
- ----- Method: ObjectExplorer>>mainTreeListMenu: (in category 'menus') -----
- mainTreeListMenu: aMenu
- <treeListMenu>
-
- aMenu addStayUpItemSpecial.
-
- aMenu addList: #(
- ('inspect (i)' inspectSelection)
- ('explore (I)' exploreSelection)
- -
- ('method refs to this inst var' referencesToSelection)
- ('methods storing into this inst var' defsOfSelection)
- ('objects pointing to this value' objectReferencesToSelection)
- ('chase pointers' chasePointersForSelection)
- ('explore pointers' explorePointersForSelection)
- -
- ('browse full (b)' browseFull)
- ('browse hierarchy (h)' browseClassHierarchy)
- ('browse protocol (p)' browseFullProtocol)
- -
- ('references... (r)' browseVariableReferences)
- ('assignments... (a)' browseVariableAssignments)
- ('class refs (N)' browseClassRefs)
- -
- ('copy name (c)' copyName)
- ('copy value' copyValue)
- ('basic inspect' inspectBasic)).
-
- Smalltalk isMorphic ifTrue: [
- aMenu addList: #(
- -
- ('viewer for this value (v)' viewerForValue))].
-
- aMenu addList: #(
- -
- ('monitor changes' monitorSelection)).
-
- monitorList isEmptyOrNil ifFalse: [
- aMenu addList: #(
- ('stop monitoring all' stopMonitoring))].
-
- ^ aMenu!
Item was removed:
- ----- Method: ObjectExplorer>>monitor: (in category 'monitoring') -----
- monitor: aBinding
- "Start stepping and watching the given binding for changes."
-
- aBinding ifNil: [ ^self ].
- self world ifNil: [ ^self ].
- self monitorList add: aBinding.
-
- self world startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 2000.!
Item was removed:
- ----- Method: ObjectExplorer>>monitorList (in category 'monitoring') -----
- monitorList
- ^monitorList ifNil: [ monitorList := WeakOrderedCollection new ].!
Item was removed:
- ----- Method: ObjectExplorer>>monitorSelection (in category 'menus - actions') -----
- monitorSelection
-
- self monitor: self currentSelection.!
Item was removed:
- ----- Method: ObjectExplorer>>object (in category 'accessing - objects') -----
- object
-
- ^ self currentSelection value!
Item was removed:
- ----- Method: ObjectExplorer>>objectReferencesToSelection (in category 'menus - actions') -----
- objectReferencesToSelection
- "Open a list inspector on all the objects that point to the value of the selected instance variable, if any. "
-
- self object ifNil: [^ self changed: #flash].
-
- self systemNavigation
- browseAllObjectReferencesTo: self object
- except: {self currentSelection. self currentParent. self parentObject}
- ifNone: [:obj | self changed: #flash].!
Item was removed:
- ----- Method: ObjectExplorer>>okToClose (in category 'user interface') -----
- okToClose
- "Give the object-under-exploration a chance to react. Maybe this explorer is an important reference to the object and the user needs to be informed about this fact."
-
- ^ super okToClose
- and: [(self rootObject respondsTo: #explorerOkToClose)
- ==> [(self rootObject perform: #explorerOkToClose) == true]]!
Item was removed:
- ----- Method: ObjectExplorer>>okToRevertChanges: (in category 'user edits') -----
- okToRevertChanges: aspect
- "Clear caches since we use #textEdited: callback from view."
-
- aspect = #expression: ifTrue: [expression := ''].
- ^ true!
Item was removed:
- ----- Method: ObjectExplorer>>parentObject (in category 'accessing - objects') -----
- parentObject
-
- ^ self currentParent value!
Item was removed:
- ----- Method: ObjectExplorer>>possibleReferencesToSelection (in category 'accessing - view') -----
- possibleReferencesToSelection
-
- ^ {self}, self visibleObjectExplorerWrappers!
Item was removed:
- ----- Method: ObjectExplorer>>referencesToSelection (in category 'menus - actions') -----
- referencesToSelection
- "Open a browser on all references to the selected instance variable, if that's what currently selected."
-
- self selectedParentClass ifNil: [^ self changed: #flash].
- self selectedParentClass isVariable ifTrue: [^ self changed: #flash].
- self selectedInstVarName ifNil: [^ self changed: #flash].
-
- self systemNavigation browseAllAccessesTo: self selectedInstVarName from: self selectedParentClass.!
Item was removed:
- ----- Method: ObjectExplorer>>release (in category 'monitoring') -----
- release
- self world ifNotNil: [ :world | world stopStepping: self selector: #step ].
- super release.!
Item was removed:
- ----- Method: ObjectExplorer>>representsSameBrowseeAs: (in category 'user interface') -----
- representsSameBrowseeAs: anotherObjectExplorer
- ^ self rootObject == anotherObjectExplorer rootObject!
Item was removed:
- ----- Method: ObjectExplorer>>root (in category 'accessing') -----
- root
-
- ^ root ifNil: [root := 'root' -> nil]!
Item was removed:
- ----- Method: ObjectExplorer>>rootObject (in category 'accessing - objects') -----
- rootObject
-
- ^ self root value!
Item was removed:
- ----- Method: ObjectExplorer>>rootObject: (in category 'accessing - objects') -----
- rootObject: anObject
-
- self root value: anObject.
-
- self changed: #label.
- self changed: #getList.
- self changed: #expandRootsRequested.
-
- self currentSelection: self getList first.!
Item was removed:
- ----- Method: ObjectExplorer>>selectedClass (in category 'accessing - other') -----
- selectedClass
- "Answer the class of the receiver's current selection"
-
- ^self doItReceiver class
- !
Item was removed:
- ----- Method: ObjectExplorer>>selectedInstVarName (in category 'accessing - other') -----
- selectedInstVarName
-
- self parentObject ifNil: [^ nil].
- (self parentObject class allInstVarNames includes: self currentSelection key)
- ifTrue: [^ self currentSelection key asSymbol].
- ^ nil!
Item was removed:
- ----- Method: ObjectExplorer>>selectedParentClass (in category 'accessing - other') -----
- selectedParentClass
-
- ^ self parentObject ifNotNil: [:o | o class]!
Item was removed:
- ----- Method: ObjectExplorer>>setExpression: (in category 'accessing - other') -----
- setExpression: aString
-
- self expression: aString.
- self changed: #expression.!
Item was removed:
- ----- Method: ObjectExplorer>>shouldGetStepsFrom: (in category 'monitoring') -----
- shouldGetStepsFrom: aWorld
- ^self monitorList notEmpty!
Item was removed:
- ----- Method: ObjectExplorer>>step (in category 'monitoring') -----
- step
- "Let all views know that some of my objects need to be updated."
-
- self monitorList do: [ :object |
- object ifNotNil: [self changed: #objectChanged with: object]].
- self monitorList ifEmpty: [
- self world stopStepping: self selector: #step ].!
Item was removed:
- ----- Method: ObjectExplorer>>stopMonitoring (in category 'monitoring') -----
- stopMonitoring
- monitorList := nil.
- self world ifNotNil: [ :world | world stopStepping: self selector: #step].!
Item was removed:
- ----- Method: ObjectExplorer>>veryDeepInner: (in category 'copying') -----
- veryDeepInner: aDeepCopier
- super veryDeepInner: aDeepCopier.
- inspector := inspector veryDeepCopyWith: aDeepCopier.
- monitorList := monitorList veryDeepCopyWith: aDeepCopier.
- expression := expression veryDeepCopyWith: aDeepCopier!
Item was removed:
- ----- Method: ObjectExplorer>>viewerForValue (in category 'menus - actions') -----
- viewerForValue
-
- self object beViewed.!
Item was removed:
- ----- Method: ObjectExplorer>>views (in category 'accessing - view') -----
- views
-
- ^ self findDeepSubmorphsIn: self world that: [:morph |
- morph modelOrNil = self]!
Item was removed:
- ----- Method: ObjectExplorer>>visibleListItems (in category 'accessing - view') -----
- visibleListItems
-
- | lists |
- lists := self views select: [:morph |
- (morph isKindOf: PluggableTreeMorph)].
- ^ (lists collect: [:each|
- each items]) flatten!
Item was removed:
- ----- Method: ObjectExplorer>>visibleObjectExplorerWrappers (in category 'accessing - view') -----
- visibleObjectExplorerWrappers
-
- | listItems |
- listItems := self visibleListItems.
- ^ listItems collect: [:each | each complexContents]!
Item was removed:
- ----- Method: ObjectExplorer>>world (in category 'monitoring') -----
- world
- | project |
- ^(project := Project current) isMorphic ifTrue: [project world]!
Item was removed:
- ----- Method: PackageInfo>>browse (in category '*Tools-Browsing') -----
- browse
-
- ^ ToolSet browsePackage: self!
Item was removed:
- Browser subclass: #PackagePaneBrowser
- instanceVariableNames: 'package packageListIndex packageList'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !PackagePaneBrowser commentStamp: '<historical>' prior: 0!
- A package browser represents a hierarchical query path through an organization of class and method information. It parses class categories into a two-level hierarchy on the first '-' character, giving "packages" (e.g., Magnitude, Collections, Graphics, etc.), and "categories" (e.g., Magnitude-General and Magnitude-Number).
-
- Instance Variables:
- package <Symbol> the "category header," e.g., #Magnitudes or #Collections
- packageListIndex <Integer> The index in the package list
- packageList <OrderedCollection of String> the list of package names
- !
Item was removed:
- ----- Method: PackagePaneBrowser class>>fullOnPackage: (in category 'instance creation') -----
- fullOnPackage: aPackage
-
- ^ self new
- selectPackageNamed: aPackage name;
- buildAndOpenFullBrowser!
Item was removed:
- ----- Method: PackagePaneBrowser class>>registerInAppRegistry (in category 'class initialization') -----
- registerInAppRegistry
- "Register the receiver in the SystemBrowser AppRegistry"
- SystemBrowser register: self.!
Item was removed:
- ----- Method: PackagePaneBrowser>>buildDefaultBrowserWith: (in category 'toolbuilder') -----
- buildDefaultBrowserWith: builder
- "assemble the spec for a full 5-pane browser - package, category, class, protocol & message lists, build it and return the built but not opened morph.
- the build-but-don't-open phase is factored out to support the prototypicalToolWindow facility"
-
- "PackagePaneBrowser fullOnClass: Browser."
-
- | max windowSpec |
- max := self wantsOptionalButtons ifTrue:[0.42] ifFalse:[0.5].
- windowSpec := self buildWindowWith: builder specs: {
- (0@0 corner: 0.15@max) -> [self buildPackageListWith: builder].
- (0.15@0 corner: 0.35@max) -> [self buildSystemCategoryListWith: builder].
- (self classListFrame: max fromLeft: 0.35 width: 0.25) -> [self buildClassListWith: builder].
- (self switchesFrame: max fromLeft: 0.35 width: 0.25) -> [self buildSwitchesWith: builder].
- (0.6@0 corner: 0.75@max) -> [self buildMessageCategoryListWith: builder].
- (0.75@0 corner: 1@max) -> [self buildMessageListWith: builder].
- (0@max corner: 1@1) -> [self buildCodePaneWith: builder].
- }.
- self setMultiWindowFor:windowSpec.
- windowSpec defaultFocus: #packageList.
-
- ^builder build: windowSpec!
Item was removed:
- ----- Method: PackagePaneBrowser>>buildPackageListWith: (in category 'toolbuilder') -----
- buildPackageListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- name: #packageList;
- list: #packageList;
- getIndex: #packageListIndex;
- setIndex: #packageListIndex:;
- menu: #packageMenu:;
- keyPress: #packageListKey:from:.
- ^listSpec
- !
Item was removed:
- ----- Method: PackagePaneBrowser>>categoryExistsForPackage (in category 'package list') -----
- categoryExistsForPackage
- ^ self hasPackageSelected
- and: [(systemOrganizer categories indexOf: self package asSymbol) ~= 0]
- !
Item was removed:
- ----- Method: PackagePaneBrowser>>changeCategoryForClass:srcSystemCategory:atListMorph:internal:copy: (in category 'dragNDrop') -----
- changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag
- "only move semantic"
- | newClassCategory success |
- self flag: #stringSymbolProblem.
- success := copyFlag not ifFalse: [^ false].
- newClassCategory := self dstCategoryDstListMorph: dstListMorph internal: internal.
- (success := newClassCategory notNil & (newClassCategory ~= class category))
- ifTrue:
- [class category: newClassCategory.
- self changed: #classList.
- internal ifFalse: [self selectClass: class]].
- ^ success!
Item was removed:
- ----- Method: PackagePaneBrowser>>classList (in category 'class list') -----
- classList
- "Answer an array of the class names of the selected category. Answer an
- empty array if no selection exists."
-
- ^ self hasSystemCategorySelected
- ifFalse: [self packageClasses]
- ifTrue: [systemOrganizer listAtCategoryNamed: self selectedSystemCategory]!
Item was removed:
- ----- Method: PackagePaneBrowser>>defaultBrowserTitle (in category 'initialize-release') -----
- defaultBrowserTitle
- ^ 'Package Browser'!
Item was removed:
- ----- Method: PackagePaneBrowser>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.9 g: 0.9 b: 0.63)!
Item was removed:
- ----- Method: PackagePaneBrowser>>dstCategoryDstListMorph:internal: (in category 'dragNDrop util') -----
- dstCategoryDstListMorph: dstListMorph internal: internal
- | dropItem |
- ^ internal & (dstListMorph getListSelector == #systemCategoryList)
- ifTrue: [(dropItem := dstListMorph potentialDropItem) ifNotNil: [(self package , '-' , dropItem) asSymbol]]
- ifFalse: [self selectedSystemCategory]!
Item was removed:
- ----- Method: PackagePaneBrowser>>hasPackageSelected (in category 'package list') -----
- hasPackageSelected
-
- ^ packageListIndex ~= 0!
Item was removed:
- ----- Method: PackagePaneBrowser>>hasSystemCategorySelected (in category 'system category list') -----
- hasSystemCategorySelected
- ^ super selectedSystemCategory notNil.!
Item was removed:
- ----- Method: PackagePaneBrowser>>isPackage (in category 'multi-window support') -----
- isPackage
- ^true!
Item was removed:
- ----- Method: PackagePaneBrowser>>labelString (in category 'initialize-release') -----
- labelString
- ^self package
- ifNil: [super labelString]
- ifNotNil:
- [:pkg| | label |
- label := self defaultBrowserTitle, ': ', pkg, (self selectedClass
- ifNil: ['']
- ifNotNil: [' ', self selectedClass printString]).
- (self multiWindowState notNil
- and: [self multiWindowState models size > 1]) ifTrue:
- [label := (self multiWindowState models indexOf: self) printString, '. ', label].
- label]!
Item was removed:
- ----- Method: PackagePaneBrowser>>mainPackageMenu: (in category 'package list') -----
- mainPackageMenu: aMenu
- "Answer a Menu of operations on class packages to be
- displayed when the operate menu button is pressed."
- <packageListMenu>
- ^aMenu addList: #(
- ('find class... (f)' findClass)
- ('back... (b)' recent)
- -
- ('browse extensions' browsePackageExtensions)
- ('browse dependencies' browsePackageDependencies)
- ('browse inverted dependencies' browsePackageDependenciesInverted)
- -
- ('reorganize' editSystemCategories)
- ('alphabetize' alphabetizeSystemCategories)
- -
- ('update' updatePackages));
- yourself.!
Item was removed:
- ----- Method: PackagePaneBrowser>>multiWindowName (in category 'multi-window support') -----
- multiWindowName
- "Answer the string to display for the receiver in a multi-window."
- ^String streamContents:
- [:s| | str |
- self package
- ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle]
- ifNotNil:
- [:pkg|
- self selectedClass
- ifNil: [self selectedSystemCategory
- ifNil: [s nextPutAll: pkg]
- ifNotNil: [:cat| s nextPutAll: cat]]
- ifNotNil:
- [:class|
- s nextPutAll: pkg; space; print: class.
- self metaClassIndicated ifTrue:
- [s nextPutAll: ' class']]].
- (str := self selectedMessageName) notNil
- ifTrue: [s nextPutAll: '>>'; nextPutAll: str]
- ifFalse:
- [(str := self selectedMessageCategoryName) notNil
- ifTrue: [s space; nextPut: ${; nextPutAll: str; nextPut: $}]]]!
Item was removed:
- ----- Method: PackagePaneBrowser>>multiWindowNameForState: (in category 'multi-window support') -----
- multiWindowNameForState: savedStateMessage
- "Answer the string to display for the receiver in a multi-window."
- | getarg |
- getarg := [:keyword| savedStateMessage arguments at: (savedStateMessage selector keywords indexOf: keyword)].
- ^String streamContents:
- [:s|
- (getarg value: 'restoreToPackage:')
- ifNil: [s nextPut: $a; space; nextPutAll: self defaultBrowserTitle]
- ifNotNil:
- [:pkg|
- s nextPutAll: pkg.
- (getarg value: 'className:')
- ifNil: [(getarg value: 'category:') ifNotNil:
- [:categoryName| s nextPut: $-; nextPutAll: categoryName]]
- ifNotNil:
- [:className|
- s space; nextPutAll: className.
- (getarg value: 'meta:') ifTrue:
- [s nextPutAll: ' class'].
- self isHierarchy ifTrue:
- [s space; nextPutAll: ' Hierarchy'].
- (getarg value: 'selector:')
- ifNil: [(getarg value: 'protocol:') ifNotNil:
- [:protocol| s space; nextPut: ${; nextPutAll: protocol; nextPut: $}]]
- ifNotNil: [:selector| s nextPutAll: '>>'; nextPutAll: selector]]]]!
Item was removed:
- ----- Method: PackagePaneBrowser>>package (in category 'package list') -----
- package
- "Answer the receiver's 'package'."
-
- ^ self selectedPackageName!
Item was removed:
- ----- Method: PackagePaneBrowser>>packageClasses (in category 'class list') -----
- packageClasses
- ^ self categoryExistsForPackage
- ifFalse: [Array new]
- ifTrue:
- [systemOrganizer listAtCategoryNumber:
- (systemOrganizer categories indexOf: self package asSymbol)]!
Item was removed:
- ----- Method: PackagePaneBrowser>>packageList (in category 'package list') -----
- packageList
- "Answer a list of the packages in the current system organization."
-
- | str stream |
- str := Set new: 100.
- stream := WriteStream on: (Array new: 100).
- systemOrganizer categories do:
- [ :categ | | cats |
- cats := categ asString copyUpTo: $-.
- (str includes: cats) ifFalse:
- [str add: cats.
- stream nextPut: cats]].
- ^stream contents!
Item was removed:
- ----- Method: PackagePaneBrowser>>packageListIndex (in category 'package list') -----
- packageListIndex
- "Answer the index of the current package selection."
-
- ^packageListIndex!
Item was removed:
- ----- Method: PackagePaneBrowser>>packageListIndex: (in category 'package list') -----
- packageListIndex: anInteger
- "Set anInteger to be the index of the current package selection."
-
- packageListIndex := anInteger.
- anInteger = 0
- ifFalse: [package := self packageList at: packageListIndex].
- selectedMessageCategoryName := nil.
- self selectSystemCategory: nil.
- selectedMessageName := nil.
- selectedClassName := nil.
- self setClassOrganizer.
- self changed: #packageSelectionChanged.
- self changed: #packageListIndex. "update my selection"
- self changed: #systemCategoryList. "update the category list"
- self selectSystemCategory: nil. "update category list selection"
- !
Item was removed:
- ----- Method: PackagePaneBrowser>>packageListKey:from: (in category 'package list') -----
- packageListKey: aChar from: view
- aChar == $f ifTrue: [^ self findClass].
- aChar == $b ifTrue: [^ self recent].
- ^ self classListKey: aChar from: view!
Item was removed:
- ----- Method: PackagePaneBrowser>>packageMenu: (in category 'package list') -----
- packageMenu: aMenu
-
- ^ self menu: aMenu for: #(packageListMenu packageListMenuShifted:)!
Item was removed:
- ----- Method: PackagePaneBrowser>>restoreToPackage:category:className:protocol:selector:mode:meta: (in category 'multi-window support') -----
- restoreToPackage: packageNameOrNil category: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool
- self packageListIndex: (self packageList indexOf: packageNameOrNil).
- super restoreToCategory: category className: className protocol: protocol selector: selector mode: editMode meta: metaBool!
Item was removed:
- ----- Method: PackagePaneBrowser>>saveMultiWindowState (in category 'multi-window support') -----
- saveMultiWindowState
- ^Message
- selector: #restoreToPackage:category:className:protocol:selector:mode:meta:
- arguments: { self package.
- self selectedSystemCategory.
- self selectedClassName.
- self selectedMessageCategoryName.
- self selectedMessageName.
- self editSelection.
- self metaClassIndicated }!
Item was removed:
- ----- Method: PackagePaneBrowser>>selectCategoryForClass: (in category 'system category list') -----
- selectCategoryForClass: theClass
- "Set the package and category lists to display the given class."
-
- | cat catName |
- cat := theClass category.
- self packageListIndex: (self packageList indexOf: (cat copyUpTo: $-)).
- catName := (cat copyFrom: ((cat indexOf: $-) + 1) to: cat size).
- self selectSystemCategory: catName.!
Item was removed:
- ----- Method: PackagePaneBrowser>>selectPackageNamed: (in category 'package list') -----
- selectPackageNamed: aPackageName
-
- self packageListIndex: (self packageList indexOf: aPackageName).
- self changed: #packageListIndex.!
Item was removed:
- ----- Method: PackagePaneBrowser>>selectedClass (in category 'class list') -----
- selectedClass
- "Answer the class that is currently selected. Answer nil if no selection
- exists."
-
- | name envt |
- (name := self selectedClassName) ifNil: [^ nil].
- "(envt := self selectedEnvironment) ifNil: [^ nil]."
- envt:= Smalltalk.
- ^ envt at: name!
Item was removed:
- ----- Method: PackagePaneBrowser>>selectedPackage (in category 'package list') -----
- selectedPackage
-
- ^ self selectedPackageName
- ifNil: [super selectedPackage]
- ifNotNil: [:packageName |
- self environment packageOrganizer
- packageNamed: packageName
- ifAbsent: [nil]]!
Item was removed:
- ----- Method: PackagePaneBrowser>>selectedPackageName (in category 'package list') -----
- selectedPackageName
-
- ^ self hasPackageSelected
- ifFalse: [nil]
- ifTrue: [self packageList at: packageListIndex]!
Item was removed:
- ----- Method: PackagePaneBrowser>>selectedSystemCategory (in category 'system category list') -----
- selectedSystemCategory
- "Answer the name of the selected system category or nil."
-
- self hasSystemCategorySelected
- ifFalse: [^nil].
- packageListIndex = 0
- ifTrue: [^ super selectedSystemCategory ].
- ^ self package , '-' , super selectedSystemCategory!
Item was removed:
- ----- Method: PackagePaneBrowser>>systemCategoryList (in category 'system category list') -----
- systemCategoryList
- "Answer the sequenceable collection containing the class categories that
- the receiver accesses."
-
- | prefix |
- packageListIndex = 0 ifTrue: [^ systemOrganizer categories].
- prefix := self package, '-'.
- ^ Array streamContents:
- [:strm |
- systemOrganizer categories do:
- [ :cat | (cat beginsWith: prefix) ifTrue:
- [strm nextPut: (cat copyFrom: prefix size + 1 to: cat size)]]]!
Item was removed:
- ----- Method: PackagePaneBrowser>>systemCategoryListIndex (in category 'system category list') -----
- systemCategoryListIndex
- "Answer the index of the selected class category."
-
- ^ self systemCategoryList indexOf: super selectedSystemCategory.!
Item was removed:
- ----- Method: PackagePaneBrowser>>systemOrganizer: (in category 'initialize-release') -----
- systemOrganizer: aSystemOrganizer
- "Initialize the receiver as a perspective on the system organizer,
- aSystemOrganizer. Typically there is only one--the system variable
- SystemOrganization."
-
- super systemOrganizer: aSystemOrganizer .
- packageListIndex := 0!
Item was removed:
- ----- Method: PackagePaneBrowser>>updatePackages (in category 'package list') -----
- updatePackages
- "Update the contents of the package list."
-
- self editSelection: #none.
- self changed: #packageList.
- self changed: #package.
- self packageListIndex: 0 !
Item was removed:
- ----- Method: PasteUpMorph>>defaultDesktopCommandKeyTriplets (in category '*Tools') -----
- defaultDesktopCommandKeyTriplets
- "Answer a list of triplets of the form
- <key> <receiver> <selector> [+ optional fourth element, a <description> for use in desktop-command-key-help]
- that will provide the default desktop command key handlers. If the selector takes an argument, that argument will be the command-key event"
- "World initializeDesktopCommandKeySelectors"
-
- | noviceKeys expertKeys |
-
- noviceKeys := {
- {$o. self. #activateObjectsTool. 'Activate the "Objects Tool"' translated}.
- {$r. self. #restoreMorphicDisplay. 'Redraw the screen' translated}.
- {$z. self. #undoOrRedoCommand. 'Undo or redo the last undoable command' translated}.
- {$F. Project current. #toggleFlapsSuppressed. 'Toggle the display of flaps' translated}.
- {$N. self. #toggleClassicNavigatorIfAppropriate. 'Show/Hide the classic Navigator, if appropriate' translated}.
- {$M. self. #toggleShowWorldMainDockingBar. 'Show/Hide the Main Docking Bar' translated}.
- {$]. Smalltalk. #saveSession. 'Save the image.' translated}.
- }.
-
- Preferences noviceMode ifTrue: [^ noviceKeys].
-
- expertKeys := {
- {$b. SystemBrowser. #defaultOpenBrowser. 'Open a new System Browser' translated}.
- {$k. Workspace. #open. 'Open a new Workspace' translated}.
- {$m. self. #putUpNewMorphMenu. 'Put up the "New Morph" menu' translated}.
- {$O. self. #findAMonticelloBrowser. 'Bring a Monticello window into focus.' translated}.
- {$t. self. #findATranscript:. 'Make a System Transcript visible' translated}.
- {$w. SystemWindow. #closeTopWindow. 'Close the topmost window' translated}.
- {Character escape. SystemWindow. #closeTopWindow. 'Close the topmost window' translated}.
-
- {$C. self. #findAChangeSorter:. 'Make a Change Sorter visible' translated}.
-
- {$L. self. #findAFileList:. 'Make a File List visible' translated}.
- {$P. self. #findAPreferencesPanel:. 'Activate the Preferences tool' translated}.
- {$R. Utilities. #browseRecentSubmissions. 'Make a Recent Submissions browser visible' translated}.
-
- {$W. self. #findAMessageNamesWindow:. 'Make a MessageNames tool visible' translated}.
- {$Z. ChangeList. #browseRecentLog. 'Browse recently-logged changes' translated}.
-
- {$\. SystemWindow. #sendTopWindowToBack. 'Send the top window to the back' translated}.
- {$_. Smalltalk. #quitPrimitive. 'Quit the image immediately.' translated}.
-
- {$-. Preferences. #decreaseFontSize. 'Decrease all font sizes' translated}.
- {$+. Preferences. #increaseFontSize. 'Increase all font sizes' translated}.
- }.
-
- ^ noviceKeys, expertKeys!
Item was removed:
- ----- Method: PasteUpMorph>>findAMonticelloBrowser (in category '*Tools') -----
- findAMonticelloBrowser
- (Smalltalk classNamed: #MCWorkingCopyBrowser) ifNotNil:
- [:mc|
- self
- findAWindowSatisfying: [:aWindow | aWindow model isMemberOf: mc]
- orMakeOneUsing: [mc open]]!
Item was removed:
- FileList subclass: #PluggableFileList
- instanceVariableNames: 'accepted fileFilterBlock canAcceptBlock validateBlock newFiles prompt resultBlock'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-FileList'!
-
- !PluggableFileList commentStamp: 'eem 3/30/2017 17:30' prior: 0!
- I am a model for a modal dialog akin to "Standard File Services" on various modern GUI operating systems. My protocol includes some methods to maintain upward compatibility with StandardFileMenu, which I hope to replace.
-
- Sample doIts:
-
- "StandardFileDialog getFolder"-- ask user to select folder, answer corresponding FileDirectory
- "StandardFileDialog getFile" -- ask user to select file, answer corresponding FileStream
- "StandardFileDialog putFile" -- ask user to create new file, answer FileStream
-
- In addition to the instance variables inhereted from FileList, of which I am a subclass, I am pluggable via the following instance variables:
-
- prompt <String>
- Display a prompt between the buttons.
-
- resultBlock <BlockClosure>
- Passed a file directory and a file name, answer the result to be answered by the dialog.
-
- canAcceptBlock <BlockClosure>
- Answer whether the accept button should be "active"
-
- fileFilterBlock <BlockClosure>
- Passed a file directory entry, answer whether the entry should be added to the list. The list can be further filtered (but not expanded) by the user through the pattern.
-
- validateBlock <BlockClosure>
- Passed a file directory entry, a file name and a collection of newly created files, answer whether the dialog selection is valid. validateBlock is checked after the user has pressed accept, for example to ask if the user really meant to delete a file.
-
- newFiles <OrderedCollection>
-
- newFiles is an OrderedCollection of fileNames of files added by the user to the current directory since the user last entered same!
Item was removed:
- ----- Method: PluggableFileList class>>allFilesAndFoldersFileFilter (in category 'fileFilterBlocks') -----
- allFilesAndFoldersFileFilter
-
- ^[:each | true]!
Item was removed:
- ----- Method: PluggableFileList class>>allFoldersFileFilter (in category 'fileFilterBlocks') -----
- allFoldersFileFilter
-
- ^[:each | each isDirectory]!
Item was removed:
- ----- Method: PluggableFileList class>>alwaysAcceptBlock (in category 'canAcceptBlocks') -----
- alwaysAcceptBlock
-
- ^[:theDirectory :theFileName | true]!
Item was removed:
- ----- Method: PluggableFileList class>>alwaysValidateBlock (in category 'validateBlocks') -----
- alwaysValidateBlock
-
- ^[:theDirectory :theFileName :theNewFiles | true].!
Item was removed:
- ----- Method: PluggableFileList class>>checkExistingFileValidateBlock (in category 'validateBlocks') -----
- checkExistingFileValidateBlock
-
- ^[:theDirectory :theFileName :theNewFiles |
- (theNewFiles includes: theFileName) or:
- [(PluggableFileList okToOverwrite: theFileName)]].!
Item was removed:
- ----- Method: PluggableFileList class>>directoryResultBlock (in category 'resultBlocks') -----
- directoryResultBlock
-
- ^[:theDirectory :theFileName | theDirectory]!
Item was removed:
- ----- Method: PluggableFileList class>>existingFileValidateBlock (in category 'validateBlocks') -----
- existingFileValidateBlock
-
- ^[:theDirectory :theFileName :theNewFiles |
- (theNewFiles includes: theFileName) or:
- [(PluggableFileList okToOverwrite: theFileName)]].!
Item was removed:
- ----- Method: PluggableFileList class>>fileNameResultBlock (in category 'resultBlocks') -----
- fileNameResultBlock
-
- ^[:theDirectory :theFileName | theFileName]!
Item was removed:
- ----- Method: PluggableFileList class>>fileNameSelectedAcceptBlock (in category 'canAcceptBlocks') -----
- fileNameSelectedAcceptBlock
-
- ^[:theDirectory :theFileName | theFileName notNil]!
Item was removed:
- ----- Method: PluggableFileList class>>getFile (in category 'standard dialog operations') -----
- getFile
- | result |
-
- self flag: #unused.
- result := self getFilePathName.
- ^result ifNotNil: [FileStream oldFileNamed: result]!
Item was removed:
- ----- Method: PluggableFileList class>>getFilePathName (in category 'standard dialog operations') -----
- getFilePathName
-
- ^self getFilePathNameDialog open!
Item was removed:
- ----- Method: PluggableFileList class>>getFilePathNameDialog (in category 'instance creation') -----
- getFilePathNameDialog
-
- ^(self new)
- validateBlock: PluggableFileList alwaysValidateBlock;
- yourself!
Item was removed:
- ----- Method: PluggableFileList class>>getFilePathNameDialogWithExistenceCheck (in category 'instance creation') -----
- getFilePathNameDialogWithExistenceCheck
-
- ^(self new)
- prompt: 'Select New File:';
- validateBlock: PluggableFileList checkExistingFileValidateBlock;
- yourself!
Item was removed:
- ----- Method: PluggableFileList class>>getFilePathNameWithExistenceCheck (in category 'standard dialog operations') -----
- getFilePathNameWithExistenceCheck
-
- ^self getFilePathNameDialogWithExistenceCheck open!
Item was removed:
- ----- Method: PluggableFileList class>>getFolder (in category 'standard dialog operations') -----
- getFolder
-
- ^self getFolderDialog open!
Item was removed:
- ----- Method: PluggableFileList class>>getFolderDialog (in category 'instance creation') -----
- getFolderDialog
-
- ^(self new)
- prompt: 'Select a Folder';
- fileFilterBlock: PluggableFileList allFoldersFileFilter;
- canAcceptBlock: PluggableFileList alwaysAcceptBlock;
- resultBlock: PluggableFileList directoryResultBlock;
- validateBlock: PluggableFileList alwaysValidateBlock;
- yourself!
Item was removed:
- ----- Method: PluggableFileList class>>okToOpen:without: (in category 'validateBlocks') -----
- okToOpen: aFileNameString without: aSuffixString
-
- "Answer whether user confirms that it is ok to overwrite the file named in aString"
- ^ 1 = (Project uiManager
- chooseOptionFrom: #('overwrite that file' 'select another file')
- title: aFileNameString, ' already exists.').
- !
Item was removed:
- ----- Method: PluggableFileList class>>okToOverwrite: (in category 'validateBlocks') -----
- okToOverwrite: aString
-
- "Answer whether user confirms that it is ok to overwrite the file named in aString"
- ^ 1 = (Project uiManager
- chooseOptionFrom: #('overwrite that file' 'select another file')
- title: aString, ' already exists.')
- !
Item was removed:
- ----- Method: PluggableFileList class>>open (in category 'instance creation') -----
- open
-
- ^self new open!
Item was removed:
- ----- Method: PluggableFileList class>>pathNameResultBlock (in category 'resultBlocks') -----
- pathNameResultBlock
-
- ^[:theDirectory :theFileName |
- theFileName
- ifNil: [theDirectory pathName]
- ifNotNil: [theDirectory fullNameFor: theFileName]].
- !
Item was removed:
- ----- Method: PluggableFileList class>>putFile (in category 'standard dialog operations') -----
- putFile
-
- | result |
- result := self getFilePathNameWithExistenceCheck.
- ^result ifNotNil:
- [FileDirectory deleteFilePath: result.
- FileStream newFileNamed: result]!
Item was removed:
- ----- Method: PluggableFileList>>addNew:byEvaluating: (in category 'file list menu') -----
- addNew: aString byEvaluating: aBlock
- "A parameterization of earlier versions of #addNewDirectory and
- #addNewFile. Fixes the bug in each that pushing the cancel button
- in the FillInTheBlank dialog gave a walkback."
-
- | response newName index ending |
- self okToChange ifFalse: [^ self].
- (response := UIManager default request: 'New ',aString,' Name?'
- initialAnswer: aString,'Name')
- isEmpty ifTrue: [^ self].
- newName := response asFileName.
- Cursor wait showWhile: [
- aBlock value: newName].
- self updateFileList.
- index := list indexOf: newName.
- index = 0 ifTrue: [ending := ') ',newName.
- index := list findFirst: [:line | line endsWith: ending]].
- self fileListIndex: index.
- newFiles add: newName
- !
Item was removed:
- ----- Method: PluggableFileList>>beAccepted (in category 'accessing') -----
- beAccepted
-
- ^accepted := true!
Item was removed:
- ----- Method: PluggableFileList>>canAccept (in category 'accessing') -----
- canAccept
-
- ^canAcceptBlock value: directory value: fileName!
Item was removed:
- ----- Method: PluggableFileList>>canAcceptBlock: (in category 'accessing') -----
- canAcceptBlock: aBlock
-
- ^canAcceptBlock := aBlock!
Item was removed:
- ----- Method: PluggableFileList>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ Color lightYellow!
Item was removed:
- ----- Method: PluggableFileList>>fileFilterBlock: (in category 'accessing') -----
- fileFilterBlock: aBlock
-
- ^fileFilterBlock := aBlock!
Item was removed:
- ----- Method: PluggableFileList>>fileListIndex (in category 'accessing') -----
- fileListIndex
-
- self changed: #fileString.
- ^super fileListIndex!
Item was removed:
- ----- Method: PluggableFileList>>fileSelectedMenu: (in category 'file list menu') -----
- fileSelectedMenu: aMenu
- | firstItems secondItems thirdItems n1 n2 n3 services |
- firstItems := self itemsForFile: self fullName asLowercase.
- secondItems := self itemsForAnyFile.
- thirdItems := self itemsForNoFile.
- n1 := firstItems size.
- n2 := n1 + secondItems size.
- n3 := n2 + thirdItems size.
- services := firstItems, secondItems, thirdItems,
- (OrderedCollection with: (SimpleServiceEntry provider: self label: 'more...' selector: #offerAllFileOptions)).
- ^ aMenu
- addServices2: services
- for: self
- extraLines: (Array with: n1 with: n2 with: n3)
- !
Item was removed:
- ----- Method: PluggableFileList>>fileString (in category 'file string') -----
- fileString
-
- fileName ifNil: [^directory pathName].
- ^directory fullNameFor: fileName!
Item was removed:
- ----- Method: PluggableFileList>>fileString: (in category 'file string') -----
- fileString: aString
-
- "| textName index ending |
- textName := aString asString.
- (FileDirectory default fileExists: textName) ifTrue:
- [self directory: (FileDirectory forFileName: textName).
- index := list indexOf: (FileDirectory localNameFor: textName).
- index = 0 ifTrue:
- [ending := ') ', (FileDirectory localNameFor: textName).
- index := list findFirst: [:line | line endsWith: ending]].
- self fileListIndex: index].
- (FileDirectory default directoryExists: textName) ifTrue:
- [self directory: (FileDirectory on: textName)]."
- self changed: #fileString.
- self changed: #contents.
- ^true!
Item was removed:
- ----- Method: PluggableFileList>>fileVolumeIndex (in category 'accessing') -----
- fileVolumeIndex
-
- self changed: #fileString.
- ^super fileVolumeIndex!
Item was removed:
- ----- Method: PluggableFileList>>initialize (in category 'initialize-release') -----
- initialize
-
- super initialize.
- prompt := 'Select File'.
- directory := FileDirectory default.
- newFiles := OrderedCollection new.
- fileFilterBlock := PluggableFileList allFilesAndFoldersFileFilter.
- canAcceptBlock := PluggableFileList fileNameSelectedAcceptBlock.
- resultBlock := PluggableFileList pathNameResultBlock.
- validateBlock := PluggableFileList checkExistingFileValidateBlock.
- !
Item was removed:
- ----- Method: PluggableFileList>>leftButtonPressed (in category 'accepting/cancelling') -----
- leftButtonPressed
-
- accepted := false.
- self changed: #close.
- !
Item was removed:
- ----- Method: PluggableFileList>>leftButtonState (in category 'accepting/cancelling') -----
- leftButtonState
-
- ^true!
Item was removed:
- ----- Method: PluggableFileList>>listForPattern: (in category 'file list menu') -----
- listForPattern: pat
- "Make the list be those file names which match the pattern."
- | entries sizePad newList allFiles |
- entries := directory entries select: fileFilterBlock.
- sizePad := (entries inject: 0 into: [:mx :entry | mx max: entry fileSize])
- asStringWithCommas size - 1.
-
- newList := OrderedCollection new: entries size.
-
- allFiles := pat = '*'.
- entries do:
- [:entry | "<dirflag><name><creationTime><modificationTime><fileSize>"
- (allFiles or: [entry isDirectory or: [pat match: entry name]]) ifTrue:
- [newList add: entry]].
- newList := newList asArray sort: self sortBlock.
- newList := newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ].
-
- volList size = 1 ifTrue:
- ["Include known servers along with other desktop volumes"
- ^newList ,
- (ServerDirectory serverNames collect: [:n | '^' , n , self folderString])].
- newFiles := OrderedCollection new.
- ^ newList!
Item was removed:
- ----- Method: PluggableFileList>>open (in category 'initialize-release') -----
- open
- self deprecated: 'PluggableFileList is being deprecated'. "This can go away soon"
-
- ^ Project uiManager openPluggableFileList: self label: prompt in: self currentWorld!
Item was removed:
- ----- Method: PluggableFileList>>prompt: (in category 'accessing') -----
- prompt: aString
-
- prompt := aString!
Item was removed:
- ----- Method: PluggableFileList>>result (in category 'accepting/cancelling') -----
- result
-
- accepted ifFalse: [^nil].
- ^resultBlock value: directory value: fileName!
Item was removed:
- ----- Method: PluggableFileList>>resultBlock: (in category 'accessing') -----
- resultBlock: aBlock
-
- ^resultBlock := aBlock!
Item was removed:
- ----- Method: PluggableFileList>>rightButtonPressed (in category 'accepting/cancelling') -----
- rightButtonPressed
-
- (canAcceptBlock value: directory value: fileName) ifFalse: [^nil].
- (validateBlock value: directory value: fileName value: newFiles) ifFalse: [^nil].
- accepted := true.
- self changed: #close!
Item was removed:
- ----- Method: PluggableFileList>>rightButtonState (in category 'accepting/cancelling') -----
- rightButtonState
-
- ^self canAccept!
Item was removed:
- ----- Method: PluggableFileList>>startUpWithCaption: (in category 'StandardFileMenu') -----
- startUpWithCaption: captionOrNil
- "Display the menu, slightly offset from the cursor, so that a slight tweak is required to confirm any action."
-
- ^ self
- startUpWithCaption: captionOrNil
- at: (self currentHand ifNil: [Sensor]) cursorPoint!
Item was removed:
- ----- Method: PluggableFileList>>startUpWithCaption:at: (in category 'StandardFileMenu') -----
- startUpWithCaption: aString at: location
-
- self prompt: aString.
- ^self open!
Item was removed:
- ----- Method: PluggableFileList>>validate (in category 'accessing') -----
- validate
-
- ^validateBlock value: directory value: fileName value: newFiles!
Item was removed:
- ----- Method: PluggableFileList>>validateBlock: (in category 'accessing') -----
- validateBlock: aBlock
-
- ^validateBlock := aBlock!
Item was removed:
- ----- Method: PluggableTextMorph>>canHaveUnacceptedEdits (in category '*Tools-multi-window support') -----
- canHaveUnacceptedEdits
- "Answer if the receiver is an object that can hold unaccepted edits (such as a text editor widget)"
-
- ^true!
Item was removed:
- ----- Method: PluggableTextMorph>>saveContentsInFile (in category '*Tools-file out') -----
- saveContentsInFile
- self handleEdit: [textMorph editor saveContentsInFile]!
Item was removed:
- ----- Method: PluggableTextMorph>>unacceptedEditState (in category '*Tools-multi-window support') -----
- unacceptedEditState
- ^hasUnacceptedEdits ifTrue: [self text]!
Item was removed:
- ----- Method: PluggableTextMorph>>unacceptedEditState: (in category '*Tools-multi-window support') -----
- unacceptedEditState: stateOrNil
- stateOrNil
- ifNotNil:
- [self setText: stateOrNil.
- hasUnacceptedEdits := true "setText: clears hasUnacceptedEdits, so must do this post setText:"]
- ifNil: [hasUnacceptedEdits := false]!
Item was removed:
- ObjectExplorer subclass: #PointerExplorer
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Explorer'!
-
- !PointerExplorer commentStamp: 'avi 8/21/2004 20:01' prior: 0!
- A variant on the ObjectExlorer that works "backwards": like the ObjectExplorer, it shows a tree of objects, but expanding a node won't show the objects which that node references, but rather the objects that reference that node. Its main use is to track down memory leaks: if you want to know why a particular object is still alive, open a PointerExplorer on it and drill down until you find the root object that's referencing it. For example, find all the references to the symbol #zot with:
-
- PointerExplorer new openExplorerFor: #zot
-
- For the "name" of the object, the PointerExplorer shows each object's identityHash, to allow the user to identify when two similar objects are identical and notice cycles.!
Item was removed:
- ----- Method: PointerExplorer class>>nodeClass (in category 'defaults') -----
- nodeClass
-
- ^ PointerExplorerWrapper!
Item was removed:
- ----- Method: PointerExplorer>>rootObject: (in category 'accessing') -----
- rootObject: anObject
- self root key: 'leaf'.
- super rootObject: anObject!
Item was removed:
- ObjectExplorerWrapper subclass: #PointerExplorerWrapper
- instanceVariableNames: 'weakOnly'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Explorer'!
-
- !PointerExplorerWrapper commentStamp: 'avi 8/21/2004 19:58' prior: 0!
- A subclass of ObjectExplorerWrapper for use with PointerExplorer. #contents is overridden to work backwards: it returns wrappers for the objects pointing to item rather than for the objects that item points to.!
Item was removed:
- ----- Method: PointerExplorerWrapper>>asString (in category 'converting') -----
- asString
-
- ^ self object identityHash asString, ': ', super asString.!
Item was removed:
- ----- Method: PointerExplorerWrapper>>contents (in category 'accessing') -----
- contents
- "Return the wrappers with the objects holding references to item. Eldest objects come first, weak only referencers are at the end and have parentheses around their identity hash."
-
- | objects weakOnlyReferences |
- objects := self object inboundPointersExcluding: { self. self item. model }.
- weakOnlyReferences := OrderedCollection new.
- objects removeAllSuchThat: [ :each |
- each class == self class
- or: [ each class == PointerExplorer
- or: [ (each isContext
- and: [ (each objectClass: each receiver) == PointerExplorer ] )
- or: [ (each pointsOnlyWeaklyTo: self object)
- ifTrue: [ weakOnlyReferences add: each. true ]
- ifFalse: [ false ] ] ] ] ].
- ^(objects replace: [ :each |
- self class with: each name: (self nameForParent: each) model: self object ])
- addAll: (weakOnlyReferences replace: [ :each |
- (self class with: each name: '(', (self nameForParent: each), ')' model: self object)
- weakOnly: true;
- yourself ]);
- yourself!
Item was removed:
- ----- Method: PointerExplorerWrapper>>hasContents (in category 'testing') -----
- hasContents
- ^true!
Item was removed:
- ----- Method: PointerExplorerWrapper>>isWeakOnly (in category 'testing') -----
- isWeakOnly
-
- ^weakOnly ifNil: [ false ] "This #ifNil: message is only here to avoid errors when updating an image with opened PointerExplorers."!
Item was removed:
- ----- Method: PointerExplorerWrapper>>memberNameFrom:to: (in category 'accessing') -----
- memberNameFrom: aParent to: aChild
-
- 1 to: aParent class instSize do: [ :instVarIndex |
- (aParent instVarAt: instVarIndex) == aChild
- ifTrue: [ ^ '''', (aParent class instVarNameForIndex: instVarIndex), '''' ]].
-
- "This covers compiled methods and compiled blocks."
- aParent isCompiledCode ifTrue: [
- 1 to: aParent numLiterals do: [ :index |
- (aParent literalAt: index) == aChild
- ifTrue: [^ 'literal', index asString]]].
-
- "This also covers arrays"
- 1 to: aParent basicSize do: [ :index |
- (aParent basicAt: index) == aChild
- ifTrue: [^ index asString]].
- ^ '???'!
Item was removed:
- ----- Method: PointerExplorerWrapper>>nameForParent: (in category 'accessing') -----
- nameForParent: anObject
-
- ^ self memberNameFrom: anObject to: self object!
Item was removed:
- ----- Method: PointerExplorerWrapper>>preferredColor (in category 'accessing') -----
- preferredColor
-
- ^self isWeakOnly
- ifTrue: [ Color gray ]
- ifFalse: [ super preferredColor ]!
Item was removed:
- ----- Method: PointerExplorerWrapper>>weakOnly: (in category 'accessing') -----
- weakOnly: aBoolean
-
- weakOnly := aBoolean!
Item was removed:
- Model subclass: #PointerFinder
- instanceVariableNames: 'goal parents toDo toDoNext hasGemStone pointerList objectList parentsSize todoSize depth pointerListIndex excludedObjects'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Debugger'!
-
- !PointerFinder commentStamp: '<historical>' prior: 0!
- I can search for reasons why a certain object isn't garbage collected. I'm a quick port of a VisualWorks program written by Hans-Martin Mosner. Call me as shown below. I'll search for a path from a global variable to the given object, presenting it in a small morphic UI.
-
- Examples:
- PointerFinder on: self currentHand
- PointerFinder on: StandardSystemView someInstance
-
- Now, let's see why this image contains more HandMorphs as expected...
-
- HandMorph allInstancesDo: [:e | PointerFinder on: e]!
Item was removed:
- ----- Method: PointerFinder class>>on: (in category 'instance creation') -----
- on: anObject
- ^ self
- on: anObject
- except: Array empty!
Item was removed:
- ----- Method: PointerFinder class>>on:except: (in category 'instance creation') -----
- on: anObject except: aCollection
- ^ self new
- goal: anObject;
- excludedObjects: aCollection;
- search;
- open!
Item was removed:
- ----- Method: PointerFinder class>>pointersTo: (in category 'utilities') -----
- pointersTo: anObject
- "Find all occurrences in the system of pointers to the argument anObject."
- "(PointerFinder pointersTo: Browser) inspect."
-
- ^ self pointersTo: anObject except: #()
- !
Item was removed:
- ----- Method: PointerFinder class>>pointersTo:except: (in category 'utilities') -----
- pointersTo: anObject except: objectsToExclude
- "Find all occurrences in the system of pointers to the argument anObject.
- Remove objects in the exclusion list from the results."
-
- ^ anObject inboundPointersExcluding: objectsToExclude!
Item was removed:
- ----- Method: PointerFinder class>>pointersToItem:of: (in category 'utilities') -----
- pointersToItem: index of: anArray
- "Find all occurrences in the system of pointers to the given element of the given array.
- This is useful for tracing up a pointer chain from an inspector on the results of a previous call of pointersTo:. To find out who points to the second element of the results, one would evaluate:
-
- PointerFinder pointersToItem: 2 of: self
-
- in the inspector."
-
- ^ self pointersTo: (anArray at: index) except: (Array with: anArray)!
Item was removed:
- ----- Method: PointerFinder>>arrowKey:from: (in category 'pointer-list') -----
- arrowKey: key from: aController
- key = $i ifTrue: [^ self inspectObject].
- ^ super arrowKey: key from: aController!
Item was removed:
- ----- Method: PointerFinder>>buildList (in category 'initialize-release') -----
- buildList
- | list obj parent object key |
- list := OrderedCollection new.
- obj := goal.
-
- [list addFirst: obj.
- obj := parents at: obj ifAbsent: [].
- obj == nil] whileFalse.
- list removeFirst.
- parent := Smalltalk.
- objectList := OrderedCollection new.
- pointerList := OrderedCollection new.
- [list isEmpty]
- whileFalse:
- [object := list removeFirst.
- key := nil.
- (parent isKindOf: Dictionary)
- ifTrue: [list size >= 2
- ifTrue:
- [key := parent keyAtValue: list second ifAbsent: [].
- key == nil
- ifFalse:
- [object := list removeFirst; removeFirst.
- pointerList add: key printString , ' -> ' , object class name]]].
- key == nil
- ifTrue:
- [parent class == object ifTrue: [key := 'CLASS'].
- key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i)
- == object ifTrue: [key := parent class instVarNameForIndex: i]]]].
- key == nil ifTrue: [parent isCompiledCode ifTrue: [key := 'literals?']].
- key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i)
- == object ifTrue: [key := i printString]]]].
- key == nil ifTrue: [(parent isMorph and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']].
- key == nil ifTrue: [key := '???'].
- pointerList add: key , ': ' , object class name, (object isMorph ifTrue: [' (', object identityHash asString, ')'] ifFalse: [ String empty ]) ].
- objectList add: object.
- parent := object]!
Item was removed:
- ----- Method: PointerFinder>>buildWith: (in category 'ui-building') -----
- buildWith: builder
- | listSpec windowSpec |
- windowSpec := builder pluggableWindowSpec new
- model: self;
- label: 'Pointer Finder'.
-
- listSpec := builder pluggableListSpec new
- model: self;
- frame: (0@0 corner: 1@1);
- list: #pointerList;
- getIndex: #pointerListIndex;
- setIndex: #pointerListIndex:;
- menu: #menu:shifted:;
- keyPress: #arrowKey:from:;
- doubleClick: #inspectObject;
- yourself.
-
- windowSpec children: {listSpec}.
-
- ^ builder build: windowSpec.!
Item was removed:
- ----- Method: PointerFinder>>excludedObjects (in category 'accessing') -----
- excludedObjects
- ^ excludedObjects!
Item was removed:
- ----- Method: PointerFinder>>excludedObjects: (in category 'initialize-release') -----
- excludedObjects: aCollection
- excludedObjects := aCollection asIdentitySet!
Item was removed:
- ----- Method: PointerFinder>>follow:from: (in category 'private') -----
- follow: anObject from: parentObject
- anObject == goal ifTrue:
- [ parents
- at: anObject
- put: parentObject.
- ^ true ].
- anObject shouldFollowOutboundPointers ifFalse: [ ^ false ].
- ((parents includesKey: anObject) or: [ anObject class = self class ]) ifTrue: [ ^ false ].
- parents
- at: anObject
- put: parentObject.
- toDoNext add: anObject.
- ^ false!
Item was removed:
- ----- Method: PointerFinder>>followObject: (in category 'private') -----
- followObject: anObject
-
- (self excludedObjects includes: anObject)
- ifTrue: [^ false].
- anObject outboundPointersDo: [:ea |
- (self follow: ea from: anObject)
- ifTrue: [^ true]].
- ^ false!
Item was removed:
- ----- Method: PointerFinder>>goal: (in category 'initialize-release') -----
- goal: anObject
- goal := anObject!
Item was removed:
- ----- Method: PointerFinder>>initialExtent (in category 'ui-building') -----
- initialExtent
- ^ 300 @ 300!
Item was removed:
- ----- Method: PointerFinder>>initialize (in category 'initialize-release') -----
- initialize
- parents := IdentityDictionary new: 20000.
- parents at: Smalltalk put: nil.
- parents at: Processor put: nil.
- parents at: self put: nil.
-
- toDo := OrderedCollection new: 5000.
- toDo add: Smalltalk.
- toDoNext := OrderedCollection new: 5000.
-
- excludedObjects := IdentitySet new!
Item was removed:
- ----- Method: PointerFinder>>inspectObject (in category 'pointer-list') -----
- inspectObject
- pointerListIndex = 0 ifTrue: [^ Beeper beep].
- (objectList at: pointerListIndex) inspect!
Item was removed:
- ----- Method: PointerFinder>>menu:shifted: (in category 'pointer-list') -----
- menu: aMenu shifted: shifted
-
- ^ self menu: aMenu for: #(pointerListMenu pointerListMenuShifted:) shifted: shifted!
Item was removed:
- ----- Method: PointerFinder>>open (in category 'ui-building') -----
- open
- ^ ToolBuilder open: self.!
Item was removed:
- ----- Method: PointerFinder>>openInMorphic (in category 'morphic ui') -----
- openInMorphic
- | window list |
- window := (SystemWindow labelled: 'Pointer Finder')
- model: self.
- list := PluggableListMorph new
- doubleClickSelector: #inspectObject;
-
- on: self
- list: #pointerList
- selected: #pointerListIndex
- changeSelected: #pointerListIndex:
- menu: #menu:shifted:
- keystroke: #arrowKey:from:.
- "For doubleClick to work best disable autoDeselect"
- list autoDeselect: false.
- window addMorph: list frame: (0@0 extent: 1@1).
- list color: Color lightMagenta.
- window openInWorld!
Item was removed:
- ----- Method: PointerFinder>>pointerList (in category 'pointer-list') -----
- pointerList
- ^ pointerList asArray!
Item was removed:
- ----- Method: PointerFinder>>pointerListIndex (in category 'pointer-list') -----
- pointerListIndex
- ^ pointerListIndex ifNil: [0]!
Item was removed:
- ----- Method: PointerFinder>>pointerListIndex: (in category 'pointer-list') -----
- pointerListIndex: anInteger
- pointerListIndex := anInteger.
- self changed: #pointerListIndex!
Item was removed:
- ----- Method: PointerFinder>>pointerListMenu: (in category 'pointer-list') -----
- pointerListMenu: aMenu
-
- <pointerListMenu>
- ^ aMenu
- addList: #(
- ('Inspect (i)' #inspectObject 'Live long and prosper!!')
- -
- ('Search again' #searchAgain 'Search again\for the same object' withCRs));
- yourself.!
Item was removed:
- ----- Method: PointerFinder>>search (in category 'application') -----
- search
- Smalltalk garbageCollect.
-
- self initialize.
-
- Cursor wait showWhile: [
- [[toDo isEmpty or: [self followObject: toDo removeFirst]] whileFalse.
- toDo isEmpty and: [toDoNext isEmpty not]]
- whileTrue:
- [toDo := toDoNext.
- toDoNext := OrderedCollection new: 5000]].
-
- self buildList!
Item was removed:
- ----- Method: PointerFinder>>searchAgain (in category 'pointer-list') -----
- searchAgain
- self pointerListIndex: 0.
- self search.
- self changed: #pointerList!
Item was removed:
- ----- Method: PointerFinder>>update (in category 'application') -----
- update
- ('done: ' , parents size asString , ' todo: ' , toDo size asString , ' ') displayAt: 0@0!
Item was removed:
- Object subclass: #PopUpMenu
- instanceVariableNames: 'labelString font lineArray frame form marker selection'
- classVariableNames: 'CacheMenuForms'
- poolDictionaries: ''
- category: 'Tools-Menus'!
-
- !PopUpMenu commentStamp: '<historical>' prior: 0!
- I represent a list of items. My instances are presented on the display screen in a rectangular area. The user points to an item, pressing a mouse button; the item is highlighted. When the button is released, the highlighted item indicates the selection.!
Item was removed:
- ----- Method: PopUpMenu class>>cleanUp (in category 'class initialization') -----
- cleanUp
- "Re-initialize"
-
- self initialize.!
Item was removed:
- ----- Method: PopUpMenu class>>confirm: (in category 'dialogs') -----
- confirm: queryString
- "Put up a yes/no menu with caption queryString. Answer true if the
- response is yes, false if no. This is a modal question--the user must
- respond yes or no."
-
- "PopUpMenu confirm: 'Are you hungry?'"
-
- ^ self confirm: queryString trueChoice: 'Yes' translated falseChoice: 'No' translated!
Item was removed:
- ----- Method: PopUpMenu class>>confirm:orCancel: (in category 'dialogs') -----
- confirm: queryString orCancel: cancelBlock
- "Put up a yes/no/cancel menu with caption aString. Answer
- true if
- the response is yes, false if no. If cancel is chosen, evaluate
- cancelBlock. This is a modal question--the user must respond
- yes or no."
- "PopUpMenu confirm: 'Reboot universe' orCancel:
- [^'Nevermind'] "
- | menu choice |
- menu := PopUpMenu labelArray: {'Yes' translated. 'No' translated. 'Cancel' translated}.
- choice := menu startUpWithCaption: queryString icon: MenuIcons confirmIcon.
- choice = 1
- ifTrue: [^ true].
- choice = 2
- ifTrue: [^ false].
- ^ cancelBlock value!
Item was removed:
- ----- Method: PopUpMenu class>>confirm:trueChoice:falseChoice: (in category 'dialogs') -----
- confirm: queryString trueChoice: trueChoice falseChoice: falseChoice
- "Put up a yes/no menu with caption queryString. The actual
- wording
- for the two choices will be as provided in the trueChoice and
- falseChoice parameters. Answer true if the response is the
- true-choice,
- false if it's the false-choice.
- This is a modal question -- the user must respond one way or
- the other."
- "PopUpMenu
- confirm: 'Are you hungry?'
- trueChoice: 'yes, I''m famished'
- falseChoice: 'no, I just ate'"
- | menu choice |
- menu := PopUpMenu labelArray: {trueChoice. falseChoice}.
- [(choice := menu startUpWithCaption: queryString icon: MenuIcons confirmIcon) isNil] whileTrue.
- ^ choice = 1!
Item was removed:
- ----- Method: PopUpMenu class>>inform: (in category 'dialogs') -----
- inform: aString
- "PopUpMenu inform: 'I like Squeak'"
-
- | iconOrNil |
- iconOrNil := Smalltalk at: #MenuIcons ifPresent: [:cls | cls confirmIcon].
- (PopUpMenu labels: ' OK ' translated)
- startUpWithCaption: aString
- icon: iconOrNil
- !
Item was removed:
- ----- Method: PopUpMenu class>>labelArray: (in category 'instance creation') -----
- labelArray: labelArray
- "Answer an instance of me whose items are in labelArray."
-
- ^ self labelArray: labelArray lines: nil!
Item was removed:
- ----- Method: PopUpMenu class>>labelArray:lines: (in category 'instance creation') -----
- labelArray: labelArray lines: lineArray
- "Answer an instance of me whose items are in labelArray, with lines
- drawn after each item indexed by anArray. 2/1/96 sw"
-
- labelArray isEmpty ifTrue: [self error: 'Menu must not be zero size'].
- ^ self
- labels: (String streamContents:
- [:stream |
- labelArray do: [:each | stream nextPutAll: each; cr].
- stream skip: -1 "remove last CR"])
- lines: lineArray
-
- "Example:
- (PopUpMenu labelArray: #('frog' 'and' 'toad') lines: #()) startUp"!
Item was removed:
- ----- Method: PopUpMenu class>>labels: (in category 'instance creation') -----
- labels: aString
- "Answer an instance of me whose items are in aString."
-
- ^ self labels: aString lines: nil!
Item was removed:
- ----- Method: PopUpMenu class>>labels:lines: (in category 'instance creation') -----
- labels: aString lines: anArray
- "Answer an instance of me whose items are in aString, with lines drawn
- after each item indexed by anArray."
-
- ^ self new
- labels: aString
- font: Preferences standardMenuFont
- lines: anArray!
Item was removed:
- ----- Method: PopUpMenu class>>notify: (in category 'dialogs') -----
- notify: message
- "Deprecated. Use #inform: instead."
-
- self inform: message!
Item was removed:
- ----- Method: PopUpMenu class>>standardMenuStyle (in category 'class initialization') -----
- standardMenuStyle
-
- ^ (TextStyle fontArray: { Preferences standardMenuFont })
- centered;
- yourself!
Item was removed:
- ----- Method: PopUpMenu class>>withCaption:chooseFrom: (in category 'instance creation') -----
- withCaption: cap chooseFrom: labels
- "Simply put up a menu. Get the args in the right order with the caption
- first. labels may be either an array of items or a string with CRs in it.
- May use backslashes for returns."
-
- ^ (labels isString
- ifTrue: [self labels: labels withCRs lines: nil]
- ifFalse: [self labelArray: labels lines: nil])
- startUpWithCaption: cap withCRs!
Item was removed:
- ----- Method: PopUpMenu>>center (in category 'accessing') -----
- center
- "Answer the point at the center of the receiver's rectangular area."
-
- ^ frame center!
Item was removed:
- ----- Method: PopUpMenu>>computeForm (in category 'private') -----
- computeForm
- "Compute and answer a Form to be displayed for this menu."
-
- | borderInset paraForm menuForm menuStyle inside |
- borderInset := 4@4.
- menuStyle := self class standardMenuStyle.
- paraForm := ((DisplayText text: labelString asText textStyle: menuStyle)
- foregroundColor: (self userInterfaceTheme textColor ifNil: [Color black])
- backgroundColor: (self userInterfaceTheme color ifNil: [Color white])) form.
- menuForm := Form extent: paraForm extent + (borderInset * 2) depth: paraForm depth.
- menuForm fill: (0 @ 0 extent: menuForm extent)
- rule: Form over
- fillColor: (self userInterfaceTheme color ifNil: [Color white]).
- menuForm
- border: menuForm boundingBox
- width: 2
- fillColor: (self userInterfaceTheme borderColor ifNil: [Color black]).
-
- paraForm displayOn: menuForm at: borderInset.
- lineArray == nil ifFalse:
- [lineArray do:
- [ :line |
- menuForm
- fill: (4 @ ((line * font lineGrid) + borderInset y)
- extent: (menuForm width - 8 @ 1))
- rule: Form over
- fillColor: (self userInterfaceTheme lineColor ifNil: [Color black])]].
-
- frame := Quadrangle new.
- frame region: menuForm boundingBox.
- frame borderWidth: 4.
- inside := frame inside.
- marker := inside topLeft extent: (inside width @ menuStyle lineGrid).
- selection := 1.
-
- ^ form := menuForm
- !
Item was removed:
- ----- Method: PopUpMenu>>controlActivity (in category 'basic control sequence') -----
- controlActivity
- "Do whatever a menu must do - now with keyboard support."
-
- | didNotMove downPos |
- didNotMove := true.
- Sensor anyButtonPressed
- ifFalse:
- [didNotMove := false.
- Sensor waitButtonOrKeyboard].
-
- Sensor keyboardPressed ifFalse: [self manageMarker].
- (didNotMove and: [selection = 0])
- ifTrue:
- [downPos := Sensor cursorPoint.
- [didNotMove and: [Sensor anyButtonPressed]]
- whileTrue:
- [ Project current world activeController interActivityPause.
- (downPos dist: Sensor cursorPoint) < 2 ifFalse: [didNotMove := false]].
- didNotMove ifTrue: [Sensor waitButtonOrKeyboard]].
-
- [Sensor keyboardPressed] whileTrue:
- [self readKeyboard ifTrue: [^ self].
- Sensor waitButtonOrKeyboard].
-
- [Sensor anyButtonPressed] whileTrue: [
- ScheduledControllers activeController interActivityPause.
- self manageMarker]!
Item was removed:
- ----- Method: PopUpMenu>>displayAt:withCaption:during: (in category 'displaying') -----
- displayAt: aPoint withCaption: captionOrNil during: aBlock
- "Display the receiver just to the right of aPoint while aBlock is evaluated. If the receiver is forced off screen, display it just to the right."
- | delta savedArea captionForm captionSave outerFrame captionText tFrame frameSaveLoc captionBox |
- marker ifNil: [self computeForm].
- frame := frame align: marker leftCenter with: aPoint + (2@0).
- outerFrame := frame.
- captionOrNil notNil ifTrue:
- [captionText := (DisplayText
- text: captionOrNil asText
- textStyle: self class standardMenuStyle copy centered)
- foregroundColor: (self userInterfaceTheme textColor ifNil: [Color black])
- backgroundColor: (self userInterfaceTheme color ifNil: [Color white]).
- tFrame := captionText boundingBox insetBy: -2.
- outerFrame := frame merge: (tFrame align: tFrame bottomCenter
- with: frame topCenter + (0@2))].
- delta := outerFrame amountToTranslateWithin: Display boundingBox.
- frame right > Display boundingBox right
- ifTrue: [delta := 0 - frame width @ delta y].
- frame := frame translateBy: delta.
- captionOrNil notNil ifTrue:
- [captionForm := captionText form.
- captionBox := captionForm boundingBox expandBy: 4.
- captionBox := captionBox align: captionBox bottomCenter
- with: frame topCenter + (0@2).
- captionSave := Form fromDisplay: captionBox.
- Display border: captionBox width: 4 fillColor: (self userInterfaceTheme color ifNil: [Color white]).
- Display border: captionBox width: 2 fillColor: (self userInterfaceTheme textColor ifNil: [Color black]).
- captionForm displayAt: captionBox topLeft + 4].
- marker := marker align: marker leftCenter with: aPoint + delta + (2@0).
- savedArea := Form fromDisplay: frame.
- self menuForm displayOn: Display at: (frameSaveLoc := frame topLeft).
- selection ~= 0 ifTrue: [Display reverse: marker].
- Cursor normal showWhile: aBlock.
- savedArea displayOn: Display at: frameSaveLoc.
- captionOrNil notNil ifTrue:
- [captionSave displayOn: Display at: captionBox topLeft]!
Item was removed:
- ----- Method: PopUpMenu>>frameHeight (in category 'accessing') -----
- frameHeight
- "Designed to avoid the entire frame computation (includes MVC form),
- since the menu may well end up being displayed in Morphic anyway."
- | nItems |
- frame ifNotNil: [^ frame height].
- nItems := 1 + (labelString occurrencesOf: Character cr).
- ^ (nItems * self class standardMenuStyle lineGrid) + 4 "border width"!
Item was removed:
- ----- Method: PopUpMenu>>labelString (in category 'accessing') -----
- labelString
- ^ labelString!
Item was removed:
- ----- Method: PopUpMenu>>labels:font:lines: (in category 'private') -----
- labels: aString font: aFont lines: anArray
-
- labelString := aString.
- font := aFont.
- lineArray := anArray.
- !
Item was removed:
- ----- Method: PopUpMenu>>lineArray (in category 'accessing') -----
- lineArray
- ^ lineArray!
Item was removed:
- ----- Method: PopUpMenu>>manageMarker (in category 'marker adjustment') -----
- manageMarker
- "If the cursor is inside the receiver's frame, then highlight the marked
- item. Otherwise no item is to be marked."
- | pt |
- "Don't let pt get far from display box, so scrolling will go all the way"
- pt := Sensor cursorPoint adhereTo: (Display boundingBox expandBy: 1).
- (frame inside containsPoint: pt)
- ifTrue: ["Need to cache the form for reasonable scrolling performance"
- ((Display boundingBox insetBy: 0@3) containsPoint: pt)
- ifFalse: [pt := pt - (self scrollIntoView: pt)].
- self markerOn: pt]
- ifFalse: [self markerOff]!
Item was removed:
- ----- Method: PopUpMenu>>markerOff (in category 'marker adjustment') -----
- markerOff
- "No item is selected. Reverse the highlight if any item has been marked
- as selected."
-
- self setSelection: 0!
Item was removed:
- ----- Method: PopUpMenu>>markerOn: (in category 'marker adjustment') -----
- markerOn: aPoint
- "The item whose bounding area contains aPoint should be marked as
- selected. Highlight its area and set the selection to its index."
-
- selection = 0 | (marker containsPoint: aPoint) not
- ifTrue: [selection = 0 & (marker containsPoint: aPoint)
- ifTrue: [Display reverse: marker]
- ifFalse:
- [selection > 0 ifTrue: [Display reverse: marker].
- marker :=
- marker
- align: marker topLeft
- with: marker left @ (self markerTop: aPoint).
- Display reverse: marker]].
- selection := marker top - frame top // marker height + 1!
Item was removed:
- ----- Method: PopUpMenu>>markerTop: (in category 'marker adjustment') -----
- markerTop: aPoint
- "Answer aPoint, gridded to lines in the receiver."
-
- ^(aPoint y - frame inside top truncateTo: font lineGrid) + frame inside top!
Item was removed:
- ----- Method: PopUpMenu>>menuForm (in category 'private') -----
- menuForm
- "Answer a Form to be displayed for this menu."
-
- form == nil ifTrue: [self computeForm].
- ^ form!
Item was removed:
- ----- Method: PopUpMenu>>nItems (in category 'accessing') -----
- nItems
- ^ (labelString occurrencesOf: Character cr) + 1!
Item was removed:
- ----- Method: PopUpMenu>>readKeyboard (in category 'basic control sequence') -----
- readKeyboard
- "Keyboard support for menus. ESC will abort the menu, Space or CR
- will select an item. Cursor up and cursor down will change the
- selection. Any other key will either select an item whose label starts
- with that character or select the next matching label.
- Answer true if the menu should be closed and false otherwise."
-
- | ch labels occurences |
- ch := Sensor keyboard asciiValue.
- (ch = 13 or: [ch = 32]) ifTrue: [^ true].
- ch = 27 ifTrue: [self setSelection: 0. ^ true].
- ch = 30
- ifTrue:
- [self setSelection: (selection <= 1
- ifTrue: [self nItems]
- ifFalse: [selection - 1])].
- ch = 31 ifTrue: [self setSelection: selection \\ self nItems + 1].
- ch := ch asCharacter asLowercase.
- labels := labelString lines.
- occurences := 0.
- 1 + selection to: selection + labels size do:
- [:index |
- | i | i := index - 1 \\ labels size + 1.
- (labels at: i) withBlanksTrimmed first asLowercase = ch
- ifTrue: [(occurences := occurences + 1) = 1 ifTrue: [self setSelection: i]]].
- ^ occurences = 1!
Item was removed:
- ----- Method: PopUpMenu>>rescan (in category 'private') -----
- rescan
- "Cause my form to be recomputed after a font change."
-
- labelString == nil ifTrue: [labelString := 'NoText!!'].
- self labels: labelString font: Preferences standardMenuFont lines: lineArray.
- frame := marker := form := nil.
-
- "PopUpMenu allSubInstancesDo: [:m | m rescan]"!
Item was removed:
- ----- Method: PopUpMenu>>scrollIntoView: (in category 'marker adjustment') -----
- scrollIntoView: cursorLoc
- | dy |
- dy := 0.
- cursorLoc y < 2 ifTrue: [dy := font height].
- cursorLoc y > (Display height-3) ifTrue: [dy := font height negated].
- dy = 0 ifTrue: [^ 0@0].
- self markerOff.
- frame := frame translateBy: 0@dy.
- marker := marker translateBy: 0@dy.
- self menuForm displayOn: Display at: frame topLeft.
- ^ 0@dy!
Item was removed:
- ----- Method: PopUpMenu>>selection (in category 'selecting') -----
- selection
- "Answer the current selection."
-
- ^ selection!
Item was removed:
- ----- Method: PopUpMenu>>setSelection: (in category 'selecting') -----
- setSelection: index
- | newSelection |
- selection = index ifTrue: [^ self].
- newSelection := (0 max: index) min: frame height // marker height.
- selection > 0 ifTrue: [Display reverse: marker].
- marker := marker translateBy: 0 @ (newSelection - selection * marker height).
- selection := newSelection.
- selection > 0 ifTrue: [Display reverse: marker]!
Item was removed:
- ----- Method: PopUpMenu>>startUp (in category 'basic control sequence') -----
- startUp
- "Display and make a selection from the receiver as long as the button
- is pressed. Answer the current selection."
-
- ^ self startUpWithCaption: nil!
Item was removed:
- ----- Method: PopUpMenu>>startUpCenteredWithCaption: (in category 'basic control sequence') -----
- startUpCenteredWithCaption: captionOrNil
- "Differs from startUpWithCaption: by appearing with cursor in the menu, and thus ready to act on mouseUp, without requiring user tweak to confirm"
-
- ^ self
- startUpWithCaption: captionOrNil
- at: (self currentHand ifNil: [Sensor]) cursorPoint - (20 @ 0)!
Item was removed:
- ----- Method: PopUpMenu>>startUpSegmented:withCaption:at: (in category 'basic control sequence') -----
- startUpSegmented: segmentHeight withCaption: captionOrNil at: location
- "This menu is too big to fit comfortably on the screen.
- Break it up into smaller chunks, and manage the relative indices.
- Inspired by a special-case solution by Reinier van Loon."
- "
- (PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1])
- lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'.
- "
- | nLines nLinesPer allLabels from to subset subLines index |
- frame ifNil: [self computeForm].
- allLabels := labelString lines.
- nLines := allLabels size.
- lineArray ifNil: [lineArray := Array new].
- nLinesPer := segmentHeight // marker height - 3.
- from := 1.
- [to := (from + nLinesPer) min: nLines.
- subset := allLabels copyFrom: from to: to.
- subset add: (to = nLines ifTrue: ['start over...' translated] ifFalse: ['more...' translated])
- before: subset first.
- subLines := lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1].
- subLines := (Array with: 1) , subLines.
- index := (PopUpMenu labels: subset asStringWithCr lines: subLines)
- startUpWithCaption: captionOrNil at: location.
- index = 1
- ifTrue: [from := to + 1.
- from > nLines ifTrue: [ from := 1 ]]
- ifFalse: [index = 0 ifTrue: [^ 0].
- ^ from + index - 2]] repeat!
Item was removed:
- ----- Method: PopUpMenu>>startUpSegmented:withCaption:at:allowKeyboard: (in category 'basic control sequence') -----
- startUpSegmented: segmentHeight withCaption: captionOrNil at: location allowKeyboard: aBoolean
- "This menu is too big to fit comfortably on the screen.
- Break it up into smaller chunks, and manage the relative indices.
- Inspired by a special-case solution by Reinier van Loon. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)"
-
- "
- (PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1])
- lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'.
- "
- | nLines nLinesPer allLabels from to subset subLines index |
- frame ifNil: [self computeForm].
- allLabels := labelString lines.
- nLines := allLabels size.
- lineArray ifNil: [lineArray := Array new].
- nLinesPer := segmentHeight // marker height - 3.
- from := 1.
- [to := (from + nLinesPer) min: nLines.
- subset := (allLabels copyFrom: from to: to) asOrderedCollection.
- subset add: (to = nLines ifTrue: ['start over...' translated] ifFalse: ['more...' translated])
- before: subset first.
- subLines := lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1].
- subLines := (Array with: 1) , subLines.
- index := (PopUpMenu labels: subset asStringWithCr lines: subLines)
- startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean.
- index = 1
- ifTrue: [from := to + 1.
- from > nLines ifTrue: [ from := 1 ]]
- ifFalse: [index = 0 ifTrue: [^ 0].
- ^ from + index - 2]] repeat!
Item was removed:
- ----- Method: PopUpMenu>>startUpWithCaption: (in category 'basic control sequence') -----
- startUpWithCaption: captionOrNil
- "Display the menu, slightly offset from the cursor,
- so that a slight tweak is required to confirm any action."
- self flag: #fix. "mt: Could we manage to open pop-up menus in Morphic without accessing self currentHand?"
-
- ^ self
- startUpWithCaption: captionOrNil
- at: (self currentHand ifNil: [Sensor]) cursorPoint!
Item was removed:
- ----- Method: PopUpMenu>>startUpWithCaption:at: (in category 'basic control sequence') -----
- startUpWithCaption: captionOrNil at: location
- "Display the menu, with caption if supplied. Wait for the mouse button to go down,
- then track the selection as long as the button is pressed. When the button is released,
- answer the index of the current selection, or zero if the mouse is not released over
- any menu item. Location specifies the desired topLeft of the menu body rectangle."
-
- ^ self startUpWithCaption: captionOrNil at: location allowKeyboard: Preferences menuKeyboardControl!
Item was removed:
- ----- Method: PopUpMenu>>startUpWithCaption:at:allowKeyboard: (in category 'basic control sequence') -----
- startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean
- "Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released,
- Answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard."
-
- ^ self
- startUpWithCaption: captionOrNil
- icon: nil
- at: location
- allowKeyboard: aBoolean!
Item was removed:
- ----- Method: PopUpMenu>>startUpWithCaption:icon: (in category 'basic control sequence') -----
- startUpWithCaption: captionOrNil icon: aForm
- "Display the menu, slightly offset from the cursor, so that a slight tweak is required to confirm any action."
-
- ^ self
- startUpWithCaption: captionOrNil
- icon: aForm
- at: (self currentHand ifNil: [Sensor]) cursorPoint!
Item was removed:
- ----- Method: PopUpMenu>>startUpWithCaption:icon:at: (in category 'basic control sequence') -----
- startUpWithCaption: captionOrNil icon: aForm at: location
- "Display the menu, with caption if supplied. Wait for the mouse button to go down,
- then track the selection as long as the button is pressed. When the button is released,
- answer the index of the current selection, or zero if the mouse is not released over
- any menu item. Location specifies the desired topLeft of the menu body rectangle."
-
- ^ self
- startUpWithCaption: captionOrNil
- icon: aForm
- at: location
- allowKeyboard: Preferences menuKeyboardControl
- !
Item was removed:
- ----- Method: PopUpMenu>>startUpWithCaption:icon:at:allowKeyboard: (in category 'basic control sequence') -----
- startUpWithCaption: captionOrNil icon: aForm at: location allowKeyboard: aBoolean
- "Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released,
- Answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard."
-
- | maxHeight |
- (ProvideAnswerNotification signal: captionOrNil) ifNotNil:
- [:answer | ^ selection := answer ifTrue: [1] ifFalse: [2]].
-
- maxHeight := Display height*3//4.
- self frameHeight > maxHeight ifTrue:
- [^ self
- startUpSegmented: maxHeight
- withCaption: captionOrNil
- at: location
- allowKeyboard: aBoolean].
-
- ^ Project uiManager startUpMenu: self withCaption: captionOrNil icon: aForm at: location allowKeyboard: aBoolean!
Item was removed:
- ----- Method: PopUpMenu>>startUpWithoutKeyboard (in category 'basic control sequence') -----
- startUpWithoutKeyboard
- "Display and make a selection from the receiver as long as the button is pressed. Answer the current selection. Do not allow keyboard input into the menu"
-
- ^ self
- startUpWithCaption: nil
- at: ((self currentHand ifNil: [Sensor]) cursorPoint)
- allowKeyboard: false!
Item was removed:
- Model subclass: #ProcessBrowser
- instanceVariableNames: 'selectedProcess selectedContext methodText processList processListIndex stackList stackListIndex stackDepth sourceMap selectedClass selectedSelector searchString autoUpdateProcess lastUpdate startedCPUWatcher'
- classVariableNames: 'Browsers SuspendedProcesses WellKnownProcesses'
- poolDictionaries: ''
- category: 'Tools-Process Browser'!
-
- !ProcessBrowser commentStamp: '<historical>' prior: 0!
- Change Set: ProcessBrowser
- Date: 14 March 2000
- Author: Ned Konz
-
- email: ned(a)bike-nomad.com
-
- This is distributed under the Squeak License.
-
- Added 14 March:
- CPUWatcher integration
- automatically start and stop CPUWatcher
- added CPUWatcher to process list menu
-
- Added 29 October:
- MVC version
- 2.8, 2.7 compatibility
- rearranged menus
- added pointer inspection and chasing
- added suspend/resume
- recognized more well-known processes
- misc. bug fixes
-
- Added 26 October: highlight pc in source code
- Added 27 October: added 'signal semaphore'
- added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu
- added 'find context', 'next context' to process list menu
- added 'change priority' and 'debug' choices to process list menu
-
- 27 October mods by Bob Arning:
-
- alters process display in Ned's ProcessBrowser to
- - show process priority
- - drop 'a Process in' that appears on each line
- - show in priority order
- - prettier names for known processes
- - fix to Utilities to forget update downloading process when it ends (1 less dead
- process)
- - correct stack dump for the active process
- !
Item was removed:
- ----- Method: ProcessBrowser class>>cleanUp (in category 'class initialization') -----
- cleanUp
- "Remove terminated processes from my suspended list"
-
- self suspendedProcesses keys do: [:ea |
- ea isTerminated ifTrue: [self suspendedProcesses removeKey: ea]]!
Item was removed:
- ----- Method: ProcessBrowser class>>debugProcess: (in category 'process control') -----
- debugProcess: aProcess
- (aProcess isActiveProcess ifTrue: [Processor] ifFalse: [aProcess])
- debugWithTitle: 'Interrupted from the Process Browser' translated
- full: true.!
Item was removed:
- ----- Method: ProcessBrowser class>>destroyProcess: (in category 'process control') -----
- destroyProcess: aProcess
-
- aProcess ifNil: [^ self].
-
- self suspendedProcesses
- removeKey: aProcess
- ifAbsent: [].
- aProcess destroy.!
Item was removed:
- ----- Method: ProcessBrowser class>>dumpTallyOnTranscript: (in category 'CPU utilization') -----
- dumpTallyOnTranscript: tally
- "tally is from ProcessorScheduler>>tallyCPUUsageFor:
- Dumps lines with percentage of time, hash of process, and a friendly name"
-
- tally sortedCounts do: [ :assoc | | procName |
- procName := (self nameAndRulesFor: assoc value) first.
- Transcript print: (((assoc key / tally size) * 100.0) roundTo: 1);
- nextPutAll: '% ';
- print: assoc value identityHash; space;
- nextPutAll: procName;
- cr.
- ].
- Transcript flush.!
Item was removed:
- ----- Method: ProcessBrowser class>>initialize (in category 'class initialization') -----
- initialize
- "ProcessBrowser initialize"
- Browsers ifNil: [ Browsers := WeakSet new ].
- SuspendedProcesses ifNil: [ SuspendedProcesses := IdentityDictionary new ].
- Smalltalk addToStartUpList: self.
- Smalltalk addToShutDownList: self.
- self registerInFlapsRegistry.
- self registerWellKnownProcesses!
Item was removed:
- ----- Method: ProcessBrowser class>>isUIProcess: (in category 'process control') -----
- isUIProcess: aProcess
- ^aProcess == Project uiProcess
- !
Item was removed:
- ----- Method: ProcessBrowser class>>nameAndRulesFor: (in category 'process control') -----
- nameAndRulesFor: aProcess
- "Answer a nickname and two flags: allow-stop, and allow-debug"
- ^ [aProcess caseOf: WellKnownProcesses
- otherwise:
- [(aProcess priority = Processor timingPriority
- and: [aProcess suspendedContext receiver == Delay])
- ifTrue: [{'the timer interrupt watcher'. false. false}]
- ifFalse: [{aProcess suspendedContext asString. true. true}]]]
- ifError: [:err :rcvr | {aProcess suspendedContext asString. true. true}]!
Item was removed:
- ----- Method: ProcessBrowser class>>open (in category 'instance creation') -----
- open
- ^ToolBuilder open: self new!
Item was removed:
- ----- Method: ProcessBrowser class>>postRecompileAction (in category 'recompilation') -----
- postRecompileAction
- "Reinitialize the standard WellKnownProcesses. Each registration includes a couple of
- block references that need to be freshened post recompile."
-
- WellKnownProcesses ifNotNil:
- [:oldWKP|
- self registerWellKnownProcesses.
- "Attempt to preserve any user additions..."
- WellKnownProcesses addAllLast: (oldWKP allButFirst: WellKnownProcesses size)]!
Item was removed:
- ----- Method: ProcessBrowser class>>prototypicalToolWindow (in category 'instance creation') -----
- prototypicalToolWindow
- "Answer a window representing a prototypical instance of the receiver"
-
- ^ ToolBuilder build: self new!
Item was removed:
- ----- Method: ProcessBrowser class>>registerInFlapsRegistry (in category 'class initialization') -----
- registerInFlapsRegistry
- "Register the receiver in the system's flaps registry"
- self environment
- at: #Flaps
- ifPresent: [:cl | cl registerQuad: {#ProcessBrowser. #prototypicalToolWindow. 'Processes' translatedNoop. 'A Process Browser shows you all the running processes' translatedNoop}
- forFlapNamed: 'Tools'.]!
Item was removed:
- ----- Method: ProcessBrowser class>>registerWellKnownProcess:label:allowStop:allowDebug: (in category 'process control') -----
- registerWellKnownProcess: aBlockForProcess label: nickname allowStop: allowStop allowDebug: allowDebug
- "Add an entry to the registry of well known processes. aBlockForProcess
- evaluates to a known process to be identified by nickname, and allowStop
- and allowDebug are flags controlling allowable actions for this process
- in the browser."
-
- WellKnownProcesses add: aBlockForProcess->[{nickname . allowStop . allowDebug}]!
Item was removed:
- ----- Method: ProcessBrowser class>>registerWellKnownProcesses (in category 'class initialization') -----
- registerWellKnownProcesses
- "Associate each well-known process with a nickname and two flags: allow-stop, and allow-debug.
- Additional processes may be added to this list as required"
-
- WellKnownProcesses := OrderedCollection new.
- self registerWellKnownProcess: []
- label: 'no process'
- allowStop: false
- allowDebug: false.
- self registerWellKnownProcess: [Smalltalk lowSpaceWatcherProcess]
- label: 'the low space watcher'
- allowStop: false
- allowDebug: false.
- self registerWellKnownProcess: [WeakArray runningFinalizationProcess]
- label: 'the WeakArray finalization process'
- allowStop: false
- allowDebug: false.
- self registerWellKnownProcess: [Processor activeProcess]
- label: 'the UI process'
- allowStop: true
- allowDebug: true.
- self registerWellKnownProcess: [Processor backgroundProcess]
- label: 'the idle process'
- allowStop: false
- allowDebug: false.
- self registerWellKnownProcess: [Sensor interruptWatcherProcess]
- label: 'the user interrupt watcher'
- allowStop: false
- allowDebug: false.
- self registerWellKnownProcess: [Sensor eventTicklerProcess]
- label: 'the event tickler'
- allowStop: false
- allowDebug: false.
- self registerWellKnownProcess: [Project uiProcess]
- label: 'the inactive Morphic UI process'
- allowStop: true
- allowDebug: true.
- " self registerWellKnownProcess:
- [Smalltalk at: #SoundPlayer ifPresent: [:sp | sp playerProcess]]
- label: 'the Sound Player'
- allowStop: false
- allowDebug: false."
- self registerWellKnownProcess:
- [ScheduledControllers ifNotNil: [ScheduledControllers activeControllerProcess]]
- label: 'the inactive MVC controller process'
- allowStop: false
- allowDebug: true.
- self registerWellKnownProcess:
- [Smalltalk at: #CPUWatcher ifPresent: [:cw | cw currentWatcherProcess]]
- label: 'the CPUWatcher'
- allowStop: false
- allowDebug: false
- !
Item was removed:
- ----- Method: ProcessBrowser class>>resumeProcess: (in category 'process control') -----
- resumeProcess: aProcess
- | priority |
- priority := self suspendedProcesses
- removeKey: aProcess
- ifAbsent: [aProcess priority].
- aProcess priority: priority.
- aProcess suspendedContext ifNotNil: [ aProcess resume ]
- !
Item was removed:
- ----- Method: ProcessBrowser class>>setProcess:toPriority: (in category 'process control') -----
- setProcess: aProcess toPriority: priority
- | oldPriority |
- oldPriority := self suspendedProcesses at: aProcess ifAbsent: [ ].
- oldPriority ifNotNil: [ self suspendedProcesses at: aProcess put: priority ].
- aProcess priority: priority.
- ^oldPriority!
Item was removed:
- ----- Method: ProcessBrowser class>>shutDown (in category 'system startup') -----
- shutDown
- Browsers do: [ :ea | ea isAutoUpdating ifTrue: [ ea pauseAutoUpdate ]]!
Item was removed:
- ----- Method: ProcessBrowser class>>startUp (in category 'system startup') -----
- startUp
- Browsers
- do: [:ea | ea isAutoUpdatingPaused
- ifTrue: [ea initialize; startAutoUpdate]
- ifFalse: [ea initialize]]!
Item was removed:
- ----- Method: ProcessBrowser class>>suspendProcess: (in category 'process control') -----
- suspendProcess: aProcess
- | priority |
- priority := aProcess priority.
- self suspendedProcesses at: aProcess put: priority.
- "Need to take the priority down below the caller's
- so that it can keep control after signaling the Semaphore"
- (aProcess suspendingList isKindOf: Semaphore)
- ifTrue: [aProcess priority: Processor lowestPriority.
- aProcess suspendingList signal].
- [aProcess suspend]
- on: Error
- do: [:ex | self suspendedProcesses removeKey: aProcess].
- aProcess priority: priority.
- !
Item was removed:
- ----- Method: ProcessBrowser class>>suspendedProcesses (in category 'process control') -----
- suspendedProcesses
- "Answer a collection of processes that my instances have suspended.
- This is so that they don't get garbage collected."
- ^ SuspendedProcesses
- ifNil: [SuspendedProcesses := IdentityDictionary new]!
Item was removed:
- ----- Method: ProcessBrowser class>>tallyCPUUsageFor: (in category 'CPU utilization') -----
- tallyCPUUsageFor: seconds
- "Compute CPU usage using a 10-msec sample for the given number of seconds,
- then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile"
- "ProcessBrowser tallyCPUUsageFor: 10"
- ^self tallyCPUUsageFor: seconds every: 10!
Item was removed:
- ----- Method: ProcessBrowser class>>tallyCPUUsageFor:every: (in category 'CPU utilization') -----
- tallyCPUUsageFor: seconds every: msec
- "Compute CPU usage using a msec millisecond sample for the given number of seconds,
- then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile"
- "ProcessBrowser tallyCPUUsageFor: 10 every: 100"
-
- | promise |
- promise := Processor tallyCPUUsageFor: seconds every: msec.
-
- [ | tally |
- tally := promise value.
- Smalltalk isMorphic
- ifTrue: [ Project current addDeferredUIMessage: [ self dumpTallyOnTranscript: tally ] ]
- ifFalse: [ [ Transcript open ] forkAt: Processor userSchedulingPriority.
- [ (Delay forSeconds: 1) wait.
- self dumpTallyOnTranscript: tally ] forkAt: Processor userSchedulingPriority.]
- ] fork.!
Item was removed:
- ----- Method: ProcessBrowser class>>terminateProcess: (in category 'process control') -----
- terminateProcess: aProcess
-
- ^ self terminateProcess: aProcess aggressively: false!
Item was removed:
- ----- Method: ProcessBrowser class>>terminateProcess:aggressively: (in category 'process control') -----
- terminateProcess: aProcess aggressively: aggressive
-
- aProcess ifNil: [^ self].
-
- self suspendedProcesses
- removeKey: aProcess
- ifAbsent: [].
- aggressive
- ifFalse: [aProcess terminate]
- ifTrue: [aProcess terminateAggressively].!
Item was removed:
- ----- Method: ProcessBrowser class>>unload (in category 'class initialization') -----
- unload
- "Unload the receiver from global registries"
-
- self environment at: #Flaps ifPresent: [:cl |
- cl unregisterQuadsWithReceiver: self] !
Item was removed:
- ----- Method: ProcessBrowser class>>unregisterWellKnownProcess: (in category 'process control') -----
- unregisterWellKnownProcess: aProcess
- "Remove the first registry entry that matches aProcess. Use
- with caution if more than one registry entry may match aProcess."
-
- "self unregisterWellKnownProcess: Smalltalk lowSpaceWatcherProcess"
-
- | entry |
- entry := WellKnownProcesses
- detect: [:e | e key value == aProcess]
- ifNone: [^ self].
- WellKnownProcesses remove: entry!
Item was removed:
- ----- Method: ProcessBrowser class>>wasProcessSuspendedByProcessBrowser: (in category 'process control') -----
- wasProcessSuspendedByProcessBrowser: aProcess
- ^self suspendedProcesses includesKey: aProcess!
Item was removed:
- ----- Method: ProcessBrowser>>browseContext (in category 'stack list') -----
- browseContext
- ToolSet browseMethod: selectedContext home method!
Item was removed:
- ----- Method: ProcessBrowser>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- "Create a pluggable version of me, answer a window"
- | windowSpec listSpec textSpec |
- windowSpec := builder pluggableWindowSpec new.
- windowSpec model: self.
- windowSpec label: 'Process Browser'.
- windowSpec children: OrderedCollection new.
-
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #processNameList;
- getIndex: #processListIndex;
- setIndex: #processListIndex:;
- menu: #processListMenu:shifted:;
- keyPress: #processListKey:from:;
- frame: (0 @ 0 extent: 0.5 @ 0.5).
- windowSpec children add: listSpec.
-
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #stackNameList;
- getIndex: #stackListIndex;
- setIndex: #stackListIndex:;
- menu: #stackListMenu:;
- keyPress: #stackListKey:from:;
- frame: (0.5 @ 0.0 extent: 0.5 @ 0.5).
- windowSpec children add: listSpec.
-
- textSpec := builder pluggableTextSpec new.
- textSpec
- model: self;
- getText: #selectedMethod;
- setText: nil;
- selection: nil;
- menu: nil;
- frame: (0 @ 0.5 corner: 1 @ 1).
- windowSpec children add: textSpec.
-
- ^builder build: windowSpec!
Item was removed:
- ----- Method: ProcessBrowser>>changePriority (in category 'process actions') -----
- changePriority
- | str newPriority nameAndRules |
- nameAndRules := self nameAndRulesForSelectedProcess.
- nameAndRules third ifFalse: [
- ^ self inform: ('Nope, won''t change priority of {1}' translated format: {nameAndRules first})].
-
- str := Project uiManager
- request: 'New priority' translated
- initialAnswer: selectedProcess priority asString.
- str isEmptyOrNil ifTrue: [^ self].
-
- newPriority := str asNumber asInteger.
- newPriority ifNil: [^ self].
- (newPriority < 1
- or: [newPriority > Processor highestPriority])
- ifTrue: [^ self inform: 'Bad priority' translated].
-
- self class setProcess: selectedProcess toPriority: newPriority.
- self updateProcessList.!
Item was removed:
- ----- Method: ProcessBrowser>>changeStackListTo: (in category 'stack list') -----
- changeStackListTo: aCollection
-
- stackList := aCollection.
- self changed: #stackNameList.
- self stackListIndex: 0!
Item was removed:
- ----- Method: ProcessBrowser>>chasePointers (in category 'process actions') -----
- chasePointers
- | saved |
- saved := selectedProcess.
- [selectedProcess := nil.
- (Smalltalk includesKey: #PointerFinder)
- ifTrue: [PointerFinder on: saved]
- ifFalse: [self inspectPointers]]
- ensure: [selectedProcess := saved]!
Item was removed:
- ----- Method: ProcessBrowser>>copyProcessStackToClipboard (in category 'process list') -----
- copyProcessStackToClipboard
- | stackStream startContext |
- stackStream := WriteStream on: (String new: 256).
- startContext := selectedProcess == Processor activeProcess
- ifTrue: [thisContext]
- ifFalse: [selectedProcess suspendedContext].
- startContext findContextSuchThat:
- [:context|
- stackStream print: context; cr.
- false].
- Clipboard clipboardText: stackStream contents!
Item was removed:
- ----- Method: ProcessBrowser>>debugProcess (in category 'process actions') -----
- debugProcess
- | nameAndRules |
- nameAndRules := self nameAndRulesForSelectedProcess.
- nameAndRules third
- ifFalse: [self inform: 'Nope, won''t debug ' , nameAndRules first.
- ^ self].
- self class debugProcess: selectedProcess.!
Item was removed:
- ----- Method: ProcessBrowser>>destroyProcess (in category 'process actions') -----
- destroyProcess
-
- | nameAndRules |
- nameAndRules := self nameAndRulesForSelectedProcess.
- nameAndRules second ifFalse: [
- ^ self inform: ('Nope, won''t destroy {1}' translated format: {nameAndRules first})].
- self class destroyProcess: selectedProcess.
- self updateProcessList.!
Item was removed:
- ----- Method: ProcessBrowser>>exploreContext (in category 'stack list') -----
- exploreContext
- selectedContext explore!
Item was removed:
- ----- Method: ProcessBrowser>>exploreProcess (in category 'process list') -----
- exploreProcess
- selectedProcess explore!
Item was removed:
- ----- Method: ProcessBrowser>>exploreReceiver (in category 'stack list') -----
- exploreReceiver
- selectedContext receiver explore!
Item was removed:
- ----- Method: ProcessBrowser>>findContext (in category 'process list') -----
- findContext
- | initialProcessIndex initialStackIndex found |
- initialProcessIndex := self processListIndex.
- initialStackIndex := self stackListIndex.
- searchString := Project uiManager
- request: 'Enter a string to search for in the process stack lists' translated
- initialAnswer: searchString.
- searchString isEmpty
- ifTrue: [^ false].
- self processListIndex: 1.
- self stackListIndex: 1.
- found := self nextContext.
- found
- ifFalse: [self processListIndex: initialProcessIndex.
- self stackListIndex: initialStackIndex].
- ^ found!
Item was removed:
- ----- Method: ProcessBrowser>>fullStack (in category 'stack list') -----
- fullStack
- stackDepth := SmallInteger maxVal.
- self updateStackList!
Item was removed:
- ----- Method: ProcessBrowser>>hasView (in category 'views') -----
- hasView
- ^self dependents isEmptyOrNil not!
Item was removed:
- ----- Method: ProcessBrowser>>initialize (in category 'initialize-release') -----
- initialize
- methodText := ''..
- stackDepth := 20.
- stackListIndex := 0.
- searchString := ''.
- lastUpdate := 0.
- startedCPUWatcher := CPUWatcher cpuWatcherEnabled and: [ self startCPUWatcher ].
- self updateProcessList; processListIndex: 1.
- Browsers add: self!
Item was removed:
- ----- Method: ProcessBrowser>>inspectContext (in category 'stack list') -----
- inspectContext
- selectedContext inspect!
Item was removed:
- ----- Method: ProcessBrowser>>inspectPointers (in category 'process actions') -----
- inspectPointers
- | tc pointers |
- tc := thisContext.
- pointers := PointerFinder
- pointersTo: selectedProcess
- except: {
- self processList.
- tc.
- self}.
- pointers isEmpty ifTrue: [^ self].
- ToolSet
- inspect: pointers
- label: 'Objects pointing to ' , selectedProcess browserPrintString!
Item was removed:
- ----- Method: ProcessBrowser>>inspectProcess (in category 'process list') -----
- inspectProcess
- selectedProcess inspect!
Item was removed:
- ----- Method: ProcessBrowser>>inspectReceiver (in category 'stack list') -----
- inspectReceiver
- selectedContext receiver inspect!
Item was removed:
- ----- Method: ProcessBrowser>>isAutoUpdating (in category 'updating') -----
- isAutoUpdating
- ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended not ]!
Item was removed:
- ----- Method: ProcessBrowser>>isAutoUpdatingPaused (in category 'updating') -----
- isAutoUpdatingPaused
- ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended ]!
Item was removed:
- ----- Method: ProcessBrowser>>messageTally (in category 'stack list') -----
- messageTally
- | secString secs |
- secString := Project uiManager request: 'Profile for how many seconds?' translated initialAnswer: '4'.
- secString isEmptyOrNil ifTrue: [^ self].
- secs := secString asNumber asInteger.
- (secs isNil or: [secs isZero])
- ifTrue: [^ self].
- [ TimeProfileBrowser spyOnProcess: selectedProcess forMilliseconds: secs * 1000 ] forkAt: selectedProcess priority + 1.!
Item was removed:
- ----- Method: ProcessBrowser>>moreStack (in category 'stack list') -----
- moreStack
- stackDepth := stackDepth + stackDepth.
- self updateStackList!
Item was removed:
- ----- Method: ProcessBrowser>>nameAndRulesFor: (in category 'process actions') -----
- nameAndRulesFor: aProcess
- "Answer a nickname and two flags: allow-stop, and allow-debug"
- aProcess == autoUpdateProcess ifTrue: [ ^{'my auto-update process'. true. true} ].
- ^self class nameAndRulesFor: aProcess
- !
Item was removed:
- ----- Method: ProcessBrowser>>nameAndRulesForSelectedProcess (in category 'process actions') -----
- nameAndRulesForSelectedProcess
- "Answer a nickname and two flags: allow-stop, and allow-debug"
- ^self nameAndRulesFor: selectedProcess!
Item was removed:
- ----- Method: ProcessBrowser>>nextContext (in category 'process list') -----
- nextContext
- | initialProcessIndex initialStackIndex |
- searchString isEmpty ifTrue: [ ^false ].
- initialProcessIndex := self processListIndex.
- initialStackIndex := self stackListIndex.
- initialProcessIndex
- to: self processList size
- do: [:pi | self processListIndex: pi.
- self stackNameList
- withIndexDo: [:name :si | (pi ~= initialProcessIndex
- or: [si > initialStackIndex])
- ifTrue: [(name includesSubstring: searchString)
- ifTrue: [self stackListIndex: si.
- ^true]]]].
- self processListIndex: initialProcessIndex.
- self stackListIndex: initialStackIndex.
- ^ false!
Item was removed:
- ----- Method: ProcessBrowser>>notify:at:in: (in category 'process list') -----
- notify: errorString at: location in: aStream
- "A syntax error happened when I was trying to highlight my pc.
- Raise a signal so that it can be ignored."
- Warning signal: 'syntax error'!
Item was removed:
- ----- Method: ProcessBrowser>>pauseAutoUpdate (in category 'updating') -----
- pauseAutoUpdate
- self isAutoUpdating
- ifTrue: [ autoUpdateProcess suspend ].
- self updateProcessList!
Item was removed:
- ----- Method: ProcessBrowser>>pcRange (in category 'stack list') -----
- pcRange
- "Answer the indices in the source code for the method corresponding to
- the selected context's program counter value."
- (selectedContext isNil or: [methodText isEmptyOrNil]) ifTrue:
- [^ 1 to: 0].
- ^selectedContext debuggerMap
- rangeForPC: (selectedContext pc ifNil: [selectedContext method endPC])
- in: selectedContext method
- contextIsActiveContext: stackListIndex = 1!
Item was removed:
- ----- Method: ProcessBrowser>>prettyNameForProcess: (in category 'process list') -----
- prettyNameForProcess: aProcess
- | nameAndRules |
- aProcess ifNil: [ ^'<nil>' ].
- nameAndRules := self nameAndRulesFor: aProcess.
- ^ aProcess browserPrintStringWith: nameAndRules first!
Item was removed:
- ----- Method: ProcessBrowser>>processList (in category 'accessing') -----
- processList
- ^ processList!
Item was removed:
- ----- Method: ProcessBrowser>>processListIndex (in category 'accessing') -----
- processListIndex
- ^ processListIndex!
Item was removed:
- ----- Method: ProcessBrowser>>processListIndex: (in category 'accessing') -----
- processListIndex: index
- processListIndex := index.
- selectedProcess := processList
- at: index
- ifAbsent: [].
- self updateStackList.
- self changed: #processListIndex.!
Item was removed:
- ----- Method: ProcessBrowser>>processListKey:from: (in category 'process list') -----
- processListKey: aKey from: aView
-
- aKey
- caseOf: {
- [$f] -> [^ self findContext].
- [$g] -> [^ self nextContext].
- [$a] -> [^ self toggleAutoUpdate].
- [$u] -> [^ self updateProcessList] }
- otherwise: [].
- selectedProcess ifNil: [^ self changed: #flash].
- ^ aKey
- caseOf: {
- [$i] -> [self inspectProcess].
- [$I] -> [self exploreProcess].
- [$c] -> [self chasePointers].
- [$P] -> [self inspectPointers].
- [$t] -> [self terminateProcess].
- [$T] -> [self terminateProcessAggressively].
- [$r] -> [self resumeProcess].
- [$s] -> [self suspendProcess].
- [$d] -> [self debugProcess].
- [$p] -> [self changePriority].
- [$m] -> [self messageTally].
- [$S] -> [self signalSemaphore].
- [$k] -> [self fullStack]}
- otherwise: [self arrowKey: aKey from: aView]!
Item was removed:
- ----- Method: ProcessBrowser>>processListMenu:shifted: (in category 'process list') -----
- processListMenu: menu shifted: shifted
-
- selectedProcess ifNotNil:
- [:process|
- [:name :allowStop :allowDebug|
- menu addList: #(('inspect (i)' inspectProcess) ('explore (I)' exploreProcess) ('inspect Pointers (P)' inspectPointers)).
- (Smalltalk includesKey: #PointerFinder) ifTrue:
- [menu add: 'chase pointers (c)' translated action: #chasePointers].
- menu addLine.
- allowStop ifTrue:
- [menu add: 'terminate (t)' translated action: #terminateProcess.
- menu add: 'terminate aggressively (T)' translated action: #terminateProcessAggressively.
- shifted ifTrue:
- [menu
- add: 'destroy' translated action: #destroyProcess;
- balloonTextForLastItem: (Process firstCommentAt: #destroy)].
- process isSuspended
- ifTrue: [menu add: 'resume (r)' translated action: #resumeProcess]
- ifFalse: [menu add: 'suspend (s)' translated action: #suspendProcess]].
- allowDebug ifTrue:
- [menu addList: #(('change priority (p)' changePriority) ('debug (d)' debugProcess))].
- menu add: 'profile messages (m)' action: #messageTally.
- (process suspendingList isKindOf: Semaphore) ifTrue:
- [menu add: 'signal Semaphore (S)' translated action: #signalSemaphore].
- menu addList: #(('full stack (k)' fullStack) ('copy stack to clipboard' copyProcessStackToClipboard)).
- menu addLine] valueWithArguments: (self nameAndRulesFor: process)].
-
- menu
- addList: #(#('find context... (f)' findContext) #('find again (g)' nextContext));
- addLine;
- add: (self isAutoUpdating
- ifTrue: ['turn off auto-update (a)' translated]
- ifFalse: ['turn on auto-update (a)' translated])
- action: #toggleAutoUpdate;
- add: 'update list (u)' translated action: #updateProcessList.
-
- (Smalltalk at: #CPUWatcher ifAbsent: []) ifNotNil:
- [:pw|
- menu addLine.
- pw isMonitoring
- ifTrue: [menu add: 'stop CPUWatcher' translated action: #stopCPUWatcher]
- ifFalse: [menu add: 'start CPUWatcher' translated action: #startCPUWatcher]].
-
- ^menu!
Item was removed:
- ----- Method: ProcessBrowser>>processNameList (in category 'process list') -----
- processNameList
- "since processList is a WeakArray, we have to strengthen the result"
- | pw tally |
- pw := Smalltalk at: #CPUWatcher ifAbsent: [ ].
- tally := pw ifNotNil: [ pw current ifNotNil: [ pw current tally ] ].
- ^ (processList asOrderedCollection
- copyWithout: nil)
- collect: [:each | | percent |
- percent := tally
- ifNotNil: [ ((((tally occurrencesOf: each) * 100.0 / tally size) roundTo: 1)
- asString padded: #left to: 2 with: $ ), '% ' ]
- ifNil: [ '' ].
- percent, (self prettyNameForProcess: each)
- ] !
Item was removed:
- ----- Method: ProcessBrowser>>resumeProcess (in category 'process actions') -----
- resumeProcess
- self class resumeProcess: selectedProcess.
- self updateProcessList!
Item was removed:
- ----- Method: ProcessBrowser>>selectedClass (in category 'accessing') -----
- selectedClass
- "Answer the class in which the currently selected context's method was
- found."
- ^ selectedClass
- ifNil: [
- selectedContext ifNil: [^ nil].
- selectedClass := selectedContext receiver
- ifNil: [selectedSelector := selectedContext method selector.
- selectedContext method methodClass]
- ifNotNil: [selectedContext methodClass]]!
Item was removed:
- ----- Method: ProcessBrowser>>selectedMethod (in category 'accessing') -----
- selectedMethod
- ^ methodText ifNil: [methodText := selectedContext
- ifNil: ['']
- ifNotNil: [| pcRange |
- methodText := [ selectedContext sourceCode ]
- ifError: [ :err :rcvr | 'error getting method text' ].
- pcRange := self pcRange.
- methodText asText
- addAttribute: TextColor red
- from: pcRange first
- to: pcRange last;
-
- addAttribute: TextEmphasis bold
- from: pcRange first
- to: pcRange last]]!
Item was removed:
- ----- Method: ProcessBrowser>>selectedProcess (in category 'accessing') -----
- selectedProcess
-
- self processListIndex = 0 ifTrue: [^ nil].
- ^ self processList at: self processListIndex!
Item was removed:
- ----- Method: ProcessBrowser>>selectedSelector (in category 'accessing') -----
- selectedSelector
- "Answer the class in which the currently selected context's method was
- found."
- ^ selectedSelector
- ifNil: [selectedSelector := selectedContext receiver
- ifNil: [selectedClass := selectedContext method methodClass
- selectedContext method selector]
- ifNotNil: [selectedContext selector]]!
Item was removed:
- ----- Method: ProcessBrowser>>setUpdateCallbackAfter: (in category 'updating') -----
- setUpdateCallbackAfter: seconds
-
- [(Delay forSeconds: seconds) wait.
- Project current addDeferredUIMessage: [self updateProcessList]] fork!
Item was removed:
- ----- Method: ProcessBrowser>>signalSemaphore (in category 'process actions') -----
- signalSemaphore
- (selectedProcess suspendingList isKindOf: Semaphore)
- ifFalse: [^ self].
- [selectedProcess suspendingList signal] fork.
- (Delay forMilliseconds: 300) wait.
- "Hate to make the UI wait, but it's convenient..."
- self updateProcessList!
Item was removed:
- ----- Method: ProcessBrowser>>stackList (in category 'accessing') -----
- stackList
- ^ stackList!
Item was removed:
- ----- Method: ProcessBrowser>>stackListIndex (in category 'accessing') -----
- stackListIndex
- ^ stackListIndex!
Item was removed:
- ----- Method: ProcessBrowser>>stackListIndex: (in category 'accessing') -----
- stackListIndex: index
- stackListIndex := index.
- selectedContext := (stackList notNil
- and: [index > 0]) ifTrue:
- [stackList at: index ifAbsent: []].
- selectedClass := nil.
- selectedSelector := nil.
- methodText := nil.
- self changed: #stackListIndex.
- self changed: #selectedMethod!
Item was removed:
- ----- Method: ProcessBrowser>>stackListKey:from: (in category 'views') -----
- stackListKey: aKey from: aView
-
- selectedContext ifNil: [^ self changed: #flash].
- ^ aKey
- caseOf: {
- [$c] -> [self inspectContext].
- [$C] -> [self exploreContext].
- [$i] -> [self inspectReceiver].
- [$I] -> [self exploreReceiver].
- [$b] -> [self browseContext]}
- otherwise: [self arrowKey: aKey from: aView]!
Item was removed:
- ----- Method: ProcessBrowser>>stackListMenu: (in category 'stack list') -----
- stackListMenu: aMenu
- selectedContext ifNil: [^aMenu].
- ^aMenu
- labels: 'inspect context (c)
- explore context (C)
- inspect receiver (i)
- explore receiver (I)
- browse (b)
- more stack'
- lines: #(2 4 5)
- selections: #(#inspectContext #exploreContext #inspectReceiver #exploreReceiver #browseContext moreStack)!
Item was removed:
- ----- Method: ProcessBrowser>>stackNameList (in category 'stack list') -----
- stackNameList
- ^ stackList
- ifNil: [#()]
- ifNotNil: [stackList
- collect: [:each | each asString]]!
Item was removed:
- ----- Method: ProcessBrowser>>startAutoUpdate (in category 'updating') -----
- startAutoUpdate
- self isAutoUpdatingPaused
- ifTrue: [^ autoUpdateProcess resume].
-
- self isAutoUpdating ifFalse:
- [| project |
- project := Project current.
- autoUpdateProcess :=
- [[[self hasView] whileTrue:
- [2 seconds wait.
- project addDeferredUIMessage: [self updateProcessList]].
- autoUpdateProcess := nil]
- ensure: [self removeActionsForEvent: #aboutToEnterWorld]] fork.
-
- "Do not update process browsers from inactive projects. Otherwise, an auto-updating process browser from a Morphic project would raise periodic errors after entering an MVC project, or an auto-updating process browser from a MVC project would cause spooky screen updates after entering a Morphic project."
- self flag: #startStepping:. "A better solution strategy would use something like StepMessages for MVC, which however do not exist as of today."
- project world
- when: #aboutToLeaveWorld send: #pauseAutoUpdate to: self;
- when: #aboutToEnterWorld send: #startAutoUpdate to: self].
-
- self updateProcessList.!
Item was removed:
- ----- Method: ProcessBrowser>>startCPUWatcher (in category 'initialize-release') -----
- startCPUWatcher
- "Answers whether I started the CPUWatcher"
-
- | pw |
- pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ].
- pw ifNotNil: [
- pw isMonitoring ifFalse: [
- pw startMonitoringPeriod: 5 rate: 100 threshold: 0.85.
- self setUpdateCallbackAfter: 7.
- ^true
- ]
- ].
- ^false
- !
Item was removed:
- ----- Method: ProcessBrowser>>stopAutoUpdate (in category 'updating') -----
- stopAutoUpdate
- autoUpdateProcess ifNotNil: [
- autoUpdateProcess terminate.
- autoUpdateProcess := nil].
- self updateProcessList!
Item was removed:
- ----- Method: ProcessBrowser>>stopCPUWatcher (in category 'initialize-release') -----
- stopCPUWatcher
- | pw |
- pw := Smalltalk at: #CPUWatcher ifAbsent: [ ^self ].
- pw ifNotNil: [
- pw stopMonitoring.
- self updateProcessList.
- startedCPUWatcher := false. "so a manual restart won't be killed later"
- ]
- !
Item was removed:
- ----- Method: ProcessBrowser>>suspendProcess (in category 'process actions') -----
- suspendProcess
- | nameAndRules |
- selectedProcess isSuspended ifTrue:
- [^self].
- nameAndRules := self nameAndRulesForSelectedProcess.
- nameAndRules second ifFalse:
- [self inform: 'Nope, won''t suspend ' , nameAndRules first.
- ^self].
- selectedProcess == Project current uiProcess ifTrue:
- [Project current spawnNewProcessIfThisIsUI: selectedProcess.
- WorldState addDeferredUIMessage: [self updateProcessList]].
- self class suspendProcess: selectedProcess.
- self updateProcessList!
Item was removed:
- ----- Method: ProcessBrowser>>terminateProcess (in category 'process actions') -----
- terminateProcess
-
- ^ self terminateProcess: false!
Item was removed:
- ----- Method: ProcessBrowser>>terminateProcess: (in category 'process actions') -----
- terminateProcess: aggressive
-
- | nameAndRules |
- nameAndRules := self nameAndRulesForSelectedProcess.
- nameAndRules second ifFalse: [
- ^ self inform: ('Nope, won''t terminate {1}' translated format: {nameAndRules first})].
- self class terminateProcess: selectedProcess aggressively: aggressive.
- self updateProcessList.!
Item was removed:
- ----- Method: ProcessBrowser>>terminateProcessAggressively (in category 'process actions') -----
- terminateProcessAggressively
-
- ^ self terminateProcess: true!
Item was removed:
- ----- Method: ProcessBrowser>>text (in category 'accessing') -----
- text
- ^methodText!
Item was removed:
- ----- Method: ProcessBrowser>>toggleAutoUpdate (in category 'updating') -----
- toggleAutoUpdate
- self isAutoUpdating
- ifTrue: [ self stopAutoUpdate ]
- ifFalse: [ self startAutoUpdate ].
- !
Item was removed:
- ----- Method: ProcessBrowser>>updateProcessList (in category 'process list') -----
- updateProcessList
- | oldSelectedProcess newIndex now |
- now := Time millisecondClockValue.
- now - lastUpdate < 500
- ifTrue: [^ self].
- "Don't update too fast"
- lastUpdate := now.
- oldSelectedProcess := selectedProcess.
- processList := selectedProcess := selectedSelector := nil.
- Smalltalk garbageCollectMost.
- "lose defunct processes"
-
- processList := Process allSubInstances
- reject: [:each | each isTerminated].
- processList := processList
- sorted: [:a :b | a priority >= b priority].
- processList := WeakArray withAll: processList.
- newIndex := processList indexOf: oldSelectedProcess.
- self changed: #processNameList.
- self processListIndex: newIndex!
Item was removed:
- ----- Method: ProcessBrowser>>updateStackList (in category 'stack list') -----
- updateStackList
- self updateStackList: stackDepth!
Item was removed:
- ----- Method: ProcessBrowser>>updateStackList: (in category 'stack list') -----
- updateStackList: depth
- | suspendedContext oldHighlight |
- selectedProcess
- ifNil: [^ self changeStackListTo: nil].
- (stackList notNil and: [ stackListIndex > 0 ])
- ifTrue: [oldHighlight := stackList at: stackListIndex].
- selectedProcess == Processor activeProcess
- ifTrue: [self
- changeStackListTo: (thisContext stackOfSize: depth)]
- ifFalse: [suspendedContext := selectedProcess suspendedContext.
- suspendedContext
- ifNil: [self changeStackListTo: nil]
- ifNotNil: [self
- changeStackListTo: (suspendedContext stackOfSize: depth)]].
- self
- stackListIndex: (stackList
- ifNil: [0]
- ifNotNil: [stackList indexOf: oldHighlight])!
Item was removed:
- ----- Method: ProcessBrowser>>wasProcessSuspendedByProcessBrowser: (in category 'process actions') -----
- wasProcessSuspendedByProcessBrowser: aProcess
- ^self class suspendedProcesses includesKey: aProcess!
Item was removed:
- ----- Method: ProcessBrowser>>windowIsClosing (in category 'initialize-release') -----
- windowIsClosing
- startedCPUWatcher ifTrue: [ CPUWatcher stopMonitoring ]!
Item was removed:
- ----- Method: PseudoClass>>toolIcon (in category '*Tools-icons') -----
- toolIcon
- "For polymorphy with behaviors"
- ^ self realClass ifNil: [#blank] ifNotNil: [:real | real toolIcon]!
Item was removed:
- ----- Method: PseudoClass>>toolIconSelector: (in category '*Tools-icons') -----
- toolIconSelector: aSymbol
- "For polymorphy with behaviors"
- ^ self realClass ifNil: [#blank] ifNotNil: [:real | real toolIconSelector: aSymbol]!
Item was removed:
- MessageSet subclass: #RecentMessageSet
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !RecentMessageSet commentStamp: 'sw 8/1/2002 17:40' prior: 0!
- RecentMessageSet is a message set that shows the most recently-submitted methods, in chronological order.!
Item was removed:
- ----- Method: RecentMessageSet>>addExtraShiftedItemsTo: (in category 'message list') -----
- addExtraShiftedItemsTo: aMenu
- "The shifted selector-list menu is being built. Overridden here to defeat the presence of the items that add or change order, since RecentMessageSet defines methods & order explicitly based on external criteria"
-
- aMenu add: 'set size of recent history...' target: RecentMessages action: #setRecentHistorySize!
Item was removed:
- ----- Method: RecentMessageSet>>contents:notifying: (in category 'contents') -----
- contents: c notifying: n
- | result |
- result := super contents: c notifying: n.
- result == true ifTrue:
- [self reformulateList].
- ^ result!
Item was removed:
- ----- Method: RecentMessageSet>>formattedLabel:forSelector:inClass: (in category 'message list') -----
- formattedLabel: aString forSelector: aSymbol inClass: aClass
- "Overridden to account for outdated MethodReference after class renames."
-
- self flag: #fix. "mt: We might want to fix RecentMessages to instead. Other tools (or features) might depend on it, too."
- ^ aClass
- ifNil: [aString asText]
- ifNotNil: [super formattedLabel: aString forSelector: aSymbol inClass: aClass]
- !
Item was removed:
- ----- Method: RecentMessageSet>>growable (in category 'update') -----
- growable
- "Answer whether the receiver can be changed by manual additions & deletions"
-
- ^ false!
Item was removed:
- ----- Method: RecentMessageSet>>initializeMessageList: (in category 'private') -----
- initializeMessageList: anArray
- "Initialize my messageList from the given list of MethodReference or string objects. NB: special handling for uniclasses.
- Do /not/ replace the elements of anArray if they are already MethodReferences, so as to allow users to construct richer systems, such as differencers between existing and edited versions of code."
- messageList := OrderedCollection new.
- anArray do:
- [:each | each isMethodReference
- ifTrue: [messageList addLast: each]
- ifFalse:
- [ MessageSet
- parse: each
- toClassAndSelector:
- [ : class : sel | class ifNotNil: [ messageList addLast: (MethodReference class: class selector: sel) ] ] ] ].
- messageListIndex := messageList isEmpty ifTrue: [0] ifFalse: [1].
- contents := String empty!
Item was removed:
- ----- Method: RecentMessageSet>>messageHelpForMethod: (in category 'message list') -----
- messageHelpForMethod: aMethod
- "Overridden to account for outdated MethodReference after class renames."
-
- self flag: #fix. "mt: We might want to fix RecentMessages to instead. Other tools (or features) might depend on it, too."
- ^ aMethod ifNotNil: [super messageHelpForMethod: aMethod]!
Item was removed:
- ----- Method: RecentMessageSet>>messageListMenuForRecentSubmission: (in category 'message functions') -----
- messageListMenuForRecentSubmission: aMenu
- <messageListMenuShifted: false>
- aMenu addList:#(
- ('remove from RecentSubmissions' removeFromRecentSubmissions)).
- ^ aMenu!
Item was removed:
- ----- Method: RecentMessageSet>>reformulateList (in category 'update') -----
- reformulateList
- "Reformulate the receiver's list. Exclude methods now deleted"
-
- | currentSelection |
- messageListIndex > 0 ifTrue:
- [currentSelection := messageList at: messageListIndex].
- self initializeMessageList: (RecentMessages default methodReferences select: [:mr| mr isValid]).
- currentSelection ifNotNil:
- [messageListIndex := messageList indexOf: currentSelection ifAbsent: [1]].
- self
- changed: #messageList;
- changed: #messageListIndex!
Item was removed:
- ----- Method: RecentMessageSet>>removeFromRecentSubmissions (in category 'message functions') -----
- removeFromRecentSubmissions
- "Remove the currently-selected method from the RecentMessages list"
-
- | aClass methodSym |
- ((aClass := self selectedClassOrMetaClass) notNil and: [(methodSym := self selectedMessageName) notNil])
- ifTrue:
- [RecentMessages default purgeFromRecentSubmissions: (MethodReference class: aClass selector: methodSym).
- self reformulateList]!
Item was removed:
- ----- Method: RecentMessageSet>>setRecentHistorySize (in category 'message list') -----
- setRecentHistorySize
- "Let the user specify the recent history size"
-
- | aReply aNumber |
- aReply := UIManager default request: 'How many recent methods
- should be maintained?' initialAnswer: RecentMessages numberOfRecentSubmissionsToStore asString.
- aReply isEmptyOrNil ifFalse:
- [aNumber := aReply asNumber rounded.
- (aNumber > 1 and: [aNumber <= 1000])
- ifTrue:
- [RecentMessages numberOfRecentSubmissionsToStore: aNumber.
- self inform: 'Okay, ', aNumber asString, ' is the new size of the recent method history']
- ifFalse:
- [self inform: 'Sorry, must be a number between 2 & 1000']]!
Item was removed:
- ----- Method: RecentMessageSet>>updateListsAndCodeIn: (in category 'update') -----
- updateListsAndCodeIn: aWindow
- self canDiscardEdits ifFalse: [^self].
- RecentMessages default isEmpty ifTrue: [^self].
- (messageList isEmpty
- or: [RecentMessages default mostRecent = messageList first and: [RecentMessages default mostRecent isValid]])
- ifTrue: [self updateCodePaneIfNeeded]
- ifFalse: [self reformulateList]!
Item was removed:
- Object subclass: #SavedMultiWindowState
- instanceVariableNames: 'models modelStates modelDependents currentModelIndex prototype'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Base'!
-
- !SavedMultiWindowState commentStamp: 'eem 6/30/2010 15:45' prior: 0!
- A SavedMultiWindowState is a collection of states of inactive windows for a multi-window tool ui where one can select between multiple copies of a tool sharing a single system window, each tol having its own state. It manages switching between windows, swapping unaccepted edit state (e.g. in text views) as it does so.
-
- Instance Variables
- currentModelIndex: <Integer>
- modelDependents: <IdentitySet>
- modelStates: <OrderedCollection of: (Array
- with: modelState <Object>
- with: unacceptedEditStates <WeakIdentityKeyDictionary>) >
- models: <OrderedCollection of: Model>
-
- currentModelIndex
- - index into models and modelStates of current window selection
-
- modelDependents
- - set of all dependents
-
- modelStates
- - the pairs of model-specific selection state and widget-specfic unaccepted edit state for each unselected/inactive window
-
- models
- - the models for each window
- !
Item was removed:
- ----- Method: SavedMultiWindowState class>>on: (in category 'instance creation') -----
- on: aModel
- ^self new on: aModel!
Item was removed:
- ----- Method: SavedMultiWindowState>>addNewWindow (in category 'operations') -----
- addNewWindow
- self addWindow: prototype shallowCopy!
Item was removed:
- ----- Method: SavedMultiWindowState>>addWindow: (in category 'operations') -----
- addWindow: aModel
- aModel multiWindowState: self.
- self assert: models size = modelStates size.
- models := models
- copyReplaceFrom: currentModelIndex + 1
- to: currentModelIndex
- with: (Array with: aModel).
- modelStates := modelStates
- copyReplaceFrom: currentModelIndex + 1
- to: currentModelIndex
- with: (Array with: self emptyEditState).
- self assert: models size = modelStates size.
- self selectWindowIndex: (currentModelIndex = 0 ifTrue: [currentModelIndex := 1] ifFalse: [currentModelIndex + 1]).
- self assert: models size = modelStates size.
- 1 to: models size do:
- [:idx|
- self assert: (idx = currentModelIndex
- or: [(modelStates at: idx) isArray and: [(modelStates at: idx) size = 2]])]!
Item was removed:
- ----- Method: SavedMultiWindowState>>copyWindow (in category 'operations') -----
- copyWindow
- self addWindow: (models at: currentModelIndex) copy breakDependents!
Item was removed:
- ----- Method: SavedMultiWindowState>>currentModelIndex (in category 'accessing') -----
- currentModelIndex
- ^currentModelIndex!
Item was removed:
- ----- Method: SavedMultiWindowState>>editState (in category 'selecting') -----
- editState
- | textState |
- textState := WeakIdentityKeyDictionary new.
- modelDependents do:
- [:dep|
- dep canHaveUnacceptedEdits ifTrue:
- [textState at: dep put: dep unacceptedEditState]].
- ^textState!
Item was removed:
- ----- Method: SavedMultiWindowState>>emptyEditState (in category 'accessing') -----
- emptyEditState
- ^#(nil ())!
Item was removed:
- ----- Method: SavedMultiWindowState>>initialize (in category 'initialize-release') -----
- initialize
- models := OrderedCollection new.
- modelStates := OrderedCollection new.
- modelDependents := IdentitySet new.
- currentModelIndex := 0!
Item was removed:
- ----- Method: SavedMultiWindowState>>models (in category 'accessing') -----
- models
- ^models!
Item was removed:
- ----- Method: SavedMultiWindowState>>okToClose (in category 'testing') -----
- okToClose
- "Answer if the unaccepted edit states are void. If they are not then
- offer to select a window with non-empty unaccepted edit state."
-
- modelStates withIndexDo:
- [:savedState :index|
- savedState ifNotNil:
- [(savedState last anySatisfy: [:editState| editState notNil]) ifTrue:
- [(PopUpMenu
- confirm: 'One or more windows have unsaved changes.'
- trueChoice: 'Close Anyway'
- falseChoice: 'Select Unsaved') ifTrue: [^true].
- self selectWindowIndex: index.
- ^false]]].
- ^true!
Item was removed:
- ----- Method: SavedMultiWindowState>>on: (in category 'initialize-release') -----
- on: aModel
- prototype := aModel shallowCopy.
- self addWindow: aModel!
Item was removed:
- ----- Method: SavedMultiWindowState>>prototype (in category 'accessing') -----
- prototype
- ^prototype!
Item was removed:
- ----- Method: SavedMultiWindowState>>removeCurrentWindow (in category 'operations') -----
- removeCurrentWindow
- "Remove the current pane."
- | deletedIndex |
- self assert: models size > 1.
- self assert: models size = modelStates size.
- (models at: currentModelIndex) okToChange ifFalse:
- [^self].
- deletedIndex := currentModelIndex.
- self selectWindowIndex: (currentModelIndex = 1
- ifTrue: [currentModelIndex + 1]
- ifFalse: [currentModelIndex - 1]).
- models := models copyWithoutIndex: deletedIndex.
- modelStates := modelStates copyWithoutIndex: deletedIndex.
- currentModelIndex > deletedIndex ifTrue:
- [currentModelIndex := currentModelIndex - 1].
- (models at: currentModelIndex) changed: #relabel!
Item was removed:
- ----- Method: SavedMultiWindowState>>restoreEditState: (in category 'selecting') -----
- restoreEditState: aWeakDictionary
- aWeakDictionary keysAndValuesDo:
- [:depOrNil :unacceptedEditState|
- depOrNil ifNotNil:
- [depOrNil unacceptedEditState: unacceptedEditState]]!
Item was removed:
- ----- Method: SavedMultiWindowState>>selectWindowIndex: (in category 'selecting') -----
- selectWindowIndex: index
- | currentModel newModel newModelState |
- index = currentModelIndex ifTrue: [^self].
-
- currentModel := models at: currentModelIndex.
- newModel := models at: index.
- modelDependents addAll: currentModel dependents.
- modelStates at: currentModelIndex put: { currentModel saveMultiWindowState. self editState }.
- "the become makes things confusing. currentModel will end up being newModel and vice verce"
- models swap: currentModelIndex with: index.
- currentModel become: newModel.
- currentModel := models at: currentModelIndex.
- newModel := models at: index.
- newModel myDependents: (DependentsArray withAll: modelDependents asArray).
- currentModel myDependents: nil.
- "Change currentModelIndex before restoreMultiWIndowState: so label index is shown correctly"
- currentModelIndex := index.
- newModelState := modelStates at: index.
- newModelState first ifNotNil: "emptyState has nil for savedModelState. Don;t restore state for a new window"
- [:savedModelState| newModel restoreMultiWindowState: savedModelState].
- self restoreEditState: newModelState last.
- modelStates at: index put: nil.
- newModel changed: #relabel!
Item was removed:
- ----- Method: SavedMultiWindowState>>selectWindowsMenu (in category 'operations') -----
- selectWindowsMenu
- | menu currentItem |
- menu := MenuMorph new defaultTarget: self.
- models withIndexDo:
- [:model :index| | modelLabel |
- modelLabel := index = currentModelIndex
- ifTrue: [model multiWindowName]
- ifFalse: [model multiWindowNameForState: (modelStates at: index) first].
- models size > 1 ifTrue:
- [modelLabel := index printString, '. ', modelLabel].
- menu
- add: (index = currentModelIndex
- ifTrue: [Text string: modelLabel attribute: TextEmphasis bold]
- ifFalse:
- [((modelStates at: index) last anySatisfy: [:editState| editState notNil])
- ifTrue: [Text string: modelLabel attribute: TextColor red]
- ifFalse: [modelLabel]])
- target: self
- selector: #selectWindowIndex:
- argument: index.
- index = currentModelIndex ifTrue:
- [currentItem := menu lastItem]].
- menu
- addLine;
- add: 'new window' target: self selector: #addNewWindow;
- add: 'copy this window' target: self selector: #copyWindow;
- add: 'remove this window' target: self selector: #removeCurrentWindow.
- models size <= 1 ifTrue:
- [menu lastItem isEnabled: false].
- menu selectItem: currentItem event: nil.
- ^menu!
Item was removed:
- ----- Method: SearchBar>>spawn: (in category '*Tools') -----
- spawn: contentsString
-
- UIManager default edit: contentsString label: nil shouldStyle: Workspace shouldStyle!
Item was removed:
- PopUpMenu subclass: #SelectionMenu
- instanceVariableNames: 'selections'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Menus'!
Item was removed:
- ----- Method: SelectionMenu class>>fromArray: (in category 'instance creation') -----
- fromArray: anArray
- "Construct a menu from anArray. The elements of anArray must be either:
- * A pair of the form: <label> <selector>
- or * The 'dash' (or 'minus sign') symbol
-
- Refer to the example at the bottom of the method"
-
- | labelList lines selections anIndex |
- labelList := OrderedCollection new.
- lines := OrderedCollection new.
- selections := OrderedCollection new.
- anIndex := 0.
- anArray do:
- [:anElement |
- anElement size = 1
- ifTrue:
- [(anElement == #-) ifFalse: [self error: 'badly-formed menu constructor'].
- lines add: anIndex]
- ifFalse:
- [anElement size = 2 ifFalse: [self error: 'badly-formed menu constructor'].
- anIndex := anIndex + 1.
- labelList add: anElement first.
- selections add: anElement second]].
- ^ self labelList: labelList lines: lines selections: selections
-
- "(SelectionMenu fromArray:
- #( ('first label' moja)
- ('second label' mbili)
- -
- ('third label' tatu)
- -
- ('fourth label' nne)
- ('fifth label' tano))) startUp"!
Item was removed:
- ----- Method: SelectionMenu class>>labelList: (in category 'instance creation') -----
- labelList: labelList
- ^ self labelArray: labelList!
Item was removed:
- ----- Method: SelectionMenu class>>labelList:lines: (in category 'instance creation') -----
- labelList: labelList lines: lines
- ^ self labelArray: labelList lines: lines!
Item was removed:
- ----- Method: SelectionMenu class>>labelList:lines:selections: (in category 'instance creation') -----
- labelList: labelList lines: lines selections: selections
- ^ (self labelArray: labelList lines: lines) selections: selections!
Item was removed:
- ----- Method: SelectionMenu class>>labelList:selections: (in category 'instance creation') -----
- labelList: labelList selections: selections
- ^ self
- labelList: labelList
- lines: #()
- selections: selections!
Item was removed:
- ----- Method: SelectionMenu class>>labels:lines: (in category 'instance creation') -----
- labels: labels lines: linesArray
- "Answer an instance of me whose items are in labels, with lines drawn
- after each item indexed by linesArray. Labels can be either a string
- with embedded CRs, or a collection of strings."
-
- (labels isString)
- ifTrue: [^ super labels: labels lines: linesArray]
- ifFalse: [^ super labelArray: labels lines: linesArray]!
Item was removed:
- ----- Method: SelectionMenu class>>labels:lines:selections: (in category 'instance creation') -----
- labels: labels lines: linesArray selections: selectionsArray
- "Answer an instance of me whose items are in labels, with lines drawn
- after each item indexed by linesArray. Labels can be either a string
- with embedded CRs, or a collection of strings. Record the given array of
- selections corresponding to the items in labels."
-
- | labelString |
- (labels isString)
- ifTrue: [labelString := labels]
- ifFalse: [labelString := String streamContents:
- [:s |
- labels do: [:l | s nextPutAll: l; cr].
- s skip: -1]].
- ^ (self labels: labelString lines: linesArray) selections: selectionsArray
- !
Item was removed:
- ----- Method: SelectionMenu class>>labels:selections: (in category 'instance creation') -----
- labels: labels selections: selectionsArray
- "Answer an instance of me whose items are in labels, recording
- the given array of selections corresponding to the items in labels."
-
- ^ self
- labels: labels
- lines: #()
- selections: selectionsArray!
Item was removed:
- ----- Method: SelectionMenu class>>selections: (in category 'instance creation') -----
- selections: selectionsArray
- "Answer an instance of me whose labels and selections are identical."
-
- ^ self selections: selectionsArray lines: nil!
Item was removed:
- ----- Method: SelectionMenu class>>selections:lines: (in category 'instance creation') -----
- selections: selectionsArray lines: linesArray
- "Answer an instance of me whose labels and selections are identical."
-
- ^ self
- labelList: (selectionsArray collect: [:each | each asString])
- lines: linesArray
- selections: selectionsArray!
Item was removed:
- ----- Method: SelectionMenu>>invokeOn: (in category 'basic control sequence') -----
- 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."
-
- | sel |
- sel := self startUp.
- sel = nil ifFalse: [^ targetObject perform: sel].
- ^ nil
-
- "Example:
- (SelectionMenu labels: 'sin
- cos
- neg' lines: #() selections: #(sin cos negated)) invokeOn: 0.7"!
Item was removed:
- ----- Method: SelectionMenu>>invokeOn:orSendTo: (in category 'invocation') -----
- invokeOn: targetObject orSendTo: anObject
- "Pop up the receiver, obtaining a selector; return the result of having the target object perform the selector. If it dos not understand the selector, give the alternate object a chance"
-
- | aSelector |
- ^ (aSelector := self startUp) ifNotNil:
- [(targetObject respondsTo: aSelector)
- ifTrue:
- [targetObject perform: aSelector]
- ifFalse:
- [anObject perform: aSelector]]!
Item was removed:
- ----- Method: SelectionMenu>>selections (in category 'accessing') -----
- selections
- ^ selections!
Item was removed:
- ----- Method: SelectionMenu>>selections: (in category 'accessing') -----
- selections: selectionArray
- selections := selectionArray!
Item was removed:
- ----- Method: SelectionMenu>>startUpWithCaption:at:allowKeyboard: (in category 'basic control sequence') -----
- startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean
- "Overridden to return value returned by manageMarker. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)"
-
- | index |
- index := super startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean.
- (selections isNil or: [(index between: 1 and: selections size) not])
- ifTrue: [^ nil].
- ^ selections at: index!
Item was removed:
- StringHolder subclass: #SelectorBrowser
- instanceVariableNames: 'selectorIndex selectorList classListIndex classList'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Browser'!
-
- !SelectorBrowser commentStamp: 'tpr 10/15/2017 16:42' prior: 0!
- A SelectorBrowser is more commonly referred to as the method finder; you can enter message names or more interestingly, example inputs and results to have the system try to find plausible methods that would satisfy the parameters. See SelectorBrowser>>#byExample for much more detail.!
Item was removed:
- ----- Method: SelectorBrowser class>>prototypicalToolWindow (in category 'instance creation') -----
- prototypicalToolWindow
- "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
-
- | aWindow |
- aWindow := ToolBuilder build: self new.
- aWindow setLabel: 'Selector Browser'.
- aWindow applyModelExtent.
- ^ aWindow!
Item was removed:
- ----- Method: SelectorBrowser>>buildClassListWith: (in category 'toolbuilder') -----
- buildClassListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #classList;
- getIndex: #classListIndex;
- setIndex: #classListIndex:;
- keyPress: #arrowKey:from:.
- ^listSpec
- !
Item was removed:
- ----- Method: SelectorBrowser>>buildEditViewWith: (in category 'toolbuilder') -----
- buildEditViewWith: builder
- | textSpec |
- textSpec := builder pluggableInputFieldSpec new.
- textSpec
- model: self;
- getText: #contents;
- setText: #contents:notifying:;
- selection: #contentsSelection;
- menu: #codePaneMenu:shifted:.
- ^textSpec!
Item was removed:
- ----- Method: SelectorBrowser>>buildExamplePaneWith: (in category 'toolbuilder') -----
- buildExamplePaneWith: builder
- | textSpec |
- textSpec := builder pluggableTextSpec new.
- textSpec
- model: self;
- getText: #byExample;
- setText: #byExample:;
- selection: #contentsSelection;
- menu: #codePaneMenu:shifted:.
- ^textSpec!
Item was removed:
- ----- Method: SelectorBrowser>>buildMessageListWith: (in category 'toolbuilder') -----
- buildMessageListWith: builder
- | listSpec |
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #messageList;
- getIndex: #messageListIndex;
- setIndex: #messageListIndex:;
- menu: #selectorMenu:;
- keyPress: #messageListKey:from:.
- ^listSpec
- !
Item was removed:
- ----- Method: SelectorBrowser>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
- "Create a Browser that lets you type part of a selector, shows a list of selectors, shows the classes of the one you chose, and spawns a full browser on it. Answer the window
- SelectorBrowser new open "
- | windowSpec |
- selectorIndex := classListIndex := 0.
- windowSpec := self buildWindowWith: builder specs: {
- (0@0 corner: 0.5(a)0.14) -> [self buildEditViewWith: builder].
- (0(a)0.14 corner: 0.5(a)0.6) -> [self buildMessageListWith: builder].
- (0.5@0 corner: 1(a)0.6) -> [self buildClassListWith: builder].
- (0(a)0.6 corner: 1@1) -> [self buildExamplePaneWith: builder].
- }.
- ^builder build: windowSpec!
Item was removed:
- ----- Method: SelectorBrowser>>byExample (in category 'example pane') -----
- byExample
- "The comment in the bottom pane"
-
- false ifTrue: [MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10)].
- "to keep the method methodFor: from being removed from the system"
-
- ^ 'Type a fragment of a selector in the top pane. Accept it.
-
- Or, use an example to find a method in the system. Type receiver, args, and answer in the top pane with periods between the items. 3. 4. 7
-
- Or, in this pane, use examples to find a method in the system. Select the line of code and choose "print it".
-
- MethodFinder methodFor: #( (4 3) 7 (0 5) 5 (5 5) 10).
- This will discover (data1 + data2).
-
- You supply inputs and answers and the system will find the method. Each inner array is a list of inputs. It contains the receiver and zero or more arguments. For Booleans and any computed arguments, use brace notation.
-
- MethodFinder methodFor: { {1. 3}. true. {20. 10}. false}.
- This will discover the expressions (data1 < data2), (data2 > data1), and many others.
-
- MethodFinder methodFor: { {''29 Apr 1999'' asDate}. ''Thursday''.
- {''30 Apr 1999'' asDate}. ''Friday'' }.
- This will discover the expression (data1 weekday)
-
- Receiver and arguments do not have to be in the right order.
- See MethodFinder.verify for more examples.'!
Item was removed:
- ----- Method: SelectorBrowser>>byExample: (in category 'example pane') -----
- byExample: newText
- "Don't save it"
- ^ true!
Item was removed:
- ----- Method: SelectorBrowser>>classList (in category 'class list') -----
- classList
- ^ classList ifNil: [#()]!
Item was removed:
- ----- Method: SelectorBrowser>>classListIndex (in category 'class list') -----
- classListIndex
- ^ classListIndex!
Item was removed:
- ----- Method: SelectorBrowser>>classListIndex: (in category 'class list') -----
- classListIndex: anInteger
-
- classListIndex := anInteger.
- classListIndex > 0 ifTrue:
- [self changed: #startNewBrowser. "MVC view will terminate control to prepare for new browser"
- ToolSet browse: self selectedClass selector: self selectedMessageName.
- "classListIndex := 0"]
- !
Item was removed:
- ----- Method: SelectorBrowser>>classListSelectorTitle (in category 'class list') -----
- classListSelectorTitle
- ^ 'Class List Menu'!
Item was removed:
- ----- Method: SelectorBrowser>>contents:notifying: (in category 'example pane') -----
- contents: aString notifying: aController
- "Take what the user typed and find all selectors containing it"
-
- | tokens |
- contents := aString.
- classList := #(). classListIndex := 0.
- selectorIndex := 0.
- tokens := contents asString findTokens: ' .'.
- selectorList := Cursor wait showWhile: [
- tokens size = 1
- ifTrue: [(Symbol selectorsContaining: contents asString) asArray
- sort: [:x :y | x asLowercase <= y asLowercase]]
- ifFalse: [self quickList]]. "find selectors from a single example of data"
- self changed: #messageList.
- self changed: #classList.
- ^ true!
Item was removed:
- ----- Method: SelectorBrowser>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.45 g: 0.9 b: 0.9)!
Item was removed:
- ----- Method: SelectorBrowser>>implementors (in category 'selector functions') -----
- implementors
- | aSelector |
- (aSelector := self selectedMessageName) ifNotNil:
- [self systemNavigation browseAllImplementorsOf: aSelector]!
Item was removed:
- ----- Method: SelectorBrowser>>initialExtent (in category 'message list') -----
- initialExtent
-
- ^ 350@250
- !
Item was removed:
- ----- Method: SelectorBrowser>>labelString (in category 'user interface') -----
- labelString
-
- ^ 'Selector Browser' translated!
Item was removed:
- ----- Method: SelectorBrowser>>listFromResult: (in category 'selector finding') -----
- listFromResult: resultOC
- "ResultOC is of the form #('(data1 op data2)' '(...)'). Answer a sorted array."
-
- (resultOC first beginsWith: 'no single method') ifTrue: [^ #()].
- ^ resultOC sorted: [:a :b |
- (a copyFrom: 6 to: a size) < (b copyFrom: 6 to: b size)].
-
- !
Item was removed:
- ----- Method: SelectorBrowser>>mainSelectorMenu: (in category 'selector list') -----
- mainSelectorMenu: aMenu
-
- <selectorMenu>
- ^ aMenu addList: #(
- ('senders (n)' senders)
- ('implementors (m)' implementors)
- ('copy selector to clipboard' copyName));
- yourself
- !
Item was removed:
- ----- Method: SelectorBrowser>>markMatchingClasses (in category 'message list') -----
- markMatchingClasses
- "If an example is used, mark classes matching the example instance with an asterisk."
-
- | unmarkedClassList firstPartOfSelector receiverString receiver |
-
- self flag: #mref. "allows for old-fashioned style"
-
- "Only 'example' queries can be marked."
- (contents asString includes: $.) ifFalse: [^ self].
-
- unmarkedClassList := classList copy.
-
- "Get the receiver object of the selected statement in the message list."
- firstPartOfSelector := (Scanner new scanTokens: (selectorList at: selectorIndex)) second.
- receiverString := (ReadStream on: (selectorList at: selectorIndex))
- upToAll: firstPartOfSelector.
- receiver := Compiler evaluate: receiverString.
-
- unmarkedClassList do: [ :classAndMethod | | class |
- (classAndMethod isKindOf: MethodReference) ifTrue: [
- (receiver isKindOf: classAndMethod actualClass) ifTrue: [
- classAndMethod stringVersion: '*', classAndMethod stringVersionDefault.
- ]
- ] ifFalse: [
- class := Compiler evaluate:
- ((ReadStream on: classAndMethod) upToAll: firstPartOfSelector).
- (receiver isKindOf: class) ifTrue: [
- classList add: '*', classAndMethod.
- classList remove: classAndMethod
- ]
- ].
- ].
- !
Item was removed:
- ----- Method: SelectorBrowser>>messageList (in category 'message list') -----
- messageList
- "Find all the selectors containing what the user typed in."
-
- ^ selectorList ifNil: [#()]!
Item was removed:
- ----- Method: SelectorBrowser>>messageListIndex (in category 'message list') -----
- messageListIndex
- "Answer the index of the selected message selector."
-
- ^ selectorIndex!
Item was removed:
- ----- Method: SelectorBrowser>>messageListIndex: (in category 'message list') -----
- messageListIndex: anInteger
- "Set the selected message selector to be the one indexed by anInteger.
- Find all classes it is in."
- selectorIndex := anInteger.
- selectorIndex = 0
- ifTrue: [^ self].
- classList := self systemNavigation allImplementorsOf: self selectedMessageName.
- self markMatchingClasses.
- classListIndex := 0.
- self changed: #messageListIndex.
- "update my selection"
- self changed: #classList!
Item was removed:
- ----- Method: SelectorBrowser>>messageListKey:from: (in category 'message list') -----
- messageListKey: aChar from: view
- "Respond to a command key. Handle (m) and (n) here,
- else defer to the StringHolder behaviour."
-
- aChar == $m ifTrue: [^ self implementors].
- aChar == $n ifTrue: [^ self senders].
- super messageListKey: aChar from: view
- !
Item was removed:
- ----- Method: SelectorBrowser>>open (in category 'toolbuilder') -----
- open
- "Create a Browser that lets you type part of a selector, shows a list of selectors,
- shows the classes of the one you chose, and spwns a full browser on it.
- SelectorBrowser new open
- "
- ^ToolBuilder open: self!
Item was removed:
- ----- Method: SelectorBrowser>>quickList (in category 'selector finding') -----
- quickList
- "Compute the selectors for the single example of receiver and args, in the very top pane"
-
- | data result resultArray dataStrings mf dataObjects aa statements |
- data := contents asString withBlanksTrimmed.
- mf := MethodFinder new.
- data := mf cleanInputs: data. "remove common mistakes"
- dataObjects := Compiler evaluate: '{', data, '}'. "#( data1 data2 result )"
- statements := (Compiler new parse: 'zort ' , data in: Object notifying: nil)
- body statements select: [:each | (each isKindOf: ReturnNode) not].
- dataStrings := statements collect:
- [:node | String streamContents:
- [:strm | (node isMessage) ifTrue: [strm nextPut: $(].
- node shortPrintOn: strm.
- (node isMessage) ifTrue: [strm nextPut: $)].]].
- dataObjects size < 2 ifTrue: [self inform: 'If you are giving an example of receiver, \args, and result, please put periods between the parts.\Otherwise just type one selector fragment' withCRs. ^#()].
- dataObjects := Array with: dataObjects allButLast with: dataObjects last. "#( (data1
- data2) result )"
- result := mf load: dataObjects; findMessage.
- (result first beginsWith: 'no single method') ifFalse: [
- aa := self testObjects: dataObjects strings: dataStrings.
- dataObjects := aa second. dataStrings := aa third].
- resultArray := self listFromResult: result.
- resultArray isEmpty ifTrue: [self inform: result first].
-
- dataStrings size = (dataObjects first size + 1) ifTrue:
- [resultArray := resultArray collect: [:expression | | newExp |
- newExp := expression.
- dataObjects first withIndexDo: [:lit :i |
- newExp := newExp copyReplaceAll: 'data', i printString
- with: (dataStrings at: i)].
- newExp, ' --> ', dataStrings last]].
-
- ^ resultArray!
Item was removed:
- ----- Method: SelectorBrowser>>searchResult: (in category 'example pane') -----
- searchResult: anExternalSearchResult
-
- self contents: ''.
- classList := #(). classListIndex := 0.
- selectorIndex := 0.
- selectorList := self listFromResult: anExternalSearchResult.
- self changed: #messageList.
- self changed: #classList.
- self changed: #contents
- !
Item was removed:
- ----- Method: SelectorBrowser>>selectedClass (in category 'class list') -----
- selectedClass
- "Answer the currently selected class."
-
- | pairString |
-
- self flag: #mref. "allows for old-fashioned style"
-
- classListIndex = 0 ifTrue: [^nil].
- pairString := classList at: classListIndex.
- (pairString isKindOf: MethodReference) ifTrue: [
- ^pairString actualClass
- ].
- (pairString includes: $*) ifTrue: [pairString := pairString allButFirst].
- MessageSet
- parse: pairString
- toClassAndSelector: [:cls :sel | ^ cls].!
Item was removed:
- ----- Method: SelectorBrowser>>selectedClassName (in category 'accessing') -----
- selectedClassName
- "Answer the name of the currently selected class."
-
- classListIndex = 0 ifTrue: [^nil].
- ^ self selectedClass name!
Item was removed:
- ----- Method: SelectorBrowser>>selectedMessageName (in category 'accessing') -----
- selectedMessageName
- "Answer the name of the currently selected message or nil if not a known Symbol."
-
- | example tokens |
- selectorIndex = 0 ifTrue: [^nil].
- example := selectorList at: selectorIndex.
- tokens := Scanner new scanTokens: example.
- tokens size = 1 ifTrue: [^ tokens first].
- tokens first == #'^' ifTrue: [^ nil].
- (tokens second includes: $:) ifTrue: [^ example findSelector].
- ^Symbol lookup: tokens second!
Item was removed:
- ----- Method: SelectorBrowser>>selectorList: (in category 'selector list') -----
- selectorList: anExternalList
-
- self contents: ''.
- classList := #(). classListIndex := 0.
- selectorIndex := 0.
- selectorList := anExternalList.
- self changed: #messageList.
- self changed: #classList.
- self changed: #contents
-
- !
Item was removed:
- ----- Method: SelectorBrowser>>selectorMenu: (in category 'selector list') -----
- selectorMenu: aMenu
- ^ self menu: aMenu for: #(selectorMenu selectorMenuShifted:)
- !
Item was removed:
- ----- Method: SelectorBrowser>>selectorMenuTitle (in category 'selector list') -----
- selectorMenuTitle
- ^ self selectedMessageName ifNil: ['<no selection>']!
Item was removed:
- ----- Method: SelectorBrowser>>senders (in category 'selector functions') -----
- senders
- | aSelector |
- (aSelector := self selectedMessageName) ifNotNil:
- [self systemNavigation browseAllCallsOn: aSelector]!
Item was removed:
- ----- Method: SelectorBrowser>>testObjects:strings: (in category 'selector finding') -----
- testObjects: dataObjects strings: dataStrings
- | dataObjs dataStrs selectors classes didUnmodifiedAnswer |
- "Try to make substitutions in the user's inputs and search for the selector again.
- 1 no change to answer.
- 2 answer Array -> OrderedCollection.
- 2 answer Character -> String
- 4 answer Symbol or String of len 1 -> Character
- For each of these, try straight, and try converting args:
- Character -> String
- Symbol or String of len 1 -> Character
- Return array with result, dataObjects, dataStrings. Don't ever do a find on the same set of data twice."
-
- dataObjs := dataObjects. dataStrs := dataStrings.
- selectors := {#asString. #first. #asOrderedCollection}.
- classes := {Character. String. Array}.
- didUnmodifiedAnswer := false.
- selectors withIndexDo: [:ansSel :ansInd | | ds do result answerMod | "Modify the answer object"
- answerMod := false.
- do := dataObjs copyTwoLevel. ds := dataStrs copy.
- (dataObjs last isKindOf: (classes at: ansInd)) ifTrue: [
- ((ansSel ~~ #first) or: [dataObjs last size = 1]) ifTrue: [
- do at: do size put: (do last perform: ansSel). "asString"
- ds at: ds size put: ds last, ' ', ansSel.
- result := MethodFinder new load: do; findMessage.
- (result first beginsWith: 'no single method') ifFalse: [
- "found a selector!!"
- ^ Array with: result first with: do with: ds].
- answerMod := true]].
-
- selectors allButLast withIndexDo: [:argSel :argInd | | ddo dds | "Modify an argument object"
- "for args, no reason to do Array -> OrderedCollection. Identical protocol."
- didUnmodifiedAnswer not | answerMod ifTrue: [
- ddo := do copyTwoLevel. dds := ds copy.
- dataObjs first withIndexDo: [:arg :ind |
- (arg isKindOf: (classes at: argInd)) ifTrue: [
- ((argSel ~~ #first) or: [arg size = 1]) ifTrue: [
- ddo first at: ind put: ((ddo first at: ind) perform: argSel). "asString"
- dds at: ind put: (dds at: ind), ' ', argSel.
- result := MethodFinder new load: ddo; findMessage.
- (result first beginsWith: 'no single method') ifFalse: [
- "found a selector!!"
- ^ Array with: result first with: ddo with: dds] .
- didUnmodifiedAnswer not & answerMod not ifTrue: [
- didUnmodifiedAnswer := true].
- ]]]]].
- ].
- ^ Array with: 'no single method does that function' with: dataObjs with: dataStrs!
Item was removed:
- ----- Method: Set>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Set'!
Item was removed:
- ----- Method: Set>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
- "Answer the class of the inspector to be used on the receiver. Called by inspect;
- use basicInspect to get a normal (less useful) type of inspector."
-
- ^ SetInspector!
Item was removed:
- CollectionInspector subclass: #SetInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !SetInspector commentStamp: 'ct 1/12/2020 15:21' prior: 0!
- I am an inspector that is specialized for inspecting Sets. I display the elements of the set like elements of an array. Note that the indices, being phyical locations in the hash table, are not meaningful outside of the set.!
Item was removed:
- ----- Method: SetInspector>>elementGetterAt: (in category 'private') -----
- elementGetterAt: index
-
- ^ [:set | (set array at: index) enclosedSetElement]!
Item was removed:
- ----- Method: SetInspector>>elementIndices (in category 'private') -----
- elementIndices
- "In the set's internal array, extract the indices that point to actual elements."
-
- | numIndices |
- (numIndices := self objectSize) = 0
- ifTrue: [^#()].
-
- ^ Array
- new: numIndices
- streamContents: [:stream |
- self object array withIndexDo: [:element :index |
- (self isElementValid: element) ifTrue: [stream nextPut: index]]]!
Item was removed:
- ----- Method: SetInspector>>elementSetterAt: (in category 'private') -----
- elementSetterAt: index
- "Because of sets are hashed collections, we have to use the public interface, which means removing the element the index is pointing to first -- and only then can we add the new element."
-
- ^ [:set :element |
- set remove: (set array at: index) enclosedSetElement.
- set add: element]!
Item was removed:
- ----- Method: SetInspector>>isElementValid: (in category 'private') -----
- isElementValid: anElement
-
- ^ anElement notNil!
Item was removed:
- ----- Method: SetInspector>>replaceSelectionValue: (in category 'selection') -----
- replaceSelectionValue: anObject
- "After replacing the value, we have to scan for the field that now contains anObject."
-
- (super replaceSelectionValue: anObject) ifTrue: [
- self updateFields.
- self selectFieldSuchThat: [:field | [(field getValueFor: self) == anObject] ifError: [false] ]].!
Item was removed:
- ----- Method: StandardFileStream>>dirAndFileName (in category '*Tools-FileList') -----
- dirAndFileName
- "A temporary solution for supporting project loading via drag and drop."
-
- ^{ self directory. self localName }!
Item was removed:
- Object subclass: #StandardToolSet
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Base'!
-
- !StandardToolSet commentStamp: '<historical>' prior: 0!
- Main comment stating the purpose of this class and relevant relationship to other classes.
-
- Possible useful expressions for doIt or printIt.
-
- Structure:
- instVar1 type -- comment about the purpose of instVar1
- instVar2 type -- comment about the purpose of instVar2
-
- Any further useful comments about the general approach of this implementation.!
Item was removed:
- ----- Method: StandardToolSet class>>basicInspect: (in category 'inspecting') -----
- basicInspect: anObject
- "Open a basic inspector on the given object."
- ^ BasicInspector openOn: anObject!
Item was removed:
- ----- Method: StandardToolSet class>>browse:selector: (in category 'browsing') -----
- browse: aClass selector: aSelector
- "Open a browser"
- ^SystemBrowser default fullOnClass: aClass selector: aSelector!
Item was removed:
- ----- Method: StandardToolSet class>>browseCategory: (in category 'browsing') -----
- browseCategory: aCategory
-
- ^ SystemBrowser default fullOnCategory: aCategory!
Item was removed:
- ----- Method: StandardToolSet class>>browseChangeSetsWithClass:selector: (in category 'browsing') -----
- browseChangeSetsWithClass: aClass selector: aSelector
- "Browse all the change sets with the given class/selector"
- ^ChangeSorter browseChangeSetsWithClass: aClass selector: aSelector!
Item was removed:
- ----- Method: StandardToolSet class>>browseClass: (in category 'browsing') -----
- browseClass: aClass
- "Open a browser"
- ^SystemBrowser default fullOnClass: aClass.!
Item was removed:
- ----- Method: StandardToolSet class>>browseClass:category: (in category 'browsing') -----
- browseClass: aClass category: aCategory
- "Open a browser for a class selecting a given message category."
-
- ^ SystemBrowser default
- fullOnClass: aClass
- category: aCategory!
Item was removed:
- ----- Method: StandardToolSet class>>browseClassCommentOf: (in category 'browsing') -----
- browseClassCommentOf: aClass
-
- ^ SystemBrowser default fullOnClassComment: aClass!
Item was removed:
- ----- Method: StandardToolSet class>>browseEnvironment: (in category 'browsing') -----
- browseEnvironment: anEnvironment
-
- ^ SystemBrowser default fullOnEnvironment: anEnvironment!
Item was removed:
- ----- Method: StandardToolSet class>>browseHierarchy:selector: (in category 'browsing') -----
- browseHierarchy: aClass selector: aSelector
- "Open a browser"
-
- ^ HierarchyBrowser fullOnClass: aClass selector: aSelector.!
Item was removed:
- ----- Method: StandardToolSet class>>browseMessageCategory:inClass: (in category 'browsing') -----
- browseMessageCategory: aCategory inClass: aClass
- "Open a message category browser."
-
- ^ SystemBrowser default
- newOnClass: aClass messageCategory: aCategory!
Item was removed:
- ----- Method: StandardToolSet class>>browseMessageNames: (in category 'browsing') -----
- browseMessageNames: aString
- ^(MessageNames methodBrowserSearchingFor: aString) openInWorld!
Item was removed:
- ----- Method: StandardToolSet class>>browseMessageSet:name:autoSelect: (in category 'browsing') -----
- browseMessageSet: messageList name: title autoSelect: autoSelectString
- "Open a message set or message-trace browser, depending on the #traceMessages setting."
- ^ Preferences traceMessages
- ifTrue:
- [ MessageTrace
- openMessageList: messageList
- name: title
- autoSelect: autoSelectString ]
- ifFalse:
- [ MessageSet
- openMessageList: messageList
- name: title
- autoSelect: autoSelectString ]!
Item was removed:
- ----- Method: StandardToolSet class>>browseMethod: (in category 'browsing') -----
- browseMethod: aCompiledMethod
- "Browse aCompiledMethod on the most convenient possible way, using a System Browser, a Versions Browser, or an Inspector."
-
- aCompiledMethod isInstalled
- ifTrue: [^ self browse: aCompiledMethod methodClass selector: aCompiledMethod selector].
- (aCompiledMethod methodClass changeRecordsAt: aCompiledMethod selector)
- ifNotNil: [^ self browseMethodVersion: aCompiledMethod].
- ^ self inspect: aCompiledMethod!
Item was removed:
- ----- Method: StandardToolSet class>>browseMethodVersion: (in category 'browsing') -----
- browseMethodVersion: aCompiledMethod
-
- ^ VersionsBrowser browseMethod: aCompiledMethod!
Item was removed:
- ----- Method: StandardToolSet class>>browsePackage: (in category 'browsing') -----
- browsePackage: aPackageInfo
-
- ^ PackagePaneBrowser fullOnPackage: aPackageInfo!
Item was removed:
- ----- Method: StandardToolSet class>>browseVersionsOf:selector: (in category 'browsing') -----
- browseVersionsOf: class selector: selector
- "Open and answer a browser on versions of the method.
- If the method doesn't exist try and find version from the current change set.
- If not found there, answer nil."
- | methodOrNil methodCategory |
- methodOrNil := class compiledMethodAt: selector ifAbsent: [].
- methodOrNil ifNil:
- [(ChangeSet current methodInfoFromRemoval: {class name. selector})
- ifNil: [^nil]
- ifNotNil:
- [:pair|
- methodOrNil := CompiledMethod toReturnSelfTrailerBytes:
- (CompiledMethodTrailer new sourcePointer: pair first).
- methodCategory := pair second]].
- ^VersionsBrowser
- browseVersionsOf: methodOrNil
- class: class theNonMetaClass
- meta: class isMeta
- category: (methodCategory ifNil: [class organization categoryOfElement: selector])
- selector: selector!
Item was removed:
- ----- Method: StandardToolSet class>>codeCompletionAround:textMorph:keyStroke: (in category 'completion') -----
- codeCompletionAround: aBlock textMorph: aTextMorph keyStroke: evt
- ^ aBlock value!
Item was removed:
- ----- Method: StandardToolSet class>>debugException: (in category 'debugging') -----
- debugException: anException
- "For convenience. Construct a helper process to debug an exception that occurred in the active process later on so that the active process can (try to) resume. Uses a temporary variable to access and copy the signaler context now before it gets GC'ed."
-
- | helperProcess |
- helperProcess := (Process
- forContext: anException signalerContext copyStack
- priority: Processor activeProcess priority)
- shouldResumeFromDebugger: false;
- yourself.
-
- Project current addDeferredUIMessage: [
- helperProcess
- debugWithTitle: anException description
- full: false
- contents: ((anException isKindOf: Warning)
- ifTrue: [anException messageText])].!
Item was removed:
- ----- Method: StandardToolSet class>>debugProcess:context:label:contents:fullView: (in category 'debugging') -----
- debugProcess: aProcess context: aContext label: aString contents: contents fullView: aBool
-
- (aProcess isTerminated and: [aString isNil or: [aString beginsWith: 'Debug it']]) ifTrue: [
- ^ Project uiManager inform: 'Nothing to debug. Process has terminated.\Expression optimized.' translated withCRs].
-
- ^ Debugger
- openOn: aProcess
- context: aContext
- label: aString
- contents: contents
- fullView: aBool!
Item was removed:
- ----- Method: StandardToolSet class>>debugSyntaxError: (in category 'debugging') -----
- debugSyntaxError: aSyntaxErrorNotification
-
- ^ SyntaxError open: aSyntaxErrorNotification!
Item was removed:
- ----- Method: StandardToolSet class>>explore: (in category 'inspecting') -----
- explore: anObject
-
- ^ ObjectExplorer openOn: anObject!
Item was removed:
- ----- Method: StandardToolSet class>>explore:label: (in category 'inspecting') -----
- explore: anObject label: label
-
- ^ ObjectExplorer openOn: anObject withLabel: label!
Item was removed:
- ----- Method: StandardToolSet class>>handleError: (in category 'debugging - handlers') -----
- handleError: anError
- "Double dispatch. Let the processor take care of that error, which usually calls back here to #debugProcess:..."
-
- ^ Processor
- debugContext: anError signalerContext
- title: anError description
- full: false
- contents: nil!
Item was removed:
- ----- Method: StandardToolSet class>>handleRecursiveError: (in category 'debugging - handlers') -----
- handleRecursiveError: description
-
- ^ Project current recursiveError: description!
Item was removed:
- ----- Method: StandardToolSet class>>handleSyntaxError: (in category 'debugging - handlers') -----
- handleSyntaxError: aSyntaxErrorNotification
- "Double dispatch. Let the current project manage processes, which usually calls back into #debugSyntaxError:."
-
- ^ Project current syntaxError: aSyntaxErrorNotification!
Item was removed:
- ----- Method: StandardToolSet class>>handleUserInterruptRequest: (in category 'debugging - handlers') -----
- handleUserInterruptRequest: aString
- "Double dispatch. Let the current project manage processes, which usually calls back here eventually into #debugProcess..."
-
- Preferences cmdDotEnabled ifFalse: [^ self].
- ^ Project current interruptName: aString!
Item was removed:
- ----- Method: StandardToolSet class>>handleWarning: (in category 'debugging - handlers') -----
- handleWarning: aWarning
- "Double dispatch. Let the processor take care of that warning, which usually calls back here to #debugProcess:..."
-
- | message |
- message := '{1}\\{2}' withCRs asText format: {
- "First, show the actual text of this warning."
- aWarning messageText.
- "Second, append some helpful information that apply to all kinds of warnings."
- ('{1} {2}' asText format: {
- 'Select "Proceed" to continue or close this window to cancel the operation.' translated.
- 'If you do not want to be interrupted anymore, you can {1} this kind of warning. You can also {2}, which resets such warnings on the next image startup.' translated asText format: {
- "Provide clickable text links so that the user can directly suppress warnings."
- 'always suppress' asText
- addAttribute: (PluggableTextAttribute evalBlock: [
- aWarning class suppressWarnings.
- self inform: ('All ''{1}'' warnings will be suppressed.' translated format: {aWarning class name})]).
- 'suppress temporarily' asText
- addAttribute: (PluggableTextAttribute evalBlock: [
- aWarning class suppressAndResetOnStartUp.
- self inform: ('All ''{1}'' warnings will be suppressed\and reset on the next image startup.' translated withCRs format: {aWarning class name})])}.
- }) addAttribute: (
- "Show this helpful information in a smaller font."
- TextFontReference toFont: Preferences standardButtonFont)}.
-
- ^ Processor
- debugContext: aWarning signalerContext
- title: 'Warning' translated
- full: false
- contents: message!
Item was removed:
- ----- Method: StandardToolSet class>>initialize (in category 'class initialization') -----
- initialize
- ToolSet register: self.!
Item was removed:
- ----- Method: StandardToolSet class>>inspect: (in category 'inspecting') -----
- inspect: anObject
- "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
- ^ anObject inspectorClass openOn: anObject!
Item was removed:
- ----- Method: StandardToolSet class>>inspect:label: (in category 'inspecting') -----
- inspect: anObject label: aString
- "Open an inspector on the given object. The tool set must know which inspector type to use for which object - the object cannot possibly know what kind of inspectors the toolset provides."
- ^ anObject inspectorClass openOn: anObject withLabel: aString!
Item was removed:
- ----- Method: StandardToolSet class>>menuItems (in category 'menu') -----
- menuItems
- "Answer the menu items available for this tool set"
- ^#(
- ('class browser' #openClassBrowser)
- ('workspace' #openWorkspace)
- ('file list' #openFileList)
- ('package pane browser' #openPackagePaneBrowser)
- ('process browser' #openProcessBrowser)
- -
- ('method finder' #openSelectorBrowser)
- ('message names' #openMessageNames)
- -
- ('simple change sorter' #openChangeSorter)
- ('dual change sorter' #openDualChangeSorter)
- )
- !
Item was removed:
- ----- Method: StandardToolSet class>>openChangeSorter (in category 'menu') -----
- openChangeSorter
- ToolBuilder open: ChangeSorter new!
Item was removed:
- ----- Method: StandardToolSet class>>openChangedMessageSet: (in category 'browsing') -----
- openChangedMessageSet: aChangeSet
- "Open a ChangedMessageSet for aChangeSet"
- ChangedMessageSet openFor: aChangeSet!
Item was removed:
- ----- Method: StandardToolSet class>>openClassBrowser (in category 'menu') -----
- openClassBrowser
- SystemBrowser default open!
Item was removed:
- ----- Method: StandardToolSet class>>openClassListBrowser:title: (in category 'browsing') -----
- openClassListBrowser: anArray title: aString
- "Open a class list browser on the list of classes named"
-
- ^ClassListBrowser newOnClassesNamed: anArray label: aString
- !
Item was removed:
- ----- Method: StandardToolSet class>>openDualChangeSorter (in category 'menu') -----
- openDualChangeSorter
- ToolBuilder open: DualChangeSorter new!
Item was removed:
- ----- Method: StandardToolSet class>>openFileList (in category 'menu') -----
- openFileList
- FileList open!
Item was removed:
- ----- Method: StandardToolSet class>>openMessageNames (in category 'menu') -----
- openMessageNames
- "Bring a MessageNames tool to the front"
- MessageNames openMessageNames!
Item was removed:
- ----- Method: StandardToolSet class>>openPackagePaneBrowser (in category 'menu') -----
- openPackagePaneBrowser
- PackagePaneBrowser openBrowser.!
Item was removed:
- ----- Method: StandardToolSet class>>openProcessBrowser (in category 'menu') -----
- openProcessBrowser
- ProcessBrowser open!
Item was removed:
- ----- Method: StandardToolSet class>>openSelectorBrowser (in category 'menu') -----
- openSelectorBrowser
- ToolBuilder open: SelectorBrowser new!
Item was removed:
- ----- Method: StandardToolSet class>>openWorkspace (in category 'menu') -----
- openWorkspace
- Workspace open!
Item was removed:
- ----- Method: StandardToolSet class>>unload (in category 'class initialization') -----
- unload
- ToolSet unregister: self.!
Item was removed:
- ----- Method: Stream class>>toolIcon (in category '*Tools-icons') -----
- toolIcon
-
- ^ #stream!
Item was removed:
- ----- Method: String class>>toolIcon (in category '*Tools-icons') -----
- toolIcon
-
- ^ #string!
Item was removed:
- ----- Method: String>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'String'!
Item was removed:
- ----- Method: StringHolder class>>codePaneMenu:shifted: (in category '*Tools-yellow button menu') -----
- codePaneMenu: aMenu shifted: shifted
- "Utility method for the 'standard' codePane menu"
- aMenu addList: (shifted
- ifTrue:[self shiftedYellowButtonMenuItems]
- ifFalse:[self yellowButtonMenuItems]).
- ^aMenu!
Item was removed:
- ----- Method: StringHolder class>>open (in category '*Tools') -----
- open
- ^ (Smalltalk at: #Workspace ifAbsent:[self]) new openLabel: 'Workspace'
- !
Item was removed:
- ----- Method: StringHolder class>>openLabel: (in category '*Tools') -----
- openLabel: aString
-
- ^self new openLabel: aString!
Item was removed:
- ----- Method: StringHolder class>>shiftedYellowButtonMenuItems (in category '*Tools-yellow button menu') -----
- shiftedYellowButtonMenuItems
- "Returns the standard yellow button menu items"
- | entries |
- entries := OrderedCollection withAll:
- {
- #-.
- {'explain' translated. #explain}.
- {'pretty print' translated. #prettyPrint}.
- {'pretty print with color' translated. #prettyPrintWithColor}.
- {'file it in (G)' translated. #fileItIn}.
- {'spawn (o)' translated. #spawn}.
- #-.
- {'browse it (b)' translated. #browseIt}.
- {'senders of it (n)' translated. #sendersOfIt}.
- {'implementors of it (m)' translated. #implementorsOfIt}.
- {'references to it (N)' translated. #referencesToIt}.
- #-.
- {'selectors containing it (W)' translated. #methodNamesContainingIt}.
- {'method strings with it (E)' translated. #methodStringsContainingit}.
- {'method source with it' translated. #methodSourceContainingIt}.
- {'class names containing it' translated. #classNamesContainingIt}.
- {'class comments with it' translated. #classCommentsContainingIt}.
- {'change sets with it' translated. #browseChangeSetsWithSelector}.
- #-.
- {'save contents to file...' translated. #saveContentsInFile}.
- {'send contents to printer' translated. #sendContentsToPrinter}.
- {'printer setup' translated. #printerSetup}.
- #-.
- }.
- Smalltalk isMorphic ifFalse: [ entries add:
- {'special menu...' translated. #presentSpecialMenu}.].
- entries add:
- {'more...' translated. #yellowButtonActivity}.
- ^ entries!
Item was removed:
- ----- Method: StringHolder class>>yellowButtonMenuItems (in category '*Tools-yellow button menu') -----
- yellowButtonMenuItems
- "Returns the standard yellow button menu items"
- ^{
- #-.
- {'set font... (k)' translated. #offerFontMenu}.
- {'set style... (K)' translated. #changeStyle}.
- {'set alignment... (u)' translated. #chooseAlignment}.
- #-.
- {'make project link (P)' translated. #makeProjectLink}.
- #-.
- {'find...(f)' translated. #find}.
- {'find again (g)' translated. #findAgain}.
- {'find and replace ...' translated. #findReplace}.
- {'do/replace again (j)' translated. #again}.
- #-.
- {'undo (z)' translated. #undo}.
- {'redo (Z)' translated. #redo}.
- #-.
- {'copy (c)' translated. #copySelection}.
- {'cut (x)' translated. #cut}.
- {'paste (v)' translated. #paste}.
- {'paste...' translated. #pasteRecent}.
- #-.
- {'do it (d)' translated. #doIt}.
- {'debug it (D)' translated. #debugIt}.
- {'print it (p)' translated. #printIt}.
- {'inspect it (i)' translated. #inspectIt}.
- {'explore it (I)' translated. #exploreIt}.
- {'button for it' translated. #buttonForIt}.
- {'tally it' translated. #tallyIt}.
- {'spy on it' translated. #spyOnIt}.
- #-.
- {'accept (s)' translated. #accept}.
- {'cancel (l)' translated. #cancelSafely}.
- #-.
- {'show bytecodes' translated. #showBytecodes}.
- #-.
- {'copy as html' translated. #copyHtmlSelection}.
- #-.
- {'more...' translated. #shiftedTextPaneMenuRequest}.
- }!
Item was removed:
- ----- Method: StringHolder>>browseAllMessages (in category '*Tools') -----
- browseAllMessages
- "Create and schedule a message set browser on all implementors of all the messages sent by the current method."
-
- | aClass aName method filteredList |
- (aName := self selectedMessageName) ifNotNil: [
- method := (aClass := self selectedClassOrMetaClass) compiledMethodAt: aName.
- filteredList := method messages reject:
- [:each | #(new initialize = ) includes: each].
- self systemNavigation browseAllImplementorsOfList: filteredList sorted
- title: 'All messages sent in ', aClass name, '.', aName]
- !
Item was removed:
- ----- Method: StringHolder>>browseClass (in category '*Tools') -----
- browseClass
- "Open an class browser on this class and method"
- ^ self browseMethodFull.!
Item was removed:
- ----- Method: StringHolder>>browseClassHierarchy (in category '*Tools') -----
- browseClassHierarchy
- "Create and schedule a class list browser on the receiver's hierarchy."
-
- self systemNavigation
- spawnHierarchyForClass: self selectedClassOrMetaClass "OK if nil"
- selector: self selectedMessageName!
Item was removed:
- ----- Method: StringHolder>>browseClassRefs (in category '*Tools-traits') -----
- browseClassRefs
-
- self selectedClass ifNotNil: [:cls |
- cls isTrait ifFalse: [self systemNavigation browseAllCallsOnClass: cls]]
- !
Item was removed:
- ----- Method: StringHolder>>browseImplementors (in category '*Tools') -----
- browseImplementors
-
- self browseAllImplementorsOf: self selectedMessageName requestor: #modelMenu.!
Item was removed:
- ----- Method: StringHolder>>browseLocalImplementors (in category '*Tools') -----
- browseLocalImplementors
- "Present a menu of all messages sent by the currently selected message.
- Open a message set browser of all implementors of the message chosen in or below
- the selected class.
- Do nothing if no message is chosen."
- self getSelectorAndSendQuery: #browseAllImplementorsOf:localTo:
- to: self systemNavigation
- with: { self selectedClass }!
Item was removed:
- ----- Method: StringHolder>>browseLocalSenders (in category '*Tools') -----
- browseLocalSenders
- self selectedClassOrMetaClass ifNotNil:
- [:cls| | token |
- token := UIManager default request: 'browse for selector or literal'.
- token isEmpty ifTrue: [^self].
- Scanner new
- typedScan: token
- do: [:scannedToken :tokenType|
- token := tokenType = #word
- ifTrue:
- [(Symbol lookup: token)
- ifNil: [^UIManager default inform: 'no such selector: ', token]
- ifNotNil: [:symbol| symbol]]
- ifFalse:
- [scannedToken].
- self systemNavigation browseAllCallsOn: token localTo: cls]]!
Item was removed:
- ----- Method: StringHolder>>browseLocalSendersOfMessages (in category '*Tools') -----
- browseLocalSendersOfMessages
- "Present a menu of the currently selected message, as well as all
- messages sent by it. Open a message set browser of all implementors
- of the message chosen in or below the selected class"
-
- self getSelectorAndSendQuery: #browseAllCallsOn:localTo:
- to: self systemNavigation
- with: { self selectedClass }!
Item was removed:
- ----- Method: StringHolder>>browseMessages (in category '*Tools') -----
- browseMessages
- "Present a menu of all messages sent by the currently selected message.
- Open a message set browser of all implementors of the message chosen."
-
- self getSelectorAndSendQuery: #browseAllImplementorsOf:requestor: to: self with: #(modelMenu).!
Item was removed:
- ----- Method: StringHolder>>browseMethodFull (in category '*Tools') -----
- browseMethodFull
- "Create and schedule a full Browser and then select the current class and message."
- ^ self selectedClassOrMetaClass ifNotNil: [ :cls |
- self selectedMessageName
- ifNotNil: [ :sel |
- ToolSet browse: cls selector: sel]
- ifNil: [ToolSet browseClass: cls]].!
Item was removed:
- ----- Method: StringHolder>>browseSenders (in category '*Tools') -----
- browseSenders
-
- self browseAllCallsOn: self selectedMessageName requestor: #modelMenu.!
Item was removed:
- ----- Method: StringHolder>>browseSendersOfMessages (in category '*Tools') -----
- browseSendersOfMessages
- "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen."
-
- self getSelectorAndSendQuery: #browseAllCallsOn:requestor: to: self with: #(modelMenu).!
Item was removed:
- ----- Method: StringHolder>>browseTraitUsers (in category '*Tools-traits') -----
- browseTraitUsers
-
- self selectedClass ifNotNil: [:classOrTrait |
- classOrTrait isTrait ifTrue: [self systemNavigation browseAllUsersOfTrait: classOrTrait]]
- !
Item was removed:
- ----- Method: StringHolder>>browseUnusedMethods (in category '*Tools') -----
- browseUnusedMethods
- | classes unsent messageList cls |
- (cls := self selectedClass)
- ifNil: [^ self].
- classes := Array with: cls with: cls class.
- unsent := Set new.
- classes
- do: [:c | unsent addAll: c selectors].
- unsent := self systemNavigation allUnSentMessagesIn: unsent.
- messageList := OrderedCollection new.
- classes
- do: [:c | (c selectors
- select: [:s | unsent includes: s]) sort
- do: [:sel | messageList add: c name , ' ' , sel]].
- self systemNavigation browseMessageList: messageList name: 'Unsent Methods in ' , cls name!
Item was removed:
- ----- Method: StringHolder>>browseVariableAssignments (in category '*Tools-traits') -----
- browseVariableAssignments
- | cls |
- cls := self selectedClassOrMetaClass.
- (cls notNil and: [ cls isTrait not ]) ifTrue: [ self systemNavigation browseVariableAssignments: cls ]!
Item was removed:
- ----- Method: StringHolder>>browseVariableReferences (in category '*Tools-traits') -----
- browseVariableReferences
- | cls |
- cls := self selectedClassOrMetaClass.
- (cls notNil and: [cls isTrait not])
- ifTrue: [self systemNavigation browseVariableReferences: cls]!
Item was removed:
- ----- Method: StringHolder>>browseVersions (in category '*Tools') -----
- browseVersions
- "Create and schedule a Versions Browser, showing all versions of the
- currently selected message. Answer the browser or nil."
- ^ self classCommentIndicated
- ifTrue: [ClassCommentVersionsBrowser browseCommentOf: self selectedClass]
- ifFalse: [self selectedMessageName ifNotNil:
- [:selector |
- ToolSet browseVersionsOf: self selectedClassOrMetaClass selector: selector]]!
Item was removed:
- ----- Method: StringHolder>>classListKey:from: (in category '*Tools') -----
- classListKey: aChar from: view
- "Respond to a Command key. I am a model with a list of classes and 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."
-
- aChar == $f ifTrue: [^ self findMethod].
- aChar == $r ifTrue: [^ self browseVariableReferences].
- aChar == $a ifTrue: [^ self browseVariableAssignments].
- aChar == $h ifTrue: [^ self spawnHierarchy].
- aChar == $x ifTrue: [^ self removeClass].
- ^ self messageListKey: aChar from: view!
Item was removed:
- ----- Method: StringHolder>>codePaneMenu:shifted: (in category '*Tools-code pane menu') -----
- codePaneMenu: aMenu shifted: shifted
- ^ self menu: aMenu for: #(codePaneMenu codePaneMenuShifted:) shifted: shifted
- !
Item was removed:
- ----- Method: StringHolder>>codePaneMenuHook:shifted: (in category '*Tools-pluggable menus - hooks') -----
- codePaneMenuHook: aMenu shifted: aBoolean
- <codePaneMenu>
- <menuPriority: 400>
- ^ self menuHook: aMenu named: #codePaneMenu shifted: aBoolean.
- !
Item was removed:
- ----- Method: StringHolder>>codeTextMorph (in category '*Tools') -----
- codeTextMorph
- "Find a Morphic text pane that displays the contents of the receiver. Note that this is a hack only and violates the original idea of the model-view pattern. Using this selector in your model will likely break compatibility with other UI frameworks such as MVC. Usually, the communication should come from the view instead, e.g., via a pluggable selector."
-
- | textPane |
- textPane := self codeTextPane.
- ^ textPane isMorph ifTrue: [textPane]!
Item was removed:
- ----- Method: StringHolder>>codeTextPane (in category '*Tools') -----
- codeTextPane
- "Find a text pane that displays the contents of the receiver. Note that this is a hack only and violates the original idea of the model-view pattern. Usually, the communication should come from the view instead, e.g., via a pluggable selector."
-
- ^ self anyTextPaneWithSelector: #contents!
Item was removed:
- ----- Method: StringHolder>>contents:notifying: (in category '*Tools-code pane menu') -----
- contents: aString notifying: aController
- "Accept text"
- ^self acceptContents: aString!
Item was removed:
- ----- Method: StringHolder>>copyName (in category '*Tools') -----
- copyName
- "Copy the current selector to the clipboard"
- | selector |
- (selector := self selectedMessageName) ifNotNil:
- [Clipboard clipboardText: selector asString asText]!
Item was removed:
- ----- Method: StringHolder>>copyReference (in category '*Tools') -----
- copyReference
- "Copy the selected selector to the clipboard"
- self selectedMessageName ifNotNil:
- [ : selector | Clipboard clipboardText:
- (self selectedClassOrMetaClass
- ifNil: [ selector asString ]
- ifNotNil: [ : cls | (cls >> selector) reference ]) ]!
Item was removed:
- ----- Method: StringHolder>>copySelector (in category '*Tools') -----
- copySelector
- "Copy the selected selector to the clipboard"
-
- | selector |
- (selector := self selectedMessageName) ifNotNil:
- [Clipboard clipboardText: selector asString]!
Item was removed:
- ----- Method: StringHolder>>fileOutAllMessages (in category '*Tools') -----
- fileOutAllMessages
- "Put a description of the all the message list on a file."
-
- FileStream
- writeSourceCodeFrom:
- (String new: 16000 streamContents: [:str |
- self messageList do: [:e |
- e actualClass printMethodChunk: e methodSymbol withPreamble: true
- on: str moveSource: false toFile: 0]])
- baseName: (self messageListSelectorTitle replaceAll: Character space with: $_) isSt: true useHtml: false!
Item was removed:
- ----- Method: StringHolder>>fileOutMessage (in category '*Tools') -----
- fileOutMessage
- "Put a description of the selected message on a file.
- If no message is selected, put a description of ALL the message list."
-
- self selectedMessageName
- ifNil:
- [self fileOutAllMessages]
- ifNotNil:
- [Cursor write showWhile:
- [self selectedClassOrMetaClass fileOutMethod: self selectedMessageName]]!
Item was removed:
- ----- Method: StringHolder>>findMethodInChangeSets (in category '*Tools') -----
- findMethodInChangeSets
- "Find and open a changeSet containing the current method."
-
- | aName |
- (aName := self selectedMessageName) ifNotNil: [
- ChangeSorter browseChangeSetsWithClass: self selectedClassOrMetaClass
- selector: aName]!
Item was removed:
- ----- Method: StringHolder>>inspectInstances (in category '*Tools') -----
- inspectInstances
- "Inspect all instances of the selected class."
-
- | myClass |
- (myClass := self selectedClassOrMetaClass) ifNotNil:
- [myClass theNonMetaClass inspectAllInstances].
- !
Item was removed:
- ----- Method: StringHolder>>inspectSubInstances (in category '*Tools') -----
- inspectSubInstances
- "Inspect all instances of the selected class and all its subclasses"
-
- | aClass |
- (aClass := self selectedClassOrMetaClass) ifNotNil: [
- aClass theNonMetaClass inspectSubInstances].
- !
Item was removed:
- ----- Method: StringHolder>>mainCodePaneMenu:shifted: (in category '*Tools-code pane menu') -----
- mainCodePaneMenu: aMenu shifted: shifted
- <codePaneMenu>
- "Fill in the given menu with additional items. The menu is prepoulated with the 'standard' text commands that the editor supports. Note that unless we override perform:orSendTo:, the editor will respond to all menu items in a text pane"
- ^ self class codePaneMenu: aMenu shifted: shifted.
- !
Item was removed:
- ----- Method: StringHolder>>menuHook:named:shifted: (in category '*Tools-code pane menu') -----
- menuHook: aMenu named: aSymbol shifted: aBool
- "Provide a hook for supplemental menu items. Answer the appropriately-enhanced menu."
- ^ aMenu!
Item was removed:
- ----- Method: StringHolder>>messageList (in category '*Tools') -----
- messageList
- ^Array new!
Item was removed:
- ----- Method: StringHolder>>messageListKey:from: (in category '*Tools') -----
- 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].
-
- aChar == $m ifTrue: [^ self browseImplementors].
- aChar == $n ifTrue: [^ self browseSenders].
-
- "The following require a class selection"
- sel := self selectedMessageName.
- (class := self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view].
- aChar == $b ifTrue: [^ ToolSet browse: class selector: sel].
- aChar == $N ifTrue: [^ self browseClassRefs].
- aChar == $i ifTrue: [^ self methodHierarchy].
- aChar == $h ifTrue: [^ self browseClassHierarchy].
- aChar == $p ifTrue: [^ self browseFullProtocol].
-
- "The following require a method selection"
- sel ifNotNil:
- [aChar == $o ifTrue: [^ self fileOutMessage].
- aChar == $c ifTrue: [^ self copySelector].
- aChar == $C ifTrue: [^ self copyReference].
- aChar == $v ifTrue: [^ self browseVersions].
- aChar == $x ifTrue: [^ self removeMessage]].
-
- ^ self arrowKey: aChar from: view!
Item was removed:
- ----- Method: StringHolder>>messageListSelectorTitle (in category '*Tools') -----
- messageListSelectorTitle
- | selector aString aStamp aSize |
-
- (selector := self selectedMessageName)
- ifNil:
- [aSize := self messageList size.
- ^ (aSize = 0 ifTrue: ['no'] ifFalse: [aSize printString]), ' message', (aSize = 1 ifTrue: [''] ifFalse: ['s'])]
- ifNotNil:
- [Preferences timeStampsInMenuTitles
- ifFalse: [^ nil].
- aString := selector truncateWithElipsisTo: 28.
- ^ (aStamp := self timeStamp) size > 0
- ifTrue:
- [aString, String cr, aStamp]
- ifFalse:
- [aString]]!
Item was removed:
- ----- Method: StringHolder>>methodHierarchy (in category '*Tools') -----
- methodHierarchy
- "Create and schedule a method browser on the hierarchy of implementors."
-
- self systemNavigation
- methodHierarchyBrowserForClass: self selectedClassOrMetaClass
- selector: self selectedMessageName
- !
Item was removed:
- ----- Method: StringHolder>>offerDurableMenuFrom:shifted: (in category '*Tools') -----
- offerDurableMenuFrom: menuRetriever shifted: aBoolean
- "Pop up (morphic only) a menu whose target is the receiver and whose contents are provided by sending the menuRetriever to the receiver. The menuRetriever takes two arguments: a menu, and a boolean representing the shift state; put a stay-up item at the top of the menu."
-
- | aMenu |
- aMenu := MenuMorph new defaultTarget: self.
- aMenu addStayUpItem.
- self perform: menuRetriever with: aMenu with: aBoolean.
- aMenu popUpInWorld!
Item was removed:
- ----- Method: StringHolder>>offerMenuFrom:shifted: (in category '*Tools') -----
- offerMenuFrom: menuRetriever shifted: aBoolean
- "Pop up a menu whose target is the receiver and whose contents are provided
- by sending the menuRetriever to the receiver. The menuRetriever takes two
- arguments: a menu, and a boolean representing the shift state."
-
- Project current offerMenu: menuRetriever from: self shifted: aBoolean
- !
Item was removed:
- ----- Method: StringHolder>>openLabel: (in category '*Tools') -----
- openLabel: aString
- "Create a standard system view of the model, me, a StringHolder and open it. If in mvc, terminate the active controller so that the new window will immediately be activated."
- ^ToolBuilder open: self label: aString!
Item was removed:
- ----- Method: StringHolder>>printOutMessage (in category '*Tools') -----
- printOutMessage
- "Write a file with the text of the selected message, for printing by a web browser"
-
- self selectedMessageName ifNotNil: [
- self selectedClassOrMetaClass fileOutMethod: self selectedMessageName
- asHtml: true]!
Item was removed:
- ----- Method: StringHolder>>removeFromCurrentChanges (in category '*Tools') -----
- removeFromCurrentChanges
- "Tell the changes mgr to forget that the current msg was changed."
-
- ChangeSet current removeSelectorChanges: self selectedMessageName
- class: self selectedClassOrMetaClass.
- self changed: #annotation!
Item was removed:
- ----- Method: StringHolder>>revertAndForget (in category '*Tools') -----
- revertAndForget
- "Revert to the previous version of the current method, and tell the changes mgr to forget that it was ever changed. Danger!! Use only if you really know what you're doing!!"
-
- self okToChange ifFalse: [^ self].
- self revertToPreviousVersion.
- self removeFromCurrentChanges.
- self contentsChanged
- !
Item was removed:
- ----- Method: StringHolder>>revertToPreviousVersion (in category '*Tools') -----
- revertToPreviousVersion
- "Revert to the previous version of the current method"
- | aClass aSelector changeRecords |
- self okToChange ifFalse: [^ self].
- aClass := self selectedClassOrMetaClass.
- aClass ifNil: [^ self changed: #flash].
- aSelector := self selectedMessageName.
- changeRecords := aClass changeRecordsAt: aSelector.
- (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [self changed: #flash. ^ Beeper beep].
- changeRecords second fileIn.
- self contentsChanged
- !
Item was removed:
- ----- Method: StringHolder>>selectMessageAndEvaluate: (in category '*Tools') -----
- selectMessageAndEvaluate: aBlock
- "Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any"
-
- | selector method |
- (selector := self selectedMessageName) ifNil: [^ self].
- method := (self selectedClassOrMetaClass ifNil: [^aBlock value: selector])
- compiledMethodAt: selector
- ifAbsent: [].
- method isNil ifTrue: [^aBlock value: selector].
- ^self withSelectorAndMessagesIn: method evaluate: aBlock!
Item was removed:
- ----- Method: StringHolder>>showBytecodes (in category '*Tools-code pane menu') -----
- showBytecodes
- "We don't know how to do this"
-
- ^ self changed: #flash!
Item was removed:
- ----- Method: StringHolder>>timeStamp (in category '*Tools') -----
- timeStamp
- "Answer the time stamp for the chosen class and method, if any, else an empty string"
-
- | selector aMethod |
- (selector := self selectedMessageName) ifNotNil:
- [self selectedClassOrMetaClass
- ifNil:
- [^ String new]
- ifNotNil:
- [aMethod := self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: [nil].
- aMethod ifNotNil: [^ aMethod timeStamp]]].
- ^ String new!
Item was removed:
- ----- Method: StringHolder>>wantsAnnotationPane (in category '*Tools-optional panes') -----
- wantsAnnotationPane
- "Answer whether the receiver, seen in some browser window, would like to have the so-called annotationpane included. By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary."
-
- ^ Preferences annotationPanes!
Item was removed:
- ----- Method: StringHolder>>wantsOptionalButtons (in category '*Tools-optional panes') -----
- wantsOptionalButtons
- "Answer whether the receiver, seen in some browser window, would like to have the so-called optional button pane included. By default, various browsers defer to the global preference 'optionalButtons' -- but individual subclasses can insist to the contrary."
-
- ^ Preferences optionalButtons!
Item was removed:
- ----- Method: StringHolder>>withSelectorAndMessagesIn:evaluate: (in category '*Tools') -----
- withSelectorAndMessagesIn: aCompiledMethod evaluate: aBlock
- "Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any"
-
- | selectorOrNil messages |
- selectorOrNil := aCompiledMethod selector.
- messages := aCompiledMethod anyAndAllMessages.
- messages remove: selectorOrNil ifAbsent: ["do nothing"].
- messages ifEmpty: "If only one item, there is no choice"
- [^selectorOrNil ifNotNil: [aBlock value: selectorOrNil]].
- self systemNavigation
- showMenuOf: messages
- withFirstItem: selectorOrNil
- ifChosenDo: aBlock!
Item was removed:
- ----- Method: Symbol>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Symbol'!
Item was removed:
- StringHolder subclass: #SyntaxError
- instanceVariableNames: 'class selector debugger notification'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Debugger'!
-
- !SyntaxError commentStamp: '<historical>' prior: 0!
- I represent syntax error report for syntax errors encountered when filing in class descriptions from a non-interactive source such as an external file. As a StringHolder, the string to be viewed is the method code or expression containing the error.
-
- The user may fix the error and accept the method to continue the fileIn.
- !
Item was removed:
- ----- Method: SyntaxError class>>open: (in category 'instance creation') -----
- open: aSyntaxErrorNotification
-
- ^ ToolBuilder default openDebugger: (self new setNotification: aSyntaxErrorNotification; yourself)!
Item was removed:
- ----- Method: SyntaxError>>aboutToStyle: (in category 'text menu support') -----
- aboutToStyle: aStyler
-
- aStyler
- classOrMetaClass: self selectedClassOrMetaClass;
- environment: notification environment;
- context: notification context;
- parseAMethod: notification doitFlag not.
- ^ true!
Item was removed:
- ----- Method: SyntaxError>>buildWith: (in category 'toolbuilder') -----
- buildWith: builder
-
- | windowSpec listSpec textSpec |
- windowSpec := builder pluggableWindowSpec new
- model: self;
- label: 'Syntax Error';
- children: OrderedCollection new.
-
- listSpec := builder pluggableListSpec new.
- listSpec
- model: self;
- list: #list;
- getIndex: #listIndex;
- setIndex: nil;
- menu: #listMenu:;
- frame: (0@0 corner: 1(a)0.15).
- windowSpec children add: listSpec.
-
- textSpec := builder pluggableCodePaneSpec new.
- textSpec
- model: self;
- getText: #contents;
- setText: #contents:notifying:;
- selection: #contentsSelection;
- menu: #codePaneMenu:shifted:;
- frame: (0(a)0.15 corner: 1@1).
- windowSpec children add: textSpec.
-
- ^ builder build: windowSpec!
Item was removed:
- ----- Method: SyntaxError>>contents:notifying: (in category 'other') -----
- contents: aString notifying: aController
- "Accept the code editions if syntax is correct.
- Then let the notification signalerContext proceed and restart compilation with these newSource."
-
- "In case of failure, return false so as to not accept the edits"
- notification reparse: aString notifying: aController ifFail: [^false].
-
- "else accept edits and proceed"
- aController hasUnacceptedEdits: false.
- self proceed!
Item was removed:
- ----- Method: SyntaxError>>contentsSelection (in category 'accessing') -----
- contentsSelection
-
- ^ notification ifNil: [1 to: 0] ifNotNil: [self errorMessageInterval]!
Item was removed:
- ----- Method: SyntaxError>>debug (in category 'menu') -----
- debug
- "Show the stack of the process leading to this syntax editor, typically showing the stack of the compiler as called from fileIn."
-
- debugger openFullNoSuspendLabel: 'Stack of the Syntax Error'.
- Smalltalk isMorphic ifFalse: [Processor terminateActive].
- !
Item was removed:
- ----- Method: SyntaxError>>debugger (in category 'accessing') -----
- debugger
-
- ^ debugger!
Item was removed:
- ----- Method: SyntaxError>>errorMessageInterval (in category 'text menu support') -----
- errorMessageInterval
- "To understand this format, see Parser >> #notify:at:."
-
- ^ notification location
- to: notification location
- + '"' size
- + notification errorMessage size - 1
- + ' ->"' size!
Item was removed:
- ----- Method: SyntaxError>>initialExtent (in category 'initialize-release') -----
- initialExtent
-
- ^ 380@220!
Item was removed:
- ----- Method: SyntaxError>>list (in category 'message list') -----
- list
- "Answer an array of one element made up of the class name and message selector in which the syntax error was found. This is the single item in the message list of a view/browser on the receiver."
-
- ^ Array with: (class name, ' ', (selector ifNil: ['<none>']))
- !
Item was removed:
- ----- Method: SyntaxError>>listIndex (in category 'message list') -----
- listIndex
- "There is always exactly one element in my list and it is always selected."
-
- ^ 1
- !
Item was removed:
- ----- Method: SyntaxError>>listMenu: (in category 'menu') -----
- listMenu: aMenu
-
- ^ aMenu labels:
- 'proceed
- debug calling process
- browse full'
- lines: #()
- selections: #(proceed debug browseMethodFull)
- !
Item was removed:
- ----- Method: SyntaxError>>proceed (in category 'menu') -----
- proceed
- "The user has has edited and presumably fixed the syntax error and the filein can now proceed. The active process usually suspends (or terminates) after this call."
-
- [debugger proceed]
- ensure: [self changed: #close].!
Item was removed:
- ----- Method: SyntaxError>>release (in category 'initialize-release') -----
- release
- debugger ifNotNil:
- [debugger interruptedProcess ifNotNil:
- [:p | p isTerminated ifFalse:
- [p terminate]]].!
Item was removed:
- ----- Method: SyntaxError>>selectedClass (in category 'text menu support') -----
- selectedClass
- "Answer the class in which the syntax error occurred."
-
- ^ class
- !
Item was removed:
- ----- Method: SyntaxError>>selectedClassOrMetaClass (in category 'text menu support') -----
- selectedClassOrMetaClass
- "Answer the class of the method being compiled."
-
- ^ class
- !
Item was removed:
- ----- Method: SyntaxError>>selectedMessageName (in category 'text menu support') -----
- selectedMessageName
- "Answer the selector of the method being compiled."
-
- ^ selector
- !
Item was removed:
- ----- Method: SyntaxError>>setNotification: (in category 'accessing') -----
- setNotification: aSyntaxErrorNotification
-
- | types printables badChar code |
- notification := aSyntaxErrorNotification.
- class := aSyntaxErrorNotification errorClass.
-
- debugger := Project current debuggerClass new.
- debugger context: aSyntaxErrorNotification signalerContext.
-
- code := aSyntaxErrorNotification errorCode.
- selector := class newParser parseSelector: code.
- types := Scanner classPool at: #TypeTable. "dictionary"
- printables := '!!@#$%&*-_=+<>{}?/\,·£¢§¶ªº–—“‘”’…Úæگ׿«»`~`' asSet.
- badChar := code detect: [:aChar | (types at: aChar asciiValue ifAbsent: [#xLetter]) == #xBinary and: [
- (printables includes: aChar) not]] ifNone: [nil].
- contents := badChar
- ifNil: [code]
- ifNotNil: ['<<<This string contains a character (ascii value ',
- badChar asciiValue printString,
- ') that is not normally used in code>>> ', code].
-
- self changed: #contentsSelection.!
Item was removed:
- AppRegistry subclass: #SystemBrowser
- instanceVariableNames: ''
- classVariableNames: 'BrowseWithDragNDrop BrowseWithPrettyPrint'
- poolDictionaries: ''
- category: 'Tools-Base'!
-
- !SystemBrowser commentStamp: '<historical>' prior: 0!
- This is the AppRegistry class for class browsing!
Item was removed:
- ----- Method: SystemBrowser class>>addRegistryMenuItemsTo:inAccountOf: (in category 'registration') -----
- addRegistryMenuItemsTo: aMenu inAccountOf: aBrowser
- "Add some useful options related Browser registry to the
- browsers windows menu"
- aMenu addLine;
- add: 'Register this Browser as default'
- target: [self default: aBrowser class]
- action: #value;
- add: 'Choose new default Browser'
- target: self
- action: #askForDefault!
Item was removed:
- ----- Method: SystemBrowser class>>browseWithDragNDrop (in category 'preferences') -----
- browseWithDragNDrop
- <preference: 'Browse with drag ''n'' drop' category: 'browsing' description: 'If true, new browsers will open with drag & drop functionality (only in Morphic)' type: #Boolean>
- ^ BrowseWithDragNDrop ifNil: [false].!
Item was removed:
- ----- Method: SystemBrowser class>>browseWithDragNDrop: (in category 'preferences') -----
- browseWithDragNDrop: aBoolean
- BrowseWithDragNDrop := aBoolean.!
Item was removed:
- ----- Method: SystemBrowser class>>browseWithPrettyPrint (in category 'preferences') -----
- browseWithPrettyPrint
- <preference: 'Browse with pretty-print' category: 'browsing' description: 'If true, browsers will automatically format their contents' type: #Boolean>
- ^ BrowseWithPrettyPrint ifNil: [false].!
Item was removed:
- ----- Method: SystemBrowser class>>browseWithPrettyPrint: (in category 'preferences') -----
- browseWithPrettyPrint: aBoolean
- BrowseWithPrettyPrint := aBoolean.!
Item was removed:
- ----- Method: SystemBrowser class>>browserShowsPackagePane (in category 'preferences') -----
- browserShowsPackagePane
- <preference: 'Browser shows package pane' category: 'browsing' description: 'If true, then the various ''browse full'' and ''browse it'' commands (usually invoked via cmd-b) will open a Package Browser rather than a System Browser. The Package Browser includes a package pane which groups system categories into packages based on the initial portion of their category name.' type: #Boolean>
- ^ SystemNavigation default browserClass == PackagePaneBrowser.!
Item was removed:
- ----- Method: SystemBrowser class>>browserShowsPackagePane: (in category 'preferences') -----
- browserShowsPackagePane: aBooleanOrNil
- | theOtherOne |
- self registeredClasses size = 2
- ifTrue: [theOtherOne := (self registeredClasses copyWithout: PackagePaneBrowser) first]
- ifFalse: [theOtherOne := nil].
- aBooleanOrNil == true
- ifTrue: [self default: PackagePaneBrowser]
- ifFalse: [self default: theOtherOne].
- SystemNavigation default browserClass: self default.!
Item was removed:
- ----- Method: SystemBrowser class>>defaultOpenBrowser (in category 'instance creation') -----
- defaultOpenBrowser
- ^self default openBrowser!
Item was removed:
- ----- Method: SystemNavigation>>allUsersOfTrait: (in category '*tools-traits') -----
- allUsersOfTrait: aTrait
-
- ^ aTrait users collect: [:class | MethodReference class: class selector: #Definition]!
Item was removed:
- ----- Method: SystemNavigation>>browseAllUsersOfTrait: (in category '*tools-traits') -----
- browseAllUsersOfTrait: aTrait
-
- ^ self
- browseMessageList: [self allUsersOfTrait: aTrait]
- name: 'Users of ', aTrait name!
Item was removed:
- ----- Method: SystemNavigation>>browserClass (in category '*tools-browser') -----
- browserClass
- browserClass ifNil: [browserClass := self defaultBrowserClass].
- ^browserClass!
Item was removed:
- ----- Method: SystemNavigation>>browserClass: (in category '*tools-browser') -----
- browserClass: aBrowserClass
- browserClass := aBrowserClass!
Item was removed:
- ----- Method: SystemNavigation>>defaultBrowserClass (in category '*tools-browser') -----
- defaultBrowserClass
- ^SystemBrowser default!
Item was removed:
- ----- Method: SystemNavigation>>defaultHierarchyBrowserClass (in category '*tools-browser') -----
- defaultHierarchyBrowserClass
- ^self class environment at: #HierarchyBrowser ifAbsent:[]!
Item was removed:
- ----- Method: SystemNavigation>>hierarchyBrowserClass (in category '*tools-browser') -----
- hierarchyBrowserClass
- hierarchyBrowserClass ifNil: [hierarchyBrowserClass := self defaultHierarchyBrowserClass].
- ^hierarchyBrowserClass!
Item was removed:
- ----- Method: SystemNavigation>>hierarchyBrowserClass: (in category '*tools-browser') -----
- hierarchyBrowserClass: aBrowserClass
- hierarchyBrowserClass := aBrowserClass!
Item was removed:
- ----- Method: TTCFont>>browseAllGlyphsScaledToDisplay (in category '*Tools-Browsing') -----
- browseAllGlyphsScaledToDisplay
- "Overwritten to support not-yet-registered fonts, e.g. through the FontImporterTool."
-
- ^ self isInstalled
- ifTrue: [super browseAllGlyphsScaledToDisplay]
- ifFalse: [self browseAllGlyphs]!
Item was removed:
- ----- Method: TTCFont>>browseGlyphsByCategoryOf:select:label: (in category '*Tools-Browsing') -----
- browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil
- "Overwritten to speed up browsing for remote fonts. We have to compose a paragraph with a lot of new glyphs in a paragraph ... even though we will not render all at the same time."
-
- ttcDescription cacheGlyphDataDuring: [
- ^ super browseGlyphsByCategoryOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil].!
Item was removed:
- ----- Method: TTCFont>>browseGlyphsOf:select:label: (in category '*Tools-Browsing') -----
- browseGlyphsOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil
- "Overwritten to speed up browsing for remote fonts. We have to compose a paragraph with a lot of new glyphs in a paragraph ... even though we will not render all at the same time."
-
- ttcDescription cacheGlyphDataDuring: [
- ^ super browseGlyphsOf: someCodePointsOrCharacters select: aBlock label: aLabelOrNil].!
Item was removed:
- ----- Method: Text>>addAttributesForDeprecation (in category '*Tools-attributes') -----
- addAttributesForDeprecation
- "Add text attributes to the receiver so that clients will recognize the underlying artifact (e.g., class or method) as deprecated."
-
- ((UserInterfaceTheme current get: #deprecatedMessageAttributes for: #CodeHolder)
- ifNil: [{TextColor gray. TextEmphasis struckOut}])
- do: [:textAttribute | self addAttribute: textAttribute].!
Item was removed:
- ----- Method: Text>>askIfAddStyle:req: (in category '*Tools-attributes') -----
- askIfAddStyle: priorMethod req: requestor
- "Ask the user if we have a complex style (i.e. bold) for the first time"
- | tell answ old |
- (SystemBrowser browseWithPrettyPrint) ifTrue:
- [self couldDeriveFromPrettyPrinting ifTrue: [^ self asString]].
- self runs coalesce.
- self unembellished ifTrue: [^ self asString].
- priorMethod ifNotNil:
- [old := priorMethod getSourceFromFile].
- (old == nil or: [old unembellished]) ifTrue:
- [tell := 'This method contains style for the first time (e.g. bold or colored text).
- Do you really want to save the style info?'.
- answ := (Project uiManager
- chooseOptionFrom: #('Save method with style' 'Save method simply')
- title: tell).
- answ = 2 ifTrue: [^ self asString]]!
Item was removed:
- ----- Method: Text>>canonicalArgumentName (in category '*Tools-Debugger') -----
- canonicalArgumentName
- ^ 'Text'!
Item was removed:
- ----- Method: TextEditor>>saveContentsInFile (in category '*Tools-file out') -----
- saveContentsInFile
- "Save the receiver's contents string to a file, which usually prompts the user for a file name."
-
- self paragraph text string
- ifEmpty: [self inform: 'Nothing to save.']
- ifNotEmpty: [:stringToSave |
- (self model saveContents: stringToSave accessMode: #create)
- ifTrue: [
- self flag: #discuss. "mt: Is this correct? Having unaccepted contents means that the model does not know about it. Do we assume that the model will also keep track of the stringToSave?"
- self morph hasUnacceptedEdits: false]].!
Item was removed:
- ----- Method: TextStyle class>>browseAllStyles (in category '*Tools-Browsing') -----
- browseAllStyles
-
- ^ self browseAllStylesAtPointSize: self defaultFont pointSize!
Item was removed:
- ----- Method: TextStyle class>>browseAllStylesAtPointSize: (in category '*Tools-Browsing') -----
- browseAllStylesAtPointSize: pointSize
- "
- self browseAllStylesAtPointSize: 24.0
- "
- ^ self browseAllStylesAtPointSize: pointSize sample: 'HelloSqueak' !
Item was removed:
- ----- Method: TextStyle class>>browseAllStylesAtPointSize:sample: (in category '*Tools-Browsing') -----
- browseAllStylesAtPointSize: pointSize sample: aString
- "
- self browseAllStylesAtPointSize: 24.0 sample: 'HelloSqueak'
- "
-
- (Text streamContents: [:stream | | allStyles |
- allStyles := self actualTextStyles sorted: [:a :b |
- (a isTTCStyle and: [b isTTCStyle not])
- or: [a isTTCStyle = b isTTCStyle and: [a defaultFamilyName <= b defaultFamilyName]]].
-
- "1) Combine all side-by-side to be able to compare ascent/descent/baseline."
- allStyles do: [:style |
- stream nextPutAll: (aString asText addAttribute: (TextFontReference toFont: (style defaultFont asPointSize: pointSize)); yourself)].
- stream cr; cr.
-
- "2) Show one per line. Be sure to also set the font for the line break to get the correct line height."
- allStyles do: [:style | stream nextPutAll: (
- ('{1} {2}\' withCRs asText format: {aString. style defaultFamilyName asText addAttribute: (PluggableTextAttribute evalBlock: [style explore]); yourself}) addAttribute: (TextFontReference toFont: (style defaultFont asPointSize: pointSize)); yourself)]
-
- ]) editWithLabel: 'All known fonts/styles'!
Item was removed:
- ----- Method: TextStyle>>chooseExtraGap (in category '*Tools-Browsing') -----
- chooseExtraGap
- "
- TextStyle defaultFixed chooseExtraGap.
- "
- | sampleFont answer |
- self isTTCStyle ifFalse: [^ self].
- sampleFont := self defaultFont.
-
- answer := Project uiManager
- request: ('Change extra leading for font\{1}.\Reset to default via non-number.' translated withCRs asText format: {self defaultFamilyName asText allBold})
- initialAnswer: sampleFont extraLineGap asString.
- (answer isNil or: [answer isEmpty]) ifTrue: [^ self].
- answer := [answer asNumber] on: NumberParserError do: [nil].
-
- sampleFont extraLineGap: answer.
- UserInterfaceTheme current basicApply.!
Item was removed:
- ----- Method: TextStyle>>chooseExtraScale (in category '*Tools-Browsing') -----
- chooseExtraScale
- "
- TextStyle defaultFixed chooseExtraScale.
- "
- | sampleFont answer |
- self isTTCStyle ifFalse: [^ self].
- sampleFont := self defaultFont.
-
- answer := Project uiManager
- request: ('Change extra scale for glyphs of font\{1}.\Reset to default via non-number.' translated withCRs asText format: {self defaultFamilyName asText allBold})
- initialAnswer: sampleFont extraGlyphScale asString.
- (answer isNil or: [answer isEmpty]) ifTrue: [^ self].
- answer := [answer asNumber] on: NumberParserError do: [nil].
-
- sampleFont extraGlyphScale: answer.
- UserInterfaceTheme current basicApply.!
Item was removed:
- ----- Method: TheWorldMenu>>browseRecentLog (in category '*Tools') -----
- browseRecentLog
- ChangeList browseRecentLog!
Item was removed:
- ----- Method: TheWorldMenu>>openChangeSorter1 (in category '*Tools') -----
- openChangeSorter1
-
- ToolBuilder open: ChangeSorter new!
Item was removed:
- ----- Method: TheWorldMenu>>openChangeSorter2 (in category '*Tools') -----
- openChangeSorter2
-
- ToolBuilder open: DualChangeSorter new!
Item was removed:
- ----- Method: TheWorldMenu>>openMessageNames (in category '*Tools') -----
- openMessageNames
- "Bring a MessageNames tool to the front"
-
- MessageNames openMessageNames!
Item was removed:
- ----- Method: TheWorldMenu>>openProcessBrowser (in category '*Tools') -----
- openProcessBrowser
- ProcessBrowser open!
Item was removed:
- ----- Method: TheWorldMenu>>openSelectorBrowser (in category '*Tools') -----
- openSelectorBrowser
-
- ToolBuilder open: SelectorBrowser new!
Item was removed:
- ----- Method: TheWorldMenu>>startThenBrowseMessageTally (in category '*Tools') -----
- startThenBrowseMessageTally
- (self confirm: 'MessageTally will start now,
- and stop when the cursor goes
- to the top of the screen')
- ifTrue: [ | world |
- world := Project current world.
- TimeProfileBrowser
- onBlock: [[Sensor peekPosition y > 10]
- whileTrue: [world doOneCycle]]]!
Item was removed:
- MessageSet subclass: #TimeProfileBrowser
- instanceVariableNames: 'block tally methodReferences'
- classVariableNames: 'TextMenu'
- poolDictionaries: ''
- category: 'Tools-Debugger'!
-
- !TimeProfileBrowser commentStamp: '<historical>' prior: 0!
- A TimeProfileBrowser is a browser visualizing the runtime profile of an executed Smalltalk block. It is useful for finding performance bottlenecks in code. When optimizing code it can
- be hard to know what methods actually constitute the bulk of the execution time. Is it a few
- methods that take very long time to execute or is it perhaps a single method that gets executed a thousand times?
-
- The block is first spied on using a MessageTally instance (which has even more funtionality than used by the TimeProfileBrowser) which samples the block during it's execution and collects the amount of time approximately spent in the methods executed. Then the methods are shown in the browser with their relative execution time in percent.
-
- Example:
- TimeProfileBrowser onBlock: [20 timesRepeat: [Transcript show: 100 factorial printString]]
- !
Item was removed:
- ----- Method: TimeProfileBrowser class>>onBlock: (in category 'instance creation') -----
- onBlock: block
- "Open a profile browser on the given block, thereby running the block and
- collecting the message tally."
- "TimeProfileBrowser onBlock: [20 timesRepeat:
- [Transcript show: 100 factorial printString]]"
-
- | inst result |
- inst := self new.
- result := inst runBlock: block.
- self open: inst name: 'Time Profile'.
- ^ result!
Item was removed:
- ----- Method: TimeProfileBrowser class>>parse:toClassAndSelector: (in category 'utilities') -----
- parse: aString toClassAndSelector: csBlock
- "Try to create a MethodReference from a line returned by MessageTally. Set both class and selector to nil if the string doesn't have the given format."
-
- | stream className class selector |
- stream := aString readStream.
- "Skip percentages and timing data."
- stream
- skipTo: $};
- skipSeparators.
- (stream peekFor: $[) ifTrue: [ "Skip block markers."
- stream upToAnyOf: CharacterSet separators ].
- className := stream upToAnyOf: '(>'.
-
- stream atEnd ifTrue: [ ^ csBlock value: nil value: nil ].
- stream last == $( ifTrue: [ "Method is defined in a super class"
- className := stream upTo: $).
- (stream peekFor: $>) ifFalse: [ ^ csBlock value: nil value: nil ] ].
- (stream peekFor: $>) ifFalse: [ ^ csBlock value: nil value: nil ].
- selector := stream upToEnd.
-
- self flag: #environments. "missing information about the class environment"
- (class := Smalltalk classNamed: className) ifNil: [^ csBlock value: nil value: nil].
- (selector := Symbol lookup: selector) ifNil: [^ csBlock value: nil value: nil].
- ^ csBlock value: class value: selector!
Item was removed:
- ----- Method: TimeProfileBrowser class>>spyOn: (in category 'instance creation') -----
- spyOn: block
- "Open a profile browser on the given block, thereby running the block and
- collecting the message tally."
- "TimeProfileBrowser spyOn: [20 timesRepeat:
- [Transcript show: 100 factorial printString]]"
-
- ^self onBlock: block!
Item was removed:
- ----- Method: TimeProfileBrowser class>>spyOnProcess:forMilliseconds: (in category 'instance creation') -----
- spyOnProcess: aProcess forMilliseconds: msecDuration
- "Run aProcess for msecDuration milliseconds, then open a TimeProfileBrowser on the results."
-
- "| p |
- p := [100000 timesRepeat: [3.14159 printString]] fork.
- (Delay forMilliseconds: 100) wait.
- TimeProfileBrowser spyOnProcess: p forMilliseconds: 1000"
-
- | inst |
- inst := self new.
- inst runProcess: aProcess forMilliseconds: msecDuration pollingEvery: MessageTally defaultPollPeriod.
- self open: inst name: (String streamContents: [ :s | s nextPutAll: 'Time Profile for '; print: msecDuration; nextPutAll: ' msec' ]).
- ^ inst!
Item was removed:
- ----- Method: TimeProfileBrowser>>formattedLabel:forSelector:inClass: (in category 'as yet unclassified') -----
- formattedLabel: aString forSelector: aSymbol inClass: aClass
-
- ^ aClass
- ifNil: [aString]
- ifNotNil: [super formattedLabel: aString forSelector: aSymbol inClass: aClass]!
Item was removed:
- ----- Method: TimeProfileBrowser>>hasMessageSelected (in category 'message list') -----
- hasMessageSelected
-
- ^super hasMessageSelected and: [
- (self methodReferences at: self messageListIndex) notNil ]!
Item was removed:
- ----- Method: TimeProfileBrowser>>initializeMessageList: (in category 'private') -----
- initializeMessageList: anArray
- messageList := anArray.
- messageListIndex := 0.
- contents := ''!
Item was removed:
- ----- Method: TimeProfileBrowser>>isModeStyleable (in category 'contents') -----
- isModeStyleable
- "Ensure that only methods are styled."
-
- ^self selectedMessageName notNil and: [ super isModeStyleable ]!
Item was removed:
- ----- Method: TimeProfileBrowser>>messageHelpAt: (in category 'message list') -----
- messageHelpAt: anIndex
- "Show the first n lines of the sources code of the selected message."
-
- | reference |
- Preferences balloonHelpInMessageLists ifFalse: [^ nil].
- self messageList size < anIndex ifTrue: [^ nil].
-
- reference := (self methodReferences at: anIndex) ifNil: [ ^nil ].
- reference isValid ifFalse: [ ^nil ].
- ^ self messageHelpForMethod: reference compiledMethod!
Item was removed:
- ----- Method: TimeProfileBrowser>>messageIconAt: (in category 'message list') -----
- messageIconAt: index
-
- ^nil!
Item was removed:
- ----- Method: TimeProfileBrowser>>messageListKey:from: (in category 'private') -----
- messageListKey: aChar from: view
- "Respond to a Command key. Cmd-D means re-run block."
-
- aChar == $d ifTrue: [ ^Cursor execute showWhile: block ].
- ^super messageListKey: aChar from: view!
Item was removed:
- ----- Method: TimeProfileBrowser>>methodReferenceFrom: (in category 'private') -----
- methodReferenceFrom: aString
-
- ^ self class parse: aString toClassAndSelector: [:class :selector |
- class ifNotNil: [MethodReference class: class selector: selector]]!
Item was removed:
- ----- Method: TimeProfileBrowser>>methodReferences (in category 'accessing') -----
- methodReferences
-
- ^methodReferences ifNil: [
- methodReferences := messageList collect: [ :each | self methodReferenceFrom: each ] ]
- !
Item was removed:
- ----- Method: TimeProfileBrowser>>runBlock: (in category 'private') -----
- runBlock: aBlock
- ^self runBlock: aBlock pollingEvery: MessageTally defaultPollPeriod!
Item was removed:
- ----- Method: TimeProfileBrowser>>runBlock:pollingEvery: (in category 'private') -----
- runBlock: aBlock pollingEvery: pollPeriod
- | list result |
- block := MessageSend
- receiver: self
- selector: #runBlock:pollingEvery:
- arguments: {
- aBlock.
- pollPeriod}. "so we can re-run it"
- tally := MessageTally new.
- tally
- reportOtherProcesses: false;
- maxClassNameSize: 1000;
- maxClassPlusSelectorSize: 1000;
- maxTabs: 100.
- result := tally spyEvery: pollPeriod on: aBlock.
- list := OrderedCollection withAll: (String streamContents: [ :s | tally report: s]) lines.
- self initializeMessageList: list.
- self changed: #messageList.
- self changed: #messageListIndex.
- ^result!
Item was removed:
- ----- Method: TimeProfileBrowser>>runProcess:forMilliseconds:pollingEvery: (in category 'private') -----
- runProcess: aProcess forMilliseconds: msecDuration pollingEvery: pollPeriod
- | list result |
- block := MessageSend
- receiver: self
- selector: #runProcess:forMilliseconds:pollingEvery:
- arguments: {
- aProcess.
- msecDuration.
- pollPeriod}. "so we can re-run it"
- tally := MessageTally new.
- tally
- reportOtherProcesses: false;
- maxClassNameSize: 1000;
- maxClassPlusSelectorSize: 1000;
- maxTabs: 100.
- result := tally
- spyEvery: pollPeriod
- onProcess: aProcess
- forMilliseconds: msecDuration.
- list := OrderedCollection withAll: (String streamContents: [ :s | tally report: s]) lines.
- self initializeMessageList: list.
- self changed: #messageList.
- self changed: #messageListIndex.
- ^result!
Item was removed:
- ----- Method: TimeProfileBrowser>>selectedMessage (in category 'message list') -----
- selectedMessage
- "Answer the source method for the currently selected message."
-
- self setClassAndSelectorIn: [ :class :selector |
- | source |
- source := (class == UndefinedObject and: [ selector == #DoIt ])
- ifTrue: [ 'DoIt', String cr, String cr, block arguments first decompile decompileString ]
- ifFalse: [ class sourceMethodAt: selector ifAbsent: [ ^'Missing' ] ].
- SystemBrowser browseWithPrettyPrint ifTrue: [
- source := class prettyPrinterClass
- format: source
- in: class
- notifying: nil
- decorated: false ].
- ^source asText makeSelectorBoldIn: class ].
- ^''!
Item was removed:
- ----- Method: TimeProfileBrowser>>setClassAndSelectorIn: (in category 'private') -----
- setClassAndSelectorIn: csBlock
- "Evaluate csBlock with the selected methodReference, or return nil if there's nothing selected."
-
- ^((self methodReferences at: self messageListIndex) ifNil: [ ^nil ])
- setClassAndSelectorIn: csBlock!
Item was removed:
- ----- Method: TimeProfileBrowser>>tally (in category 'accessing') -----
- tally
- "Answer the receiver's 'tally'."
-
- ^tally!
Item was removed:
- ----- Method: TimeProfileBrowser>>tally: (in category 'accessing') -----
- tally: anObject
- "Set the receiver's instance variable 'tally' to be anObject."
-
- tally := anObject!
Item was removed:
- Object subclass: #ToolIconHelp
- instanceVariableNames: ''
- classVariableNames: 'HelpTexts'
- poolDictionaries: ''
- category: 'Tools-Base'!
Item was removed:
- ----- Method: ToolIconHelp class>>abstract (in category 'icons') -----
- abstract
-
- ^ 'This method is abstract.' !
Item was removed:
- ----- Method: ToolIconHelp class>>arrowDown (in category 'icons') -----
- arrowDown
-
- ^ 'This method is overriden by another method.'!
Item was removed:
- ----- Method: ToolIconHelp class>>arrowUp (in category 'icons') -----
- arrowUp
-
- ^ 'This method overrides a super method.'!
Item was removed:
- ----- Method: ToolIconHelp class>>arrowUpAndDown (in category 'icons') -----
- arrowUpAndDown
-
- ^ 'This method overrides and is overridden by other methods.'!
Item was removed:
- ----- Method: ToolIconHelp class>>blank (in category 'icons') -----
- blank
-
- ^ ''!
Item was removed:
- ----- Method: ToolIconHelp class>>breakpoint (in category 'icons') -----
- breakpoint
-
- ^ 'This method contains a breakpoint.'!
Item was removed:
- ----- Method: ToolIconHelp class>>flag (in category 'icons') -----
- flag
-
- ^ 'This method needs attention of some kind.' !
Item was removed:
- ----- Method: ToolIconHelp class>>helpTexts (in category 'accessing') -----
- helpTexts
-
- ^ HelpTexts ifNil: [HelpTexts := IdentityDictionary new]!
Item was removed:
- ----- Method: ToolIconHelp class>>iconHelpNamed: (in category 'icons help') -----
- iconHelpNamed: aSymbol
-
- ^ (self respondsTo: aSymbol)
- ifTrue: [self helpTexts at: aSymbol ifAbsentPut: [self perform: aSymbol]]
- ifFalse: [String empty]
- !
Item was removed:
- ----- Method: ToolIconHelp class>>no (in category 'icons') -----
- no
-
- ^ 'This method should not be implemented.' !
Item was removed:
- ----- Method: ToolIconHelp class>>notOverridden (in category 'icons') -----
- notOverridden
-
- ^ 'This method is abstract and has not been overridden.' !
Item was removed:
- ----- Method: ToolIconHelp class>>primitive (in category 'icons') -----
- primitive
-
- ^ 'This method implements a primitive.'!
Item was removed:
- Object subclass: #ToolIcons
- instanceVariableNames: ''
- classVariableNames: 'Icons'
- poolDictionaries: ''
- category: 'Tools-Base'!
Item was removed:
- ----- Method: ToolIcons class>>abstract (in category 'private') -----
- abstract
-
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 165 165 165 165 165 16777215 16777215 165 165 165 165 165 16777215 16777215 165 165 16777215 2712832 2712832 16777215 165 165 165 165 165 165 165 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 165 165 165 165 165 4294967295 4284714821 4284714821 4284714821 4284714821 4284714821 4284714821 4294967295 165 165 165 16777215 4294967295 4284714821 4288074840 4288074840 4288074840 4287677545 4284714821 4294967295 16777215 165 165 16777215 4294967295 4284714821 4288074840 4287679828 4287810910 4287677545 4284714821 4294967295 16777215 165 165 16777215 4294967295 4284714821 4288074840 4287614291 4287810910 4286361178 4284714821 4294967295 16777215 165 165 16777215 4294967295 4284714821 4288074840 4287677545 4286361178 4286361178 4284714821 4294967295 16777215 165 165 165 4294967295 4284714821 4284714821 4284714821 4284714821 4284714821 4284714821 4294967295 165 165 165 165 165 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 165 165 165 165
165 165 165 16777215 2712832 2712832 16777215 165 165 165 165 165 165 165 165 165 16777215 16777215 165 165 165 165 165)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>arrowDown (in category 'private') -----
- arrowDown
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 0 0 0 0 0 0 4294967295 4284714821 4284714821 4284714821 4284714821 4294967295 0 0 0 0 0 0 4294967295 4284714821 4287614291 4287810910 4284714821 4294967295 0 0 0 0 4294967295 4294967295 4294967295 4284714821 4287679828 4287810910 4284714821 4294967295 4294967295 4294967295 0 0 4294967295 4284714821 4284714821 4284714821 4288074840 4287677545 4284714821 4284714821 4284714821 4294967295 0 0 0 4294967295 4284714821 4287810910 4288272218 4287876447 4287350105 4284714821 4294967295 0 0 0 0 0 4294967295 4284714821 4287810910 4286361178 4284714821 4294967295 0 0 0 0 0 0 0 4294967295 4284714821 4284714821 4294967295 0 0 0 0 0 0 0 0 0 4294967295 4294967295 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>arrowUp (in category 'private') -----
- arrowUp
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294967295 4294967295 0 0 0 0 0 0 0 0 0 4294967295 4284714821 4284714821 4294967295 0 0 0 0 0 0 0 4294967295 4284714821 4287810910 4286361178 4284714821 4294967295 0 0 0 0 0 4294967295 4284714821 4287810910 4288272218 4287876447 4287350105 4284714821 4294967295 0 0 0 4294967295 4284714821 4284714821 4284714821 4288074840 4287677545 4284714821 4284714821 4284714821 4294967295 0 0 4294967295 4294967295 4294967295 4284714821 4287679828 4287810910 4284714821 4294967295 4294967295 4294967295 0 0 0 0 4294967295 4284714821 4287614291 4287810910 4284714821 4294967295 0 0 0 0 0 0 4294967295 4284714821 4284714821 4284714821 4284714821 4294967295 0 0 0 0 0 0 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>arrowUpAndDown (in category 'private') -----
- arrowUpAndDown
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 0 0 0 0 0 4294967295 4294967295 0 0 0 0 0 0 0 0 0 4294967295 4284714821 4284714821 4294967295 0 0 0 0 0 0 0 4294967295 4284714821 4287810910 4286361178 4284714821 4294967295 0 0 0 0 0 4294967295 4284714821 4287810910 4288272218 4287876447 4287350105 4284714821 4294967295 0 0 0 4294967295 4284714821 4284714821 4284714821 4288074840 4287677545 4284714821 4284714821 4284714821 4294967295 0 0 4294967295 4294967295 4294967295 4284714821 4287679828 4287810910 4284714821 4294967295 4294967295 4294967295 0 0 4294967295 4294967295 4294967295 4284714821 4287614291 4287810910 4284714821 4294967295 4294967295 4294967295 0 0 4294967295 4284714821 4284714821 4284714821 4288074840 4287677545 4284714821 4284714821 4284714821 4294967295 0 0 0 4294967295 4284714821 4287810910 4288272218 4287876447 4287350105 4284714821 4294967295 0 0 0 0 0 4294967295 4284714821 4287810910 4286361178 4284714821 4294967295 0 0 0 0 0 0 0 4294967295 4284714821 4284714821 4294967295 0 0 0 0 0 0 0 0 0 42949
67295 4294967295 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>blank (in category 'private') -----
- blank
- ^ Form extent: 12 @ 12 depth: 8!
Item was removed:
- ----- Method: ToolIcons class>>blank16 (in category 'private') -----
- blank16
- ^ Form extent: 16 @ 16 depth: 8!
Item was removed:
- ----- Method: ToolIcons class>>breakpoint (in category 'private') -----
- breakpoint
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294156190 4294219671 4294085257 4294146939 4294140771 4294138201 4294136145 4284036633 4284036633 4284036633 4294967295 4294967295 4294219671 4294830826 4294697184 4294764005 4294156190 4294156190 4294156190 4291318347 4289820229 4284036633 4294967295 4294967295 4294085257 4294697184 4294140771 4294139229 4294136145 4294136145 4294134860 4291318347 4289820229 4284496668 4294967295 4294967295 4294140771 4294156190 4294138201 4294137173 4294136145 4294134860 4294134860 4288365876 4289820229 4284036633 4294967295 4294967295 4294139229 4294219671 4294136145 4294136145 4294134860 4294134860 4294134860 4288365876 4289820229 4283708184 4294967295 4294967295 4294137173 4294085257 4293619053 4293619053 4293619053 4293619053 4293619053 4287311645 4289820229 4283708184 4294967295 4294967295 4293473589 4292813603 4292418331 4291366414 42
90250246 4290250246 4290250246 4284036633 4289820229 4283708184 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4284036633 4289820229 4283708184 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4289820229 4283708184 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4289820229 4284036633 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4284036633 4284036633 4294967295)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>checkmark (in category 'private') -----
- checkmark
- "© 2018 Icon8
- Website: https://icons8.com
- License: https://creativecommons.org/licenses/by-nd/3.0/"
-
- ^ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: 'iVBORw0KGgoAAAANSUhEUgAAAEAAAABACAYAAACqaXHeAAAABmJLR0QA/wD/AP+gvaeTAAAD
- zUlEQVRYCe2ZT0hUQRzH561adLBDpFBBKvRH0AITtEPQHwiCgrCgIAhBJOhUdAoKOnjqUEGH
- AiE6FRF1C0+RQpcKhCgwOuSf0jDDCMsSW3f6DOuDx+72nHm7+5Z5zeP73ffcmfnN7/ud35t9
- 6wrhDueAc8A54BxwDjgHnAN2OlCTSqWuVFVVveJ8Fwnb4P8DRN+DMsBfXJ/HgRRMNlj1bsTK
- QqTtBeqbYWKxAeGzsKABy+/PYUR3Ih3wPO/JssgwA1RbBhOOhJlg3b2CoB4MOBwmKtDmSSlP
- Bv7Ou7TNgAYp5Y08FeFvzIU329PKwntPNUtflb/iIvJaof1A+AWoRJnwov3KswpaEL8AtcWz
- VzxnqG23OCnnowbhw1BbPH3nCbMd2g/EXIIm4lXfc/YrzypoR/wiVKK0yE45yNBElP4qhL+G
- WsKX+6mPvEaRhANBfdBEvGTjO5ME7UpDJ+L/QG0DKP0BNTAJXIPwd1BbPH1nEb4R2g/EXIMm
- 4lXpn7ZfeVbBXsQvQalLSv9Rdqj9r7WIHoXa4uk7jew6aD8QcwuaiFelf9R+5Siorq4+hPgM
- NDHgPkOLhhchwnoSPc69t8TxkPHq4YNTZKjSf8PoRqF/zGQymVa6f4Wxog3x09BfqXEhRFFf
- OojVD/14WmceeLqYN3Z0kuh3mJvkDJnsgMZAyLEC8XLj5/59x3iiEgzoINFC4v3kophQT8wZ
- 6MfQOU+gZS2MFR0kGSbeT9zIBGI+gP5YnXOGzfJArMqZbB1JTkGdBFWfKcasuCdQ+l0GMVVc
- xX5ixwsS7Y2Q6GeyDDOhjphfoBKlyzFi1sKSI7VCxKUV2gs1q19tBmkoaAIfn7dpq4e6UM8H
- PXT+AWOH+oweNVwtf1XzKoGKOhUh1s3YVedMuJmkP0BfmMk5uDGqODqbaTD+W3JZDSsOlXwx
- Juyk9KP8qLGr4soDCWylCiZhcIV0r39GGHc1MHfZLj3DyKoShoQQTbBsoFqG+Z6xmwnSsKzw
- IkQvtwkLfNFpJ68RWHakIszwkQT3M24MlgN9BI1FPPMIT71EZAP39ZAQolGU6KD0X1L6ewiX
- hrHAK3KWUprwm8pqI5/3MDZEuQWCyU2Q9D4hxLgo/rhMiFjFM1/JoCphjFtCRiFPiENCiGIX
- gxCVxRbEf4KmJsyRdhNMBJQJk4YmnE2E8oAI7SdGdv0BxnkwcdAx4RuqN8HEooVb4Z//+GDj
- 602s8oCwZkwYgbkb4/VAn4pexnH/1bDaJ6SUB1E6jxmP0+n0M64dnAPOAeeAc8A54BxwDlTU
- gb+am3XexSy3CAAAAABJRU5ErkJggg==' readStream)!
Item was removed:
- ----- Method: ToolIcons class>>cleanUp: (in category 'initialize-release') -----
- cleanUp: aggressive
-
- aggressive ifTrue: [Icons := nil].!
Item was removed:
- ----- Method: ToolIcons class>>collection (in category 'private') -----
- collection
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 4294964203 4294947198 4294938953 4294947198 4294964203 0 0 0 0 0 0 0 4294946167 4294483041 4293435505 4293693782 4294945395 0 4293916398 4287874445 4285050207 4287874445 4293916398 0 4294939470 4293566834 4292777576 4291988059 4294938953 0 4287545991 4287348353 4288922521 4286558838 4287283332 0 4294946167 4293891161 4292119903 4293035852 4294945395 0 4285247331 4288988570 4288461714 4287606661 4285050207 0 4294963945 4294946426 4294938181 4294946426 4294963945 0 4287545991 4286821753 4287803784 4286031980 4287283332 0 0 0 0 0 0 0 4293785068 4287677321 4284787547 4287677321 4293785068 0 0 0 4294834926 4294238348 4293907294 4294238348 4294834926 0 0 0 0 0 0 0 4294172295 4293777015 4292988807 4293053292 4294172035 0 0 0 0 0 0 0 4293973090 4293186184 4292462206 4291672945 4293907294 0 0 0 0 0 0 0 4294172295 4293184879 4291738741 4292460898 4294172035 0 0 0 0 0 0 0 4294834924 4294238089 4293907034 4294238089 4294834924 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>exception (in category 'private') -----
- exception
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 0 0 4294371495 4293908066 4293842277 4293841507 4293775456 4293708891 4293577045 4293378633 4294371516 4294834928 0 0 4294172547 4294106220 4294040432 4294039405 4293973096 4293906533 4293576270 4293245752 4294504141 4294835187 0 4294768349 4293974633 4294634386 4294368606 4294235479 4294301290 4294236810 4293444430 4294636250 0 0 0 4294239131 4294370178 4294368870 4294102843 4294036547 4294236543 4293510488 4294437573 0 0 0 4294834665 4293973866 4294502031 4294169671 4293970487 4294170225 4293840750 4294239413 0 0 0 0 4294371762 4294172025 4294435187 4294168905 4293969724 4294169977 4293246022 4293444706 4293378916 4293246298 4293048405 4293511033 4293577033 4294105718 4294171257 4294038641 4294170495 4294103156 4293970801 4293971324 4293640551 4292915263 4293709969 4294371787 4294239138 4294107034 4294040985 4293842310 4293510493 4294036070 4293969512 4293310802 4293378927 4294437840 0 0 0 0 0 4294635995 4293509979 4293773681 4293113677 4293974434 4294967037 0 0 0
0 0 0 4293180237 4293245257 4293312869 4294702567 0 0 0 0 0 0 0 4294106534 4292849719 4294040744 0 0 0 0 0 0 0 0 0 4294239161 4294570202 0 0 0 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>flag (in category 'private') -----
- flag
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4288859642 4288400378 4287284473 4286102264 4284132854 4283673334 4283016693 4284036633 4284036633 4284036633 4294967295 4294967295 4288400378 4293259774 4293259774 4293259774 4289188346 4288859642 4288859642 4282294213 4289820229 4284036633 4294967295 4294967295 4287284473 4293259774 4284132854 4283673334 4283016693 4282688501 4282425845 4282023874 4289820229 4284627477 4294967295 4294967295 4284132854 4289188346 4283279606 4283016693 4282425845 4282425845 4282425845 4281886101 4289820229 4284036633 4294967295 4294967295 4283673334 4288400378 4283016693 4282819829 4282425845 4282425845 4282425845 4281886101 4289820229 4283708184 4294967295 4294967295 4283016693 4287284473 4285250295 4285250295 4284856054 4284856054 4284856054 4284627477 4289820229 4283708184 4294967295 4294967295 4282232813 4282232813 4282167001 4282167001 42
82034889 4282294213 4281965995 4284036633 4289820229 4283708184 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 4284036633 4289820229 4283708184 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4289820229 4283708184 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4289820229 4284036633 4294967295 0 0 0 0 0 0 0 4294967295 4284036633 4284036633 4284036633 4294967295)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>font (in category 'private') -----
- font
-
- | icon f1 f2 |
- icon := Form extent: 16@16 depth: 32.
- f1 := StrikeFont familyName: 'Bitmap DejaVu Sans' pointSize: 7.5.
- f2 := StrikeFont familyName: 'Bitmap DejaVu Sans' pointSize: 10.5.
- icon getCanvas
- drawString: 'A' at: 0@ (15 - f1 height) font: f1 color: Color black;
- drawString: 'A' at: (f1 widthOf: $A) @ (15 - f2 height) font: f2 color: Color black.
- ^ icon!
Item was removed:
- ----- Method: ToolIcons class>>iconForClass: (in category 'support') -----
- iconForClass: aClassNameSymbol
-
- self environment
- at: aClassNameSymbol
- ifPresent: [:global |
- (global respondsTo: #toolIcon) ifTrue: [
- ^ global toolIcon]]
- ifAbsent: [^ #blank].
- ^ #blank!
Item was removed:
- ----- Method: ToolIcons class>>iconForClass:selector: (in category 'support') -----
- iconForClass: aBehavior selector: aSelector
- "Answer an icon to be shown for the selector aSymbol in aBehavior."
- (aBehavior respondsTo: #toolIconSelector:) ifTrue: [
- ^ aBehavior toolIconSelector: aSelector].
- ^ #blank
- !
Item was removed:
- ----- Method: ToolIcons class>>iconNamed: (in category 'accessing') -----
- iconNamed: aSymbol
-
- ^self icons at: aSymbol ifAbsentPut: [self perform: aSymbol]!
Item was removed:
- ----- Method: ToolIcons class>>icons (in category 'accessing') -----
- icons
-
- ^ Icons ifNil: [Icons := Dictionary new]!
Item was removed:
- ----- Method: ToolIcons class>>keyboardButtonLabeled: (in category 'buttons') -----
- keyboardButtonLabeled: stringOrForm
-
- ^ self keyboardButtonLabeled: stringOrForm dyed: Color black!
Item was removed:
- ----- Method: ToolIcons class>>keyboardButtonLabeled:dyed: (in category 'buttons') -----
- keyboardButtonLabeled: anObject dyed: aColor
-
- | id form c width height elevation thickness font margins color label |
- thickness := RealEstateAgent scaleFactor rounded.
-
- anObject isForm
- ifTrue: [label := anObject]
- ifFalse: [
- label := anObject asString.
- id := (#button, label, thickness) asSymbol.
- self icons at: id ifPresent: [:icon |
- ^ aColor ~= Color black
- ifTrue: [icon dyed: aColor]
- ifFalse: [icon]]].
-
- elevation := (thickness * 2.5) rounded.
- font := Preferences standardButtonFont.
- color := Color black.
-
- margins := (font widthOf: $x) @ (font height // 2).
- width := label isForm ifTrue: [label width] ifFalse: [font widthOfString: label].
- height := label isForm ifTrue: [label height] ifFalse: [font height].
-
- form := Form
- extent: (width + (2* margins x)) @ (height + (2* margins y) + elevation)
- depth: 32.
-
- c := form getCanvas.
- c
- frameRoundRect: (0@0 extent: form extent - (0@elevation))
- radius: thickness * 5
- width: thickness
- color: Color black.
-
- elevation > 0 ifTrue: [
- c
- clipBy: (0@ (form height // 2) corner: form width @ form height)
- during: [:c2 |
- c2
- frameRoundRect: (0@ elevation extent: form extent - (0@elevation))
- radius: thickness * 5
- width: thickness
- color: Color black]].
-
- label isForm
- ifTrue: [ c paintImage: label at: margins x @ (margins y)]
- ifFalse: [
- c
- drawString: label
- at: margins x @ (margins y)
- font: font
- color: color].
-
- id ifNotNil: [self icons at: id put: form].
-
- ^ aColor ~= Color black
- ifTrue: [form dyed: aColor]
- ifFalse: [form]!
Item was removed:
- ----- Method: ToolIcons class>>magnitude (in category 'private') -----
- magnitude
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 0 4292861919 4286677377 4286479998 4287993237 4288059030 4287598479 4285756275 4285164138 4287072135 0 0 0 0 4288059030 4290690750 4287730065 4289901234 4289703855 4289243304 4289309097 4288322202 0 0 0 0 4293322470 4287335307 4287664272 4292532954 0 0 0 4286611584 0 0 0 0 0 4290295992 4288651167 4286151033 4294309365 0 0 0 0 0 0 0 0 0 4286677377 4288387995 4290164406 0 0 0 0 0 0 0 0 0 4290953922 4284637794 4288124823 0 0 0 0 0 0 0 0 4294309365 4285229931 4285164138 0 0 0 0 0 0 0 0 0 4287269514 4285690482 4288387995 0 0 0 4281611316 0 0 0 0 4290690750 4285493103 4285361517 0 0 4294177779 0 4282137660 0 0 0 4292796126 4283914071 4283782485 4288716960 4288585374 4287598479 4283190348 4281216558 4284440415 0 0 0 4290493371 4285822068 4285558896 4285229931 4285032552 4284835173 4284637794 4284440415 4286940549 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>morph (in category 'private') -----
- morph
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 4289839580 4288331238 4287542498 4287607777 4287475934 4287344604 4287278554 4287146969 4286949590 4287278037 4288525266 4290234076 4287934423 4287543013 4287016930 4287016930 4286950879 4286885086 4286819293 4286753500 4286621914 4286884827 4286751180 4288196048 4286754273 4287214049 4287608033 4287410913 4287345381 4287673834 4287476968 4287279842 4287542498 4287543013 4286161107 4286291404 4288593123 4293719549 4292209405 4293259773 4293587947 4291880146 4292931041 4293916413 4292668925 4293522685 4289708509 4287144908 4289249763 4291159551 4285840895 4289189887 4290435500 4284722775 4288005764 4291947263 4287417087 4290503935 4290234076 4287341514 4288986848 4291684863 4286957055 4290043135 4290830265 4285314924 4288597652 4292209919 4288008191 4290897919 4290036186 4287209670 4288461538 4293850862 4291814867 4293063142 4294767338 4294434247 4294568413 4294638062 4294176722 4294769125 4289576667 4286684358 4288920552 4290436015 4284919642 4287416979 4294953900 42
94936894 4294946435 4294307254 4294235741 4294961804 4289445600 4286487243 4288788710 4291421627 4285904999 4288533664 4294956727 4294941008 4294950033 4294899137 4294696554 4294963868 4289642464 4286355142 4287079630 4292469742 4292075239 4292206827 4292468971 4292467684 4292468200 4292337385 4292271331 4292271590 4287932618 4286157760 4287933133 4287671254 4287867353 4287473106 4286882253 4286685904 4286554058 4286552260 4286486986 4286355142 4286617792 4288458446 0 0 0 0 0 0 0 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>no (in category 'private') -----
- no
-
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1357600601 2162906969 2162906969 820729689 0 0 0 0 0 0 283858777 3488307033 4293613401 4293613401 4293613401 4293613401 3219871577 283858777 0 0 0 0 3488307033 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 3219871577 0 0 0 1357600601 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 820729689 0 0 2162906969 4293613401 4294628822 4294628822 4294628822 4294628822 4294628822 4294628822 4293613401 1894471513 0 0 2162906969 4293613401 4294628822 4294628822 4294628822 4294628822 4294628822 4294628822 4293613401 1894471513 0 0 820729689 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 820729689 0 0 0 3219871577 4293613401 4293613401 4293613401 4293613401 4293613401 4293613401 2951436121 0 0 0 0 283858777 3219871577 4293613401 4293613401 4293613401 4293613401 2951436121 283858777 0 0 0 0 0 0 820729689 1894471513 1894471513 820729689 0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>notOverridden (in category 'private') -----
- notOverridden
-
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4292955472 4292955472 4292955472 4292955472 4292955472 4292955472 0 0 0 0 0 0 4292955472 4294940569 4294940569 4294940569 4294936200 4292955472 0 0 0 0 0 0 4292955472 4294940569 4294937229 4294937999 4294936200 4292955472 0 0 0 0 0 0 4292955472 4294940569 4294937229 4294937999 4294535787 4292955472 0 0 0 0 0 0 4292955472 4294940569 4294936458 4294535787 4294535787 4292889936 0 0 0 0 0 0 4292955472 4292955472 4292955472 4292955472 4292759120 4292236111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>primitive (in category 'private') -----
- primitive
-
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4288124823 4288124823 9934743 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 4288124823 4288782753 4288782753 4288124823 9934743 16777215 16777215 16777215 16777215 16777215 16777215 4288124823 4288782753 4288782753 4289045925 4289440683 4288124823 9934743 16777215 16777215 16777215 16777215 4288124823 4288782753 4288782753 4289045925 4289045925 4289440683 4288848546 4288124823 16777215 16777215 16777215 16777215 4288124823 4288782753 4289045925 4289045925 4289045925 4288848546 4288848546 4288124823 16777215 16777215 16777215 16777215 9934743 4288124823 4289440683 4289440683 4288848546 4288848546 4288124823 10658466 16777215 16777215 16777215 16777215 9934743 10592673 4288124823 4288848
546 4288848546 4288124823 10658466 10658466 16777215 16777215 16777215 16777215 16777215 9934743 11250603 4288124823 4288124823 10658466 10658466 9934743 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>stream (in category 'private') -----
- stream
-
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 0 0 0 0 0 0 0 0 0 0 0 0 0 0 4294967295 4294967295 0 0 4294967295 4294967295 0 0 0 0 0 4294967295 4290038244 4292075503 4294967295 4294967295 4290038244 4292075503 4294967295 0 0 0 0 4294967295 4288921054 4284189380 4292535794 4294967295 4288921054 4284189380 4292535794 4294967295 0 0 0 4294967295 4288921054 4283597761 4284386245 4293850105 4289183968 4283597761 4284386245 4292995828 4294967295 0 0 4294967295 4288921054 4283597761 4283597761 4288461275 4289381089 4283597761 4283597761 4284583622 4293784313 4294967295 0 4294967295 4288921054 4283597761 4283597761 4288198106 4289381088 4283597761 4283597761 4284123588 4293192949 4294967295 0 4294967295 4288921054 4283597761 4283926211 4293127157 4289183968 4283597761 4283926211 4291812590 4294967295 0 0 4294967295 4288921054 4283794882 4291155690 4294967295 4288921054 4283794882 4291155690 4294967295 0 0 0 4294967295 4289381088 4290629607 4294967295 4294967295 4289381088 4290629607 4294967295 0 0 0 0 4294967295 42949672
95 4294967295 0 4294967295 4294967295 4294967295 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: ToolIcons class>>string (in category 'private') -----
- string
-
- ^ Form
- extent: 12@12
- depth: 32
- fromArray: #( 0 0 4292077049 4285510895 4285577969 4285577455 4285577199 4285577199 4285577199 4285771759 0 0 0 0 4285249007 4286956786 4287810035 4287218674 4285837807 0 4285771759 4285771503 0 0 0 0 4285577455 4287809779 4287809779 4287152882 4285771759 0 4285705967 4285705965 0 0 0 0 4285838063 4286562033 4287743987 4287152882 4285771503 0 4285705453 4285639661 0 0 0 0 4293981949 4286231022 4285642223 4286495729 4285705453 0 4285639661 4285639149 0 0 0 0 0 0 4293981693 4285377517 4285639661 0 4285638893 4285638892 0 0 0 0 0 0 0 4285639661 4285638893 0 4285638892 4285572844 0 0 0 0 0 0 0 4285638893 4285638892 0 4285572844 4285507052 0 0 0 0 0 0 0 4285638380 4285572844 0 4285507052 4285506540 0 0 0 0 0 0 0 4285507052 4285507052 0 4285506540 4285506284 0 0 0 0 0 0 0 4285506796 4285506540 0 4285506028 4285440492 0 0 0 0 0 0 0 4285506284 4285506284 0 4285440236 4285440234 0 0)
- offset: 0@0!
Item was removed:
- ----- Method: TranscriptStream class>>buildWith: (in category '*Tools') -----
- buildWith: aBuilder
- ^(Smalltalk at: #Transcript) buildWith: aBuilder!
Item was removed:
- ----- Method: TranscriptStream class>>openMorphicTranscript (in category '*Tools') -----
- openMorphicTranscript
- "Have the current project's transcript open up as a morph"
-
- ^ToolBuilder open: self!
Item was removed:
- ----- Method: TranscriptStream>>buildWith: (in category '*Tools') -----
- buildWith: builder
- | windowSpec textSpec |
- windowSpec := builder pluggableWindowSpec new.
- windowSpec model: self.
- windowSpec label: 'Transcript'.
- windowSpec children: OrderedCollection new.
-
- textSpec := builder pluggableTextSpec new.
- textSpec
- model: self;
- menu: #codePaneMenu:shifted:;
- frame: (0@0corner: 1@1).
- windowSpec children add: textSpec.
-
- ^builder build: windowSpec!
Item was removed:
- ----- Method: TranscriptStream>>codePaneMenu:shifted: (in category '*Tools') -----
- codePaneMenu: aMenu shifted: shifted
- "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items"
- ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted
- !
Item was removed:
- ----- Method: TranscriptStream>>open (in category '*Tools') -----
- open
- | openCount |
- openCount := self countOpenTranscripts.
- openCount = 0
- ifTrue: [self openLabel: 'Transcript']
- ifFalse: [self openLabel: 'Transcript #' , (openCount+1) printString]!
Item was removed:
- ----- Method: TranscriptStream>>openIfNone (in category '*Tools') -----
- openIfNone
- "Open a transcript window if there are no open windows."
-
- self countOpenTranscripts = 0 ifTrue: [self open]!
Item was removed:
- ----- Method: TranscriptStream>>openLabel: (in category '*Tools') -----
- openLabel: aString
- "Open a window on this transcriptStream"
- ^ToolBuilder open: self label: aString!
Item was removed:
- ----- Method: TranscriptStream>>postAcceptBrowseFor: (in category '*Tools') -----
- postAcceptBrowseFor: aModel
- "Nothing to do."!
Item was removed:
- ----- Method: TranscriptStream>>representsSameBrowseeAs: (in category '*Tools') -----
- representsSameBrowseeAs: anotherModel
- ^ true!
Item was removed:
- ----- Method: TranscriptStream>>saveContents:accessMode: (in category '*Tools-file out') -----
- saveContents: stringContents accessMode: accessMode
- "Interactive callback from TextEditor. See commentary in Model class."
-
- ^ (Project uiManager
- saveFilenameRequest: 'Save text contents in file...'
- initialAnswer: 'Transcript.text')
- ifNil: [false] ifNotNil: [:answer | answer ifEmpty: [false]
- ifNotEmpty: [:fileName |
- Model new
- saveContents: stringContents
- onFileNamed: fileName
- accessMode: accessMode]].!
Item was removed:
- ----- Method: Unicode class>>browseClassCommentsWithLeadingCharEncoding (in category '*Tools-Browsing') -----
- browseClassCommentsWithLeadingCharEncoding
- "See commentary in browseMethodsWithLeadingCharEncoding."
-
- ^ self systemNavigation
- browseMessageList: (Array streamContents: [:s |
- self systemNavigation
- allClassesDo: [:cls |
- (cls comment asString anySatisfy: [:each | each codePoint > 255])
- ifTrue: [s nextPut: (MethodReference class: cls selector: #Comment)] ]])
- name: 'Class comments affected by #leadingChar'!
Item was removed:
- ----- Method: Unicode class>>browseClassCommentsWithNonAsciiEncoding (in category '*Tools-Browsing') -----
- browseClassCommentsWithNonAsciiEncoding
- "See commentary in browseMethodsWithNonAsciiEncoding."
-
- ^ self systemNavigation
- browseMessageList: (Array streamContents: [:s |
- self systemNavigation
- allClassesDo: [:cls | cls comment asString isAsciiString
- ifFalse: [s nextPut: (MethodReference class: cls selector: #Comment)] ]])
- name: 'Class comments with non-ASCII contents'!
Item was removed:
- ----- Method: Unicode class>>browseMethodsWithLeadingCharEncoding (in category '*Tools-Browsing') -----
- browseMethodsWithLeadingCharEncoding
- "Browse a list of methods whose sources are affected by Squeak's #leadingChar magic, which can confuse tools such as TextDiff depending on your current encoding (i.e., EncodedCharSet or LanguageEnvironment). NOTE THAT if you want to change those methods, ensure that your current encoding uses a leadingChar of 0, e.g., locale en-US and Latin1Environment. See UTF8TextConverter class >> #decodeByteString: and Unicode class >> #value:."
-
- ^ self systemNavigation
- browseMessageList: (self systemNavigation
- allMethodsSelect: [:method | method getSource asString
- anySatisfy: [:each | each codePoint > 255]])
- name: 'Methods sources affected by #leadingChar'!
Item was removed:
- ----- Method: Unicode class>>browseMethodsWithNonAsciiEncoding (in category '*Tools-Browsing') -----
- browseMethodsWithNonAsciiEncoding
- "Browse a list of methods whose sources benefit from UTF8 encoding."
-
- ^ self systemNavigation
- browseMessageList: (self systemNavigation
- allMethodsSelect: [:method | method getSource asString isAsciiString not])
- name: 'Methods with non-ASCII sources'!
Item was removed:
- ----- Method: Utilities class>>browseRecentSubmissions (in category '*Tools') -----
- browseRecentSubmissions
- "Open up a browser on the most recent methods submitted in the image."
- ^ RecentMessageSet
- openMessageList: RecentMessages default methodReferences
- name: 'Recent Submissions'
- autoSelect: nil!
Item was removed:
- ----- Method: Utilities class>>closeAllDebuggers (in category '*Tools') -----
- closeAllDebuggers
- "Utilities closeAllDebuggers"
- Smalltalk isMorphic
- ifTrue:
- [((Smalltalk at: #SystemWindow) allSubInstances select: [:w | w model isKindOf: Debugger])
- do: [:w | w delete]]
- ifFalse:
- [((Smalltalk at: #StandardSystemController) allInstances select: [:w | w model isKindOf: Debugger])
- do: [:w | w closeAndUnscheduleNoTerminate]]!
Item was removed:
- ----- Method: Utilities class>>openRecentSubmissionsBrowser (in category '*Tools') -----
- openRecentSubmissionsBrowser
- "Open up a browser on the most recent methods submitted in the image; reuse any existing one found in the world."
- self deprecated: 'use #browseRecentSubmissions'.
- self browseRecentSubmissions!
Item was removed:
- ----- Method: Utilities class>>recentSubmissionsWindow (in category '*Tools') -----
- recentSubmissionsWindow
- "Answer a SystemWindow holding recent submissions"
- | messageSet |
- messageSet := RecentMessageSet messageList: RecentMessages default methodReferences.
- messageSet
- autoSelectString: nil;
- setInitialLabel: 'Recent Submissions'.
- ^ ToolBuilder build: messageSet!
Item was removed:
- ChangeList subclass: #VersionsBrowser
- instanceVariableNames: 'classOfMethod selectorOfMethod addedChangeRecord'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Changes'!
-
- !VersionsBrowser commentStamp: 'nk 11/25/2003 10:04' prior: 0!
- VersionsBrowser shows all the versions of a particular method, and lets you compare them, revert to selected versions, and so on.!
Item was removed:
- ----- Method: VersionsBrowser class>>browseMethod: (in category 'instance creation') -----
- browseMethod: aCompiledMethod
-
- ^ (self browseVersionsOf: aCompiledMethod)
- ifNotNil: [:browser |
- browser selectMethod: aCompiledMethod];
- yourself!
Item was removed:
- ----- Method: VersionsBrowser class>>browseVersionsForClass:selector: (in category 'instance creation') -----
- browseVersionsForClass: aClass selector: aSelector
-
- ^ self
- browseVersionsOf: (aClass compiledMethodAt: aSelector)
- class: aClass
- meta: aClass isMeta
- category: (aClass organization categoryOfElement: aSelector)
- selector: aSelector!
Item was removed:
- ----- Method: VersionsBrowser class>>browseVersionsOf: (in category 'instance creation') -----
- browseVersionsOf: aCompiledMethod
-
- | methodClass methodSelector |
- methodClass := aCompiledMethod methodClass.
- methodSelector := aCompiledMethod selector.
- ^ self
- browseVersionsOf: aCompiledMethod
- class: methodClass
- meta: methodClass isMeta
- category: (methodClass organization categoryOfElement: methodSelector)
- selector: methodSelector!
Item was removed:
- ----- Method: VersionsBrowser class>>browseVersionsOf:class:meta:category:selector: (in category 'instance creation') -----
- browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector
- ^ self browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: nil!
Item was removed:
- ----- Method: VersionsBrowser class>>browseVersionsOf:class:meta:category:selector:lostMethodPointer: (in category 'instance creation') -----
- browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: sourcePointer
- | changeList browser |
- Cursor read showWhile:
- [changeList := (browser := self new)
- scanVersionsOf: method class: class meta: meta
- category: msgCategory selector: selector].
- changeList ifNil: [ self inform: 'No versions available' translated. ^nil ].
-
- sourcePointer ifNotNil:
- [changeList setLostMethodPointer: sourcePointer].
-
- self open: changeList name: ('Recent versions of {1}' translated format: {selector}) multiSelect: false.
-
- ^browser!
Item was removed:
- ----- Method: VersionsBrowser class>>timeStampFor:class:reverseOrdinal: (in category 'instance creation') -----
- 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."
-
- | method aChangeList |
- method := aClass compiledMethodAt: aSelector ifAbsent: [^ nil].
- aChangeList := self new
- scanVersionsOf: method class: aClass meta: aClass isMeta
- category: nil selector: aSelector.
- ^ aChangeList ifNil: [nil] ifNotNil:
- [aChangeList list size >= anInteger
- ifTrue:
- [(aChangeList changeList at: anInteger) stamp]
- ifFalse:
- [nil]]!
Item was removed:
- ----- Method: VersionsBrowser class>>versionCountForSelector:class: (in category 'instance creation') -----
- versionCountForSelector: aSelector class: aClass
- "Answer the number of versions known to the system for the given class and method, including the current version. A result of greater than one means that there is at least one superseded version. Answer zero if no logged version can be obtained."
-
- | method aChangeList |
- method := aClass compiledMethodAt: aSelector ifAbsent: [^ 0].
- aChangeList := self new
- scanVersionsOf: method class: aClass meta: aClass isMeta
- category: nil selector: aSelector.
- ^ aChangeList ifNil: [0] ifNotNil: [aChangeList list size]!
Item was removed:
- ----- Method: VersionsBrowser>>aboutToStyle: (in category 'contents') -----
- aboutToStyle: aStyler
-
- "Style in source view, or when there's nothing to diff with."
- (self isModeStyleable or: [ listIndex = list size ]) ifFalse: [ ^false ].
- aStyler
- classOrMetaClass: classOfMethod;
- parseAMethod: true.
- ^true
- !
Item was removed:
- ----- Method: VersionsBrowser>>addPriorVersionsCountForSelector:ofClass:to: (in category 'misc') -----
- 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 versions are seen in a versions browser -- in this case, the inherited version of this method will not work."
-
- (aClass includesSelector: aSelector) ifTrue:
- [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream].
-
- aStream nextPutAll:
- ((changeList size > 0
- ifTrue:
- [changeList size = 1
- ifTrue:
- ['Deleted - one prior version' translated]
- ifFalse:
- ['Deleted - ', changeList size printString, ' prior versions']]
- ifFalse:
- ['surprisingly, no prior versions' translated]), self annotationSeparator)!
Item was removed:
- ----- Method: VersionsBrowser>>addedChangeRecord (in category 'init & update') -----
- addedChangeRecord
- ^addedChangeRecord!
Item was removed:
- ----- Method: VersionsBrowser>>addedChangeRecord: (in category 'init & update') -----
- addedChangeRecord: aChangeRecord
- addedChangeRecord := aChangeRecord.
- self reformulateList.!
Item was removed:
- ----- Method: VersionsBrowser>>changeListButtonSpecs (in category 'init & update') -----
- changeListButtonSpecs
-
- ^#(
- ('compare to current'
- compareToCurrentVersion
- 'opens a separate window which shows the text differences between the selected version and the current version')
-
- ('revert'
- fileInSelections
- 'reverts the method to the version selected')
-
- ('remove from changes'
- removeMethodFromChanges
- 'remove this method from the current change set')
-
- ('help'
- offerVersionsHelp
- 'further explanation about use of Versions browsers')
- )!
Item was removed:
- ----- Method: VersionsBrowser>>changeListKey:from: (in category 'menu') -----
- changeListKey: aChar from: view
- "Respond to a Command key in the list pane. of the versions browser"
-
- ^ self messageListKey: aChar from: view!
Item was removed:
- ----- Method: VersionsBrowser>>classCommentIndicated (in category 'misc') -----
- classCommentIndicated
- "Answer whether the receiver is pointed at a class comment"
-
- ^ false!
Item was removed:
- ----- Method: VersionsBrowser>>compareToOtherVersion (in category 'menu') -----
- compareToOtherVersion
- "Prompt the user for a reference version, then spawn a window
- showing the diffs between the older and the newer of the current
- version and the reference version as text."
-
- | change1 change2 s1 s2 |
- change1 := changeList at: listIndex ifAbsent: [ ^self ].
-
- change2 := ((UIManager default
- chooseFrom: (list copyWithoutIndex: listIndex)
- values: (changeList copyWithoutIndex: listIndex))) ifNil: [ ^self ].
-
- "compare earlier -> later"
- "change1 timeStamp < change2 timeStamp
- ifFalse: [ | temp | temp := change1. change1 := change2. change2 := temp ]."
-
- s1 := change1 string.
- s2 := change2 string.
- s1 = s2
- ifTrue: [^ self inform: 'Exact Match' translated].
-
- (StringHolder new
- textContents: (TextDiffBuilder
- buildDisplayPatchFrom: s1
- to: s2
- inClass: classOfMethod
- prettyDiffs: self showingPrettyDiffs))
- openLabel: (('Comparison from {1} to {2}' translated) format: { change1 stamp. change2 stamp })!
Item was removed:
- ----- Method: VersionsBrowser>>defaultWindowColor (in category 'user interface') -----
- defaultWindowColor
- ^ (Color r: 0.782 g: 0.677 b: 0.9)!
Item was removed:
- ----- Method: VersionsBrowser>>fileInSelections (in category 'menu') -----
- fileInSelections
- super fileInSelections.
- self reformulateList!
Item was removed:
- ----- Method: VersionsBrowser>>fileOutSelection (in category 'menu') -----
- fileOutSelection
- | them it file |
- them := OrderedCollection new.
- listSelections with: changeList do:
- [:selected :item | selected ifTrue: [them add: item]].
- them size ~= 1
- ifTrue: [self inform: 'single version not selected, so nothing done' translated]
- ifFalse:
- [it := them first.
- file := FileStream newFileNamed: it methodClassName, (it isMetaClassChange ifTrue: [' class'] ifFalse: ['']), '-' , (it methodSelector copyReplaceAll: ':' with: '').
- [file header; timeStamp.
- it fileOutOn: file] ensure: [file close]]!
Item was removed:
- ----- Method: VersionsBrowser>>findOriginalChangeSet (in category 'menu') -----
- findOriginalChangeSet
- | changeSet |
- self currentChange ifNil: [^ self].
- changeSet := self currentChange originalChangeSetForSelector: self selectedMessageName.
- changeSet = #sources ifTrue:
- [^ self inform: 'This version is in the .sources file.' translated].
- changeSet ifNil:
- [^ self inform: 'This version was not found in any changeset nor in the .sources file.' translated].
- (ChangeSorter new myChangeSet: changeSet) open!
Item was removed:
- ----- Method: VersionsBrowser>>initialExtent (in category 'user interface') -----
- initialExtent
-
- "adopt the extent so that the revert button fits in"
- ^650@400!
Item was removed:
- ----- Method: VersionsBrowser>>listSelectionVersionsMenu: (in category 'menu') -----
- listSelectionVersionsMenu: aMenu
- "Fill aMenu with menu items appropriate to the receiver"
- <versionsMenu>
-
- listIndex > 0 ifTrue:[
- (list size > 1 ) ifTrue: [ aMenu addTranslatedList: #(
- ('compare to current' compareToCurrentVersion 'compare selected version to the current version')
- ('compare to version...' compareToOtherVersion 'compare selected version to another selected version'))].
- "Note: Revert to selected should be visible for lists of length one for having the ability to revert to an accidentally deleted method"
- aMenu addTranslatedList: #(
- ('revert to selected version' fileInSelections 'resubmit the selected version, so that it becomes the current version')
- ('fileOut selected version' fileOutSelection 'file out the selected version') )].
- ^ aMenu!
Item was removed:
- ----- Method: VersionsBrowser>>mainVersionsMenu: (in category 'menu') -----
- mainVersionsMenu: aMenu
- "Fill aMenu with menu items appropriate to the receiver"
- <versionsMenu>
-
- aMenu addTranslatedList: #(
- ('remove from changes' removeMethodFromChanges 'remove this method from the current change set, if present')
- ('find original change set' findOriginalChangeSet 'locate the changeset which originally contained this version')
- -
- ('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')
- -
- ('senders (n)' browseSenders 'browse all senders of this selector')
- ('implementors (m)' browseImplementors 'browse all implementors of this selector')
- ('inheritance (i)' methodHierarchy 'browse method inheritance')
- -
- ('help...' offerVersionsHelp 'provide an explanation of the use of this tool')).
-
- ^aMenu!
Item was removed:
- ----- Method: VersionsBrowser>>optionalButtonPairs (in category 'toolbuilder') -----
- optionalButtonPairs
-
- ^ #(('revert' fileInSelections 'resubmit the selected version, so that it becomes the current version')) , super optionalButtonPairs!
Item was removed:
- ----- Method: VersionsBrowser>>reformulateList (in category 'init & update') -----
- reformulateList
- | aMethod |
- "Some uncertainty about how to deal with lost methods here"
- aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ self].
-
- self scanVersionsOf: aMethod class: classOfMethod theNonMetaClass meta: classOfMethod isMeta category: (classOfMethod whichCategoryIncludesSelector: selectorOfMethod) selector: selectorOfMethod.
- self changed: #list. "for benefit of mvc"
- listIndex := 1.
- self changed: #listIndex.
- self contentsChanged
- !
Item was removed:
- ----- Method: VersionsBrowser>>removeMethodFromChanges (in category 'menu') -----
- removeMethodFromChanges
- "Remove my method from the current change set"
-
- ChangeSet current removeSelectorChanges: selectorOfMethod class: classOfMethod.
- self changed: #annotation
- !
Item was removed:
- ----- Method: VersionsBrowser>>scanVersionsOf:class:meta:category:selector: (in category 'init & update') -----
- scanVersionsOf: method class: class meta: meta category: category selector: selector
-
- selectorOfMethod := selector.
- currentCompiledMethod := method.
- classOfMethod := meta ifTrue: [class class] ifFalse: [class].
- changeList := OrderedCollection new.
- list := OrderedCollection new.
- self addedChangeRecord ifNotNil: [ :change |
- self
- addItem: change
- text: ('{1} (in {2})' translated
- format: { change stamp. change fileName }) ].
- listIndex := 0.
- (ChangeSet scanVersionsOf: method class: class meta: meta category: category selector: selector)
- ifNil: [^ nil];
- do: [ :change |
- self
- addItem: change
- text: ('{1} {2} {3} \{{4}\}' translated format: {
- change stamp. classOfMethod name. selector. change category })].
- listSelections := Array new: list size withAll: false.!
Item was removed:
- ----- Method: VersionsBrowser>>selectMethod: (in category 'menu') -----
- selectMethod: aCompiledMethod
-
- self toggleListIndex: (self changeList indexOf: (
- self changeList detect: [:change |
- change stamp = aCompiledMethod timeStamp and: [
- change string = aCompiledMethod getSource asString]]))!
Item was removed:
- ----- Method: VersionsBrowser>>selectedClass (in category 'misc') -----
- 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 theNonMetaClass!
Item was removed:
- ----- Method: VersionsBrowser>>selectedClassOrMetaClass (in category 'misc') -----
- selectedClassOrMetaClass
- "Answer the class or metaclass 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!
Item was removed:
- ----- Method: VersionsBrowser>>selectedMessageName (in category 'misc') -----
- selectedMessageName
- "Answer the message name 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"
-
- ^ selectorOfMethod!
Item was removed:
- ----- Method: VersionsBrowser>>showsVersions (in category 'misc') -----
- showsVersions
- ^ true!
Item was removed:
- ----- Method: VersionsBrowser>>titleVersionsMenu: (in category 'menu') -----
- titleVersionsMenu: aMenu
- "Add a menu title atop aMenu"
- <versionsMenu>
- <menuPriority: 100>
- aMenu title: 'Versions' translated.
- aMenu addStayUpItemSpecial.
- ^ aMenu!
Item was removed:
- ----- Method: VersionsBrowser>>toggleListIndex: (in category 'viewing access') -----
- toggleListIndex: newListIndex
-
- listIndex ~= 0 ifTrue: [listSelections at: listIndex put: false].
- newListIndex ~= 0 ifTrue: [listSelections at: newListIndex put: true].
-
- super toggleListIndex: newListIndex.!
Item was removed:
- ----- Method: VersionsBrowser>>updateListsAndCodeIn: (in category 'init & update') -----
- updateListsAndCodeIn: aWindow
- | aMethod |
- aMethod := classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ false].
- aMethod == 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)."
- aMethod last ~= 0 ifTrue: [self reformulateList]].
- ^ true
- !
Item was removed:
- ----- Method: VersionsBrowser>>versionFrom: (in category 'menu') -----
- versionFrom: secsSince1901
-
- "Return changeRecord of the version in effect at that time. Accept in the VersionsBrowser does not use this code."
-
- changeList do: [:cngRec | | vTime strings |
- (strings := cngRec stamp findTokens: ' ') size > 2 ifTrue: [
- vTime := strings second asDate asSeconds +
- strings third asTime asSeconds.
- vTime <= secsSince1901 ifTrue: ["this one"
- ^ cngRec == changeList first ifTrue: [nil] ifFalse: [cngRec]]]].
- "was not defined that early. Don't delete the method."
- ^ changeList last "earliest one may be OK" !
Item was removed:
- ----- Method: VersionsBrowser>>versionsHelpString (in category 'menu') -----
- versionsHelpString
- ^ 'Each entry in the list pane represents a version of the source code for the same method; the topmost entry is the current version, the next entry is the next most recent, etc.
-
- To revert to an earlier version, select it (in the list pane) and then do any of the following:
- * Choose "revert to this version" from the list pane menu.
- * Hit the "revert" button,
- * Type ENTER in the code pane
- * Type cmd-s (alt-s) in the code pane.
-
- The code pane shows the source for the selected version. If "diffing" is in effect, then differences betwen the selected version and the version before it are pointed out in the pane. Turn diffing on and off by choosing "toggle diffing" from the list pane menu, or hitting the "diffs" button, or hitting cmd-D when the cursor is over the list pane.
-
- To get a comparison between the selected version and the current version, choose "compare to current" from the list pane menu or hit the "compare to current" button. (This is meaningless if the current version is selected, and is unnecessary if you''re interested in diffs from between the current version and the next-most-recent version, since the standard in-pane "diff" feature will give you that.)
-
- You can also compare the selected version with any other version using the "compare to version..." menu choice.
-
- If further versions of the method in question have been submitted elsewhere since you launched a particular Versions Browser, it will still stay nicely up-to-date if you''re in Morphic and have asked that smart updating be maintained; if you''re in mvc or in morphic but with smart-updating turned off, a versions browser is only brought up to date when you activate its window (and when you issue "revert" from within it, of course,) and you can also use the "update list" command to make certain the versions list is up to date.
-
- Hit the "remove from changes" button, or choose the corresponding command in the list pane menu, to have the method in question deleted from the current change set. This is useful if you''ve put debugging code into a method, and now want to strip it out and cleanse your current change set of all memory of the excursion.
-
- Note: the annotation pane in versions browsers shows information about the *current* version of the method in the image, not about the selected version.' translated!
Item was removed:
- ----- Method: VersionsBrowser>>versionsMenu: (in category 'menu') -----
- versionsMenu: aMenu
-
- ^ self menu: aMenu for: #(versionsMenu versionsMenuShifted:)
- !
Item was removed:
- ----- Method: WeakSet>>inspectorClass (in category '*Tools-Inspector') -----
- inspectorClass
- ^ WeakSetInspector!
Item was removed:
- SetInspector subclass: #WeakSetInspector
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Tools-Inspector'!
-
- !WeakSetInspector commentStamp: '<historical>' prior: 0!
- A verison of the SetInspector specialized for inspecting WeakSets. It knows about the flag object used to indicate empty locations in the hash table.!
Item was removed:
- ----- Method: WeakSetInspector>>isElementValid: (in category 'private') -----
- isElementValid: anElement
- "Consider the #flag object, which is used to mark GC'ed elements in the WeakSet."
-
- ^ anElement notNil and: [anElement ~~ (self object instVarNamed: #flag)]!
Item was removed:
- StringHolder subclass: #Workspace
- instanceVariableNames: 'bindings acceptDroppedMorphs acceptAction mustDeclareVariables shouldStyle environment windowTitle fileDirectory fileLineEndConvention'
- classVariableNames: 'DeclareVariablesAutomatically EmbedTranscript FileOutFilePath FileOutOnAccept LookupPools ShouldStyle'
- poolDictionaries: ''
- category: 'Tools-Base'!
-
- !Workspace commentStamp: 'fbs 6/2/2012 20:46' prior: 0!
- A Workspace is a text area plus a lot of support for executable code. It is a great place to execute top-level commands to compute something useful, and it is a great place to develop bits of a program before those bits get put into class methods.
-
- To open a new workspace, execute:
-
- Workspace open
-
-
- A workspace can have its own variables, called "workspace variables", to hold intermediate results. For example, if you type into a workspace "x := 5" and do-it, then later you could type in "y := x * 2" and y would become 10.
-
- Additionally, in Morphic, a workspace can gain access to morphs that are on the screen. If acceptDroppedMorphs is turned on, then whenever a morph is dropped on the workspace, a variable will be created which references that morph. This functionality is toggled with the window-wide menu of a workspace.
-
-
- The instance variables of this class are:
-
- bindings - holds the workspace variables for this workspace
-
- acceptDroppedMorphs - whether dropped morphs should create new variables!
Item was removed:
- ----- Method: Workspace class>>addLookupPool: (in category 'lookup pools') -----
- addLookupPool: sharedPool
- "Add a SharedPool that bindings should be looked up in."
- LookupPools ifNil: [LookupPools := IdentitySet new].
- LookupPools add: sharedPool!
Item was removed:
- ----- Method: Workspace class>>clearLookupPools (in category 'lookup pools') -----
- clearLookupPools
- LookupPools := nil.
- !
Item was removed:
- ----- Method: Workspace class>>declareVariablesAutomatically (in category 'preferences') -----
- declareVariablesAutomatically
- <preference: 'Automatically declare variables in Workspaces'
- category: 'browsing'
- description: 'If true, workspaces automatically create variables.'
- type: #Boolean>
- ^DeclareVariablesAutomatically ifNil: [true]!
Item was removed:
- ----- Method: Workspace class>>declareVariablesAutomatically: (in category 'preferences') -----
- declareVariablesAutomatically: aBoolean
- DeclareVariablesAutomatically := aBoolean!
Item was removed:
- ----- Method: Workspace class>>embedTranscript (in category 'preferences') -----
- embedTranscript
- <preference: 'Embed a Transcript in Workspace'
- categoryList: #('browsing' 'tools')
- description: 'If true, new workspaces will open with an embedded Transcript.'
- type: #Boolean>
- ^ EmbedTranscript ifNil: [ false ]!
Item was removed:
- ----- Method: Workspace class>>embedTranscript: (in category 'preferences') -----
- embedTranscript: aBoolean
-
- EmbedTranscript := aBoolean.!
Item was removed:
- ----- Method: Workspace class>>fileOutOnAccept (in category 'preferences') -----
- fileOutOnAccept
- <preference: 'File-out workspace contents on accept'
- categoryList: #('browsing' 'tools')
- description: 'If true, accepting contents in a workspace will append them to a file on disk. The file name is derived from the workspace''s current window title and can thus be changed. The default name is thus ''Workspace.text''.'
- type: #Boolean>
- ^ FileOutOnAccept ifNil: [ true ]!
Item was removed:
- ----- Method: Workspace class>>fileOutOnAccept: (in category 'preferences') -----
- fileOutOnAccept: aBoolean
-
- FileOutOnAccept := aBoolean.!
Item was removed:
- ----- Method: Workspace class>>open (in category 'instance creation') -----
- open
-
- | workspace |
- workspace := self new.
- ^ self embedTranscript
- ifTrue: [workspace buildAndOpenWorkspaceTranscript]
- ifFalse: [workspace buildAndOpen]!
Item was removed:
- ----- Method: Workspace class>>prototypicalToolWindow (in category 'instance creation') -----
- prototypicalToolWindow
- "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools"
-
- | aWorkspace |
- aWorkspace := ToolBuilder build: self new.
- ^ aWorkspace!
Item was removed:
- ----- Method: Workspace class>>removeLookupPool: (in category 'lookup pools') -----
- removeLookupPool: sharedPool
- "Workspaces should no longer look up bindings in the specified SharedPool."
- LookupPools ifNil: [^self].
- LookupPools remove: sharedPool ifAbsent: [].!
Item was removed:
- ----- Method: Workspace class>>shouldStyle (in category 'preferences') -----
- shouldStyle
- <preference: 'Shout styling in Workspace'
- category: 'browsing'
- description: 'If true, new workspaces use Shout to style their contents.'
- type: #Boolean>
- ^ ShouldStyle ifNil: [ false ]!
Item was removed:
- ----- Method: Workspace class>>shouldStyle: (in category 'preferences') -----
- shouldStyle: aBoolean
-
- ShouldStyle := aBoolean.
-
- self allSubInstancesDo: [:workspace | workspace changed: #style].!
Item was removed:
- ----- Method: Workspace>>aboutToStyle: (in category 'code pane') -----
- aboutToStyle: aStyler
-
- self shouldStyle ifFalse: [ ^false ].
- aStyler
- classOrMetaClass: nil;
- workspace: self.
- ^true!
Item was removed:
- ----- Method: Workspace>>acceptAction (in category 'accessing') -----
- acceptAction
- ^acceptAction!
Item was removed:
- ----- Method: Workspace>>acceptAction: (in category 'accessing') -----
- acceptAction: anAction
- acceptAction := anAction.!
Item was removed:
- ----- Method: Workspace>>acceptContents: (in category 'accessing') -----
- acceptContents: aString
-
- (self class fileOutOnAccept and: [acceptAction isNil]) ifTrue: [
- (Project uiManager
- confirm: ('Do you want to append the contents to\\ {1}\\on accept so that you can safely close this window?\\{2}' translated withCRs asText format: {
- self suggestedFileNameForSave asText allBold.
- '(You will not be asked again for this window. Use the window menu to revise your decision later. Disable this prompt via the system-wide #fileOutOnAccept preference.)' translated withCRs asText
- addAttribute: (TextFontReference toFont: Preferences standardButtonFont)})
- title: 'Accept Changes')
- ifTrue: [self appendContentsToFileOnAccept]
- ifFalse: [acceptAction := [:edits | true ]]].
-
- ^ (acceptAction ifNotNil: [acceptAction value: aString]) ~~ false
- and: [super acceptContents: aString]!
Item was removed:
- ----- Method: Workspace>>acceptDroppedMorphsWording (in category 'drag and drop') -----
- acceptDroppedMorphsWording
-
- ^ self acceptsDroppingMorphForReference
- ifTrue: ['<yes> create textual references to dropped morphs' translated]
- ifFalse: ['<no> create textual references to dropped morphs' translated]
- !
Item was removed:
- ----- Method: Workspace>>acceptDroppingMorph:event:inMorph: (in category 'drag and drop') -----
- acceptDroppingMorph: dropee event: evt inMorph: targetMorph
- "Return the dropee to its old position, and add a reference to it at the
- cursor point."
- | bindingName externalName reference |
- (dropee isKindOf: TransferMorph)
- ifTrue: [reference := dropee passenger.
- externalName := dropee passenger className]
- ifFalse: [reference := dropee.
- externalName := dropee externalName].
- externalName := externalName isOctetString
- ifTrue: [externalName]
- ifFalse: ['a' , externalName].
- bindingName := externalName withFirstCharacterDownshifted , reference identityHash printString.
- targetMorph correctSelectionWithString: bindingName , ' '.
- (self bindingOf: bindingName)
- value: reference.
- (dropee isKindOf: TransferMorph)
- ifFalse: [dropee rejectDropMorphEvent: evt].
- ^ true"success"!
Item was removed:
- ----- Method: Workspace>>acceptsDroppingMorphForReference (in category 'drag and drop') -----
- acceptsDroppingMorphForReference
-
- ^ acceptDroppedMorphs
-
- !
Item was removed:
- ----- Method: Workspace>>acceptsDroppingMorphForReference: (in category 'drag and drop') -----
- acceptsDroppingMorphForReference: trueFalse
-
- acceptDroppedMorphs := trueFalse
-
- !
Item was removed:
- ----- Method: Workspace>>addModelItemsToWindowMenu: (in category 'menu commands') -----
- addModelItemsToWindowMenu: aMenu
-
- aMenu addLine.
- aMenu
- add: 'change file name...'
- target: self
- action: #changeFileName.
- aMenu
- add: 'save contents to file...'
- target: self
- action: #saveContentsInFile.
- aMenu
- addUpdating: #saveContentsInFileOnAcceptWording
- target: self
- action: #saveContentsInFileOnAccept.
- aMenu
- addUpdating: #appendContentsToFileOnAcceptWording
- target: self
- action: #appendContentsToFileOnAccept.
- aMenu addLine.
- aMenu
- add: 'inspect variables'
- target: self
- action: #inspectBindings.
- aMenu
- add: 'reset variables'
- target: self
- action: #resetBindings.
- aMenu addLine.
- aMenu
- addUpdating: #mustDeclareVariableWording
- target: self
- action: #toggleVariableDeclarationMode.
- aMenu
- addUpdating: #acceptDroppedMorphsWording
- target: self
- action: #toggleDroppingMorphForReference.
-
- self addToggleStylingMenuItemTo: aMenu.
- !
Item was removed:
- ----- Method: Workspace>>addToggleStylingMenuItemTo: (in category 'code pane menu') -----
- addToggleStylingMenuItemTo: aMenu
-
- aMenu
- addUpdating: #toggleStylingLabel
- target: self
- action: #toggleStyling!
Item was removed:
- ----- Method: Workspace>>appendContentsOfFile (in category 'menu commands') -----
- appendContentsOfFile
- "Prompt for a file, and if one is obtained, append its contents to the contents of the receiver. Caution: as currently implemented this abandons any custom style information previously in the workspace. Someone should fix this. Also, for best results you should accept the contents of the workspace before requesting this."
-
- | fName |
- fName := UIManager default chooseFileMatching: '*' label: 'Choose file to add to workspace'.
- fName ifNil:[^self].
-
- FileStream oldFileNamed: fName do:[:aFileStream|
- contents := (contents ifNil: ['']) asString, aFileStream contentsOfEntireFile].
- self changed: #contents!
Item was removed:
- ----- Method: Workspace>>appendContentsToFileOnAccept (in category 'menu commands') -----
- appendContentsToFileOnAccept
- "Arrange that the contents will be appended to a file when the user accepts."
-
- self saveContentsInFileOnAcceptEnabled
- ifTrue: [(Project uiManager confirm: 'Do you really want to change file access mode\from #update to #append?\\You might corrupt data when accepting changes.' translated withCRs)
- ifFalse: [^ self]].
-
- self acceptAction: (self appendContentsToFileOnAcceptEnabled ifTrue: [ "no action" ] ifFalse: [
- [:freshContents | | fileName stringToAppend |
- "Ensure to compute fileName as late as possible to consider recent changes of the #windowTitle."
- fileName := self suggestedFileNameForSave.
-
- stringToAppend := '"----ACCEPT----{1}"\{2}\' withCRs
- format: { DateAndTime now asString. freshContents }.
-
- ((FileDirectory forFileName: fileName) fileExists: fileName)
- ifFalse: [ "If the default file name, which is derived from the current window title, does not exist, ask the user once to confirm the location."
- self
- saveContents: stringToAppend
- accessMode: #create]
- ifTrue: [ "Update/replace the contents in the existing file."
- self
- saveContents: stringToAppend
- onFileNamed: fileName
- accessMode: #append]] ]).!
Item was removed:
- ----- Method: Workspace>>appendContentsToFileOnAcceptEnabled (in category 'menu commands') -----
- appendContentsToFileOnAcceptEnabled
-
- ^ (acceptAction notNil and: [acceptAction home selector = #appendContentsToFileOnAccept])!
Item was removed:
- ----- Method: Workspace>>appendContentsToFileOnAcceptWording (in category 'menu commands') -----
- appendContentsToFileOnAcceptWording
-
- ^ (self appendContentsToFileOnAcceptEnabled
- ifTrue: ['<yes> append contents to {1} on accept']
- ifFalse: ['<no> append contents to {1} on accept']) translated
- format: { self suggestedFileNameForSave contractTo: 32 }!
Item was removed:
- ----- Method: Workspace>>bindingOf: (in category 'binding') -----
- bindingOf: aString
- mustDeclareVariables ifTrue: [^ nil].
- "I want to have workspace that force the user to declare
- variables. Still subclasses may want to do something else"
- (bindings includesKey: aString) ifFalse: [
- (self lookupInPools: aString)
- ifNotNil: [:val |
- "Caveat: since we're not inserting the pool's Association into
- the dictionary, assigning a new value to the variable will only
- affect the one Workspace (i.e. you can't assign to a variable in a
- SharedPool)."
- bindings at: aString put: val]
- ifNil: [aString first isUppercase
- ifTrue: [^nil]
- ifFalse: [bindings at: aString put: nil]]
- ].
- ^ bindings associationAt: aString!
Item was removed:
- ----- Method: Workspace>>buildAndOpen (in category 'toolbuilder') -----
- buildAndOpen
-
- ToolBuilder default open: self.
- ^ self!
Item was removed:
- ----- Method: Workspace>>buildAndOpenWorkspaceTranscript (in category 'toolbuilder') -----
- buildAndOpenWorkspaceTranscript
-
- | windowSpec builder |
- builder := ToolBuilder default.
- windowSpec := self buildWindowWith: builder specs: {
- (0.0 @ 0.0 corner: 1.0 @ 0.6) -> [self buildCodePaneWith: builder].
- (0.0 @ 0.6 corner: 1.0 @ 1.0) -> [self buildTranscriptWith: builder].
- }.
- builder open: windowSpec.
- ^ self!
Item was removed:
- ----- Method: Workspace>>buildCodePaneWith: (in category 'toolbuilder') -----
- buildCodePaneWith: builder
- | textSpec |
- textSpec := builder pluggableCodePaneSpec new.
- textSpec
- model: self;
- getText: #contents;
- setText: #contents:notifying:;
- selection: #contentsSelection;
- menu: #codePaneMenu:shifted:.
- ^textSpec!
Item was removed:
- ----- Method: Workspace>>buildTranscriptWith: (in category 'toolbuilder') -----
- buildTranscriptWith: builder
-
- | textSpec |
- textSpec := builder pluggableTextSpec new.
- textSpec
- model: Transcript;
- menu: #codePaneMenu:shifted:.
- ^ textSpec!
Item was removed:
- ----- Method: Workspace>>canStyle (in category 'code pane menu') -----
- canStyle
-
- ^ (TextStyler for: #Smalltalk) notNil!
Item was removed:
- ----- Method: Workspace>>changeFileName (in category 'menu commands') -----
- changeFileName
- "Let the user specify a new file name (and path) for save-contents requests."
-
- (Project uiManager
- saveFilenameRequest: 'Save text contents in file...'
- initialAnswer: self suggestedFileNameForSave)
- ifNotNil: [:newFileName |
- newFileName ifNotEmpty: [self setFileName: newFileName]].!
Item was removed:
- ----- Method: Workspace>>contents: (in category 'accessing') -----
- contents: textOrString
- super contents: textOrString.
- self changed: #contents.!
Item was removed:
- ----- Method: Workspace>>convertToCurrentVersion:refStream: (in category 'object fileIn') -----
- convertToCurrentVersion: varDict refStream: smartRefStrm
-
- acceptDroppedMorphs ifNil: [acceptDroppedMorphs := false].
- ^super convertToCurrentVersion: varDict refStream: smartRefStrm.
-
- !
Item was removed:
- ----- Method: Workspace>>defaultFileNameForSave (in category 'user edits') -----
- defaultFileNameForSave
- "Overwritten to combine selected properties. Also see FileList >> #viewContentsInWorkspace to understand where different directories might originate."
-
- ^ self fileDirectory fullNameFor: self windowTitle!
Item was removed:
- ----- Method: Workspace>>environment (in category 'accessing') -----
- environment
- ^ environment ifNil: [Smalltalk globals]!
Item was removed:
- ----- Method: Workspace>>environment: (in category 'accessing') -----
- environment: anEnvironment
-
- environment := anEnvironment.!
Item was removed:
- ----- Method: Workspace>>expressionEvaluated:result: (in category 'menu commands') -----
- expressionEvaluated: anExpression result: anObject
-
- self changed: #style!
Item was removed:
- ----- Method: Workspace>>fileDirectory (in category 'accessing') -----
- fileDirectory
- "Answer the current directory for save-contents requests."
-
- ^ fileDirectory ifNil: [FileDirectory default]!
Item was removed:
- ----- Method: Workspace>>fileDirectory: (in category 'accessing') -----
- fileDirectory: aDirectory
- "Do not save the default directory so that the image and its surrounding files can be moved across the disk."
-
- fileDirectory := aDirectory = FileDirectory default ifFalse: [aDirectory].!
Item was removed:
- ----- Method: Workspace>>fileLineEndConvention (in category 'accessing') -----
- fileLineEndConvention
-
- ^ fileLineEndConvention!
Item was removed:
- ----- Method: Workspace>>fileLineEndConvention: (in category 'accessing') -----
- fileLineEndConvention: aSymbol
- "#cr, #lf, #crlf -- 'nil' means Squeak's default"
-
- fileLineEndConvention := aSymbol.!
Item was removed:
- ----- Method: Workspace>>hasBindingOf: (in category 'binding') -----
- hasBindingOf: aString
- ^bindings includesKey: aString!
Item was removed:
- ----- Method: Workspace>>initialExtent (in category 'initialize-release') -----
- initialExtent
- "Start small. Window aspect ratio is 5 sqrt::1 . Good asthetics. -wiz"
-
- ^ 447@200!
Item was removed:
- ----- Method: Workspace>>initialize (in category 'initialize-release') -----
- initialize
-
- super initialize.
- self resetBindings.
- acceptDroppedMorphs := false.
- mustDeclareVariables := self class declareVariablesAutomatically not.
- environment := Environment current!
Item was removed:
- ----- Method: Workspace>>inspectBindings (in category 'binding') -----
- inspectBindings
-
- bindings inspect!
Item was removed:
- ----- Method: Workspace>>lookupInPools: (in category 'binding') -----
- lookupInPools: aString
- "Iterate through all of the lookup pools to find a match for the specified name."
- LookupPools ifNil: [^nil].
- LookupPools do: [:pool | (pool bindingOf: aString) ifNotNil: [:assoc | ^assoc value]].
- ^nil
- !
Item was removed:
- ----- Method: Workspace>>mustDeclareVariableWording (in category 'variable declarations') -----
- mustDeclareVariableWording
-
- ^(mustDeclareVariables
- ifFalse: ['<yes> automatically create variable declaration']
- ifTrue: ['<no> automatically create variable declaration']) translated!
Item was removed:
- ----- Method: Workspace>>mustDeclareVariables: (in category 'accessing') -----
- mustDeclareVariables: aBoolean
-
- mustDeclareVariables := aBoolean!
Item was removed:
- ----- Method: Workspace>>resetBindings (in category 'binding') -----
- resetBindings
-
- bindings := Dictionary new.!
Item was removed:
- ----- Method: Workspace>>saveContents:onFileNamed:accessMode: (in category 'user edits') -----
- saveContents: stringContents onFileNamed: fileName accessMode: accessMode
- "Overwritten to set conversion rule of line-end character. See FileList >> #viewContentsInWorkspace."
-
- ^ self
- saveContents: stringContents
- onFileNamed: fileName
- accessMode: accessMode
- workBlock: [:fileStream |
- fileStream
- lineEndConvention: self fileLineEndConvention;
- nextPutAll: stringContents]!
Item was removed:
- ----- Method: Workspace>>saveContents:onFileNamed:accessMode:workBlock: (in category 'user edits') -----
- saveContents: stringContents onFileNamed: fileName accessMode: accessMode workBlock: workBlock
- "Overwritten to update #fileDirectory property and #windowTitle on success."
-
- ^ (super
- saveContents: stringContents
- onFileNamed: fileName
- accessMode: accessMode
- workBlock: workBlock)
- ifFalse: [false "no success"]
- ifTrue: [self setFileName: fileName. true "success"]!
Item was removed:
- ----- Method: Workspace>>saveContentsInFile (in category 'menu commands') -----
- saveContentsInFile
- "Save the view's current contents in a file. Dispatch goes through the view (or morph). See commentary in and senders of #saveContents:accessMode:."
-
- self changed: #saveContents.!
Item was removed:
- ----- Method: Workspace>>saveContentsInFileOnAccept (in category 'menu commands') -----
- saveContentsInFileOnAccept
- "Arrange that the contents will be saved to a file on each save (or accept). Replace any existing file contents."
-
- self flag: #discuss. "mt: Is it 'onFile' or rather 'inFile'? Note that there are different access modes."
-
- self appendContentsToFileOnAcceptEnabled
- ifTrue: [(Project uiManager confirm: 'Do you really want to change file access mode\from #append to #update?\\You might lose data when accepting changes.' translated withCRs)
- ifFalse: [^ self]].
-
- self acceptAction: (self saveContentsInFileOnAcceptEnabled
- ifFalse: [ [:stringToSave | | fileName |
- "Ensure to compute fileName as late as possible to consider recent changes of the #windowTitle."
- fileName := self suggestedFileNameForSave.
-
- ((FileDirectory forFileName: fileName) fileExists: fileName)
- ifFalse: [ "If the default file name, which is derived from the current window title, does not exist, ask the user once to confirm the location."
- self
- saveContents: stringToSave
- accessMode: #create]
- ifTrue: [ "Update/replace the contents in the existing file."
- self
- saveContents: stringToSave
- onFileNamed: fileName
- accessMode: #update]] ]).!
Item was removed:
- ----- Method: Workspace>>saveContentsInFileOnAcceptEnabled (in category 'menu commands') -----
- saveContentsInFileOnAcceptEnabled
-
- ^ (acceptAction notNil and: [acceptAction home selector = #saveContentsInFileOnAccept])!
Item was removed:
- ----- Method: Workspace>>saveContentsInFileOnAcceptWording (in category 'menu commands') -----
- saveContentsInFileOnAcceptWording
-
- ^ (self saveContentsInFileOnAcceptEnabled
- ifTrue: ['<yes> save contents to {1} on accept']
- ifFalse: ['<no> save contents to {1} on accept']) translated
- format: { self suggestedFileNameForSave contractTo: 32 }!
Item was removed:
- ----- Method: Workspace>>setBindings: (in category 'accessing') -----
- setBindings: aDictionary
- "Sets the Workspace to use the specified dictionary as its namespace"
-
- bindings := aDictionary.
- !
Item was removed:
- ----- Method: Workspace>>setFileName: (in category 'initialize-release') -----
- setFileName: fileName
-
- | directory |
- directory := FileDirectory forFileName: fileName.
- self fileDirectory: directory.
- self windowTitle: (directory localNameFor: fileName).!
Item was removed:
- ----- Method: Workspace>>setWindowTitle: (in category 'initialize-release') -----
- setWindowTitle: aString
- "Normalize window title to not expose file extension in regular workspaces. Do not tell the UI to avoid endless recursion; see #windowTitle: and #windowReqNewLabel:."
-
- | normalizedTitle |
- normalizedTitle := ((aString includesSubstring: 'Workspace') and: [aString endsWithAnyOf: #('.text' '.txt')])
- ifTrue: [aString copyFrom: 1 to: (aString lastIndexOf: $.) - 1]
- ifFalse: [aString].
-
- windowTitle := normalizedTitle.!
Item was removed:
- ----- Method: Workspace>>shouldStyle (in category 'code pane menu') -----
- shouldStyle
-
- ^shouldStyle ifNil: [ self class shouldStyle ]!
Item was removed:
- ----- Method: Workspace>>shouldStyle: (in category 'code pane menu') -----
- shouldStyle: aBool
- "If true, contents will by rendered w/ syntax-highlighting"
-
- shouldStyle := aBool!
Item was removed:
- ----- Method: Workspace>>spawn: (in category '*Tools') -----
- spawn: contentsString
-
- UIManager default edit: contentsString label: 'Workspace' shouldStyle: self shouldStyle!
Item was removed:
- ----- Method: Workspace>>toggleDroppingMorphForReference (in category 'drag and drop') -----
- toggleDroppingMorphForReference
-
- acceptDroppedMorphs := acceptDroppedMorphs not.
-
- !
Item was removed:
- ----- Method: Workspace>>toggleStyling (in category 'code pane menu') -----
- toggleStyling
-
- self canStyle ifFalse: [^ self inform: 'No text styler for #Smalltalk configured.'].
- shouldStyle := self shouldStyle not.
- self changed: #style.!
Item was removed:
- ----- Method: Workspace>>toggleStylingLabel (in category 'code pane menu') -----
- toggleStylingLabel
-
- self canStyle
- ifFalse: [^ '<off> syntax highlighting (not available)'].
-
- ^self shouldStyle
- ifTrue: [ '<on> syntax highlighting' ]
- ifFalse: [ '<off> syntax highlighting' ]!
Item was removed:
- ----- Method: Workspace>>toggleVariableDeclarationMode (in category 'variable declarations') -----
- toggleVariableDeclarationMode
-
- mustDeclareVariables := mustDeclareVariables not!
Item was removed:
- ----- Method: Workspace>>wantsAnnotationPane (in category 'accessing') -----
- wantsAnnotationPane
- "We have nothing to annotate"
- ^false!
Item was removed:
- ----- Method: Workspace>>wantsDroppedMorph:event:inMorph: (in category 'drag and drop') -----
- wantsDroppedMorph: dropee event: evt inMorph: target
-
- ^ acceptDroppedMorphs or: [dropee isTransferMorph]
-
- !
Item was removed:
- ----- Method: Workspace>>wantsOptionalButtons (in category 'accessing') -----
- wantsOptionalButtons
- "We have no optional buttons (yet)"
- ^false!
Item was removed:
- ----- Method: Workspace>>windowReqNewLabel: (in category 'user edits') -----
- windowReqNewLabel: newLabel
- "The user has edited the window label. Remember for a later save-to-file request. See #defaultFileNameForSave."
-
- self setWindowTitle: newLabel.
- ^ true!
Item was removed:
- ----- Method: Workspace>>windowTitle (in category 'accessing') -----
- windowTitle
-
- ^ windowTitle ifNil: ['Workspace']!
Item was removed:
- ----- Method: Workspace>>windowTitle: (in category 'accessing') -----
- windowTitle: aString
-
- self setWindowTitle: aString.
- self changed: #windowTitle.!
Item was removed:
- (PackageInfo named: 'Tools') postscript: 'ToolIcons icons removeKey: #font ifAbsent: [].
-
- "Update description of the preference #extraDebuggerButtons (Tools-ct.1128)"
- (Preferences preferenceAt: #extraDebuggerButtons) instVarNamed: ''helpString'' put: ''If true, debugger windows will show *two* rows of buttons -- the debugger-specific row (proceed, restart, etc.) and also the conventional code-tools row. This preference overrides the "Optional buttons" preference for debuggers.''.'!
1
0