[Pkg] Squeak3.10bc: Tests-kph.35.mcz
squeak-dev-noreply at lists.squeakfoundation.org
squeak-dev-noreply at lists.squeakfoundation.org
Sat Dec 13 04:47:36 UTC 2008
A new version of Tests was added to project Squeak3.10bc:
http://www.squeaksource.com/310bc/Tests-kph.35.mcz
==================== Summary ====================
Name: Tests-kph.35
Author: kph
Time: 13 December 2008, 4:47:34 am
UUID: af9f95f9-573a-442c-8f79-ae76bc069c0f
Ancestors: Tests-edc.34
Saved from SystemVersion
==================== Snapshot ====================
SystemOrganization addCategory: #'Tests-Bugs'!
SystemOrganization addCategory: #'Tests-ObjectsAsMethods'!
SystemOrganization addCategory: #'Tests-PrimCallController'!
SystemOrganization addCategory: #'Tests-Release'!
SystemOrganization addCategory: #'Tests-Utilities'!
SystemOrganization addCategory: #'Tests-VM'!
SystemOrganization addCategory: #'Tests-Hex'!
TestCase subclass: #BecomeTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-VM'!
----- Method: BecomeTest>>testBecome (in category 'Testing') -----
testBecome
"Test the two way become. Note. we cannot use string literals for this test"
| a b c d |
a := 'ab' copy.
b := 'cd' copy.
c := a.
d := b.
a become: b.
self
assert: a = 'cd';
assert: b = 'ab';
assert: c = 'cd';
assert: d = 'ab'.
!
----- Method: BecomeTest>>testBecomeForward (in category 'Testing') -----
testBecomeForward
"Test the forward become."
| a b c d |
a := 'ab' copy.
b := 'cd' copy.
c := a.
d := b.
a becomeForward: b.
self
assert: a = 'cd';
assert: b = 'cd';
assert: c = 'cd';
assert: d = 'cd'.
!
----- Method: BecomeTest>>testBecomeForwardDontCopyIdentityHash (in category 'Testing') -----
testBecomeForwardDontCopyIdentityHash
"Check that
1. the argument to becomeForward: is NOT modified to have the receiver's identity hash.
2. the receiver's identity hash is unchanged."
| a b hb |
a := 'ab' copy.
b := 'cd' copy.
hb := b identityHash.
a becomeForward: b copyHash: false.
self
assert: a identityHash = hb;
assert: b identityHash = hb.
!
----- Method: BecomeTest>>testBecomeForwardHash (in category 'Testing') -----
testBecomeForwardHash
| a b c hb |
a := 'ab' copy.
b := 'cd' copy.
c := a.
hb := b hash.
a becomeForward: b.
self
assert: a hash = hb;
assert: b hash = hb;
assert: c hash = hb.
!
----- Method: BecomeTest>>testBecomeForwardIdentityHash (in category 'Testing') -----
testBecomeForwardIdentityHash
"Check that
1. the argument to becomeForward: is modified to have the receiver's identity hash.
2. the receiver's identity hash is unchanged."
| a b ha |
a := 'ab' copy.
b := 'cd' copy.
ha := a identityHash.
a becomeForward: b.
self
assert: a identityHash = ha;
assert: b identityHash = ha.
!
----- Method: BecomeTest>>testBecomeHash (in category 'Testing') -----
testBecomeHash
| a b c d ha hb |
a := 'ab' copy.
b := 'cd' copy.
c := a.
d := b.
ha := a hash.
hb := b hash.
a become: b.
self
assert: a hash = hb;
assert: b hash = ha;
assert: c hash = hb;
assert: d hash = ha.
!
----- Method: BecomeTest>>testBecomeIdentityHash (in category 'Testing') -----
testBecomeIdentityHash
"Note. The identity hash of both objects seems to change after the become:"
| a b c d |
a := 'ab' copy.
b := 'cd' copy.
c := a.
d := b.
a become: b.
self
assert: a identityHash = c identityHash;
assert: b identityHash = d identityHash;
deny: a identityHash = b identityHash.
!
TestCase subclass: #BitBltClipBugs
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: BitBltClipBugs>>testDrawingWayOutside (in category 'as yet unclassified') -----
testDrawingWayOutside
| f1 bb f2 |
f1 := Form extent: 100 at 100 depth: 1.
f2 := Form extent: 100 at 100 depth: 1.
bb := BitBlt toForm: f1.
bb combinationRule: 3.
bb sourceForm: f2.
bb destOrigin: SmallInteger maxVal squared asPoint.
bb width: 100; height: 100.
self shouldnt:[bb copyBits] raise: Error.
!
----- Method: BitBltClipBugs>>testDrawingWayOutside2 (in category 'as yet unclassified') -----
testDrawingWayOutside2
| f1 bb f2 |
f1 := Form extent: 100 at 100 depth: 1.
f2 := Form extent: 100 at 100 depth: 1.
bb := BitBlt toForm: f1.
bb combinationRule: 3.
bb sourceForm: f2.
bb destOrigin: 0 at 0.
bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
self shouldnt:[bb copyBits] raise: Error.!
----- Method: BitBltClipBugs>>testDrawingWayOutside3 (in category 'as yet unclassified') -----
testDrawingWayOutside3
| f1 bb f2 |
f1 := Form extent: 100 at 100 depth: 1.
f2 := Form extent: 100 at 100 depth: 1.
bb := BitBlt toForm: f1.
bb combinationRule: 3.
bb sourceForm: f2.
bb destOrigin: SmallInteger maxVal squared asPoint.
bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
self shouldnt:[bb copyBits] raise: Error.
!
----- Method: BitBltClipBugs>>testDrawingWayOutside4 (in category 'as yet unclassified') -----
testDrawingWayOutside4
| f1 bb f2 |
f1 := Form extent: 100 at 100 depth: 1.
f2 := Form extent: 100 at 100 depth: 1.
bb := BitBlt toForm: f1.
bb combinationRule: 3.
bb sourceForm: f2.
bb destOrigin: SmallInteger maxVal squared asPoint.
bb width: 100; height: 100.
bb sourceOrigin: SmallInteger maxVal squared asPoint.
self shouldnt:[bb copyBits] raise: Error.
!
----- Method: BitBltClipBugs>>testDrawingWayOutside5 (in category 'as yet unclassified') -----
testDrawingWayOutside5
| f1 bb f2 |
f1 := Form extent: 100 at 100 depth: 1.
f2 := Form extent: 100 at 100 depth: 1.
bb := BitBlt toForm: f1.
bb combinationRule: 3.
bb sourceForm: f2.
bb destOrigin: 0 at 0.
bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
bb sourceOrigin: SmallInteger maxVal squared asPoint.
self shouldnt:[bb copyBits] raise: Error.!
----- Method: BitBltClipBugs>>testDrawingWayOutside6 (in category 'as yet unclassified') -----
testDrawingWayOutside6
| f1 bb f2 |
f1 := Form extent: 100 at 100 depth: 1.
f2 := Form extent: 100 at 100 depth: 1.
bb := BitBlt toForm: f1.
bb combinationRule: 3.
bb sourceForm: f2.
bb destOrigin: SmallInteger maxVal squared asPoint.
bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
bb sourceOrigin: SmallInteger maxVal squared asPoint.
self shouldnt:[bb copyBits] raise: Error.
!
----- Method: BitBltClipBugs>>testFillingWayOutside (in category 'as yet unclassified') -----
testFillingWayOutside
| f1 bb |
f1 := Form extent: 100 at 100 depth: 1.
bb := BitBlt toForm: f1.
bb combinationRule: 3.
bb fillColor: Color black.
bb destOrigin: SmallInteger maxVal squared asPoint.
bb width: 100; height: 100.
self shouldnt:[bb copyBits] raise: Error.
!
----- Method: BitBltClipBugs>>testFillingWayOutside2 (in category 'as yet unclassified') -----
testFillingWayOutside2
| f1 bb |
f1 := Form extent: 100 at 100 depth: 1.
bb := BitBlt toForm: f1.
bb combinationRule: 3.
bb fillColor: Color black.
bb destOrigin: 0 at 0.
bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
self shouldnt:[bb copyBits] raise: Error.!
----- Method: BitBltClipBugs>>testFillingWayOutside3 (in category 'as yet unclassified') -----
testFillingWayOutside3
| f1 bb |
f1 := Form extent: 100 at 100 depth: 1.
bb := BitBlt toForm: f1.
bb combinationRule: 3.
bb fillColor: Color black.
bb destOrigin: SmallInteger maxVal squared asPoint.
bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared.
self shouldnt:[bb copyBits] raise: Error.
!
TestCase subclass: #BitmapBugz
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: BitmapBugz>>testBitmapByteAt (in category 'as yet unclassified') -----
testBitmapByteAt
| bm |
bm := Bitmap new: 1.
1 to: 4 do:[:i|
self should:[bm byteAt: i put: 1000] raise: Error.
].!
TestCase subclass: #BitmapStreamTests
instanceVariableNames: 'random array stream'
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
!BitmapStreamTests commentStamp: 'nk 3/7/2004 14:26' prior: 0!
This is an incomplete test suite for storing and reading various word- and short-word subclasses of ArrayedCollection.
It demonstrates some problems with filing in of certain kinds of arrayed objects, including:
ShortPointArray
ShortIntegerArray
ShortRunArray
WordArray
MatrixTransform2x3
In 3.6b-5331, I get 8 passed/6 failed/6 errors (not counting the MatrixTransform2x3 tests, which were added later).
I ran into problems when trying to read back the SqueakLogo flash character morph, after I'd done a 'save morph to disk' from its debug menu.
The words within the ShortPointArrays and ShortRunArrays were reversed.
!
----- Method: BitmapStreamTests>>createSampleShortRunArray (in category 'tests-ShortRunArray') -----
createSampleShortRunArray
^ShortRunArray newFrom: { 0. 1. 1. 2. 2. 2. 3. 3. 3. 3 }!
----- Method: BitmapStreamTests>>randomFloat (in category 'private') -----
randomFloat
"Answer a random 32-bit float"
| w |
random seed: (w := random nextValue).
^w!
----- Method: BitmapStreamTests>>randomShortInt (in category 'private') -----
randomShortInt
^((random next * 65536) - 32768) truncated!
----- Method: BitmapStreamTests>>randomShortPoint (in category 'private') -----
randomShortPoint
^(((random next * 65536) @ (random next * 65536)) - (32768 @ 32768)) truncated!
----- Method: BitmapStreamTests>>randomWord (in category 'private') -----
randomWord
"Answer a random 32-bit integer"
| w |
random seed: (w := random nextValue).
^w truncated!
----- Method: BitmapStreamTests>>setUp (in category 'Running') -----
setUp
random := Random new.!
----- Method: BitmapStreamTests>>testMatrixTransform2x3WithImageSegment (in category 'tests-MatrixTransform2x3') -----
testMatrixTransform2x3WithImageSegment
array := MatrixTransform2x3 new.
1 to: 6 do: [ :i | array at: i put: self randomFloat ].
self validateImageSegment
!
----- Method: BitmapStreamTests>>testMatrixTransform2x3WithRefStream (in category 'tests-MatrixTransform2x3') -----
testMatrixTransform2x3WithRefStream
array := MatrixTransform2x3 new.
1 to: 6 do: [ :i | array at: i put: self randomFloat ].
self validateRefStream
!
----- Method: BitmapStreamTests>>testMatrixTransform2x3WithRefStreamOnDisk (in category 'tests-MatrixTransform2x3') -----
testMatrixTransform2x3WithRefStreamOnDisk
array := MatrixTransform2x3 new.
1 to: 6 do: [ :i | array at: i put: self randomFloat ].
self validateRefStreamOnDisk !
----- Method: BitmapStreamTests>>testMatrixTransform2x3WithSmartRefStream (in category 'tests-MatrixTransform2x3') -----
testMatrixTransform2x3WithSmartRefStream
array := MatrixTransform2x3 new.
1 to: 6 do: [ :i | array at: i put: self randomFloat ].
self validateSmartRefStream
!
----- Method: BitmapStreamTests>>testMatrixTransform2x3WithSmartRefStreamOnDisk (in category 'tests-MatrixTransform2x3') -----
testMatrixTransform2x3WithSmartRefStreamOnDisk
array := MatrixTransform2x3 new.
1 to: 6 do: [ :i | array at: i put: self randomFloat ].
self validateSmartRefStreamOnDisk
!
----- Method: BitmapStreamTests>>testOtherClasses (in category 'tests-misc') -----
testOtherClasses
#(WordArrayForSegment FloatArray PointArray IntegerArray SoundBuffer String ShortPointArray ShortIntegerArray WordArray Array DependentsArray ByteArray Bitmap ColorArray ) do: [:s | | a |
a := (Smalltalk at: s) new: 3.
self assert: (a basicSize * a bytesPerBasicElement = a byteSize). ]
!
----- Method: BitmapStreamTests>>testShortIntegerArrayReadRefStream2 (in category 'tests-ShortIntegerArray') -----
testShortIntegerArrayReadRefStream2
|refStrm|
refStrm := ReferenceStream on: ((RWBinaryOrTextStream with: (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3))) reset; binary).
self assert: (refStrm next = (ShortIntegerArray with: 0 with: 1 with: 2 with: 3)).!
----- Method: BitmapStreamTests>>testShortIntegerArrayWithImageSegment (in category 'tests-ShortIntegerArray') -----
testShortIntegerArrayWithImageSegment
array := ShortIntegerArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
self validateImageSegment
!
----- Method: BitmapStreamTests>>testShortIntegerArrayWithRefStream (in category 'tests-ShortIntegerArray') -----
testShortIntegerArrayWithRefStream
array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3.
self validateRefStream
!
----- Method: BitmapStreamTests>>testShortIntegerArrayWithRefStream2 (in category 'tests-ShortIntegerArray') -----
testShortIntegerArrayWithRefStream2
array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3.
self validateRefStream.
self assert: stream byteStream contents = (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3))
!
----- Method: BitmapStreamTests>>testShortIntegerArrayWithRefStreamOnDisk (in category 'tests-ShortIntegerArray') -----
testShortIntegerArrayWithRefStreamOnDisk
array := ShortIntegerArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
self validateRefStreamOnDisk
!
----- Method: BitmapStreamTests>>testShortIntegerArrayWithSmartRefStream (in category 'tests-ShortIntegerArray') -----
testShortIntegerArrayWithSmartRefStream
array := ShortIntegerArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
self validateSmartRefStream
!
----- Method: BitmapStreamTests>>testShortIntegerArrayWithSmartRefStream2 (in category 'tests-ShortIntegerArray') -----
testShortIntegerArrayWithSmartRefStream2
array := ShortIntegerArray with: 0 with: 1 with: 2 with: 3.
self validateSmartRefStream.
self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13))
!
----- Method: BitmapStreamTests>>testShortIntegerArrayWithSmartRefStreamOnDisk (in category 'tests-ShortIntegerArray') -----
testShortIntegerArrayWithSmartRefStreamOnDisk
array := ShortIntegerArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomShortInt ].
self validateSmartRefStreamOnDisk
!
----- Method: BitmapStreamTests>>testShortPointArrayWithImageSegment (in category 'tests-ShortPointArray') -----
testShortPointArrayWithImageSegment
array := ShortPointArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
self validateImageSegment
!
----- Method: BitmapStreamTests>>testShortPointArrayWithRefStream (in category 'tests-ShortPointArray') -----
testShortPointArrayWithRefStream
array := ShortPointArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
self validateRefStream
!
----- Method: BitmapStreamTests>>testShortPointArrayWithRefStream2 (in category 'tests-ShortPointArray') -----
testShortPointArrayWithRefStream2
array := ShortPointArray with: 0 at 1 with: 2 at 3.
self validateRefStream.
self assert: stream byteStream contents = (ByteArray withAll: #(20 6 15 83 104 111 114 116 80 111 105 110 116 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3 ))
!
----- Method: BitmapStreamTests>>testShortPointArrayWithRefStreamOnDisk (in category 'tests-ShortPointArray') -----
testShortPointArrayWithRefStreamOnDisk
array := ShortPointArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
self validateRefStreamOnDisk
!
----- Method: BitmapStreamTests>>testShortPointArrayWithSmartRefStream (in category 'tests-ShortPointArray') -----
testShortPointArrayWithSmartRefStream
array := ShortPointArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
self validateSmartRefStream
!
----- Method: BitmapStreamTests>>testShortPointArrayWithSmartRefStream2 (in category 'tests-ShortPointArray') -----
testShortPointArrayWithSmartRefStream2
array := ShortPointArray with: 0 at 1 with: 2 at 3.
self validateSmartRefStream.
self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13))
!
----- Method: BitmapStreamTests>>testShortPointArrayWithSmartRefStreamOnDisk (in category 'tests-ShortPointArray') -----
testShortPointArrayWithSmartRefStreamOnDisk
array := ShortPointArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomShortPoint ].
self validateSmartRefStreamOnDisk
!
----- Method: BitmapStreamTests>>testShortRunArrayWithImageSegment (in category 'tests-ShortRunArray') -----
testShortRunArrayWithImageSegment
array := self createSampleShortRunArray.
self validateImageSegment
!
----- Method: BitmapStreamTests>>testShortRunArrayWithRefStream (in category 'tests-ShortRunArray') -----
testShortRunArrayWithRefStream
array := self createSampleShortRunArray.
self validateRefStream
!
----- Method: BitmapStreamTests>>testShortRunArrayWithRefStreamOnDisk (in category 'tests-ShortRunArray') -----
testShortRunArrayWithRefStreamOnDisk
array := self createSampleShortRunArray.
self validateRefStreamOnDisk
!
----- Method: BitmapStreamTests>>testShortRunArrayWithSmartRefStream (in category 'tests-ShortRunArray') -----
testShortRunArrayWithSmartRefStream
array := self createSampleShortRunArray.
self validateSmartRefStream
!
----- Method: BitmapStreamTests>>testShortRunArrayWithSmartRefStream2 (in category 'tests-ShortRunArray') -----
testShortRunArrayWithSmartRefStream2
array := self createSampleShortRunArray.
self validateSmartRefStream.
self assert: (stream contents asByteArray last: 23) = (ByteArray withAll: #(0 0 0 4 0 1 0 0 0 2 0 1 0 3 0 2 0 4 0 3 33 13 13))
!
----- Method: BitmapStreamTests>>testShortRunArrayWithSmartRefStreamOnDisk (in category 'tests-ShortRunArray') -----
testShortRunArrayWithSmartRefStreamOnDisk
array := self createSampleShortRunArray.
self validateSmartRefStreamOnDisk
!
----- Method: BitmapStreamTests>>testWordArrayWithImageSegment (in category 'tests-WordArray') -----
testWordArrayWithImageSegment
array := WordArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomWord ].
self validateImageSegment
!
----- Method: BitmapStreamTests>>testWordArrayWithRefStream (in category 'tests-WordArray') -----
testWordArrayWithRefStream
array := WordArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomWord ].
self validateRefStream
!
----- Method: BitmapStreamTests>>testWordArrayWithRefStreamOnDisk (in category 'tests-WordArray') -----
testWordArrayWithRefStreamOnDisk
array := WordArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomWord ].
self validateRefStreamOnDisk
!
----- Method: BitmapStreamTests>>testWordArrayWithSmartRefStream (in category 'tests-WordArray') -----
testWordArrayWithSmartRefStream
array := WordArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomWord ].
self validateSmartRefStream
!
----- Method: BitmapStreamTests>>testWordArrayWithSmartRefStreamOnDisk (in category 'tests-WordArray') -----
testWordArrayWithSmartRefStreamOnDisk
array := WordArray new: 10.
1 to: 10 do: [ :i | array at: i put: self randomWord ].
self validateSmartRefStreamOnDisk
!
----- Method: BitmapStreamTests>>validateImageSegment (in category 'private') -----
validateImageSegment
"array is set up with an array."
| other filename |
filename := 'bitmapStreamTest.extSeg'.
FileDirectory default deleteFileNamed: filename ifAbsent: [ ].
(ImageSegment new copyFromRootsForExport: (Array with: array))
writeForExport: filename.
other := (FileDirectory default readOnlyFileNamed: filename)
fileInObjectAndCode.
self assert: array = other originalRoots first!
----- Method: BitmapStreamTests>>validateRefStream (in category 'private') -----
validateRefStream
"array is set up with an array."
| other rwstream |
rwstream := RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6).
stream := ReferenceStream on: rwstream.
stream nextPut: array; close.
rwstream position: 0.
stream := ReferenceStream on: rwstream.
other := stream next.
stream close.
self assert: array = other!
----- Method: BitmapStreamTests>>validateRefStreamOnDisk (in category 'private') -----
validateRefStreamOnDisk
"array is set up with an array."
| other filename |
filename := 'bitmapStreamTest.ref'.
FileDirectory default deleteFileNamed: filename ifAbsent: [ ].
stream := ReferenceStream fileNamed: filename.
stream nextPut: array; close.
stream := ReferenceStream fileNamed: filename.
other := stream next.
stream close.
self assert: array = other!
----- Method: BitmapStreamTests>>validateSmartRefStream (in category 'private') -----
validateSmartRefStream
"array is set up with an array."
| other |
stream := RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6).
stream binary.
stream fileOutClass: nil andObject: array.
stream position: 0.
stream binary.
other := stream fileInObjectAndCode.
self assert: array = other!
----- Method: BitmapStreamTests>>validateSmartRefStreamOnDisk (in category 'private') -----
validateSmartRefStreamOnDisk
"array is set up with an array."
| other filename |
filename := 'bitmapStreamTest.ref'.
FileDirectory default deleteFileNamed: filename ifAbsent: [ ].
stream := FileDirectory default fileNamed: filename.
stream fileOutClass: nil andObject: array.
stream close.
stream := FileDirectory default fileNamed: filename.
other := stream fileInObjectAndCode.
stream close.
self assert: array = other!
TestCase subclass: #ByteArrayBugz
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: ByteArrayBugz>>testByteArrayLongAt (in category 'as yet unclassified') -----
testByteArrayLongAt
| ba value |
ba := ByteArray new: 4.
value := -1.
self shouldnt:[ba longAt: 1 put: value bigEndian: true] raise: Error.
self assert: (ba longAt: 1 bigEndian: true) = value.
self shouldnt:[ba longAt: 1 put: value bigEndian: false] raise: Error.
self assert: (ba longAt: 1 bigEndian: false) = value.
!
TestCase subclass: #ChangeSetClassChangesTest
instanceVariableNames: 'saveCurrentChangeSet addedChangeSetAccessor'
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
!ChangeSetClassChangesTest commentStamp: 'dtl 2/19/2005 13:21' prior: 0!
Class category changes are not being properly added to the default changeset in Squeak 3.7. This test case will pass in Squeak 3.6, and fail in Squeak 3.[7-9].
!
----- Method: ChangeSetClassChangesTest>>isDefinition:equivalentTo: (in category 'support') -----
isDefinition: firstString equivalentTo: secondString
"When a class definition is reconstructed with #fatDefForClass, it may
contain extra trailing space characters in parts of the definition. This
is probably a minor bug, but it should be overlooked for purposes of
testing the change set update mechanism. The expedient here is to just
remove spaces before comparing the definition strings."
^ firstString notNil
and: [(firstString copyReplaceAll: ' ''' with: '''')
= (secondString copyReplaceAll: ' ''' with: '''')]!
----- Method: ChangeSetClassChangesTest>>tearDown (in category 'running') -----
tearDown
(Smalltalk classNamed: #JunkClass) ifNotNilDo: [:c | c removeFromSystem: true].
SystemOrganization removeCategory: #'DeleteMe-1'.
SystemOrganization removeCategory: #'DeleteMe-2'.
ChangeSet current removeClassChanges: 'JunkClass'
!
----- Method: ChangeSetClassChangesTest>>testAddInstanceVariable (in category 'testing') -----
testAddInstanceVariable
"Adding an instance variable to the class should result in a change
record being added to the current change set."
| saveClassDefinition |
"Define a class and save its definition"
Object subclass: #JunkClass
instanceVariableNames: 'zzz'
classVariableNames: ''
poolDictionaries: ''
category: 'DeleteMe-1'.
saveClassDefinition := (Smalltalk classNamed: #JunkClass) definition.
self assert: (self
isDefinition: saveClassDefinition
equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).
"Redefine the class, adding one instance variable"
Object subclass: #JunkClass
instanceVariableNames: 'zzz aaa'
classVariableNames: ''
poolDictionaries: ''
category: 'DeleteMe-1'.
"Assert that the class definition has changed"
self deny: (self
isDefinition: (Smalltalk classNamed: #JunkClass) definition
equivalentTo: saveClassDefinition).
self deny: (self
isDefinition: saveClassDefinition
equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).
self assert: (self
isDefinition: (Smalltalk classNamed: #JunkClass) definition
equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).
"Assert that the change has been recorded in the current change set"
self assert: (self
isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass))
priorDefinition
equivalentTo: saveClassDefinition).
!
----- Method: ChangeSetClassChangesTest>>testAddInstanceVariableAddsNewChangeRecord (in category 'testing') -----
testAddInstanceVariableAddsNewChangeRecord
"Changing the class category for a class should result in a change
record being updated in the current change set."
"At the start of this test, JunkClass should not exist, and there should be
no change records pertaining to it in the change set."
self deny: (Smalltalk hasClassNamed: 'JunkClass').
self assert: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass))
thisName = 'nil'.
"Remove bogus change records created as side effect of preceding assert"
ChangeSet current removeClassChanges: 'nil'.
"Define a class and save its definition"
Object subclass: #JunkClass
instanceVariableNames: 'zzz'
classVariableNames: ''
poolDictionaries: ''
category: 'DeleteMe-1'.
"Forget about JunkClass in the change set"
ChangeSet current removeClassChanges: 'JunkClass'.
"Redefine the class, adding one instance variable"
Object subclass: #JunkClass
instanceVariableNames: 'zzz aaa'
classVariableNames: ''
poolDictionaries: ''
category: 'DeleteMe-1'.
"A change record should now exist in the change set"
self assert: (self
isDefinition: (ChangeSet current
changeRecorderFor: (Smalltalk classNamed: #JunkClass)) priorDefinition
equivalentTo:
'Object subclass: #JunkClass
instanceVariableNames: ''zzz ''
classVariableNames: ''''
poolDictionaries: ''''
category: ''DeleteMe-1''')
!
----- Method: ChangeSetClassChangesTest>>testChangeClassCategory (in category 'testing') -----
testChangeClassCategory
"Changing the class category for a class should result in a change
record being added to the current change set."
| saveClassDefinition |
"Define a class and save its definition"
Object subclass: #JunkClass
instanceVariableNames: 'zzz'
classVariableNames: ''
poolDictionaries: ''
category: 'DeleteMe-1'.
saveClassDefinition := (Smalltalk classNamed: #JunkClass) definition.
self assert: saveClassDefinition =
(ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass)).
"Redefine the class, changing only the class category"
Object subclass: #JunkClass
instanceVariableNames: 'zzz'
classVariableNames: ''
poolDictionaries: ''
category: 'DeleteMe-2'.
"Assert that the class definition has changed"
self deny: (self
isDefinition: (Smalltalk classNamed: #JunkClass) definition
equivalentTo: saveClassDefinition).
self deny: (self
isDefinition: saveClassDefinition
equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).
self assert: (self
isDefinition: (Smalltalk classNamed: #JunkClass) definition
equivalentTo: (ChangeSet current fatDefForClass: (Smalltalk classNamed: #JunkClass))).
"Assert that the change has been recorded in the current change set"
self assert: (self
isDefinition: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass))
priorDefinition
equivalentTo:
'Object subclass: #JunkClass
instanceVariableNames: ''zzz ''
classVariableNames: ''''
poolDictionaries: ''''
category: ''DeleteMe-2''')!
----- Method: ChangeSetClassChangesTest>>testChangeClassCategoryAddsNewChangeRecord (in category 'testing') -----
testChangeClassCategoryAddsNewChangeRecord
"Changing the class category for a class should result in a change
record being updated in the current change set."
"At the start of this test, JunkClass should not exist, and there should be
no change records pertaining to it in the change set."
self deny: (Smalltalk hasClassNamed: 'JunkClass').
self assert: (ChangeSet current changeRecorderFor: (Smalltalk classNamed: #JunkClass))
thisName = 'nil'.
"Remove bogus change records created as side effect of preceding assert"
ChangeSet current removeClassChanges: 'nil'.
"Define a class and save its definition"
Object subclass: #JunkClass
instanceVariableNames: 'zzz'
classVariableNames: ''
poolDictionaries: ''
category: 'DeleteMe-1'.
"Forget about JunkClass in the change set"
ChangeSet current removeClassChanges: 'JunkClass'.
"Redefine the class, changing only the class category"
Object subclass: #JunkClass
instanceVariableNames: 'zzz'
classVariableNames: ''
poolDictionaries: ''
category: 'DeleteMe-2'.
"A change record should now exist in the change set"
self assert: (self
isDefinition: (ChangeSet current
changeRecorderFor: (Smalltalk classNamed: #JunkClass)) priorDefinition
equivalentTo:
'Object subclass: #JunkClass
instanceVariableNames: ''zzz ''
classVariableNames: ''''
poolDictionaries: ''''
category: ''DeleteMe-2''')!
----- Method: ChangeSetClassChangesTest>>testInitialChangeSet (in category 'testing') -----
testInitialChangeSet
"Run this to assure the initial changeset is named. Checks bug found in 3.9 7052."
"self new testInitialChangeSet"
"self run: #testInitialChangeSet"
self deny: (ChangeSet current printString = 'a ChangeSet named <no name -- garbage?>') .
^true!
TestCase subclass: #CircleMorphBugs
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: CircleMorphBugs>>testCircleInstance (in category 'as yet unclassified') -----
testCircleInstance
""
"self run: #testCircleInstance"
| circ |
self assert: (circ := CircleMorph initializedInstance) extent = circ extent x asPoint
!
TestCase subclass: #ClassRenameFixTest
instanceVariableNames: 'previousChangeSet testsChangeSet newClassName originalName'
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: ClassRenameFixTest>>newUniqueClassName (in category 'Private') -----
newUniqueClassName
"Return a class name that is not used in the system."
"self new newClassName"
| baseName newName |
baseName := 'AutoGeneratedClassForTestingSystemChanges'.
1 to: 9999
do:
[:number |
newName := baseName , number printString.
(Smalltalk hasClassNamed: newName) ifFalse: [^newName asSymbol]].
^self
error: 'Can no longer find a new and unique class name for the SystemChangeTest !!'!
----- Method: ClassRenameFixTest>>removeEverythingInSetFromSystem: (in category 'Private') -----
removeEverythingInSetFromSystem: aChangeSet
aChangeSet changedMessageList
do: [:methodRef | methodRef actualClass removeSelector: methodRef methodSymbol].
aChangeSet changedClasses
do: [:each | each isMeta
ifFalse: [each removeFromSystemUnlogged]]!
----- Method: ClassRenameFixTest>>renameClassUsing: (in category 'Tests') -----
renameClassUsing: aBlock
| createdClass foundClasses |
originalName := self newUniqueClassName.
createdClass := Object
subclass: originalName
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'ClassRenameFix-GeneradClass'.
newClassName := self newUniqueClassName.
aBlock value: createdClass value: newClassName.
self assert: (Smalltalk classNamed: originalName) isNil.
self assert: (Smalltalk classNamed: newClassName) notNil.
foundClasses := Smalltalk organization listAtCategoryNamed: 'ClassRenameFix-GeneradClass'.
self assert: (foundClasses notEmpty).
self assert: (foundClasses includes: newClassName).
self assert: (createdClass name = newClassName).!
----- Method: ClassRenameFixTest>>setUp (in category 'Running') -----
setUp
previousChangeSet := ChangeSet current.
testsChangeSet := ChangeSet new.
ChangeSet newChanges: testsChangeSet.
SystemChangeNotifier uniqueInstance
notify: self
ofSystemChangesOfItem: #class
change: #Renamed
using: #verifyRenameEvent:.
super setUp!
----- Method: ClassRenameFixTest>>tearDown (in category 'Running') -----
tearDown
self removeEverythingInSetFromSystem: testsChangeSet.
ChangeSet newChanges: previousChangeSet.
ChangesOrganizer removeChangeSet: testsChangeSet.
previousChangeSet := nil.
testsChangeSet := nil.
SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self.
super tearDown.!
----- Method: ClassRenameFixTest>>testRenameClassUsingClass (in category 'Tests') -----
testRenameClassUsingClass
"self run: #testRenameClassUsingClass"
self renameClassUsing: [:class :newName | class rename: newName].!
----- Method: ClassRenameFixTest>>verifyRenameEvent: (in category 'Running') -----
verifyRenameEvent: aRenamedEvent
| renamedClass |
self assert: aRenamedEvent isRenamed.
renamedClass := aRenamedEvent item.
self assert: (Smalltalk classNamed: newClassName) name = newClassName.
self assert: renamedClass name = newClassName!
TestCase subclass: #ClassTestCase
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Utilities'!
!ClassTestCase commentStamp: 'brp 7/26/2003 16:57' prior: 0!
This class is intended for unit tests of individual classes and their metaclasses.
It provides methods to determine the coverage of the unit tests.
Subclasses are expected to re-implement #classesToBeTested and #selectorsToBeIgnored.
They should also implement to confirm that all methods have been tested.
#testCoverage
super testCoverage.
!
----- Method: ClassTestCase class>>isAbstract (in category 'Testing') -----
isAbstract
"Override to true if a TestCase subclass is Abstract and should not have
TestCase instances built from it"
^self name = #ClassTestCase
!
----- Method: ClassTestCase class>>mustTestCoverage (in category 'Testing') -----
mustTestCoverage
^ false!
----- Method: ClassTestCase>>categoriesForClass: (in category 'private') -----
categoriesForClass: aClass
^ aClass organization allMethodSelectors collect:
[:each | aClass organization categoryOfElement: each].
!
----- Method: ClassTestCase>>classToBeTested (in category 'coverage') -----
classToBeTested
self subclassResponsibility!
----- Method: ClassTestCase>>selectorsNotTested (in category 'coverage') -----
selectorsNotTested
^ self selectorsToBeTested difference: self selectorsTested.
!
----- Method: ClassTestCase>>selectorsTested (in category 'Coverage') -----
selectorsTested
| literals |
literals := Set new.
self class
selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test')
ifTrue: [ literals addAll: (m messages)] ].
^ literals asSortedArray!
----- Method: ClassTestCase>>selectorsToBeIgnored (in category 'coverage') -----
selectorsToBeIgnored
^ #(#DoIt #DoItIn:)!
----- Method: ClassTestCase>>selectorsToBeTested (in category 'coverage') -----
selectorsToBeTested
^ ( { self classToBeTested. self classToBeTested class } gather: [:c | c selectors])
difference: self selectorsToBeIgnored!
----- Method: ClassTestCase>>targetClass (in category 'private') -----
targetClass
|className|
className := self class name asText copyFrom: 0 to: self class name size - 4.
^ Smalltalk at: (className asString asSymbol).
!
----- Method: ClassTestCase>>testClassComment (in category 'tests') -----
testClassComment
self shouldnt: [self targetClass organization hasNoComment].!
----- Method: ClassTestCase>>testCoverage (in category 'tests') -----
testCoverage
| untested |
self class mustTestCoverage ifTrue:
[ untested := self selectorsNotTested.
self assert: untested isEmpty
description: untested size asString, ' selectors are not covered' ]!
----- Method: ClassTestCase>>testNew (in category 'tests') -----
testNew
self shouldnt: [self targetClass new] raise: Error.!
----- Method: ClassTestCase>>testUnCategorizedMethods (in category 'tests') -----
testUnCategorizedMethods
| categories slips |
categories := self categoriesForClass: self targetClass.
slips := categories select: [:each | each = #'as yet unclassified'].
self should: [slips isEmpty]. !
ClassTestCase subclass: #PrimCallControllerAbstractTest
instanceVariableNames: 'pcc doNotMakeSlowTestsFlag'
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-PrimCallController'!
!PrimCallControllerAbstractTest commentStamp: 'sr 6/15/2004 19:20' prior: 0!
PrimCallController tests.
Tests are here, but this class isAbstract and won't be tested.
Tests are done in the subclasses, which inherit the tests here.
If you want to perform some more very slow tests, change doNotMakeSlowTestsFlag in >>setUp.!
PrimCallControllerAbstractTest subclass: #PCCByCompilationTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-PrimCallController'!
!PCCByCompilationTest commentStamp: 'sr 6/14/2004 22:05' prior: 0!
PCCByCompilation tests.
Tests are in the superclass and inherited from there.!
----- Method: PCCByCompilationTest class>>isAbstract (in category 'Testing') -----
isAbstract
^ false!
----- Method: PCCByCompilationTest>>cDisabledExternalCallWithoutModule (in category 'test methods') -----
cDisabledExternalCallWithoutModule
"{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName'>"
^ 'Hello World!!'!
----- Method: PCCByCompilationTest>>cDisabledRealExternalCall (in category 'test methods') -----
cDisabledRealExternalCall
"{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>"
^ 'Hello World!!'!
----- Method: PCCByCompilationTest>>cDisabledRealExternalCallNaked (in category 'test methods') -----
cDisabledRealExternalCallNaked
"{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>"!
----- Method: PCCByCompilationTest>>cDisabledRealExternalCallOrPrimitiveFailed (in category 'test methods') -----
cDisabledRealExternalCallOrPrimitiveFailed
"{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>"
self primitiveFailed!
----- Method: PCCByCompilationTest>>cExternalCall1 (in category 'example module') -----
cExternalCall1
<primitive: 'prim1' module: 'CPCCT'>
!
----- Method: PCCByCompilationTest>>cExternalCall2 (in category 'example module') -----
cExternalCall2
<primitive:'prim2'module:'CPCCT'>
self primitiveFailed!
----- Method: PCCByCompilationTest>>cExternalCallWithoutModule (in category 'test methods') -----
cExternalCallWithoutModule
<primitive: 'primGetModuleName'>
^ 'Hello World!!'!
----- Method: PCCByCompilationTest>>cFailedCall (in category 'test methods') -----
cFailedCall
<primitive: 'primGetModuleName' module:'CFailModule'>
^ 'failed call'!
----- Method: PCCByCompilationTest>>cNoExternalCall (in category 'test methods') -----
cNoExternalCall
^ 'Hello World!!'!
----- Method: PCCByCompilationTest>>cRealExternalCall (in category 'test methods') -----
cRealExternalCall
<primitive: 'primGetModuleName' module:'LargeIntegers'>
^ 'Hello World!!'!
----- Method: PCCByCompilationTest>>cRealExternalCallNaked (in category 'test methods') -----
cRealExternalCallNaked
<primitive: 'primGetModuleName' module:'LargeIntegers'>!
----- Method: PCCByCompilationTest>>cRealExternalCallOrPrimitiveFailed (in category 'test methods') -----
cRealExternalCallOrPrimitiveFailed
<primitive: 'primGetModuleName' module:'LargeIntegers'>
self primitiveFailed!
----- Method: PCCByCompilationTest>>cSingularExternalCall (in category 'test methods') -----
cSingularExternalCall
<primitive: 'cSingularExternalCall' module:'COne'>
^ 'Hello World!!'!
----- Method: PCCByCompilationTest>>classToBeTested (in category 'constants') -----
classToBeTested
^ PCCByCompilation!
----- Method: PCCByCompilationTest>>disabledCallSelectors (in category 'constants') -----
disabledCallSelectors
^ #(#cDisabledRealExternalCall #cDisabledRealExternalCallNaked #cDisabledRealExternalCallOrPrimitiveFailed #cDisabledExternalCallWithoutModule )!
----- Method: PCCByCompilationTest>>enabledCallSelectors (in category 'constants') -----
enabledCallSelectors
^ #(#cRealExternalCall #cRealExternalCallNaked #cRealExternalCallOrPrimitiveFailed #cExternalCallWithoutModule )!
----- Method: PCCByCompilationTest>>exampleModuleName (in category 'constants') -----
exampleModuleName
^ 'CPCCT'!
----- Method: PCCByCompilationTest>>failModuleName (in category 'constants') -----
failModuleName
^ 'CFailModule'!
----- Method: PCCByCompilationTest>>failedCallSelector (in category 'constants') -----
failedCallSelector
^ #cFailedCall!
----- Method: PCCByCompilationTest>>methodSelectorsToExampleModule (in category 'constants') -----
methodSelectorsToExampleModule
^ #(#cExternalCall1 #cExternalCall2 )!
----- Method: PCCByCompilationTest>>moduleNameNotWithSingularCallName (in category 'constants') -----
moduleNameNotWithSingularCallName
^ 'CNotOne'!
----- Method: PCCByCompilationTest>>moduleNameWithSingularCallName (in category 'constants') -----
moduleNameWithSingularCallName
^ 'COne'!
----- Method: PCCByCompilationTest>>noExternalCallSelector (in category 'constants') -----
noExternalCallSelector
^ #cNoExternalCall!
----- Method: PCCByCompilationTest>>realExternalCallOrPrimitiveFailedSelector (in category 'constants') -----
realExternalCallOrPrimitiveFailedSelector
^ #cRealExternalCallOrPrimitiveFailed!
----- Method: PCCByCompilationTest>>singularCallName (in category 'constants') -----
singularCallName
"occurrs exactly once as prim call name in >>cSingularExternalCall"
^ 'cSingularExternalCall'!
----- Method: PCCByCompilationTest>>singularCallSelector (in category 'constants') -----
singularCallSelector
^ #cSingularExternalCall!
PrimCallControllerAbstractTest subclass: #PCCByLiteralsTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-PrimCallController'!
!PCCByLiteralsTest commentStamp: 'sr 6/14/2004 22:05' prior: 0!
PCCByLiterals tests.
Tests are in the superclass and inherited from there.!
----- Method: PCCByLiteralsTest class>>isAbstract (in category 'Testing') -----
isAbstract
^ false!
----- Method: PCCByLiteralsTest>>classToBeTested (in category 'constants') -----
classToBeTested
^ PCCByLiterals!
----- Method: PCCByLiteralsTest>>disabledCallSelectors (in category 'constants') -----
disabledCallSelectors
^ #(#lDisabledRealExternalCall #lDisabledRealExternalCallNaked #lDisabledRealExternalCallOrPrimitiveFailed #lDisabledExternalCallWithoutModule )!
----- Method: PCCByLiteralsTest>>enabledCallSelectors (in category 'constants') -----
enabledCallSelectors
^ #(#lRealExternalCall #lRealExternalCallNaked #lRealExternalCallOrPrimitiveFailed #lExternalCallWithoutModule )!
----- Method: PCCByLiteralsTest>>exampleModuleName (in category 'constants') -----
exampleModuleName
^ 'LPCCT'!
----- Method: PCCByLiteralsTest>>failModuleName (in category 'constants') -----
failModuleName
^ 'LFailModule'!
----- Method: PCCByLiteralsTest>>failedCallSelector (in category 'constants') -----
failedCallSelector
^ #lFailedCall!
----- Method: PCCByLiteralsTest>>lDisabledExternalCallWithoutModule (in category 'test methods') -----
lDisabledExternalCallWithoutModule
<primitive: 'primGetModuleName'>
^ 'Hello World!!'!
----- Method: PCCByLiteralsTest>>lDisabledRealExternalCall (in category 'test methods') -----
lDisabledRealExternalCall
<primitive: 'primGetModuleName' module:'LargeIntegers'>
^ 'Hello World!!'!
----- Method: PCCByLiteralsTest>>lDisabledRealExternalCallNaked (in category 'test methods') -----
lDisabledRealExternalCallNaked
<primitive: 'primGetModuleName' module:'LargeIntegers'>!
----- Method: PCCByLiteralsTest>>lDisabledRealExternalCallOrPrimitiveFailed (in category 'test methods') -----
lDisabledRealExternalCallOrPrimitiveFailed
<primitive: 'primGetModuleName' module:'LargeIntegers'> "primitiveExternalCall"
self primitiveFailed!
----- Method: PCCByLiteralsTest>>lExternalCall1 (in category 'example module') -----
lExternalCall1
<primitive: 'prim1' module: 'LPCCT'>
!
----- Method: PCCByLiteralsTest>>lExternalCall2 (in category 'example module') -----
lExternalCall2
<primitive:'prim2'module:'LPCCT'>
self primitiveFailed!
----- Method: PCCByLiteralsTest>>lExternalCallWithoutModule (in category 'test methods') -----
lExternalCallWithoutModule
<primitive: 'primGetModuleName'> "primitiveExternalCall"
^ 'Hello World!!'!
----- Method: PCCByLiteralsTest>>lFailedCall (in category 'test methods') -----
lFailedCall
<primitive: 'primGetModuleName' module:'LFailModule'>
^ 'failed call'!
----- Method: PCCByLiteralsTest>>lNoExternalCall (in category 'test methods') -----
lNoExternalCall
^ 'Hello World!!'!
----- Method: PCCByLiteralsTest>>lRealExternalCall (in category 'test methods') -----
lRealExternalCall
<primitive: 'primGetModuleName' module:'LargeIntegers'>
^ 'Hello World!!'!
----- Method: PCCByLiteralsTest>>lRealExternalCallNaked (in category 'test methods') -----
lRealExternalCallNaked
<primitive: 'primGetModuleName' module:'LargeIntegers'>!
----- Method: PCCByLiteralsTest>>lRealExternalCallOrPrimitiveFailed (in category 'test methods') -----
lRealExternalCallOrPrimitiveFailed
<primitive: 'primGetModuleName' module:'LargeIntegers'>
self primitiveFailed!
----- Method: PCCByLiteralsTest>>lSingularExternalCall (in category 'test methods') -----
lSingularExternalCall
<primitive: 'lSingularExternalCall' module:'LOne'>
^ 'Hello World!!'!
----- Method: PCCByLiteralsTest>>methodSelectorsToExampleModule (in category 'constants') -----
methodSelectorsToExampleModule
^ #(#lExternalCall1 #lExternalCall2 )!
----- Method: PCCByLiteralsTest>>moduleNameNotWithSingularCallName (in category 'constants') -----
moduleNameNotWithSingularCallName
^ 'LNotOne'!
----- Method: PCCByLiteralsTest>>moduleNameWithSingularCallName (in category 'constants') -----
moduleNameWithSingularCallName
^ 'LOne'!
----- Method: PCCByLiteralsTest>>noExternalCallSelector (in category 'constants') -----
noExternalCallSelector
^ #lNoExternalCall!
----- Method: PCCByLiteralsTest>>realExternalCallOrPrimitiveFailedSelector (in category 'constants') -----
realExternalCallOrPrimitiveFailedSelector
^ #lRealExternalCallOrPrimitiveFailed!
----- Method: PCCByLiteralsTest>>setUp (in category 'tests') -----
setUp
super setUp.
"disable external calls"
(self class selectors
select: [:sel | sel beginsWith: 'lDisabled'])
do: [:sel | (self class >> sel) literals first at: 4 put: -2]!
----- Method: PCCByLiteralsTest>>singularCallName (in category 'constants') -----
singularCallName
"occurrs exactly once as prim call name in >>lSingularExternalCall"
^ 'lSingularExternalCall'!
----- Method: PCCByLiteralsTest>>singularCallSelector (in category 'constants') -----
singularCallSelector
^ #lSingularExternalCall!
----- Method: PrimCallControllerAbstractTest class>>isAbstract (in category 'Testing') -----
isAbstract
^ true!
----- Method: PrimCallControllerAbstractTest>>avoidSlowTest (in category 'helper') -----
avoidSlowTest
^ doNotMakeSlowTestsFlag and: [pcc class = PCCByCompilation]!
----- Method: PrimCallControllerAbstractTest>>compiledMethodsToExampleModule (in category 'constants') -----
compiledMethodsToExampleModule
^ self methodSelectorsToExampleModule
collect: [:sel | self class >> sel]!
----- Method: PrimCallControllerAbstractTest>>disabledCallRefs (in category 'helper') -----
disabledCallRefs
^ self disabledCallSelectors
collect: [:sel | MethodReference new setStandardClass: self class methodSymbol: sel]!
----- Method: PrimCallControllerAbstractTest>>enabledCallRefs (in category 'helper') -----
enabledCallRefs
^ self enabledCallSelectors
collect: [:sel | MethodReference new setStandardClass: self class methodSymbol: sel]!
----- Method: PrimCallControllerAbstractTest>>failedCallRef (in category 'constants') -----
failedCallRef
^ MethodReference new setStandardClass: self class methodSymbol: self failedCallSelector!
----- Method: PrimCallControllerAbstractTest>>methodRefsToExampleModule (in category 'constants') -----
methodRefsToExampleModule
^ self methodSelectorsToExampleModule
collect: [:sym | MethodReference new setStandardClass: self class methodSymbol: sym]!
----- Method: PrimCallControllerAbstractTest>>noExternalCallRef (in category 'constants') -----
noExternalCallRef
^ MethodReference new setStandardClass: self class methodSymbol: self noExternalCallSelector!
----- Method: PrimCallControllerAbstractTest>>numOfCallsExampleModule (in category 'constants') -----
numOfCallsExampleModule
^ self methodSelectorsToExampleModule size!
----- Method: PrimCallControllerAbstractTest>>setUp (in category 'tests') -----
setUp
super setUp.
pcc := self classToBeTested new.
"set failed call"
(self class >> self failedCallSelector) literals first at: 4 put: -1.
"set it to false for some very slow tests..."
doNotMakeSlowTestsFlag := true!
----- Method: PrimCallControllerAbstractTest>>singularCallRef (in category 'constants') -----
singularCallRef
^ MethodReference new setStandardClass: self class methodSymbol: self singularCallSelector!
----- Method: PrimCallControllerAbstractTest>>testChangeFailedCallFailing (in category 'tests') -----
testChangeFailedCallFailing
pcc preserveStatusOfFailedCalls.
self
should: [pcc enableCallIn: self failedCallRef]
raise: TestResult error.
self
should: [pcc disableCallIn: self failedCallRef]
raise: TestResult error!
----- Method: PrimCallControllerAbstractTest>>testChangeFailedCallSucceedingDisable (in category 'tests') -----
testChangeFailedCallSucceedingDisable
pcc changeStatusOfFailedCalls.
pcc disableCallIn: self failedCallRef.
self
assert: (pcc existsDisabledCallIn: self failedCallRef).
"necessary for PCCByCompilation (to make it visible for initialization again)"
pcc enableCallIn: self failedCallRef!
----- Method: PrimCallControllerAbstractTest>>testChangeFailedCallSucceedingEnable (in category 'tests') -----
testChangeFailedCallSucceedingEnable
pcc changeStatusOfFailedCalls.
pcc enableCallIn: self failedCallRef.
self
assert: (pcc existsEnabledCallIn: self failedCallRef)!
----- Method: PrimCallControllerAbstractTest>>testDisableCallsIntoModule (in category 'tests') -----
testDisableCallsIntoModule
"wrong module"
self
should: [pcc disableCallsIntoModule: 'totallyRandom4711']
raise: TestResult error.
"precondition: all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"disabling"
pcc disableCallsIntoModule: self exampleModuleName.
"now all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
"not enabled!!"
self
should: [pcc disableCallsIntoModule: self exampleModuleName]
raise: TestResult error.
"enabling"
self methodRefsToExampleModule
do: [:ref | pcc enableCallIn: ref].
"all enabled now"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"not enabled!!"
self
should: [pcc disableCallsIntoModule: self failModuleName]
raise: TestResult error.
pcc changeStatusOfFailedCalls.
pcc disableCallsIntoModule: self failModuleName.
self assert: (pcc existsDisabledCallIn: self failedCallRef).
"postcondition"
pcc enableCallIn: self failedCallRef
!
----- Method: PrimCallControllerAbstractTest>>testDisableCallsIntoModuleForClasses (in category 'tests') -----
testDisableCallsIntoModuleForClasses
"wrong module"
self
should: [pcc disableCallsIntoModule: 'totallyRandom4711' forClasses: {self class}]
raise: TestResult error.
"precondition: all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"disabling"
pcc disableCallsIntoModule: self exampleModuleName forClasses: {self class}.
"now all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
"not enabled!!"
self
should: [pcc disableCallsIntoModule: self exampleModuleName forClasses: {self class}]
raise: TestResult error.
"enabling"
self methodRefsToExampleModule
do: [:ref | pcc enableCallIn: ref].
"all enabled now"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"not enabled!!"
self
should: [pcc disableCallsIntoModule: self failModuleName forClasses: {self class}]
raise: TestResult error.
pcc changeStatusOfFailedCalls.
pcc disableCallsIntoModule: self failModuleName forClasses: {self class}.
self assert: (pcc existsDisabledCallIn: self failedCallRef).
"postcondition"
pcc enableCallIn: self failedCallRef
!
----- Method: PrimCallControllerAbstractTest>>testEnableCallsIntoModule (in category 'tests') -----
testEnableCallsIntoModule
self avoidSlowTest
ifTrue: [^ self].
"wrong module"
self
should: [pcc enableCallsIntoModule: 'totallyRandom4711']
raise: TestResult error.
"precondition: all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"not disabled!!"
self
should: [pcc enableCallsIntoModule: self exampleModuleName]
raise: TestResult error.
"disabling"
self methodRefsToExampleModule
do: [:ref | pcc disableCallIn: ref].
"now all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
"enabling"
"now this should work"
pcc enableCallsIntoModule: self exampleModuleName.
"all enabled now"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"not disabled!!"
self
should: [pcc enableCallsIntoModule: self failModuleName]
raise: TestResult error.
pcc changeStatusOfFailedCalls.
pcc enableCallsIntoModule: self failModuleName.
self assert: (pcc existsEnabledCallIn: self failedCallRef)
!
----- Method: PrimCallControllerAbstractTest>>testEnableCallsIntoModuleForClasses (in category 'tests') -----
testEnableCallsIntoModuleForClasses
"wrong module"
self
should: [pcc enableCallsIntoModule: 'totallyRandom4711' forClasses: {self class}]
raise: TestResult error.
"precondition: all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"not disabled!!"
self
should: [pcc enableCallsIntoModule: self exampleModuleName forClasses: {self class}]
raise: TestResult error.
"disabling"
self methodRefsToExampleModule
do: [:ref | pcc disableCallIn: ref].
"now all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
"enabling"
"now this should work"
pcc enableCallsIntoModule: self exampleModuleName forClasses: {self class}.
"all enabled now"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"not disabled!!"
self
should: [pcc enableCallsIntoModule: self failModuleName forClasses: {self class}]
raise: TestResult error.
pcc changeStatusOfFailedCalls.
pcc enableCallsIntoModule: self failModuleName forClasses: {self class}.
self assert: (pcc existsEnabledCallIn: self failedCallRef)
!
----- Method: PrimCallControllerAbstractTest>>testEnableDisableCallIn (in category 'tests') -----
testEnableDisableCallIn
| refs |
refs := self methodRefsToExampleModule.
"wrong call"
self
should: [pcc disableCallIn: self wrongCallRef]
raise: TestResult error.
"wrong class"
self
should: [pcc disableCallIn: self wrongClassRef]
raise: TestResult error.
"wrong call"
self
should: [pcc enableCallIn: self wrongCallRef]
raise: TestResult error.
"wrong class"
self
should: [pcc enableCallIn: self wrongClassRef]
raise: TestResult error.
"no external call"
self
should: [pcc enableCallIn: self noExternalCallRef]
raise: TestResult error.
"precondition: all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"not disabled!!"
self
should: [refs
do: [:ref1 | pcc enableCallIn: ref1]]
raise: TestResult error.
"disabling"
refs
do: [:ref2 | pcc disableCallIn: ref2].
"now all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
"not enabled!!"
self
should: [refs
do: [:ref3 | pcc disableCallIn: ref3]]
raise: TestResult error.
"enabling"
"now this should work"
refs
do: [:ref4 | pcc enableCallIn: ref4].
"all enabled now"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"try caches"
pcc disableEnabled.
"all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
pcc enableDisabled.
"all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule!
----- Method: PrimCallControllerAbstractTest>>testEnableDisableCallInCompiledMethod (in category 'tests') -----
testEnableDisableCallInCompiledMethod
"Note: >>compiledMethodsToExampleModule has to be called frequently,
since the CMs are changing with a successful compile!!"
"precondition: all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"not disabled!!"
self
should: [self compiledMethodsToExampleModule
do: [:cm1 | pcc enableCallInCompiledMethod: cm1]]
raise: TestResult error.
"disabling"
self compiledMethodsToExampleModule
do: [:cm2 | pcc disableCallInCompiledMethod: cm2].
"now all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
"not enabled!!"
self
should: [self compiledMethodsToExampleModule
do: [:cm3 | pcc disableCallInCompiledMethod: cm3]]
raise: TestResult error.
"enabling"
"now this should work"
self compiledMethodsToExampleModule
do: [:cm4 | pcc enableCallInCompiledMethod: cm4].
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"try caches"
pcc disableEnabled.
"all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
pcc enableDisabled.
"all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule!
----- Method: PrimCallControllerAbstractTest>>testEnableDisableCallInMethodClass (in category 'tests') -----
testEnableDisableCallInMethodClass
| sels |
sels := self methodSelectorsToExampleModule.
"wrong call"
self
should: [pcc disableCallInMethod: #nonExistingCall class: self class]
raise: TestResult error.
"wrong class"
self
should: [pcc disableCallInMethod: sels first class: Integer]
raise: TestResult error.
"wrong call"
self
should: [pcc enableCallInMethod: #nonExistingCall class: self class]
raise: TestResult error.
"wrong class"
self
should: [pcc enableCallInMethod: sels first class: Integer]
raise: TestResult error.
self
should: [pcc enableCallInMethod: self noExternalCallSelector class: self class]
raise: TestResult error.
"precondition: all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"not disabled!!"
self
should: [sels
do: [:sel1 | pcc enableCallInMethod: sel1 class: self class]]
raise: TestResult error.
"disabling"
sels
do: [:sel2 | pcc disableCallInMethod: sel2 class: self class].
"now all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
"not enabled!!"
self
should: [sels
do: [:sel3 | pcc disableCallInMethod: sel3 class: self class]]
raise: TestResult error.
"enabling"
"now this should work"
sels
do: [:sel4 | pcc enableCallInMethod: sel4 class: self class].
"all enabled now"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
"try caches"
pcc disableEnabled.
"all disabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
pcc enableDisabled.
"all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule!
----- Method: PrimCallControllerAbstractTest>>testExistsCallIn (in category 'tests') -----
testExistsCallIn
self
deny: (pcc existsCallIn: self noExternalCallRef).
self enabledCallRefs , self disabledCallRefs , {self failedCallRef}
do: [:callRef | self
assert: (pcc existsCallIn: callRef)]!
----- Method: PrimCallControllerAbstractTest>>testExistsDisabledCallIn (in category 'tests') -----
testExistsDisabledCallIn
self
deny: (pcc existsDisabledCallIn: self noExternalCallRef).
self
deny: (pcc existsDisabledCallIn: self failedCallRef).
self enabledCallRefs
do: [:callRef | self
deny: (pcc existsDisabledCallIn: callRef)].
self disabledCallRefs
do: [:disabledRef | self
assert: (pcc existsDisabledCallIn: disabledRef)]!
----- Method: PrimCallControllerAbstractTest>>testExistsEnabledCallIn (in category 'tests') -----
testExistsEnabledCallIn
self
deny: (pcc existsEnabledCallIn: self noExternalCallRef).
self
deny: (pcc existsEnabledCallIn: self failedCallRef).
self enabledCallRefs
do: [:callRef | self
assert: (pcc existsEnabledCallIn: callRef)].
self disabledCallRefs
do: [:disabledRef | self
deny: (pcc existsEnabledCallIn: disabledRef)]!
----- Method: PrimCallControllerAbstractTest>>testExistsFailedCallIn (in category 'tests') -----
testExistsFailedCallIn
self
deny: (pcc existsFailedCallIn: self noExternalCallRef).
self enabledCallRefs , self disabledCallRefs
do: [:callRef | self
deny: (pcc existsFailedCallIn: callRef)].
self
assert: (pcc existsFailedCallIn: self failedCallRef)!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithCallAndMethodsWithDisabledCall (in category 'tests') -----
testMethodsWithCallAndMethodsWithDisabledCall
| methodRefs disabledMethodRefs enabledMethodRefs failedMethodRefs |
self avoidSlowTest
ifTrue: [^ self].
disabledMethodRefs := pcc methodsWithDisabledCall.
self assert: disabledMethodRefs size > 0.
enabledMethodRefs := pcc methodsWithEnabledCall.
self assert: enabledMethodRefs size > 0.
failedMethodRefs := pcc methodsWithFailedCall.
self assert: failedMethodRefs size > 0.
methodRefs := pcc methodsWithCall.
self assert: methodRefs size = (disabledMethodRefs size + enabledMethodRefs size + failedMethodRefs size)!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithCallIntoModule (in category 'tests') -----
testMethodsWithCallIntoModule
| methodRefs |
self avoidSlowTest ifTrue: [^ self].
"precondition: all enabled"
pcc disableCallIn: self methodRefsToExampleModule first.
methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName.
self assert: methodRefs size = self numOfCallsExampleModule.
"postcondition"
pcc enableCallIn: self methodRefsToExampleModule first!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithCallIntoModuleForClass (in category 'tests') -----
testMethodsWithCallIntoModuleForClass
"precondition: all enabled"
| methodRefs |
pcc disableCallIn: self methodRefsToExampleModule first.
methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName forClass: self class.
self assert: methodRefs size = self numOfCallsExampleModule.
"postcondition"
pcc enableCallIn: self methodRefsToExampleModule first.
methodRefs := pcc methodsWithCallIntoModule: nil forClass: self class.
self
assert: (methodRefs size = 2
and: [| methodCoreStrings |
methodCoreStrings := methodRefs
collect: [:mRef | mRef methodSymbol allButFirst asString].
(methodCoreStrings includes: 'ExternalCallWithoutModule')
and: [methodCoreStrings includes: 'DisabledExternalCallWithoutModule']])!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithCallIntoModuleForClasses (in category 'tests') -----
testMethodsWithCallIntoModuleForClasses
"precondition: all enabled"
| methodRefs |
pcc disableCallIn: self methodRefsToExampleModule first.
methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName forClasses: {self class}.
self assert: methodRefs size = self numOfCallsExampleModule.
"postcondition"
pcc enableCallIn: self methodRefsToExampleModule first.
methodRefs := pcc methodsWithCallIntoModule: nil forClasses: {self class}.
self
assert: (methodRefs size = 2
and: [| methodCoreStrings |
methodCoreStrings := methodRefs
collect: [:mRef | mRef methodSymbol allButFirst asString].
(methodCoreStrings includes: 'ExternalCallWithoutModule')
and: [methodCoreStrings includes: 'DisabledExternalCallWithoutModule']])!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithCallX (in category 'tests') -----
testMethodsWithCallX
| methodRefs |
self avoidSlowTest
ifTrue: [^ self].
methodRefs := pcc methodsWithCall: self singularCallName.
self assert: methodRefs size = 1!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithCallXIntoModule (in category 'tests') -----
testMethodsWithCallXIntoModule
| methodRefs |
self avoidSlowTest
ifTrue: [^ self].
methodRefs := pcc methodsWithCall: self singularCallName intoModule: self moduleNameWithSingularCallName.
self assert: methodRefs size = 1.
methodRefs := pcc methodsWithCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName.
self assert: methodRefs isEmpty!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithDisabledCallIntoModule (in category 'tests') -----
testMethodsWithDisabledCallIntoModule
| methodRefs |
self avoidSlowTest ifTrue: [^ self].
"precondition: all enabled"
pcc disableCallIn: self methodRefsToExampleModule first.
methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName.
self assert: methodRefs size = 1.
"postcondition"
pcc enableCallIn: self methodRefsToExampleModule first!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithDisabledCallIntoModuleForClass (in category 'tests') -----
testMethodsWithDisabledCallIntoModuleForClass
"precondition: all enabled"
| methodRefs |
self methodRefsToExampleModule
do: [:ref | pcc disableCallIn: ref].
methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName forClass: self class.
self assert: methodRefs size = self numOfCallsExampleModule.
"postcondition"
self methodRefsToExampleModule
do: [:ref | pcc enableCallIn: ref].
methodRefs := pcc methodsWithDisabledCallIntoModule: nil forClass: self class.
self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'DisabledExternalCallWithoutModule')!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithDisabledCallIntoModuleForClasses (in category 'tests') -----
testMethodsWithDisabledCallIntoModuleForClasses
"precondition: all enabled"
| methodRefs |
self methodRefsToExampleModule
do: [:ref | pcc disableCallIn: ref].
methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName forClasses: {self class}.
self assert: methodRefs size = self numOfCallsExampleModule.
"postcondition"
self methodRefsToExampleModule
do: [:ref | pcc enableCallIn: ref].
methodRefs := pcc methodsWithDisabledCallIntoModule: nil forClasses: {self class}.
self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'DisabledExternalCallWithoutModule')!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithDisabledCallX (in category 'tests') -----
testMethodsWithDisabledCallX
| methodRefs |
self avoidSlowTest
ifTrue: [^ self].
"precondition: all enabled"
pcc disableCallIn: self singularCallRef.
methodRefs := pcc methodsWithDisabledCall: self singularCallName.
self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self singularCallName).
"postcondition"
pcc enableCallIn: self singularCallRef!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithDisabledCallXIntoModule (in category 'tests') -----
testMethodsWithDisabledCallXIntoModule
"precondition: all enabled"
| methodRefs |
self avoidSlowTest
ifTrue: [^ self].
"precondition: all enabled"
pcc disableCallIn: self singularCallRef.
methodRefs := pcc methodsWithDisabledCall: self singularCallName intoModule: self moduleNameWithSingularCallName.
self assert: methodRefs size = 1.
methodRefs := pcc methodsWithDisabledCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName.
self assert: methodRefs isEmpty.
"postcondition"
pcc enableCallIn: self singularCallRef!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithEnabledCall (in category 'tests') -----
testMethodsWithEnabledCall
| methodRefs |
methodRefs := pcc methodsWithEnabledCall.
self assert: methodRefs size > 0!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithEnabledCallIntoModule (in category 'tests') -----
testMethodsWithEnabledCallIntoModule
| methodRefs |
methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName.
self assert: methodRefs size = self numOfCallsExampleModule!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithEnabledCallIntoModuleForClass (in category 'tests') -----
testMethodsWithEnabledCallIntoModuleForClass
"precondition: all enabled"
| methodRefs |
methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class.
self assert: methodRefs size = self numOfCallsExampleModule.
methodRefs := pcc methodsWithEnabledCallIntoModule: nil forClass: self class.
self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'ExternalCallWithoutModule')!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithEnabledCallIntoModuleForClasses (in category 'tests') -----
testMethodsWithEnabledCallIntoModuleForClasses
"precondition: all enabled"
| methodRefs |
methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClasses: {self class}.
self assert: methodRefs size = self numOfCallsExampleModule.
methodRefs := pcc methodsWithEnabledCallIntoModule: nil forClasses: {self class}.
self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'ExternalCallWithoutModule')!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithEnabledCallX (in category 'tests') -----
testMethodsWithEnabledCallX
| methodRefs |
methodRefs := pcc methodsWithEnabledCall: self singularCallName.
self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self singularCallName)!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithEnabledCallXIntoModule (in category 'tests') -----
testMethodsWithEnabledCallXIntoModule
"precondition: all enabled"
| methodRefs |
methodRefs := pcc methodsWithEnabledCall: self singularCallName intoModule: self moduleNameWithSingularCallName.
self assert: methodRefs size = 1.
methodRefs := pcc methodsWithEnabledCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName.
self assert: methodRefs isEmpty!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithFailedCall (in category 'tests') -----
testMethodsWithFailedCall
| methodRefs |
methodRefs := pcc methodsWithFailedCall.
self assert: methodRefs size >= 1 & ((methodRefs
select: [:mRef | mRef methodSymbol = self failedCallSelector]) size = 1)!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithFailedCallForClass (in category 'tests') -----
testMethodsWithFailedCallForClass
| methodRefs |
methodRefs := pcc methodsWithFailedCallForClass: self class.
self assert: methodRefs size = 1 & (methodRefs asArray first methodSymbol = self failedCallSelector)!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithFailedCallIntoModule (in category 'tests') -----
testMethodsWithFailedCallIntoModule
| methodRefs |
methodRefs := pcc methodsWithFailedCallIntoModule: self failModuleName.
self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self failedCallSelector)!
----- Method: PrimCallControllerAbstractTest>>testMethodsWithFailedCallIntoModuleForClass (in category 'tests') -----
testMethodsWithFailedCallIntoModuleForClass
| methodRefs |
methodRefs := pcc methodsWithFailedCallIntoModule: self failModuleName forClass: self class.
self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self failedCallSelector)!
----- Method: PrimCallControllerAbstractTest>>testSwitchPrimCallOffOn (in category 'tests') -----
testSwitchPrimCallOffOn
| res |
pcc disableCallInMethod: self realExternalCallOrPrimitiveFailedSelector class: self class.
self
should: [self perform: self realExternalCallOrPrimitiveFailedSelector]
raise: TestResult error.
pcc enableCallInMethod: self realExternalCallOrPrimitiveFailedSelector class: self class.
self
shouldnt: [res := self perform: self realExternalCallOrPrimitiveFailedSelector]
raise: TestResult error.
self assert: res isString!
----- Method: PrimCallControllerAbstractTest>>testSwitchStored (in category 'tests') -----
testSwitchStored
| refs |
"all enabled, precondition"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
refs := self methodRefsToExampleModule.
"fill cache"
refs
do: [:ref | pcc disableCallIn: ref].
"enable one"
pcc enableCallIn: refs first.
self
assert: (pcc existsEnabledCallIn: refs first).
self
assert: (pcc existsDisabledCallIn: refs second).
"switching"
pcc switchStored.
"now the checks go vice versa"
self
assert: (pcc existsDisabledCallIn: refs first).
self
assert: (pcc existsEnabledCallIn: refs second).
pcc enableCallIn: refs first.
self
assert: (pcc existsEnabledCallIn: refs first)!
----- Method: PrimCallControllerAbstractTest>>testTryCaches (in category 'tests') -----
testTryCaches
| refs |
"all enabled, precondition"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
refs := self methodRefsToExampleModule.
"fill cache"
refs
do: [:ref | pcc disableCallIn: ref].
"try caches"
pcc enableDisabled.
"all enabled"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule.
pcc disableEnabled.
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0.
pcc enableDisabled.
"all enabled, postcondition"
self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule!
----- Method: PrimCallControllerAbstractTest>>wrongCallRef (in category 'constants') -----
wrongCallRef
^ MethodReference new setStandardClass: self class methodSymbol: #nonExistingCall!
----- Method: PrimCallControllerAbstractTest>>wrongClassRef (in category 'constants') -----
wrongClassRef
^ MethodReference new setStandardClass: Integer methodSymbol: self methodSelectorsToExampleModule first!
TestCase subclass: #HandBugs
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: HandBugs>>testTargetPoint (in category 'as yet unclassified') -----
testTargetPoint
"self new testTargetPoint"
"self run: #testTargetPoint"
self shouldnt: [ ActiveHand targetPoint ] raise: Error .
!
TestCase subclass: #HashAndEqualsTestCase
instanceVariableNames: 'prototypes'
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Utilities'!
!HashAndEqualsTestCase commentStamp: 'mjr 8/20/2003 17:37' prior: 0!
I am a simple TestCase that tests for correct operation of #hash and #=.
Subclasses of me need to fill my prototypes with suitable objects to be tested.!
----- Method: HashAndEqualsTestCase>>setUp (in category 'as yet unclassified') -----
setUp
"subclasses will add their prototypes into this collection"
prototypes := OrderedCollection new !
----- Method: HashAndEqualsTestCase>>testEquality (in category 'as yet unclassified') -----
testEquality
"Check that TextFontChanges report equality correctly"
prototypes
do: [:p | self
should: [(EqualityTester with: p) result]] !
----- Method: HashAndEqualsTestCase>>testHash (in category 'as yet unclassified') -----
testHash
"test that TextFontChanges hash correctly"
prototypes
do: [:p | self
should: [(HashTester with: p) result]] !
TestCase subclass: #HashTesterTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Utilities'!
!HashTesterTest commentStamp: 'mjr 8/20/2003 12:48' prior: 0!
I am a simple test case to check that HashTester works correctly!
----- Method: HashTesterTest>>testBasicBehaviour (in category 'as yet unclassified') -----
testBasicBehaviour
self
should: [(HashTester with: 1)
resultFor: 100].
self
should: [(HashTester with: 'fred')
resultFor: 100].
self
shouldnt: [(HashTester with: BadHasher new)
resultFor: 100] !
TestCase subclass: #HexTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Hex'!
!HexTest commentStamp: 'JPF 6/26/2007 10:15' prior: 0!
Rather than testing a single class, this set of tests looks at the interactions between Character, String, Integer and Color using hex and printStringHex!
----- Method: HexTest>>testCharacterHex (in category 'as yet unclassified') -----
testCharacterHex
| result |
result _ $a hex.
self assert: result = '61'.
result _ $A hex.
self assert: result = '41'.
!
----- Method: HexTest>>testColorPrintHtmlString (in category 'as yet unclassified') -----
testColorPrintHtmlString
self assert: (Color red printHtmlString ) = ( Color red asHTMLColor allButFirst asUppercase).
!
----- Method: HexTest>>testIntegerHex (in category 'as yet unclassified') -----
testIntegerHex
| result |
result _ 15 asInteger hex.
self assert: result = '0F'.
result _ 0 asInteger hex.
self assert: result = '00'.
result _ 255 asInteger hex.
self assert: result = 'FF'.
result _ 90 asInteger hex.
self assert: result = '5A'.
!
----- Method: HexTest>>testStringAsHex (in category 'as yet unclassified') -----
testStringAsHex
| result |
result _ 'abc' asHex.
self assert: result = '616263'.
!
TestCase subclass: #IslandVMTweaksTestCase
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-VM'!
!IslandVMTweaksTestCase commentStamp: 'ls 7/10/2003 18:59' prior: 0!
Test case for some tweaks to the VM that Islands requires. These tests are largely for documentation; with an un-tweaked VM, the tests mostly still succeed, albeit with possible memory corruption.!
----- Method: IslandVMTweaksTestCase>>aaaREADMEaboutPrimitives (in category 'primitives') -----
aaaREADMEaboutPrimitives
"most of the Islands tweaks allow primitive methods to be located in places other than class Object. Thus they are copied here for testing."
!
----- Method: IslandVMTweaksTestCase>>classOf: (in category 'primitives') -----
classOf: anObject
<primitive: 111>
!
----- Method: IslandVMTweaksTestCase>>instVarOf:at: (in category 'primitives') -----
instVarOf: anObject at: index
<primitive: 73>
self primitiveFailed
!
----- Method: IslandVMTweaksTestCase>>instVarOf:at:put: (in category 'primitives') -----
instVarOf: anObject at: index put: anotherObject
<primitive: 74>
self primitiveFailed
!
----- Method: IslandVMTweaksTestCase>>nextInstanceAfter: (in category 'primitives') -----
nextInstanceAfter: anObject
<primitive: 78>
!
----- Method: IslandVMTweaksTestCase>>nextObjectAfter: (in category 'primitives') -----
nextObjectAfter: anObject
<primitive: 139>
!
----- Method: IslandVMTweaksTestCase>>replaceIn:from:to:with:startingAt: (in category 'primitives') -----
replaceIn: replacee from: start to: stop with: replacer startingAt: replStart
<primitive: 105>
self primitiveFailed!
----- Method: IslandVMTweaksTestCase>>returnTwelve (in category 'miscellaneous') -----
returnTwelve
"this method is tweaked by testFlagInCompiledMethod"
^12!
----- Method: IslandVMTweaksTestCase>>someInstanceOf: (in category 'primitives') -----
someInstanceOf: aClass
<primitive: 77>
self primitiveFailed!
----- Method: IslandVMTweaksTestCase>>someObject (in category 'primitives') -----
someObject
<primitive: 138>
self primitiveFailed!
----- Method: IslandVMTweaksTestCase>>testEmptyReplace (in category 'testing') -----
testEmptyReplace
| array1 array2 |
array1 := Array with: 1 with: 2 with: 3 with: 4.
array2 := Array with: 5 with: 6 with: 7.
self replaceIn: array1 from: 1 to: 0 with: array2 startingAt: 1.
self should: [ array1 = #(1 2 3 4) ].
!
----- Method: IslandVMTweaksTestCase>>testFlagInCompiledMethod (in category 'testing') -----
testFlagInCompiledMethod
"this tests that the flag in compiled methods is treated correctly"
| method |
method := self class compiledMethodAt: #returnTwelve.
"turn off the flag"
method objectAt: 1 put: (method header bitAnd: (1 << 29) bitInvert).
self should: [ method flag not ].
"turn on the flag"
method objectAt: 1 put: (method header bitOr: (1 << 29)).
self should: [ method flag ].
"try running the method with the flag turned on"
self should: [ self returnTwelve = 12 ].
"make sure the flag bit isn't interpreted as a primitive"
self should: [ method primitive = 0 ].!
----- Method: IslandVMTweaksTestCase>>testForgivingPrims (in category 'testing') -----
testForgivingPrims
| aPoint anotherPoint array1 array2 |
aPoint := Point x: 5 y: 6.
anotherPoint := Point x: 7 y: 8. "make sure there are multiple points floating around"
anotherPoint. "stop the compiler complaining about no uses"
self should: [ (self classOf: aPoint) = Point ].
self should: [ (self instVarOf: aPoint at: 1) = 5 ].
self instVarOf: aPoint at: 2 put: 10.
self should: [ (self instVarOf: aPoint at: 2) = 10 ].
self someObject.
self nextObjectAfter: aPoint.
self should: [ (self someInstanceOf: Point) class = Point ].
self should: [ (self nextInstanceAfter: aPoint) class = Point ].
array1 := Array with: 1 with: 2 with: 3.
array2 := Array with: 4 with: 5 with: 6.
self replaceIn: array1 from: 2 to: 3 with: array2 startingAt: 1.
self should: [ array1 = #(1 4 5) ].
!
TestCase subclass: #LangEnvBugs
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: LangEnvBugs>>tearDown (in category 'as yet unclassified') -----
tearDown
Preferences restoreDefaultFonts!
----- Method: LangEnvBugs>>testIsFontAvailable (in category 'as yet unclassified') -----
testIsFontAvailable
"self new testIsFontAvailable"
"self run: #testIsFontAvailable"
| oldPref |
oldPref := Preferences valueOfPreference: #tinyDisplay .
Preferences enable: #tinyDisplay .
self shouldnt: [ [ ( LanguageEnvironment localeID: 'en' ) isFontAvailable ]
ensure: [Preferences setPreference: #tinyDisplay toValue: oldPref] ]
raise: Error.
^true!
TestCase subclass: #MorphBugs
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: MorphBugs>>adhereToEdgeTest (in category 'as yet unclassified') -----
adhereToEdgeTest
"self new adhereToEdgeTest"
"self run: #adhereToEdgeTest"
| r |
r := RectangleMorph new openInWorld .
self shouldnt: [ [ r adhereToEdge: #eternity ] ensure: [ r delete ] ] raise: Error .
r delete .
^true !
TestCase subclass: #MorphicUIBugTest
instanceVariableNames: 'cases'
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
!MorphicUIBugTest commentStamp: 'wiz 1/3/2007 13:57' prior: 0!
A MorphicUIBugTest is a class for testing the shortcomings and repairs of the MorphicUI manager.
.
Instance Variables
cases: <aCollection>
cases
- a list of morphs that may need to be deleted during teardown.
the tests are expected to fill this list it starts out empty by default.
!
----- Method: MorphicUIBugTest>>findWindowInWorldLabeled: (in category 'as yet unclassified') -----
findWindowInWorldLabeled: aLabel
^ World submorphs detect: [ :each |
each class == SystemWindow
and: [ each label = aLabel ] ] ifNone: [ nil ] .!
----- Method: MorphicUIBugTest>>setUp (in category 'as yet unclassified') -----
setUp
"default. tests will add morphs to list. Teardown will delete."
cases := #() .!
----- Method: MorphicUIBugTest>>tearDown (in category 'as yet unclassified') -----
tearDown
"default. tests will add morphs to list. Teardown will delete."
cases do: [ :each | each delete ] .!
----- Method: MorphicUIBugTest>>testOpenWorkspace (in category 'as yet unclassified') -----
testOpenWorkspace
"self new testOpenWorkspace"
"MorphicUIBugTest run: #testOpenWorkspace"
| window myLabel foundWindow myModel |
self assert: ( Smalltalk isMorphic ) .
myLabel := 'Workspace from ', 'SUnit test' .
foundWindow := self findWindowInWorldLabeled: myLabel .
self assert: ( foundWindow isNil ) .
window :=
UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"' label: myLabel .
window = window.
foundWindow := self findWindowInWorldLabeled: myLabel .
cases := Array with: foundWindow . "For teardown."
myModel := (foundWindow submorphs detect: [ :each |
each isMorphicModel ] ) .
self assert: ( myModel model class == Workspace ) .
self assert: ( foundWindow model class == Workspace ) .
foundWindow delete .!
----- Method: MorphicUIBugTest>>testOpenWorkspaceAns (in category 'as yet unclassified') -----
testOpenWorkspaceAns
"Test if method opening a workspace answers the window opened"
"MorphicUIBugTest run: #testOpenWorkspaceAns"
| window myLabel foundWindow |
self assert: ( Smalltalk isMorphic ) .
myLabel := 'Workspace from ', 'SUnit test' .
foundWindow := self findWindowInWorldLabeled: myLabel .
self assert: ( foundWindow isNil ) .
window :=
UIManager default edit: '"MorphicUIBugTest run: #openWorkspaceTest"' label: myLabel .
foundWindow := self findWindowInWorldLabeled: myLabel .
cases := Array with: foundWindow . "For teardown."
self assert: ( window == foundWindow ) .
foundWindow delete .!
MorphicUIBugTest subclass: #RenderBugz
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
!RenderBugz commentStamp: 'wiz 5/15/2008 22:58' prior: 0!
A RenderBugz is an infinite recursion bug test for TransformationMorphs.
In 3.9 (7067) and before, when TransformationMorph has no rendee there are several methods that will infinitely recurse until manually stopped or the image runs out of memory.
So far the ones I've caught are the getters and setters for heading and forwardDirection.
So there are tests for them here.
Ideally there would be a way to run a test against a stopwatch to catch endless recursion.
Found it. Now incorperated. And the tests should be both save to run and cleanup after themselves even when they fail.
So far we have not tested the normal cases of rendering working.
I will leave that as a separate task for another time.
So this is an automatic test when the bugs are fixed and interactive (crash) tests when the bugs are present.
Instance Variables
Revision notes. wiz 5/15/2008 22:58
When running tests from the TestRunner browser the test would sporadically fail.
When they failed a transfomation morph would be left on the screen and not removed by the
ensureBlock.
So I changed things to fall under MorphicUIBugTests because that had a cleanup mechansizm for left over morphs.
I also added one routine to test for time and one parameter to determine the time limit.
To my surprise doubling or tripling the time limit still produced sporadic errors when the test is run repeatedly enough ( I am using a 400mz iMac. ) So now the parameter is set to 4. Things will probably fail there if tried long enough. At that point try 5 etc.
I am reluctant to make the number larger than necessary. The tighter the test the more you know what is working.
I also added a dummy test to check specifically for the timing bug. It fails on the same sporadic basis as the other test went the time parameter is short enough. This lends confidence to the theory that the timing difficulty is coming from outside the test. The sunit runner puts up a progress morph for each test. So the morphic display stuff is busy and probably also the GC.
!
----- Method: RenderBugz>>long (in category 'utility') -----
long
"return time limit in milliseconds for tests"
^4!
----- Method: RenderBugz>>shouldntTakeLong: (in category 'utility') -----
shouldntTakeLong: aBlock
"Check for infinite recursion. Test should finish in a reasonable time."
^self should: aBlock
notTakeMoreThanMilliseconds: self long .
!
----- Method: RenderBugz>>testForward (in category 'tests') -----
testForward
"If the bug exist there will be an infinte recursion."
"self new testForward"
"self run: #testForward"
| t |
cases := {
t := TransformationMorph new openCenteredInWorld } .
self shouldntTakeLong: [self assert: ( t forwardDirection = 0.0 ) ] .
^true
!
----- Method: RenderBugz>>testHeading (in category 'tests') -----
testHeading
"If the bug exist there will be an infinte recursion."
"self new testHeading"
"self run: #testHeading"
| t |
cases := {
t := TransformationMorph new openCenteredInWorld } .
self shouldntTakeLong: [ [self assert: ( t heading = 0.0 ) ]
ensure: [ t delete ] ] .
^true
!
----- Method: RenderBugz>>testSetForward (in category 'tests') -----
testSetForward
"If the bug exist there will be an infinte reccursion."
"self new testSetForward"
"self run: #testSetForward"
| t |
cases := {
t := TransformationMorph new openCenteredInWorld } .
self shouldntTakeLong: [ t forwardDirection: 180.0 .
self assert: ( t forwardDirection = 0.0 ) ] .
"and without a rendee it should not change things."
^true
!
----- Method: RenderBugz>>testSetHeading (in category 'tests') -----
testSetHeading
"If the bug exist there will be an infinte recursion."
"self new testSetHeading"
"self run: #testSetHeading"
| t |
cases := {
t := TransformationMorph new openCenteredInWorld } .
self shouldntTakeLong: [ t heading: 180 .
self assert: ( t heading = 0.0 ) .] .
^true
!
----- Method: RenderBugz>>testTestTime (in category 'tests') -----
testTestTime
"This is a control case. Should always pass.
If it does not something external to the tests are slowing things down
past the 1 millisecond mark."
"self new testTestTime"
"self run: #testTestTime"
| t |
cases := {
t := TransformationMorph new openCenteredInWorld } .
self shouldntTakeLong: [ self assert: ( true ) ] .
^true
!
MorphicUIBugTest subclass: #StickynessBugz
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
!StickynessBugz commentStamp: 'wiz 11/24/2006 00:24' prior: 0!
A StickynessBugz is for mantis #5500 rectangles and ellipses don't act sticky when rotated even when they are..
Instance Variables
!
----- Method: StickynessBugz>>testForTiltedStickyness (in category 'as yet unclassified') -----
testForTiltedStickyness
"self new testForTiltedStickyness"
"self run: #testForTiltedStickyness"
| m |
m := RectangleMorph new openCenteredInWorld .
cases := Array with: m . "save for tear down."
self assert: ( m topRendererOrSelf isSticky not ) .
m beSticky .
self assert: ( m topRendererOrSelf isSticky ) .
m addFlexShell .
cases := Array with: m topRendererOrSelf .
m topRendererOrSelf rotationDegrees: 45.0 .
self assert: ( m topRendererOrSelf isSticky ) .
m beUnsticky .
self assert: ( m topRendererOrSelf isSticky not ) .
m topRendererOrSelf delete.
^true
!
TestCase subclass: #ReleaseTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Release'!
----- Method: ReleaseTest>>testClassesSystemCategory (in category 'testing') -----
testClassesSystemCategory
"Find cases where classes have nil system categories.
This test will tell you the classes.
This is inspired by the proposed fix of a bug in release of 3.10.1
see Mantis #7070"
| rejectClasses |
rejectClasses :=
nil systemNavigation allClasses reject: [ :each |
each category notNil ] .
self assert: rejectClasses isEmpty .
!
----- Method: ReleaseTest>>testSystemCategoryClasses (in category 'testing') -----
testSystemCategoryClasses
"Find cases where system categories name absent classes.
This test will tell you the classes.
This is inspired by a bug in release of 3.10.1
see Mantis #7070"
| rejectCats rejectClasses |
rejectCats :=
SystemOrganization categories reject: [ :catName |
(SystemOrganization listAtCategoryNamed: catName)
allSatisfy: [ :className |
( Smalltalk includesKey: className ) ] ] .
"self assert: rejectCats isEmpty ."
rejectCats isEmpty ifTrue: [ ^ true ] .
rejectClasses :=
rejectCats collect: [ :each |
each ->
( (SystemOrganization listAtCategoryNamed: each)
reject: [ :eachOne |
( Smalltalk includesKey: eachOne ) ] ) ] .
self assert: rejectCats isEmpty .
!
----- Method: ReleaseTest>>testUndeclared (in category 'testing') -----
testUndeclared
Smalltalk cleanOutUndeclared.
self assert: Undeclared isEmpty
!
TestCase subclass: #StreamBugz
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: StreamBugz>>testReadWriteStreamNextNBug (in category 'as yet unclassified') -----
testReadWriteStreamNextNBug
| aStream |
aStream := ReadWriteStream on: String new.
aStream nextPutAll: 'Hello World'.
self shouldnt:[aStream next: 5] raise: Error.
!
TestCase subclass: #TestObjectsAsMethods
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-ObjectsAsMethods'!
----- Method: TestObjectsAsMethods>>testAddNumbers (in category 'as yet unclassified') -----
testAddNumbers
"self debug: #testAddNumbers"
"md: I had to comment out the error... did strange things"
self class addSelector: #add:with: withMethod: ObjectsAsMethodsExample new.
self assert: (self add: 3 with: 4) = 7.
"self assert: (self perform: #add:with: withArguments: #(3 4)) = 7. "
self class basicRemoveSelector: #add:with:.!
----- Method: TestObjectsAsMethods>>testAnswer42 (in category 'as yet unclassified') -----
testAnswer42
self class addSelector: #answer42 withMethod: ObjectsAsMethodsExample new.
self assert: self answer42 = 42.
self class basicRemoveSelector: #answer42.!
----- Method: TestObjectsAsMethods>>testDNU (in category 'as yet unclassified') -----
testDNU
self class addSelector: #answer42 withMethod: AbstractObjectsAsMethod new.
self should: [self answer42] raise: MessageNotUnderstood.
self class basicRemoveSelector: #answer42.!
TestCase subclass: #TestValueWithinFix
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: TestValueWithinFix>>testValueWithinNonLocalReturnFixReal (in category 'tests') -----
testValueWithinNonLocalReturnFixReal
"self run: #testValueWithinNonLocalReturnFixReal"
"The real test for the fix is just as obscure as the original problem"
| startTime deltaTime |
self valueWithinNonLocalReturn.
startTime := Time millisecondClockValue.
[[] repeat] valueWithin: 100 milliSeconds onTimeout:[
"This *should* timeout after 100 msecs but the pending process from
the previous invokation will signal timeout after 20 msecs already
which will in turn cut this invokation short."
deltaTime := Time millisecondClockValue - startTime.
self deny: deltaTime < 90.
].
!
----- Method: TestValueWithinFix>>testValueWithinNonLocalReturnFixSimply (in category 'tests') -----
testValueWithinNonLocalReturnFixSimply
"self run: #testValueWithinNonLocalReturnFixSimply"
"The simple version to test the fix"
self valueWithinNonLocalReturn.
self shouldnt:[(Delay forMilliseconds: 50) wait] raise: TimedOut.!
----- Method: TestValueWithinFix>>valueWithinNonLocalReturn (in category 'tests') -----
valueWithinNonLocalReturn
"Do a non-local return from a valueWithin: block"
[^self] valueWithin: 20 milliSeconds onTimeout:[].
!
TestCase subclass: #UnimplementedCallBugz
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
----- Method: UnimplementedCallBugz>>testPolyIntersect (in category 'as yet unclassified') -----
testPolyIntersect
"self run: #testPolyIntersect"
self shouldnt: [ PolygonMorph initializedInstance
intersects: ( Rectangle center: Display center
extent: 100 asPoint ) ]
raise: Error .!
Object subclass: #AbstractObjectsAsMethod
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-ObjectsAsMethods'!
----- Method: AbstractObjectsAsMethod>>flushCache (in category 'as yet unclassified') -----
flushCache!
----- Method: AbstractObjectsAsMethod>>methodClass: (in category 'as yet unclassified') -----
methodClass: aMethodClass!
----- Method: AbstractObjectsAsMethod>>selector: (in category 'as yet unclassified') -----
selector: aSymbol!
AbstractObjectsAsMethod subclass: #ObjectsAsMethodsExample
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-ObjectsAsMethods'!
----- Method: ObjectsAsMethodsExample>>add:with: (in category 'as yet unclassified') -----
add: a with: b
^a + b!
----- Method: ObjectsAsMethodsExample>>answer42 (in category 'as yet unclassified') -----
answer42
^42!
----- Method: ObjectsAsMethodsExample>>run:with:in: (in category 'as yet unclassified') -----
run: oldSelector with: arguments in: aReceiver
^self perform: oldSelector withArguments: arguments!
Object subclass: #BadEqualer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Utilities'!
!BadEqualer commentStamp: 'mjr 8/20/2003 13:28' prior: 0!
I am an object that doesn't always report #= correctly. Used for testing the EqualityTester.!
----- Method: BadEqualer>>= (in category 'comparing') -----
= other
self class = other class
ifFalse: [^ false].
^ 100 atRandom < 30 !
Object subclass: #BadHasher
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Utilities'!
!BadHasher commentStamp: 'mjr 8/20/2003 13:28' prior: 0!
I am an object that doesn't always hash correctly. I am used for testing the HashTester.!
----- Method: BadHasher>>hash (in category 'comparing') -----
hash
"answer with a different hash some of the time"
100 atRandom < 30
ifTrue: [^ 1].
^ 2!
Object subclass: #NameOfSubclass
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Bugs'!
Object subclass: #PrimCallControllerAbstract
instanceVariableNames: 'treatedMethods logStream changeStatusOfFailedCallsFlag'
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-PrimCallController'!
!PrimCallControllerAbstract commentStamp: 'sr 6/16/2004 09:42' prior: 0!
A PrimCallController (PCC) serves for switching external prim calls (primitiveExternalCall) on and off: this is an abstract class, instantiate one of the subclasses PCCByLiterals and PCCByCompilation.
External prim calls are used to access internal and external modules (plugins) as shown by
SmalltalkImage current listLoadedModules.
SmalltalkImage current listBuiltinModules.
Note: not loaded external modules (since they have not been called so far) are not shown by these methods.
Highlight: dis/en-abling prims by a PCC works for both internal and external modules!!
To help you choosing the right subclass, some properties are listed in the following table:
Functionality/Property | PCCByLiterals PCCByCompilation
------------------------------------------------------------------------------------------------------
testing plugins | suited not suited
permanent disabling of external prim calls | no yes
------------------------------------------------------------------------------------------------------
method changes visible in changeset | no yes
enabling survives snapshot/compilation | yes yes
disabling survives snapshot/compilation | no yes
speed disabling | fast medium
speed enabling | fast slow
CompiledMethod pointer valid after en/dis-abling | yes no
Important: Be careful with mixing the use of different PCCs!! PCCByLiterals does not see prims disabled by PCCByCompilation and vice versa. For playing around you should start with PCCByLiterals; use PCCByCompilation only, if you know what you are doing!!
In protocols 'ui controlling', 'ui logging' and 'ui querying' (please look into this class) are the most important user interface methods. Thereafter the methods in 'ui testing' could be of interest.
Useful expressions:
Controlling:
"Factorial example"
| pcc tDisabled tEnabled tEnabled2 |
pcc _ PCCByLiterals new logStream: Transcript. "logStream set here for more info"
pcc disableCallsIntoModule: 'LargeIntegers'.
tDisabled _ [1000 factorial] timeToRun.
pcc enableDisabled.
tEnabled _ [1000 factorial] timeToRun.
tEnabled2 _ [1000 factorial] timeToRun.
{tDisabled. tEnabled. tEnabled2}
Note: You shouldn't switch off module 'LargeIntegers' for a longer time, since this slows down your system.
Querying:
PCCByLiterals new methodsWithCall. "all calls"
PCCByLiterals new methodsWithCall: 'prim1'. "call in all modules or without module"
PCCByLiterals new methodsWithCallIntoModule: nil. "all calls without module"
PCCByLiterals new methodsWithCallIntoModule: 'LargeIntegers'. "all calls into module 'LargeIntegers'"
PCCByLiterals new
methodsWithCallIntoModule: 'LargeIntegers'
forClass: Integer. "all calls into module 'LargeIntegers' in class Integer"
PCCByLiterals new
methodsWithCallIntoModule: 'LargeIntegers'
forClasses: Integer withAllSubclasses. "all calls into module 'LargeIntegers' in class Integer withAllSubclasses"
| pcc | (pcc _ PCCByLiterals new) methodsWithCall
collect: [:mRef | {mRef. pcc extractCallModuleNames: mRef}].
Structure:
treatedMethods Dictionary of MethodReferences->#disabled/#enabled
-- contains changed methods and how they are changed last
logStream WriteStream -- shows info about changed methods ifNotNil
changeStatusOfFailedCalls Boolean -- if status of failed calls should be changed, default is false!
PrimCallControllerAbstract subclass: #PCCByCompilation
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-PrimCallController'!
!PCCByCompilation commentStamp: 'sr 6/16/2004 09:00' prior: 0!
This class is for switching external prim calls (primitiveExternalCall) on and off.
It is best suited for permanently switching plugin calls off while preserving the possibility to switch them on later. For plugin testing purposes you probably should use PCCByLiterals for temporarily switch on/off them instead.
It works on a source code basis by compilation:
Disabling works by putting an enabled prim call into a special comment followed by a recompile to transform it into a disabled one.
Enabling works by pulling the disabled prim call out of the special comment followed by a recompile to transform it into an enabled one.
As a consequence, enabling of prims only works with method sources containing the mentioned special comment, which normally has been generated by this tool for disabling the corresponding prim.
Please look into superclass PrimCallControllerAbstract for more info and the user interface.
Structure:
No instVars here: look into superclass.
Implementation note:
To harden it for sunit testing purposes some special accessing of the source code has been necessary: to avoid accessing different processes a sources file at once, followed by generating garbage, the process priority of actions leading to these accesses has been increased (sunit tests run in the background). A better solution would be to introduce a source file locking mechanism.!
----- Method: PCCByCompilation>>comment (in category 'string constants') -----
comment
^ '{prim disabled by ', self className, '} '!
----- Method: PCCByCompilation>>disabled2EnabledPrimMethodString: (in category 'private') -----
disabled2EnabledPrimMethodString: aSourceString
| start stop primString extract |
extract := self extractDisabledPrimStringFrom: aSourceString.
primString := extract at: 1.
start := extract at: 2.
stop := start + primString size - 1.
^ aSourceString
copyReplaceFrom: start
to: stop
with: (self disabled2EnabledPrimString: primString)!
----- Method: PCCByCompilation>>disabled2EnabledPrimString: (in category 'private') -----
disabled2EnabledPrimString: aDisabledPrimString
"remove comment quotes and comment after first comment quote"
| enabledPrimString |
enabledPrimString := aDisabledPrimString copyFrom: self comment size + 2 to: aDisabledPrimString size - 1.
^ enabledPrimString!
----- Method: PCCByCompilation>>disabledPrimStartString (in category 'string constants') -----
disabledPrimStartString
^ '"', self comment, self enabledPrimStartString!
----- Method: PCCByCompilation>>disabledPrimStopChar (in category 'string constants') -----
disabledPrimStopChar
"end of disabling comment"
^ $"!
----- Method: PCCByCompilation>>enabled2DisabledPrimMethodString: (in category 'private') -----
enabled2DisabledPrimMethodString: aSourceString
| start stop primString extract |
extract := self extractEnabledPrimStringFrom: aSourceString.
primString := extract at: 1.
start := extract at: 2.
stop := start + primString size - 1.
^ aSourceString
copyReplaceFrom: start
to: stop
with: (self enabled2DisabledPrimString: primString)!
----- Method: PCCByCompilation>>enabled2DisabledPrimString: (in category 'private') -----
enabled2DisabledPrimString: anEnabledPrimString
| disabledPrimString |
disabledPrimString := '"' , self comment , anEnabledPrimString , '"'.
^ disabledPrimString!
----- Method: PCCByCompilation>>enabledPrimStartString (in category 'string constants') -----
enabledPrimStartString
^ '<primitive:'!
----- Method: PCCByCompilation>>enabledPrimStopChar (in category 'string constants') -----
enabledPrimStopChar
^ $>!
----- Method: PCCByCompilation>>existsCallIn: (in category 'ui testing') -----
existsCallIn: aMethodRef
"Here existsCompiledCallIn: (see also comment there) is sufficient to
query for enabled and failed, but not for disabled prim calls: so check
for disabled ones in sources, too."
^ (self existsCompiledCallIn: aMethodRef)
or: [self existsDisabledCallIn: aMethodRef]!
----- Method: PCCByCompilation>>existsDisabledCallIn: (in category 'ui testing') -----
existsDisabledCallIn: aMethodRef
| src |
^ (self existsCompiledCallIn: aMethodRef) not
and: ["higher priority to avoid source file accessing errors"
[src := aMethodRef sourceString]
valueAt: self higherPriority.
self methodSourceContainsDisabledCall: src]!
----- Method: PCCByCompilation>>extractCallModuleNames: (in category 'ui querying') -----
extractCallModuleNames: aMethodRef
^ (self existsCompiledCallIn: aMethodRef)
ifTrue: [self extractCallModuleNamesFromLiterals: aMethodRef]
ifFalse: [| src |
"try source"
"higher priority to avoid source file accessing errors"
[src := aMethodRef sourceString]
valueAt: self higherPriority.
self extractCallNamesFromPrimString: ((self extractDisabledPrimStringFrom: src)
ifNil: ["no disabled prim string found"
^ nil]) first]!
----- Method: PCCByCompilation>>extractCallNamesFromPrimString: (in category 'private') -----
extractCallNamesFromPrimString: aString
"method works for both enabled and disabled prim strings"
"<primitive: 'doSomething' module:'ModuleFoo'"
| tokens |
tokens := aString findTokens: ''''.
^ (tokens at: 2) -> (tokens at: 4 ifAbsent: [nil])!
----- Method: PCCByCompilation>>extractDisabledPrimStringFrom: (in category 'private') -----
extractDisabledPrimStringFrom: aSourceString
| startString start stop |
startString := self disabledPrimStartString.
start := aSourceString findString: startString.
start = 0
ifTrue: [^ nil].
stop := aSourceString indexOf: self disabledPrimStopChar startingAt: start + startString size.
stop = 0
ifTrue: [^ nil].
^ {aSourceString copyFrom: start to: stop. start}!
----- Method: PCCByCompilation>>extractEnabledPrimStringFrom: (in category 'private') -----
extractEnabledPrimStringFrom: aSourceString
| startString start stop |
startString := self enabledPrimStartString.
start := aSourceString findString: startString.
start = 0
ifTrue: [^ nil].
stop := aSourceString indexOf: self enabledPrimStopChar startingAt: start + startString size.
stop = 0
ifTrue: [^ nil].
^ {aSourceString copyFrom: start to: stop. start}!
----- Method: PCCByCompilation>>higherPriority (in category 'private') -----
higherPriority
"this priority seems to be necessary to avoid source file accessing errors"
^ Processor userSchedulingPriority + 1!
----- Method: PCCByCompilation>>methodSourceContainsDisabledCall: (in category 'private') -----
methodSourceContainsDisabledCall: methodSource
^ (methodSource findString: self disabledPrimStartString)
~= 0!
----- Method: PCCByCompilation>>methodsWithCall (in category 'ui querying') -----
methodsWithCall
"Expensive!! For just querying the system unaffected by an instance of
this class use PCCByLiterals instead."
^ self methodsWithCompiledCall , self methodsWithDisabledCall!
----- Method: PCCByCompilation>>methodsWithDisabledCall (in category 'ui querying') -----
methodsWithDisabledCall
"Answer a SortedCollection of all the methods that contain, in source
code, the substring indicating a disabled prim."
"The alternative implementation
^ SystemNavigation new allMethodsWithSourceString: self disabledPrimStartString
matchCase: true
also searches in class comments."
| list classCount string |
string := self disabledPrimStartString.
list := Set new.
'Searching all method source code...'
displayProgressAt: Sensor cursorPoint
from: 0
to: Smalltalk classNames size * 2 "classes with their metaclasses"
during: [:bar |
classCount := 0.
SystemNavigation default
allBehaviorsDo: [:class |
bar value: (classCount := classCount + 1).
class
selectorsDo: [:sel |
| src |
"higher priority to avoid source file accessing
errors"
[src := class sourceCodeAt: sel]
valueAt: self higherPriority.
(src
findString: string
startingAt: 1
caseSensitive: true) > 0
ifTrue: [sel isDoIt ifFalse: [
list add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]].
^ list asSortedCollection!
----- Method: PCCByCompilation>>privateDisableCallIn: (in category 'private user interface') -----
privateDisableCallIn: aMethodRef
"Disables enabled or failed external prim call by recompiling method
with prim call commented out, will be called by superclass."
| src newMethodSource |
"higher priority to avoid source file accessing errors"
[src := aMethodRef sourceString]
valueAt: self higherPriority.
newMethodSource := self enabled2DisabledPrimMethodString: src.
"higher priority to avoid source file accessing errors"
[aMethodRef actualClass
compile: newMethodSource
classified: (aMethodRef actualClass whichCategoryIncludesSelector: aMethodRef methodSymbol)
notifying: nil]
valueAt: self higherPriority!
----- Method: PCCByCompilation>>privateEnableCallIn: (in category 'private user interface') -----
privateEnableCallIn: aMethodRef
"Enables disabled external prim call by recompiling method with prim
call taken from disabling comment, will be called by superclass."
| src newMethodSource |
"higher priority to avoid source file accessing errors"
[src := aMethodRef sourceString]
valueAt: self higherPriority.
newMethodSource := self disabled2EnabledPrimMethodString: src.
"higher priority to avoid source file accessing errors"
[aMethodRef actualClass
compile: newMethodSource
classified: (aMethodRef actualClass whichCategoryIncludesSelector: aMethodRef methodSymbol)
notifying: nil]
valueAt: self higherPriority!
PrimCallControllerAbstract subclass: #PCCByLiterals
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-PrimCallController'!
!PCCByLiterals commentStamp: 'sr 6/16/2004 09:14' prior: 0!
This class is for switching external prim calls (primitiveExternalCall) on and off.
It is best suited for plugin testing purposes with temporarily switching plugin calls off and on. For permanently switching plugin calls off while preserving the possibility to switch them on later, you should use PCCByCompilation instead.
It works by manipulating literals in the CompiledMethods:
Disabling works by changing the function index in the first literal of the CompiledMethod to a negative value (-2). This leads to a fast fail (value -2 is used for disabling to make a difference to the standard failed value of -1).
Enabling works by changing the function index in the first literal of the CompiledMethod to 0, followed by flushing the method cache. This enforces a fresh lookup.
Please look into superclass PrimCallControllerAbstract for more info and the user interface.
Structure:
No instVars here: look into superclass.!
----- Method: PCCByLiterals>>existsCallIn: (in category 'ui testing') -----
existsCallIn: aMethodRef
"Here >>existsCompiledCallIn: (see also comment there) is sufficient to
query for all enabled, failed and disabled prim calls; for the by
compiler version it is not sufficient for disabled ones."
^ self existsCompiledCallIn: aMethodRef!
----- Method: PCCByLiterals>>existsDisabledCallIn: (in category 'ui testing') -----
existsDisabledCallIn: aMethodRef
^ (self existsCompiledCallIn: aMethodRef)
and: [(aMethodRef compiledMethod literals first at: 4)
= -2]!
----- Method: PCCByLiterals>>extractCallModuleNames: (in category 'ui querying') -----
extractCallModuleNames: aMethodRef
^ (self existsCallIn: aMethodRef)
ifTrue: [self extractCallModuleNamesFromLiterals: aMethodRef]!
----- Method: PCCByLiterals>>methodsWithCall (in category 'ui querying') -----
methodsWithCall
^ self methodsWithCompiledCall!
----- Method: PCCByLiterals>>methodsWithDisabledCall (in category 'ui querying') -----
methodsWithDisabledCall
^ self methodsWithCompiledCall
select: [:mRef | (mRef compiledMethod literals first at: 4)
= -2]!
----- Method: PCCByLiterals>>privateDisableCallIn: (in category 'private user interface') -----
privateDisableCallIn: aMethodRef
"Disables enabled or failed external prim call by filling function ref
literal with special fail value, will be called by superclass."
aMethodRef compiledMethod literals first at: 4 put: -2!
----- Method: PCCByLiterals>>privateEnableCallIn: (in category 'private user interface') -----
privateEnableCallIn: aMethodRef
"Enables disabled external prim call."
self privateEnableViaLiteralIn: aMethodRef!
----- Method: PrimCallControllerAbstract>>blockSelectCallName: (in category 'private user interface') -----
blockSelectCallName: callName
^ [:mRef | (self extractCallModuleNames: mRef) key = callName]!
----- Method: PrimCallControllerAbstract>>blockSelectFailedCall (in category 'private user interface') -----
blockSelectFailedCall
"Precondition: mRef references compiledCall."
^ [:mRef | (mRef compiledMethod literals first at: 4)
= -1]!
----- Method: PrimCallControllerAbstract>>blockSelectModuleName: (in category 'private user interface') -----
blockSelectModuleName: moduleNameOrNil
^ [:mRef | (self extractCallModuleNames: mRef) value = moduleNameOrNil]!
----- Method: PrimCallControllerAbstract>>changeCallCompiledMethod:enable: (in category 'private user interface') -----
changeCallCompiledMethod: aCompiledMethod enable: enableFlag
"Enables disabled or disables enabled external prim call by recompiling
method with prim call taken from comment."
| methodRef |
methodRef := aCompiledMethod methodReference.
enableFlag
ifTrue: [self enableCallIn: methodRef]
ifFalse: [self disableCallIn: methodRef]!
----- Method: PrimCallControllerAbstract>>changeCallMethod:class:enable: (in category 'private user interface') -----
changeCallMethod: selector class: classOrSymbol enable: enableFlag
"Enables disabled or disables enabled external prim call by recompiling
method with prim call taken from comment."
| methodRef |
methodRef := MethodReference new
setStandardClass: (classOrSymbol isSymbol
ifTrue: [Smalltalk at: classOrSymbol]
ifFalse: [classOrSymbol])
methodSymbol: selector.
enableFlag
ifTrue: [self enableCallIn: methodRef]
ifFalse: [self disableCallIn: methodRef]!
----- Method: PrimCallControllerAbstract>>changeStatusOfFailedCalls (in category 'ui controlling') -----
changeStatusOfFailedCalls
"En/dis-able not only dis/en-abled calls, but also failed ones. Using this
feature can hide serious problems."
changeStatusOfFailedCallsFlag := true!
----- Method: PrimCallControllerAbstract>>changeStatusOfFailedCallsFlag (in category 'accessing') -----
changeStatusOfFailedCallsFlag
^changeStatusOfFailedCallsFlag!
----- Method: PrimCallControllerAbstract>>disableCallIn: (in category 'ui controlling') -----
disableCallIn: aMethodRef
"Disables enabled external prim call."
(self existsEnabledCallIn: aMethodRef)
ifFalse: [self changeStatusOfFailedCallsFlag
ifTrue: [(self existsFailedCallIn: aMethodRef)
ifFalse: [^ self error: 'no enabled or failed prim call found']]
ifFalse: [^ self error: 'no enabled prim call found']].
self privateDisableCallIn: aMethodRef.
self treatedMethods at: aMethodRef put: #disabled.
self logStream
ifNotNil: [self log: 'Call ' , (self extractCallModuleNames: aMethodRef) printString , ' in ' , aMethodRef actualClass name , '>>' , aMethodRef methodSymbol , ' disabled.']!
----- Method: PrimCallControllerAbstract>>disableCallInCompiledMethod: (in category 'ui controlling') -----
disableCallInCompiledMethod: aCompiledMethod
"Disables external prim call."
self changeCallCompiledMethod: aCompiledMethod enable: false!
----- Method: PrimCallControllerAbstract>>disableCallInMethod:class: (in category 'ui controlling') -----
disableCallInMethod: selector class: classOrSymbol
"Disables external prim call."
self
changeCallMethod: selector
class: classOrSymbol
enable: false!
----- Method: PrimCallControllerAbstract>>disableCallsIntoModule: (in category 'ui controlling') -----
disableCallsIntoModule: aModule
"Disables enabled external prim calls in aModule."
| methods |
methods := self methodsWithEnabledCallIntoModule: aModule.
self changeStatusOfFailedCallsFlag
ifTrue: [methods
addAll: (self methodsWithFailedCallIntoModule: aModule)].
methods isEmpty
ifTrue: [^ self error: 'no enabled '
, (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: [''])
, 'prim calls for module ' , aModule , ' found'].
methods
do: [:mRef | self disableCallIn: mRef]!
----- Method: PrimCallControllerAbstract>>disableCallsIntoModule:forClasses: (in category 'ui controlling') -----
disableCallsIntoModule: aModule forClasses: classes
"Disables enabled external prim calls in aModule for classes."
| methods |
methods := self methodsWithEnabledCallIntoModule: aModule forClasses: classes.
self changeStatusOfFailedCallsFlag
ifTrue: [methods
addAll: (self methodsWithFailedCallIntoModule: aModule forClasses: classes)].
methods isEmpty
ifTrue: [^ self error: 'no enabled '
, (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: [''])
, 'prim calls for module ' , aModule , ' in given classes found'].
methods
do: [:mRef | self disableCallIn: mRef]!
----- Method: PrimCallControllerAbstract>>disableEnabled (in category 'ui controlling') -----
disableEnabled
"Disables these external prim calls, which are formerly enabled by self."
self treatedMethods
keysAndValuesDo: [:mRef :status | status == #enabled
ifTrue: [self disableCallIn: mRef]]!
----- Method: PrimCallControllerAbstract>>enableCallIn: (in category 'ui controlling') -----
enableCallIn: aMethodRef
"Enables disabled external prim call."
(self existsDisabledCallIn: aMethodRef)
ifTrue: [self privateEnableCallIn: aMethodRef]
ifFalse: [self changeStatusOfFailedCallsFlag
ifTrue: [(self existsFailedCallIn: aMethodRef)
ifTrue: [self privateEnableViaLiteralIn: aMethodRef]
ifFalse: [^ self error: 'no disabled or failed prim call found']]
ifFalse: [^ self error: 'no disabled prim call found']].
self treatedMethods at: aMethodRef put: #enabled.
self logStream
ifNotNil: [self log: 'Call ' , (self extractCallModuleNames: aMethodRef) printString , ' in ' , aMethodRef actualClass name , '>>' , aMethodRef methodSymbol , ' enabled.']!
----- Method: PrimCallControllerAbstract>>enableCallInCompiledMethod: (in category 'ui controlling') -----
enableCallInCompiledMethod: aCompiledMethod
"Enables disabled external prim call."
self changeCallCompiledMethod: aCompiledMethod enable: true!
----- Method: PrimCallControllerAbstract>>enableCallInMethod:class: (in category 'ui controlling') -----
enableCallInMethod: selector class: classOrSymbol
"Enables disabled external prim call."
self
changeCallMethod: selector
class: classOrSymbol
enable: true!
----- Method: PrimCallControllerAbstract>>enableCallsIntoModule: (in category 'ui controlling') -----
enableCallsIntoModule: aModule
"Enables disabled external prim calls in aModule."
| methods |
methods := self methodsWithDisabledCallIntoModule: aModule.
self changeStatusOfFailedCallsFlag
ifTrue: [methods
addAll: (self methodsWithFailedCallIntoModule: aModule)].
methods isEmpty
ifTrue: [^ self error: 'no disabled '
, (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: [''])
, 'prim calls for module ' , aModule , ' found'].
methods
do: [:mRef | self enableCallIn: mRef]!
----- Method: PrimCallControllerAbstract>>enableCallsIntoModule:forClasses: (in category 'ui controlling') -----
enableCallsIntoModule: aModule forClasses: classes
"Enables disabled external prim calls in aModule for classes."
| methods |
methods := self methodsWithDisabledCallIntoModule: aModule forClasses: classes.
self changeStatusOfFailedCallsFlag
ifTrue: [methods
addAll: (self methodsWithFailedCallIntoModule: aModule forClasses: classes)].
methods isEmpty
ifTrue: [^ self error: 'no disabled '
, (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: [''])
, 'prim calls for module ' , aModule , ' in given classes found'].
methods
do: [:mRef | self enableCallIn: mRef]!
----- Method: PrimCallControllerAbstract>>enableDisabled (in category 'ui controlling') -----
enableDisabled
"Enables these external prim calls, which are formerly disabled by self."
self treatedMethods
keysAndValuesDo: [:mRef :status | status == #disabled
ifTrue: [self enableCallIn: mRef]]!
----- Method: PrimCallControllerAbstract>>existsCallIn: (in category 'ui testing') -----
existsCallIn: aMethodRef
self subclassResponsibility!
----- Method: PrimCallControllerAbstract>>existsCompiledCallIn: (in category 'private user interface') -----
existsCompiledCallIn: aMethodRef
"This just means that there is a compiled in external prim call: from the
by compiler subclass point of view disabled prim calls not visible by
this method are also prim calls."
^ aMethodRef compiledMethod primitive = 117!
----- Method: PrimCallControllerAbstract>>existsDisabledCallIn: (in category 'ui testing') -----
existsDisabledCallIn: aMethodRef
self subclassResponsibility!
----- Method: PrimCallControllerAbstract>>existsEnabledCallIn: (in category 'ui testing') -----
existsEnabledCallIn: aMethodRef
^ (self existsCompiledCallIn: aMethodRef)
and: [(aMethodRef compiledMethod literals first at: 4)
>= 0]!
----- Method: PrimCallControllerAbstract>>existsFailedCallIn: (in category 'ui testing') -----
existsFailedCallIn: aMethodRef
^ (self existsCompiledCallIn: aMethodRef)
and: [self blockSelectFailedCall value: aMethodRef]!
----- Method: PrimCallControllerAbstract>>extractCallModuleNames: (in category 'ui querying') -----
extractCallModuleNames: aMethodRef
"Returns prim call and module name as call->module Association."
self subclassResponsibility!
----- Method: PrimCallControllerAbstract>>extractCallModuleNamesFromLiterals: (in category 'private') -----
extractCallModuleNamesFromLiterals: aMethodRef
| firstLiteral |
firstLiteral := aMethodRef compiledMethod literals first.
^ (firstLiteral at: 2)
-> (firstLiteral at: 1)!
----- Method: PrimCallControllerAbstract>>initialize (in category 'initialize-release') -----
initialize
treatedMethods := Dictionary new.
" logStream := Transcript."
changeStatusOfFailedCallsFlag := false!
----- Method: PrimCallControllerAbstract>>log: (in category 'logging') -----
log: aString
self logStream
ifNotNil: [self logStream cr; show: '[' , self className , '] ' , aString]!
----- Method: PrimCallControllerAbstract>>logStream (in category 'accessing') -----
logStream
^logStream!
----- Method: PrimCallControllerAbstract>>logStream: (in category 'ui logging') -----
logStream: aStreamOrNil
"If aStreamOrNil is notNil, there will be shown dis/en-abling prim call
info; nil means no logging."
logStream := aStreamOrNil!
----- Method: PrimCallControllerAbstract>>methodsWithCall (in category 'ui querying') -----
methodsWithCall
"Returns all methods containing external prim calls."
self subclassResponsibility!
----- Method: PrimCallControllerAbstract>>methodsWithCall: (in category 'ui querying') -----
methodsWithCall: primName
^ self methodsWithCall: primName enabled: nil!
----- Method: PrimCallControllerAbstract>>methodsWithCall:enabled: (in category 'private user interface') -----
methodsWithCall: callName enabled: enabledFlag
^ (self methodsWithCallEnabled: enabledFlag)
select: (self blockSelectCallName: callName)!
----- Method: PrimCallControllerAbstract>>methodsWithCall:intoModule: (in category 'ui querying') -----
methodsWithCall: primName intoModule: moduleNameOrNil
^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: nil!
----- Method: PrimCallControllerAbstract>>methodsWithCall:intoModule:enabled: (in category 'private user interface') -----
methodsWithCall: callName intoModule: moduleNameOrNil enabled: enabledFlag
^ ((self methodsWithCallEnabled: enabledFlag)
select: (self blockSelectCallName: callName))
select: (self blockSelectModuleName: moduleNameOrNil)!
----- Method: PrimCallControllerAbstract>>methodsWithCallEnabled: (in category 'private user interface') -----
methodsWithCallEnabled: enabledFlag
^ enabledFlag
ifNil: [self methodsWithCall]
ifNotNil: [enabledFlag
ifTrue: [self methodsWithEnabledCall]
ifFalse: [self methodsWithDisabledCall]]!
----- Method: PrimCallControllerAbstract>>methodsWithCallForClass:enabled: (in category 'private user interface') -----
methodsWithCallForClass: class enabled: enabledFlag
^ class selectors
collect: [:sel | MethodReference new setStandardClass: class methodSymbol: sel]
thenSelect: (enabledFlag
ifNil: [[:mRef | self existsCallIn: mRef]]
ifNotNil: [enabledFlag
ifTrue: [[:mRef | self existsEnabledCallIn: mRef]]
ifFalse: [[:mRef | self existsDisabledCallIn: mRef]]])!
----- Method: PrimCallControllerAbstract>>methodsWithCallForClasses:enabled: (in category 'private user interface') -----
methodsWithCallForClasses: classes enabled: enabledFlag
| result |
result := OrderedCollection new.
classes
do: [:class | result
addAll: (self methodsWithCallForClass: class enabled: enabledFlag)].
^ result!
----- Method: PrimCallControllerAbstract>>methodsWithCallIntoModule: (in category 'ui querying') -----
methodsWithCallIntoModule: moduleNameOrNil
^ self methodsWithCallIntoModule: moduleNameOrNil enabled: nil!
----- Method: PrimCallControllerAbstract>>methodsWithCallIntoModule:enabled: (in category 'private user interface') -----
methodsWithCallIntoModule: moduleNameOrNil enabled: enabledFlag
^ (self methodsWithCallEnabled: enabledFlag)
select: (self blockSelectModuleName: moduleNameOrNil)!
----- Method: PrimCallControllerAbstract>>methodsWithCallIntoModule:forClass: (in category 'ui querying') -----
methodsWithCallIntoModule: moduleNameOrNil forClass: class
^ self methodsWithCallIntoModule: moduleNameOrNil forClasses: {class}!
----- Method: PrimCallControllerAbstract>>methodsWithCallIntoModule:forClasses: (in category 'ui querying') -----
methodsWithCallIntoModule: moduleNameOrNil forClasses: classes
^ self
methodsWithCallIntoModule: moduleNameOrNil
forClasses: classes
enabled: nil!
----- Method: PrimCallControllerAbstract>>methodsWithCallIntoModule:forClasses:enabled: (in category 'private user interface') -----
methodsWithCallIntoModule: moduleNameOrNil forClasses: classes enabled: enabledFlag
^ (self methodsWithCallForClasses: classes enabled: enabledFlag)
select: (self blockSelectModuleName: moduleNameOrNil)!
----- Method: PrimCallControllerAbstract>>methodsWithCompiledCall (in category 'ui querying') -----
methodsWithCompiledCall
"Returns all methods containing compiled in external prim calls.
If the by compilation subclass has disabled some, this method does *not*
return all methods containing prim calls (use >>methodsWithCall in this
case). "
^ (SystemNavigation new
allMethodsSelect: [:method | method primitive = 117])
reject: [:method | method actualClass == ProtoObject]!
----- Method: PrimCallControllerAbstract>>methodsWithDisabledCall (in category 'ui querying') -----
methodsWithDisabledCall
"Returns all methods containing disabled external prim calls."
self subclassResponsibility!
----- Method: PrimCallControllerAbstract>>methodsWithDisabledCall: (in category 'ui querying') -----
methodsWithDisabledCall: primName
^ self methodsWithCall: primName enabled: false!
----- Method: PrimCallControllerAbstract>>methodsWithDisabledCall:intoModule: (in category 'ui querying') -----
methodsWithDisabledCall: primName intoModule: moduleNameOrNil
^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: false!
----- Method: PrimCallControllerAbstract>>methodsWithDisabledCallIntoModule: (in category 'ui querying') -----
methodsWithDisabledCallIntoModule: moduleNameOrNil
^ self methodsWithCallIntoModule: moduleNameOrNil enabled: false!
----- Method: PrimCallControllerAbstract>>methodsWithDisabledCallIntoModule:forClass: (in category 'ui querying') -----
methodsWithDisabledCallIntoModule: moduleNameOrNil forClass: class
^ self methodsWithDisabledCallIntoModule: moduleNameOrNil forClasses: {class}!
----- Method: PrimCallControllerAbstract>>methodsWithDisabledCallIntoModule:forClasses: (in category 'ui querying') -----
methodsWithDisabledCallIntoModule: moduleNameOrNil forClasses: classes
^ self
methodsWithCallIntoModule: moduleNameOrNil
forClasses: classes
enabled: false!
----- Method: PrimCallControllerAbstract>>methodsWithEnabledCall (in category 'ui querying') -----
methodsWithEnabledCall
"Returns all methods containing enabled external prim calls."
^ self methodsWithCompiledCall
select: [:mRef | (mRef compiledMethod literals first at: 4)
>= 0]!
----- Method: PrimCallControllerAbstract>>methodsWithEnabledCall: (in category 'ui querying') -----
methodsWithEnabledCall: primName
^ self methodsWithCall: primName enabled: true!
----- Method: PrimCallControllerAbstract>>methodsWithEnabledCall:intoModule: (in category 'ui querying') -----
methodsWithEnabledCall: primName intoModule: moduleNameOrNil
^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: true!
----- Method: PrimCallControllerAbstract>>methodsWithEnabledCallIntoModule: (in category 'ui querying') -----
methodsWithEnabledCallIntoModule: moduleNameOrNil
^ self methodsWithCallIntoModule: moduleNameOrNil enabled: true!
----- Method: PrimCallControllerAbstract>>methodsWithEnabledCallIntoModule:forClass: (in category 'ui querying') -----
methodsWithEnabledCallIntoModule: moduleNameOrNil forClass: class
^ self methodsWithEnabledCallIntoModule: moduleNameOrNil forClasses: {class}!
----- Method: PrimCallControllerAbstract>>methodsWithEnabledCallIntoModule:forClasses: (in category 'ui querying') -----
methodsWithEnabledCallIntoModule: moduleNameOrNil forClasses: classes
^ self
methodsWithCallIntoModule: moduleNameOrNil
forClasses: classes
enabled: true!
----- Method: PrimCallControllerAbstract>>methodsWithFailedCall (in category 'ui querying') -----
methodsWithFailedCall
"Returns all methods containing failed external prim calls."
^ self methodsWithCompiledCall select: self blockSelectFailedCall!
----- Method: PrimCallControllerAbstract>>methodsWithFailedCallForClass: (in category 'ui querying') -----
methodsWithFailedCallForClass: class
^ class selectors
collect: [:sel | MethodReference new setStandardClass: class methodSymbol: sel]
thenSelect: [:mRef | self existsFailedCallIn: mRef]!
----- Method: PrimCallControllerAbstract>>methodsWithFailedCallForClasses: (in category 'ui querying') -----
methodsWithFailedCallForClasses: classes
| result |
result := OrderedCollection new.
classes
do: [:class | result
addAll: (self methodsWithFailedCallForClass: class)].
^ result!
----- Method: PrimCallControllerAbstract>>methodsWithFailedCallIntoModule: (in category 'ui querying') -----
methodsWithFailedCallIntoModule: moduleNameOrNil
^ self methodsWithFailedCall
select: (self blockSelectModuleName: moduleNameOrNil)!
----- Method: PrimCallControllerAbstract>>methodsWithFailedCallIntoModule:forClass: (in category 'ui querying') -----
methodsWithFailedCallIntoModule: moduleNameOrNil forClass: class
^ self methodsWithFailedCallIntoModule: moduleNameOrNil forClasses: {class}!
----- Method: PrimCallControllerAbstract>>methodsWithFailedCallIntoModule:forClasses: (in category 'ui querying') -----
methodsWithFailedCallIntoModule: moduleNameOrNil forClasses: classes
^ (self methodsWithFailedCallForClasses: classes)
select: (self blockSelectModuleName: moduleNameOrNil)!
----- Method: PrimCallControllerAbstract>>preserveStatusOfFailedCalls (in category 'ui controlling') -----
preserveStatusOfFailedCalls
"Do not en/dis-able failed calls (default)."
changeStatusOfFailedCallsFlag := false!
----- Method: PrimCallControllerAbstract>>privateDisableCallIn: (in category 'private user interface') -----
privateDisableCallIn: aMethodRefWithExternalCall
"Disables enabled or failed external prim call."
self subclassResponsibility!
----- Method: PrimCallControllerAbstract>>privateEnableCallIn: (in category 'private user interface') -----
privateEnableCallIn: aMethodRefWithExternalCall
"Enables disabled external prim call."
self subclassResponsibility!
----- Method: PrimCallControllerAbstract>>privateEnableViaLiteralIn: (in category 'private user interface') -----
privateEnableViaLiteralIn: aMethodRef
"Enables external prim call by filling function ref literal with zero for
'non called'."
aMethodRef compiledMethod literals first at: 4 put: 0.
Object flushCache!
----- Method: PrimCallControllerAbstract>>switchStored (in category 'ui controlling') -----
switchStored
"Disables enabled and enables disabled (see corresponding method
comments). "
self treatedMethods
keysAndValuesDo: [:mRef :status | status == #enabled
ifTrue: [self disableCallIn: mRef]
ifFalse: [self enableCallIn: mRef]]!
----- Method: PrimCallControllerAbstract>>treatedMethods (in category 'accessing') -----
treatedMethods
^treatedMethods!
Object subclass: #PrototypeTester
instanceVariableNames: 'prototype'
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Utilities'!
!PrototypeTester commentStamp: 'mjr 8/20/2003 13:09' prior: 0!
I am a simple holder of a prototype object and hand out copies when requested.!
PrototypeTester subclass: #EqualityTester
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Utilities'!
!EqualityTester commentStamp: 'mjr 8/20/2003 13:04' prior: 0!
I provide a simple way to test the equality properties of any object.!
----- Method: EqualityTester>>resultFor: (in category 'as yet unclassified') -----
resultFor: runs
"Test that equality is the same over runs and answer the result"
1
to: runs
do: [:i | self prototype = self prototype
ifFalse: [^ false]].
^ true!
PrototypeTester subclass: #HashTester
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Tests-Utilities'!
!HashTester commentStamp: 'mjr 8/20/2003 12:48' prior: 0!
I provide a simple way to test the hash properties of any object.
I am given an object that should be tested and I treat it like a prototype. I take a copy of it when I am given it so that it can't change whilst I am holding on to it. I can then test that multiple copies of this object all hash to the same value.!
----- Method: HashTester>>resultFor: (in category 'as yet unclassified') -----
resultFor: runs
"Test that the hash is the same over runs and answer the result"
| hash |
hash := self prototype hash.
1
to: runs
do: [:i | hash = self prototype hash
ifFalse: [^ false]].
^ true !
----- Method: PrototypeTester class>>defaultRuns (in category 'as yet unclassified') -----
defaultRuns
"the default number of times to test"
^ 50!
----- Method: PrototypeTester class>>with: (in category 'as yet unclassified') -----
with: aPrototype
^self new prototype:aPrototype!
----- Method: PrototypeTester>>prototype (in category 'as yet unclassified') -----
prototype
"Get a prototype"
^ prototype copy !
----- Method: PrototypeTester>>prototype: (in category 'as yet unclassified') -----
prototype: aPrototype
"Set my prototype"
prototype := aPrototype copy !
----- Method: PrototypeTester>>result (in category 'as yet unclassified') -----
result
"Perform the test the default number of times"
^ self resultFor: self class defaultRuns !
More information about the Packages
mailing list