Packages February 2023

packages@lists.squeakfoundation.org

1 participants
79 discussions

The Treated Inbox: Kernel-jar.1480.mcz
by commits＠source.squeak.org 16 Feb '23

16 Feb '23

Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox: http://source.squeak.org/treated/Kernel-jar.1480.mcz ==================== Summary ==================== Name: Kernel-jar.1480 Author: jar Time: 9 June 2022, 7:53:32.496688 pm UUID: 1504c554-482d-a94e-b292-ab2c46c6d865 Ancestors: Kernel-mt.1479 Fix a bug: when debugging things like this: [^2] ensure: [Transcript cr; show: 'done'] if we step into the protected block [^2] and then step over ^2, we incorrectly get a BlockCannotReturn error. Improved comment; please remove Kernel-jar.1415 from the Inbox. This is an alternative to my older version in Kernel-jar.1421; the solution remains the same but it attempts to present a cleaner code (addressing Christoph's objection in [2] and [3]) and improves the comment. The bug is described in detail in Kernel-nice.1407 and discussed in [1] and most recently in [2] and [3]: [1] http://forum.world.st/stepping-over-non-local-return-in-a-protected-block-t… [2] http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-August/216214.h… [3] http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-November/216971… =============== Diff against Kernel-mt.1479 =============== Item was changed: ----- Method: Context>>resume:through: (in category 'controlling') ----- resume: value through: firstUnwindCtxt "Unwind thisContext to self and resume with value as result of last send. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext." | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: value to: self]. + ctxt := firstUnwindCtxt value. "evaluate in case firstUnwindCtxt is a block (see comment in #return:from:)" - ctxt := firstUnwindCtxt. [ctxt isNil] whileFalse: [(ctxt tempAt: 2) ifNil: [ctxt tempAt: 2 put: true. unwindBlock := ctxt tempAt: 1. thisContext terminateTo: ctxt. unwindBlock value]. ctxt := ctxt findNextUnwindContextUpTo: self]. thisContext terminateTo: self. ^value ! Item was changed: ----- Method: Context>>return:from: (in category 'instruction decoding') ----- return: value from: aSender "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" + "Note: when debugging things like this: + [^2] ensure: [Transcript cr; show: 'done'] + if we step into the protected block [^2] and then step over ^2, we incorrectly get a BlockCannotReturn. + The root cause of this is that during simulation #runUntilErrorOrReturnFrom: inserts a new unwind + context between the top of the stack and 'newTop' so we can't supply the next unwind context to + #aboutToReturn:through: now but must postpone the search for the next unwind context until the + right moment, i.e. until #resume:through: gets executed using the supplied next unwind context. + One solution is to send a block + [thisContext findNextUnwindContextUpTo: newTop] + that will execute the search in #resume:through: instead of sending the next unwind context. + Indeed we must modify #resume:through: to evaluate its second argument in case it's this block. + + The objection against such a solution is we are creating a dependency between these two methods. + See more in http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-August/216214.h…" + | newTop | aSender isDead ifTrue: [^self send: #cannotReturn: to: self with: {value}]. newTop := aSender sender. (self findNextUnwindContextUpTo: newTop) ifNotNil: + [^self send: #aboutToReturn:through: to: self with: {value. [thisContext findNextUnwindContextUpTo: newTop]}]. - [:unwindProtectCtxt| - ^self send: #aboutToReturn:through: to: self with: {value. unwindProtectCtxt}]. self releaseTo: newTop. newTop ifNotNil: [newTop push: value]. ^newTop!

1 0

The Treated Inbox: Kernel-jar.1445.mcz
by commits＠source.squeak.org 16 Feb '23

16 Feb '23

Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox: http://source.squeak.org/treated/Kernel-jar.1445.mcz ==================== Summary ==================== Name: Kernel-jar.1445 Author: jar Time: 21 January 2022, 5:55:35.796552 pm UUID: 7b6b74f1-9bcf-6c43-b4f2-f6fd072f93cf Ancestors: Kernel-mt.1441 A liitle cleanup: Context >> restart can be simplified using resumeEvaluating: introduced by Nicolas in April 2021. The new restart reads: restart ^self resumeEvaluating: [self privRefresh] =============== Diff against Kernel-mt.1441 =============== Item was changed: ----- Method: Context>>restart (in category 'controlling') ----- restart "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" + ^self resumeEvaluating: [self privRefresh]! - | ctxt unwindBlock | - self isDead ifTrue: [self cannotReturn: nil to: self]. - self privRefresh. - ctxt := thisContext. - [ ctxt := ctxt findNextUnwindContextUpTo: self. - ctxt isNil - ] whileFalse: [ - (ctxt tempAt: 2) ifNil:[ - ctxt tempAt: 2 put: true. - unwindBlock := ctxt tempAt: 1. - thisContext terminateTo: ctxt. - unwindBlock value]. - ]. - thisContext terminateTo: self. - self jump. - !

1 0

The Treated Inbox: Kernel-jar.1499.mcz
by commits＠source.squeak.org 16 Feb '23

16 Feb '23

Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox: http://source.squeak.org/treated/Kernel-jar.1499.mcz ==================== Summary ==================== Name: Kernel-jar.1499 Author: jar Time: 2 February 2023, 3:02:46.508164 pm UUID: e69bd0f7-980e-2f42-90db-171af597b735 Ancestors: Kernel-tpr.1497 Remove code duplicity in Context>>#restart, #resume:through: and #resumeEvaluating: while keeping the current unwind semantics. =============== Diff against Kernel-tpr.1497 =============== Item was changed: ----- Method: Context>>restart (in category 'controlling') ----- restart + "Unwind thisContext to self and resume from beginning. + Execute unwind blocks when unwinding. + ASSUMES self is a sender of thisContext" - "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" + ^self resumeEvaluating: [self privRefresh]! - | ctxt unwindBlock | - self isDead ifTrue: [self cannotReturn: nil to: self]. - self privRefresh. - ctxt := thisContext. - [ ctxt := ctxt findNextUnwindContextUpTo: self. - ctxt isNil - ] whileFalse: [ - (ctxt tempAt: 2) ifNil:[ - ctxt tempAt: 2 put: true. - unwindBlock := ctxt tempAt: 1. - thisContext terminateTo: ctxt. - unwindBlock value]. - ]. - thisContext terminateTo: self. - self jump. - ! Item was changed: ----- Method: Context>>resume:through: (in category 'controlling') ----- resume: value through: firstUnwindCtxt "Unwind thisContext to self and resume with value as result of last send. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext." + | ctxt | - | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: value to: self]. ctxt := firstUnwindCtxt. + ctxt unwindTo: self safely: false. - [ctxt isNil] whileFalse: - [(ctxt tempAt: 2) ifNil: - [ctxt tempAt: 2 put: true. - unwindBlock := ctxt tempAt: 1. - thisContext terminateTo: ctxt. - unwindBlock value]. - ctxt := ctxt findNextUnwindContextUpTo: self]. thisContext terminateTo: self. ^value ! Item was changed: ----- Method: Context>>resumeEvaluating: (in category 'controlling') ----- resumeEvaluating: aBlock "Unwind thisContext to self and resume with value as result of last send. + Execute unwind blocks when unwinding. + ASSUMES self is a sender of thisContext" - Execute unwind blocks when unwinding. - ASSUMES self is a sender of thisContext" + | ctxt | - | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: aBlock value to: self]. ctxt := thisContext. + ctxt unwindTo: self safely: false. - [ ctxt := ctxt findNextUnwindContextUpTo: self. - ctxt isNil - ] whileFalse: [ - (ctxt tempAt: 2) ifNil:[ - "(tempAt: 2) refers to complete temporary in ensure: and ifCurtailed: - or any other method marked with <primitive: 198>" - ctxt tempAt: 2 put: true. - unwindBlock := ctxt tempAt: 1. - thisContext terminateTo: ctxt. - unwindBlock value]. - ]. thisContext terminateTo: self. ^ aBlock value !

1 0

The Treated Inbox: Kernel-jar.1498.mcz
by commits＠source.squeak.org 16 Feb '23

16 Feb '23

Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox: http://source.squeak.org/treated/Kernel-jar.1498.mcz ==================== Summary ==================== Name: Kernel-jar.1498 Author: jar Time: 30 January 2023, 5:33:16.106677 pm UUID: f76b2d65-c441-1a44-a925-e7c1e0d45cbb Ancestors: Kernel-tpr.1497 fix four currently failing tests; improve unwind's behavior in #critical sections and #terminate resiliency in case of accidental preemption; fix a bug in #unwindAndStop:, add more tests and comments complemented by KernelTests-jar.443 please kindly remove KernelTests-jar.437 and Kernel-jar.1487 from the Inbox. =============== Diff against Kernel-tpr.1497 =============== Item was added: + ----- Method: Context>>unwindAndStop: (in category 'private') ----- + unwindAndStop: aProcess + "I'm a helper method to #terminate; I create and answer + a helper stack for a terminating process to unwind itself from. + Note: push a fake return value to create a proper top context." + + ^(self class contextEnsure: [self unwindTo: nil]) + privSender: [aProcess suspend] asContext; + push: nil + ! Item was changed: ----- Method: Process>>suspendAndReleaseCriticalSection (in category 'private') ----- suspendAndReleaseCriticalSection "Figure out if we are terminating a process that is in the ensure: block of a critical section. If it hasn't made progress but is beyond the wait (which we can tell by the oldList being + one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex), then the ensure: - one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex, et al), then the ensure: block needs to be run." | oldList selectorJustSent | + "Suspend and unblock the receiver from a condition variable using the suspend primitive #88. - "Suspend and unblock the receiver from a condition variable using suspend primitive #88. It answers the list the receiver was on before the suspension." oldList := self suspendAndUnblock. + suspendedContext ifNotNil: [:context | + (context method pragmaAt: #criticalSection) ifNil: [^self]. + "If still blocked at the condition variable of a critical section, skip the rest of the current context." + (oldList isNil or: [oldList class == LinkedList]) ifFalse: [ + suspendedContext := context pc: context endPC. + ^self]. + "Now we are somewhere beyond the wait/lock primitive, figure out where, and if necessary, + step into the ensure block to allow the unwind block to be run." + selectorJustSent := context selectorJustSentOrSelf. - (oldList isNil or: [oldList class == LinkedList]) ifFalse: [^self]. + "If still haven't made progress beyond the wait then the ensure block has not been activated, + so step into it." + selectorJustSent == #wait ifTrue: [ + suspendedContext := context stepToCallee]. - ((suspendedContext ifNil: [^self]) method pragmaAt: #criticalSection) ifNil: [^self]. - selectorJustSent := suspendedContext selectorJustSentOrSelf. + "If still haven't made progress beyond the lock primitive and the lock primitive just acquired ownership + (indicated by it answering false) then the ensure block has not been activated, so step into it." + (selectorJustSent == #primitiveEnterCriticalSection + or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue: [ + (context stackPtr > 0 and: [context top == false]) ifTrue: [ + suspendedContext := context stepToCallee]]]! - "If still at the wait the ensure: block has not been activated, so signal to restore." - selectorJustSent == #wait ifTrue: - [suspendedContext receiver signal]. - - "If still at the lock primitive and the lock primitive just acquired ownership (indicated by it answering false) - then the ensure block has not been activated, so explicitly primitiveExitCriticalSection to unlock." - (selectorJustSent == #primitiveEnterCriticalSection - or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue: - [(suspendedContext stackPtr > 0 - and: [suspendedContext top == false]) ifTrue: - [suspendedContext receiver primitiveExitCriticalSection]]! Item was changed: ----- Method: Process>>terminate (in category 'changing process state') ----- + terminate + "Stop the process that the receiver represents forever. Allow all pending unwind + blocks to run before terminating; if they are currently in progress, let them finish." - terminate - "Stop the process that the receiver represents forever. - Unwind to execute pending #ensure:/#ifCurtailed: blocks before terminating; - allow all unwind blocks to run; if they are currently in progress, let them finish." + "Note: This is the kind of behavior we expect when terminating a healthy process. - "This is the kind of behavior we expect when terminating a healthy process. See further comments in #terminateAggressively and #destroy methods dealing with process termination when closing the debugger or after a catastrophic failure. If terminating the active process, create a new stack and run unwinds from there. If terminating a suspended process (including runnable and blocked), always + suspend the terminating process first so it doesn't accidentally get woken up, + and nil the suspended context to prevent accidental resumption or termination + while manipulating the suspended context. + - suspend the terminating process first so it doesn't accidentally get woken up. Equally important is the side effect of the suspension: In 2022 a new suspend semantics has been introduced: the revised #suspend backs up a process waiting on a conditional variable to the send that invoked the wait state, while the previous #suspend simply removed the process from the conditional variable's list it was previously waiting on; see #suspend and #suspendAndUnblock comments. + + If the process is blocked, waiting to access the #critical: section, release it properly. - - If the process is in the middle of a #critical: critical section, release it properly. To allow a suspended process to unwind itself, create a new stack for the process being terminated and resume the suspended process to complete its termination + from the new, parallel stack. Use a semaphore to make the process that invoked - from the new parallel stack. Use a semaphore to make the process that invoked the termination wait for self's completion. Execute the termination in the ensure argument block to ensure it completes even if the terminator process itself gets terminated before it's finished; see testTerminateInTerminate and others." - | context | self isActiveProcess ifTrue: [ + ^(thisContext unwindAndStop: self) jump]. - context := thisContext. - ^[[] ensure: [context unwindTo: nil]. self suspend] asContext jump]. + [] ensure: [ - [] ensure: [ | terminator | self suspendAndReleaseCriticalSection. + suspendedContext ifNotNil: [:context | | terminator | + suspendedContext := nil. + terminator := Semaphore new. + context bottomContext insertSender: (Context contextEnsure: [terminator signal]). + self priority: Processor activePriority; + suspendedContext: (context unwindAndStop: self); + resume. + terminator wait]]! - context := suspendedContext ifNil: [^self]. - terminator := Semaphore new. - context bottomContext insertSender: (Context contextEnsure: [terminator signal]). - self suspendedContext: [[] ensure: [context unwindTo: nil]. self suspend] asContext; - priority: Processor activePriority; - resume. - terminator wait]!

1 0

The Trunk: Tools-mt.1189.mcz
by commits＠source.squeak.org 15 Feb '23

15 Feb '23

Marcel Taeumel uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-mt.1189.mcz ==================== Summary ==================== Name: Tools-mt.1189 Author: mt Time: 15 February 2023, 4:29:53.702748 pm UUID: 9f8065c3-3843-aa49-b942-6e2dd5520b60 Ancestors: Tools-mt.1188 Avoid hiding errors in MessageTally code. Our current debugger is able to handle this case correctly. =============== Diff against Tools-mt.1188 =============== Item was changed: ----- Method: Debugger>>initialize (in category 'initialize-release') ----- initialize super initialize. - Smalltalk at: #MessageTally ifPresentAndInMemory: [ :tally | - tally terminateTimerProcess]. - selectingPC := true. contextStackIndex := 0. "The default termination procedure is aggressive to ignore currently running, and thus erroneous, ensure-blocks in the debugged process. The preference can change that." terminateProcessSelector := self class closeMeansAbandon ifTrue: [#terminateAggressively] ifFalse:[#terminate].!

1 0

The Treated Inbox: Tools-jar.1161.mcz
by commits＠source.squeak.org 15 Feb '23

15 Feb '23

Marcel Taeumel uploaded a new version of Tools to project The Treated Inbox: http://source.squeak.org/treated/Tools-jar.1161.mcz ==================== Summary ==================== Name: Tools-jar.1161 Author: jar Time: 9 June 2022, 1:57:46.549529 pm UUID: f3921b2b-5628-104d-98a9-1e99671344a2 Ancestors: Tools-ct.1160 Fix an inconsistent Debugger behavior WRT the new alternative abandon/terminate/destroy modes introduced by Kernel-ct.1434 and Tools-ct.1092. The suggestion is to make all three termination methods equal in terms of how the chosen termination mode is propagated to #windowIsClosing. Current asymmetrical approach leads to an incorrect debugger termination via #terminate mode. Replace termination of the debugged process with an indirect termination via a forked process (otherwise the debugger waits until the debugged process is terminated but if another error is raised during unwind the termination is halted and the assertion fail). Following up a conversation in http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-May/220675.html Complemented by ToolsTests-jar.111 fixing the failing/incorrects tests in ToolsTests-ct.107 Please review as I'm no debugger expert and this is just my suggestion. Superseeds (or replaces) Tools-jar.1159 (please kindly remove from Inbox) =============== Diff against Tools-ct.1160 =============== Item was changed: CodeHolder subclass: #Debugger + instanceVariableNames: 'interruptedProcess contextStack contextStackIndex contextStackList receiverInspector receiverInspectorState contextVariablesInspector contextVariablesInspectorState externalInterrupt proceedValue selectingPC savedCursor isolationHead failedProject labelString message untilExpression terminationMethod' - instanceVariableNames: 'interruptedProcess contextStack contextStackIndex contextStackList receiverInspector receiverInspectorState contextVariablesInspector contextVariablesInspectorState externalInterrupt proceedValue selectingPC savedCursor isolationHead failedProject labelString message untilExpression' classVariableNames: 'ContextStackKeystrokes ErrorReportServer FullStackSize InterruptUIProcessIfBlockedOnErrorInBackgroundProcess NotifierStackSize SavedExtent StackSizeLimit WantsAnnotationPane' poolDictionaries: '' category: 'Tools-Debugger'! !Debugger commentStamp: 'mt 12/17/2019 12:19' prior: 0! I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context. Special note on recursive errors: Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery. * A recursive error is detected. * The current project is queried for an isolationHead * Changes in the isolationHead are revoked * The parent project of isolated project is returned to * The debugger is opened there and execution resumes. If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. --- In September 2019, we added MorphicDebugger and MVCDebugger to untangle framework-specific features in our debugger infrastructure. However, this is just an intermediate step. The overall goal would be to remove those two subclasses again while preserving their functionality. Mostly, MVC and Morphic differ in their GUI-process management. This means that "proceed" and "close" work differently depending on the process that is being debugged. --- One idea is to attach that framework-specific information to the process objects. See Process >> #environmentAt: and #environmentAt:put:. Also see ToolSet's #handle* and #debug* methods.! Item was changed: ----- Method: Debugger>>abandon (in category 'context stack menu') ----- abandon + "close the debugger and terminate the debugged process" - "abandon the debugger from its pre-debug notifier" + terminationMethod := #terminateAggressively. + self close + ! - self close.! Item was changed: ----- Method: Debugger>>initialize (in category 'initialize') ----- initialize super initialize. Smalltalk at: #MessageTally ifPresentAndInMemory: [ :tally | tally terminateTimerProcess]. externalInterrupt := false. selectingPC := true. + contextStackIndex := 0. + + terminationMethod := #terminateAggressively "debugger's default termination method"! - contextStackIndex := 0.! Item was changed: ----- Method: Debugger>>terminateProcess (in category 'context stack menu') ----- terminateProcess + "close the debugger and terminate the debugged process" + terminationMethod := #terminate. + self close + ! - interruptedProcess terminate. - interruptedProcess := nil. - self close.! Item was changed: ----- Method: Debugger>>windowIsClosing (in category 'initialize') ----- windowIsClosing "My window is being closed; clean up. Restart the low space watcher." contextStack := nil. receiverInspector := nil. contextVariablesInspector := nil. interruptedProcess == nil ifTrue: [^ self]. + [interruptedProcess perform: terminationMethod. + interruptedProcess := nil] fork. - interruptedProcess terminateAggressively. - interruptedProcess := nil. Smalltalk installLowSpaceWatcher. "restart low space handler"!

1 0

The Treated Inbox: Tools-jar.1159.mcz
by commits＠source.squeak.org 15 Feb '23

15 Feb '23

Marcel Taeumel uploaded a new version of Tools to project The Treated Inbox: http://source.squeak.org/treated/Tools-jar.1159.mcz ==================== Summary ==================== Name: Tools-jar.1159 Author: jar Time: 29 May 2022, 5:12:52.367993 pm UUID: bed7f2b8-2dd3-9b45-8262-ff51bc9dd5c3 Ancestors: Tools-mt.1158 Fix an inconsistent Debugger behavior WRT the two alternative abandon/termination modes introduced by Kernel-ct.1434 and Tools-ct.1092 Following up a conversation in http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-May/220675.html Complemented by ToolsTests-jar.110 fixing the failing/incorrects tests in ToolsTests-ct.107 =============== Diff against Tools-mt.1158 =============== Item was changed: CodeHolder subclass: #Debugger + instanceVariableNames: 'interruptedProcess contextStack contextStackIndex contextStackList receiverInspector receiverInspectorState contextVariablesInspector contextVariablesInspectorState externalInterrupt proceedValue selectingPC savedCursor isolationHead failedProject labelString message untilExpression terminationMethod' - instanceVariableNames: 'interruptedProcess contextStack contextStackIndex contextStackList receiverInspector receiverInspectorState contextVariablesInspector contextVariablesInspectorState externalInterrupt proceedValue selectingPC savedCursor isolationHead failedProject labelString message untilExpression' classVariableNames: 'ContextStackKeystrokes ErrorReportServer FullStackSize InterruptUIProcessIfBlockedOnErrorInBackgroundProcess NotifierStackSize SavedExtent StackSizeLimit WantsAnnotationPane' poolDictionaries: '' category: 'Tools-Debugger'! !Debugger commentStamp: 'mt 12/17/2019 12:19' prior: 0! I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context. Special note on recursive errors: Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery. * A recursive error is detected. * The current project is queried for an isolationHead * Changes in the isolationHead are revoked * The parent project of isolated project is returned to * The debugger is opened there and execution resumes. If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. --- In September 2019, we added MorphicDebugger and MVCDebugger to untangle framework-specific features in our debugger infrastructure. However, this is just an intermediate step. The overall goal would be to remove those two subclasses again while preserving their functionality. Mostly, MVC and Morphic differ in their GUI-process management. This means that "proceed" and "close" work differently depending on the process that is being debugged. --- One idea is to attach that framework-specific information to the process objects. See Process >> #environmentAt: and #environmentAt:put:. Also see ToolSet's #handle* and #debug* methods.! Item was changed: ----- Method: Debugger>>abandon (in category 'context stack menu') ----- abandon + "close the debugger and terminate the debugged process" - "abandon the debugger from its pre-debug notifier" + terminationMethod := #terminateAggressively. + self close + ! - self close.! Item was changed: ----- Method: Debugger>>initialize (in category 'initialize') ----- initialize super initialize. Smalltalk at: #MessageTally ifPresentAndInMemory: [ :tally | tally terminateTimerProcess]. externalInterrupt := false. selectingPC := true. + contextStackIndex := 0. + + terminationMethod := #terminateAggressively "debugger's default termination method"! - contextStackIndex := 0.! Item was changed: ----- Method: Debugger>>terminateProcess (in category 'context stack menu') ----- terminateProcess + "close the debugger and terminate the debugged process" + terminationMethod := #terminate. + self close + ! - interruptedProcess terminate. - interruptedProcess := nil. - self close.! Item was changed: ----- Method: Debugger>>windowIsClosing (in category 'initialize') ----- windowIsClosing "My window is being closed; clean up. Restart the low space watcher." contextStack := nil. receiverInspector := nil. contextVariablesInspector := nil. interruptedProcess == nil ifTrue: [^ self]. + interruptedProcess perform: terminationMethod. - interruptedProcess terminateAggressively. interruptedProcess := nil. Smalltalk installLowSpaceWatcher. "restart low space handler"!

1 0

The Treated Inbox: ToolsTests-jar.116.mcz
by commits＠source.squeak.org 15 Feb '23

15 Feb '23

Marcel Taeumel uploaded a new version of ToolsTests to project The Treated Inbox: http://source.squeak.org/treated/ToolsTests-jar.116.mcz ==================== Summary ==================== Name: ToolsTests-jar.116 Author: jar Time: 17 June 2022, 3:15:02.875775 pm UUID: 0cb238ec-203e-4c44-81b8-f9aed7f866e9 Ancestors: ToolsTests-ct.115 fix failing tests and remove #expectedFailures =============== Diff against ToolsTests-ct.115 =============== Item was removed: - SystemOrganization addCategory: #'ToolsTests-Browser'! - SystemOrganization addCategory: #'ToolsTests-Debugger'! - SystemOrganization addCategory: #'ToolsTests-FileList'! - SystemOrganization addCategory: #'ToolsTests-Inspector'! - SystemOrganization addCategory: #'ToolsTests-Menus'! Item was removed: - InspectorTest subclass: #BasicInspectorTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: BasicInspectorTest>>expectedFieldExpressionFailures (in category 'failures') ----- - expectedFieldExpressionFailures - - ^ #('self')! Item was removed: - ----- Method: BasicInspectorTest>>selectInvalidField (in category 'support - error') ----- - selectInvalidField - "Create a custom field. The existing fields will all work because the basic inspector shows only minimal information about the object." - - self - during: [self inspector addCustomField] - type: 'self printString'.! Item was removed: - ----- Method: BasicInspectorTest>>testFieldList (in category 'tests') ----- - testFieldList - - #(self 'class' 'size') do: [:label | - self assertFieldVisible: label].! Item was removed: - ----- Method: BasicInspectorTest>>testFieldSelf (in category 'tests') ----- - testFieldSelf - "The basic inspector sends as little messages as possible to the object-under-inspector. So, just look for the correct class name in a field's contents." - - | namePattern | - namePattern := '*{1}*' format: { (thisContext objectClass: self object) name }. - self assert: (self inspector fields anySatisfy: [:field | namePattern match: field value]).! Item was removed: - TestCase subclass: #BrowseTest - instanceVariableNames: 'originalBrowserClass originalHierarchyBrowserClass' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! Item was removed: - ----- Method: BrowseTest>>currentBrowsers (in category 'private') ----- - currentBrowsers - - ^ (Project current world submorphsSatisfying: [:each | - (each isKindOf: SystemWindow) - and: [each model isKindOf: Browser]]) asSet! Item was removed: - ----- Method: BrowseTest>>currentHierarchyBrowsers (in category 'private') ----- - currentHierarchyBrowsers - - ^ (Project current world submorphsSatisfying: [:each | - (each isKindOf: SystemWindow) - and: [each model isKindOf: HierarchyBrowser]]) asSet! Item was removed: - ----- Method: BrowseTest>>ensureMorphic (in category 'private') ----- - ensureMorphic - self isMorphic ifFalse: [self error: 'This test should be run in Morphic'].! Item was removed: - ----- Method: BrowseTest>>isMorphic (in category 'private') ----- - isMorphic - ^Smalltalk isMorphic! Item was removed: - ----- Method: BrowseTest>>setUp (in category 'running') ----- - setUp - | systemNavigation | - systemNavigation := SystemNavigation default. - originalBrowserClass := systemNavigation browserClass. - originalHierarchyBrowserClass := systemNavigation hierarchyBrowserClass. - - systemNavigation browserClass: nil. - systemNavigation hierarchyBrowserClass: nil. - - ! Item was removed: - ----- Method: BrowseTest>>tearDown (in category 'running') ----- - tearDown - | systemNavigation | - systemNavigation := SystemNavigation default. - systemNavigation browserClass: originalBrowserClass. - systemNavigation hierarchyBrowserClass: originalHierarchyBrowserClass.! Item was removed: - ----- Method: BrowseTest>>testBrowseClass (in category 'tests') ----- - testBrowseClass - "self debug: #testBrowseClass" - | browsersBefore browsersAfter opened | - self ensureMorphic. - - browsersBefore := self currentBrowsers. - self withImmediatelyOpeningWindowsDo: [1 class browse]. - browsersAfter := self currentBrowsers. - - self assert: (browsersAfter size = (browsersBefore size + 1)). - opened := browsersAfter removeAll: browsersBefore; yourself. - self assert: (opened size = 1). - opened := opened asArray first. - self assert: (opened model selectedClass == SmallInteger). - - opened delete - - - ! Item was removed: - ----- Method: BrowseTest>>testBrowseHierarchyClass (in category 'tests') ----- - testBrowseHierarchyClass - "self debug: #testBrowseHierarchyClass" - | browsersBefore browsersAfter opened | - self ensureMorphic. - - browsersBefore := self currentHierarchyBrowsers. - self withImmediatelyOpeningWindowsDo: [1 class browseHierarchy]. - browsersAfter := self currentHierarchyBrowsers. - - self assert: (browsersAfter size = (browsersBefore size + 1)). - opened := browsersAfter removeAll: browsersBefore; yourself. - self assert: (opened size = 1). - opened := opened asArray first. - self assert: (opened model selectedClass == SmallInteger). - - opened delete - - - ! Item was removed: - ----- Method: BrowseTest>>testBrowseHierarchyInstance (in category 'tests') ----- - testBrowseHierarchyInstance - "self debug: #testBrowseHierarchyInstance" - | browsersBefore browsersAfter opened | - self ensureMorphic. - - browsersBefore := self currentHierarchyBrowsers. - self withImmediatelyOpeningWindowsDo: [1 browseHierarchy]. - browsersAfter := self currentHierarchyBrowsers. - - self assert: (browsersAfter size = (browsersBefore size + 1)). - opened := browsersAfter removeAll: browsersBefore; yourself. - self assert: (opened size = 1). - opened := opened asArray first. - self assert: (opened model selectedClass == SmallInteger). - - opened delete - - - ! Item was removed: - ----- Method: BrowseTest>>testBrowseHierarchyMetaclass (in category 'tests') ----- - testBrowseHierarchyMetaclass - "self debug: #testBrowseHierarchyMetaclass" - | browsersBefore browsersAfter opened | - self ensureMorphic. - - browsersBefore := self currentHierarchyBrowsers. - self withImmediatelyOpeningWindowsDo: [1 class class browseHierarchy]. - browsersAfter := self currentHierarchyBrowsers. - - self assert: (browsersAfter size = (browsersBefore size + 1)). - opened := browsersAfter removeAll: browsersBefore; yourself. - self assert: (opened size = 1). - opened := opened asArray first. - self assert: (opened model selectedClass == Metaclass). - - opened delete - - - ! Item was removed: - ----- Method: BrowseTest>>testBrowseInstance (in category 'tests') ----- - testBrowseInstance - "self debug: #testBrowseInstance" - | browsersBefore browsersAfter opened | - self ensureMorphic. - - browsersBefore := self currentBrowsers. - self withImmediatelyOpeningWindowsDo: [1 browse]. - browsersAfter := self currentBrowsers. - - self assert: (browsersAfter size = (browsersBefore size + 1)). - opened := browsersAfter removeAll: browsersBefore; yourself. - self assert: (opened size = 1). - opened := opened asArray first. - self assert: (opened model selectedClass == SmallInteger). - - opened delete - - - ! Item was removed: - ----- Method: BrowseTest>>testBrowseMetaclass (in category 'tests') ----- - testBrowseMetaclass - "self debug: #testBrowseMetaclass" - | browsersBefore browsersAfter opened | - self ensureMorphic. - - browsersBefore := self currentBrowsers. - self withImmediatelyOpeningWindowsDo: [1 class class browse]. - browsersAfter := self currentBrowsers. - - self assert: (browsersAfter size = (browsersBefore size + 1)). - opened := browsersAfter removeAll: browsersBefore; yourself. - self assert: (opened size = 1). - opened := opened asArray first. - self assert: (opened model selectedClass == SmallInteger). - - opened delete - - - ! Item was removed: - ----- Method: BrowseTest>>testFindReferencesToFloatNaN (in category 'tests') ----- - testFindReferencesToFloatNaN - self assert: (SystemNavigation new allCallsOn: (Float bindingOf: #NaN)) notEmpty! Item was removed: - ----- Method: BrowseTest>>testSystemNavigationAllBehaviorsDo (in category 'tests') ----- - testSystemNavigationAllBehaviorsDo - | oc | - oc := OrderedCollection new. - SystemNavigation new allBehaviorsDo: - [:c| oc add: c]. - self assert: oc size = oc asSet size! Item was removed: - ----- Method: BrowseTest>>withImmediatelyOpeningWindowsDo: (in category 'private') ----- - withImmediatelyOpeningWindowsDo: aBlock - "Turn off any preferences that defer to the user to open a window." - | openToolsAttachedToMouseCursor | - (UIManager default respondsTo: #openToolsAttachedToMouseCursor:) ifFalse: - [^aBlock value]. - - openToolsAttachedToMouseCursor := UIManager default openToolsAttachedToMouseCursor. - UIManager default openToolsAttachedToMouseCursor: false. - ^aBlock ensure: - [UIManager default openToolsAttachedToMouseCursor: openToolsAttachedToMouseCursor]! Item was removed: - TestCase subclass: #BrowserHierarchicalListTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! - - !BrowserHierarchicalListTest commentStamp: 'rkrk 8/24/2009 05:11' prior: 0! - Tests the optional hierarchical class ordering of Browser.! Item was removed: - ----- Method: BrowserHierarchicalListTest>>assertCorrectOrderOf:followedBy:in: (in category 'assertion') ----- - assertCorrectOrderOf: classB followedBy: classA in: classCollection - - "classB comes before classA. Assert that classB is a superclass of classB or that - a common superclass is in front of both" - | commonSuperclasses commonSuperclass classAIndex classBIndex superIndex | - classA == classB ifTrue: [^ self]. - (classA inheritsFrom: classB) ifTrue: [^ self]. - commonSuperclasses := classA withAllSuperclasses intersection: classB withAllSuperclasses. - commonSuperclass := commonSuperclasses first. - (classCollection includes: commonSuperclass) ifFalse: [^ self]. - classAIndex := classCollection indexOf: classA. - classBIndex := classCollection indexOf: classB. - superIndex := classCollection indexOf: commonSuperclass. - (superIndex < classAIndex and: [superIndex < classBIndex]) ifTrue: [^self]. - self fail.! Item was removed: - ----- Method: BrowserHierarchicalListTest>>hierarchicalClassListForCategory: (in category 'helper') ----- - hierarchicalClassListForCategory: category - - ^ Browser new - selectSystemCategory: category; - hierarchicalClassList.! Item was removed: - ----- Method: BrowserHierarchicalListTest>>nameToClass: (in category 'helper') ----- - nameToClass: classNameWithIndent - - ^ Smalltalk classNamed: classNameWithIndent withoutLeadingBlanks asSymbol! Item was removed: - ----- Method: BrowserHierarchicalListTest>>testListClassesHierarchically1 (in category 'tests') ----- - testListClassesHierarchically1 - - | result classes category | - category := 'Collections-Abstract'. - result := self hierarchicalClassListForCategory: category. - self assert: (SystemOrganization listAtCategoryNamed: category) size equals: result size. - classes := result collect: [:ea | self nameToClass: ea]. - classes withIndexDo: [:ea : i | - classes - from: 1 to: i - do: [:other | self assertCorrectOrderOf: other followedBy: ea in: classes]].! Item was removed: - ----- Method: BrowserHierarchicalListTest>>testListClassesHierarchically2 (in category 'tests') ----- - testListClassesHierarchically2 - - | result classes category | - category := 'Tools-Browser'. - result := self hierarchicalClassListForCategory: category. - self assert: (SystemOrganization listAtCategoryNamed: category) size equals: result size. - classes := result collect: [:ea | self nameToClass: ea]. - classes withIndexDo: [:ea : i | - classes - from: 1 to: i - do: [:other | self assertCorrectOrderOf: other followedBy: ea in: classes]].! Item was removed: - ----- Method: BrowserHierarchicalListTest>>testListClassesHierarchicallyIndent (in category 'tests') ----- - testListClassesHierarchicallyIndent - - | result dict | - result := self hierarchicalClassListForCategory: 'Tools-Browser'. - "Create class->indent mapping" - dict := result inject: Dictionary new into: [:classIndentMapping :className | - | indent | - indent := className count: [:char | char = Character space or: [char = Character tab]]. - classIndentMapping at: (self nameToClass: className) put: indent. - classIndentMapping]. - "assert that indent of class is larger than indent of superclass" - dict keysAndValuesDo: [:class :myIndent | - dict at: class superclass ifPresent: [:superIndent | - self assert: myIndent > superIndent]].! Item was removed: - TestCase subclass: #BrowserTest - instanceVariableNames: 'browser' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! - - !BrowserTest commentStamp: 'fbs 3/4/2011 07:22' prior: 0! - I provide the test suite for Browser. - ! Item was removed: - ----- Method: BrowserTest>>setUp (in category 'running') ----- - setUp - browser := Browser new.! Item was removed: - ----- Method: BrowserTest>>testAlphabetizeMessageCategories (in category 'tests') ----- - testAlphabetizeMessageCategories - | categories | - browser selectSystemCategory: browser class category. - self deny: browser alphabetizeMessageCategories. - - browser selectClass: browser class. - browser metaClassIndicated: false. - self assert: browser alphabetizeMessageCategories. - categories := browser classOrMetaClassOrganizer categories. - self assert: (categories select: [:c| c first == $*]) isSorted. - self assert: (categories select: [:c| c beginsWith: 'private']) isSorted. - self assert: (categories reject: [:c| c first == $* or: [c beginsWith: 'private']]) isSorted. - - browser metaClassIndicated: true. - self assert: browser alphabetizeMessageCategories. - self assert: browser classOrMetaClassOrganizer categories isSorted.! Item was removed: - ----- Method: BrowserTest>>testAlphabetizeMessageCategoriesLeavesClassSelected (in category 'tests') ----- - testAlphabetizeMessageCategoriesLeavesClassSelected - browser selectSystemCategory: browser class category. - browser selectClassNamed: browser class name. - - "This is a no-op." - browser alphabetizeMessageCategories. - self assert: browser selectedClassName = browser class name.! Item was removed: - ----- Method: BrowserTest>>testAlphabetizingMethodsPreservesPlace (in category 'tests - message list') ----- - testAlphabetizingMethodsPreservesPlace - | oldCategory oldMethod | - oldCategory := 'breakpoints'. - oldMethod := #toggleBreakOnEntry. - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser selectMessageCategoryNamed: oldCategory. - browser selectMessageNamed: oldMethod. - browser alphabetizeMessageCategories. - - self assert: browser selectedMessageCategoryName = oldCategory. - self assert: browser selectedMessageName = oldMethod.! Item was removed: - ----- Method: BrowserTest>>testAlphabetizingMethodsPreservesPlaceWhenNoMessageCategorySelected (in category 'tests - message list') ----- - testAlphabetizingMethodsPreservesPlaceWhenNoMessageCategorySelected - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser selectMessageCategoryNamed: nil. - browser selectMessageNamed: nil. - browser alphabetizeMessageCategories. - - self assert: browser selectedMessageCategoryName = nil. - self assert: browser selectedMessageName = nil.! Item was removed: - ----- Method: BrowserTest>>testAlphabetizingMethodsPreservesPlaceWhenNoMethodSelected (in category 'tests - message list') ----- - testAlphabetizingMethodsPreservesPlaceWhenNoMethodSelected - | oldCategory | - oldCategory := 'breakpoints'. - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser selectMessageCategoryNamed: oldCategory. - browser selectMessageNamed: nil. - browser alphabetizeMessageCategories. - - self assert: browser selectedMessageCategoryName = oldCategory. - self assert: browser selectedMessageName = nil.! Item was removed: - ----- Method: BrowserTest>>testBuildMessageCategoryBrowserEditString (in category 'tests') ----- - testBuildMessageCategoryBrowserEditString - | spawn | - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser messageCategoryListIndex: 1. - browser messageListIndex: 1. - - spawn := browser buildMessageCategoryBrowserEditString: 'We don''t yet test that we do the right thing with this string!!'. - [self assert: spawn selectedSystemCategory = browser selectedSystemCategory. - self assert: spawn selectedClass = browser selectedClass. - self assert: spawn messageCategoryListIndex = browser messageCategoryListIndex. - self assert: spawn messageListIndex = browser messageListIndex] - ensure: [ [ToolBuilder default close: spawn topView] valueSupplyingAnswer: true].! Item was removed: - ----- Method: BrowserTest>>testBuildMessageCategoryBrowserEditStringNoCategorySelected (in category 'tests') ----- - testBuildMessageCategoryBrowserEditStringNoCategorySelected - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser messageCategoryListIndex: 0. - - self assert: (browser buildMessageCategoryBrowserEditString: 'foo') isNil.! Item was removed: - ----- Method: BrowserTest>>testChangeMessageCategoriesLeavesClassSelected (in category 'tests') ----- - testChangeMessageCategoriesLeavesClassSelected - browser selectSystemCategory: browser class category. - browser selectClassNamed: browser class name. - - "This is a no-op." - browser changeMessageCategories: browser classOrMetaClassOrganizer printString. - self assert: browser selectedClassName = browser class name.! Item was removed: - ----- Method: BrowserTest>>testClassCommentAnnotation (in category 'tests') ----- - testClassCommentAnnotation - | annotation | - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - annotation := browser annotationForClassCommentFor: browser class. - self assert: (annotation includesSubstring: browser class organization commentStamp). - self assert: (annotation includesSubstring: 'class comment for'). - self assert: (annotation includesSubstring: browser className).! Item was removed: - ----- Method: BrowserTest>>testClassCommentAnnotationIgnoresParameter (in category 'tests') ----- - testClassCommentAnnotationIgnoresParameter - | annotation | - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - "And the method ignores the parameter:" - annotation := browser annotationForClassCommentFor: browser class superclass. - self assert: (annotation includesSubstring: browser className).! Item was removed: - ----- Method: BrowserTest>>testClassCommentViewingPersists (in category 'tests') ----- - testClassCommentViewingPersists - browser selectSystemCategory: browser class category. - self assert: browser classList size > 1 description: 'We use the first TWO classes in the category!!'. - browser classListIndex: 1. - browser metaClassIndicated: false. - browser editComment. - - browser classListIndex: 2. - self assert: browser editSelection = #editComment.! Item was removed: - ----- Method: BrowserTest>>testClassDefinitionAnnotation (in category 'tests') ----- - testClassDefinitionAnnotation - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - self assert: browser class comment equals: (browser annotationForClassDefinitionFor: browser class). - "And the method ignores the parameter:" - self assert: browser class comment equals: (browser annotationForClassDefinitionFor: browser class superclass).! Item was removed: - ----- Method: BrowserTest>>testContentsNewClass (in category 'tests') ----- - testContentsNewClass - browser selectSystemCategory: browser class category. - - self assert: (Class template: browser selectedSystemCategory) equals: browser contents. - - self flag: #todo. "I don't know how to test the other half of this: see Browser >> #newClassContents".! Item was removed: - ----- Method: BrowserTest>>testContentsSelection (in category 'tests') ----- - testContentsSelection - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - - "No category or message selected." - self assert: browser contentsSelection isEmpty. - - "Category selected, but no message selected." - browser messageCategoryListIndex: 1. - browser selectMessageNamed: browser messageList first. - self assert: browser contentsSelection isEmpty. - - "Category and message selected." - browser selectMessageNamed: nil. - self deny: browser contentsSelection isEmpty.! Item was removed: - ----- Method: BrowserTest>>testCreateHierarchyTreeOf (in category 'tests') ----- - testCreateHierarchyTreeOf - "Empty." - self assert: (browser createHierarchyTreeOf: #()) isEmpty. - "Single class." - self assert: { Browser -> #() } = (browser createHierarchyTreeOf: { Browser }). - "Single class + 1 subclass" - self assert: { Browser->{HierarchyBrowser->#()} } = (browser createHierarchyTreeOf: { Browser. HierarchyBrowser. }). - "Single class + 2 subclasses" - self assert: { Browser->{HierarchyBrowser->#() . FileContentsBrowser->#()} } = (browser createHierarchyTreeOf: { Browser. HierarchyBrowser. FileContentsBrowser. }). - "Superclass, class, subclass" - self assert: { CodeHolder->{Browser->{HierarchyBrowser->#()}} } = (browser createHierarchyTreeOf: { CodeHolder. Browser. HierarchyBrowser. }). - "Two 'unrelated' classes" - self assert: {Browser->#() . SmallInteger->#()} = (browser createHierarchyTreeOf: { Browser. SmallInteger }). - "Two 'unrelated' classes and a common ancestor" - self assert: {Browser->#() . SmallInteger->#() . ProtoObject->#()} = (browser createHierarchyTreeOf: { Browser. SmallInteger. ProtoObject }).! Item was removed: - ----- Method: BrowserTest>>testDefaultClassList (in category 'tests') ----- - testDefaultClassList - browser selectSystemCategory: nil. - self assert: browser defaultClassList isEmpty. - - browser selectSystemCategory: Browser category. - self assert: browser defaultClassList = (SystemOrganization listAtCategoryNamed: Browser category)! Item was removed: - ----- Method: BrowserTest>>testFileOutMessageCategories (in category 'tests') ----- - testFileOutMessageCategories - | fileName | - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser messageCategoryListIndex: 1. - - "Handcrafted from ClassDescription>>fileOutCategory:asHtml:" - fileName := browser selectedClass name, '-', browser selectedMessageCategoryName, FileDirectory dot, 'st'. - self deny: (FileDirectory default fileExists: fileName). - - [browser fileOutMessageCategories. - self assert: (FileDirectory default fileExists: fileName). - ] ensure: [FileDirectory default deleteFileNamed: fileName].! Item was removed: - ----- Method: BrowserTest>>testFlattenHierarchyTreeOnIndent (in category 'tests') ----- - testFlattenHierarchyTreeOnIndent - | flatten | - flatten := [:coll | (browser - flattenHierarchyTree: (browser createHierarchyTreeOf: coll) - on: OrderedCollection new - indent: '') asArray ]. - "Empty collection." - self assert: (flatten value: #()) isEmpty. - "Single class." - self assert: #('Browser') equals: (flatten value: {Browser}). - "Single class + subclass." - self assert: #('Browser' ' HierarchyBrowser') equals: (flatten value: {Browser. HierarchyBrowser}). - "Single class + 2 subclasses" - self assert: #('Browser' ' HierarchyBrowser' ' FileContentsBrowser') equals: (flatten value: { Browser. HierarchyBrowser. FileContentsBrowser. }). - "Superclass, class, subclass" - self assert: #('CodeHolder' ' Browser' ' HierarchyBrowser') equals: (flatten value: { CodeHolder. Browser. HierarchyBrowser. }). - "Two 'unrelated' classes" - self assert: #('Browser' 'SmallInteger') equals: (flatten value: { Browser. SmallInteger }). - "Two 'unrelated' classes and a common ancestor" - self assert: #('Browser' 'SmallInteger' 'ProtoObject') equals: (flatten value: { Browser. SmallInteger. ProtoObject }).! Item was removed: - ----- Method: BrowserTest>>testFlattenHierarchyTreeOnIndentBy (in category 'tests') ----- - testFlattenHierarchyTreeOnIndentBy - | flatten | - flatten := [:coll | (browser - flattenHierarchyTree: (browser createHierarchyTreeOf: coll) - on: OrderedCollection new - indent: '' - by: 'x') asArray ]. - "Empty collection." - self assert: (flatten value: #()) isEmpty. - "Single class." - self assert: #('Browser') equals: (flatten value: {Browser}). - "Single class + subclass." - self assert: #('Browser' 'xHierarchyBrowser') equals: (flatten value: {Browser. HierarchyBrowser}). - "Single class + 2 subclasses" - self assert: #('Browser' 'xHierarchyBrowser' 'xFileContentsBrowser') equals: (flatten value: { Browser. HierarchyBrowser. FileContentsBrowser. }). - "Superclass, class, subclass" - self assert: #('CodeHolder' 'xBrowser' 'xxHierarchyBrowser') equals: (flatten value: { CodeHolder. Browser. HierarchyBrowser. }). - "Two 'unrelated' classes" - self assert: #('Browser' 'SmallInteger') equals: (flatten value: { Browser. SmallInteger }). - "Two 'unrelated' classes and a common ancestor" - self assert: #('Browser' 'SmallInteger' 'ProtoObject') equals: (flatten value: { Browser. SmallInteger. ProtoObject }).! Item was removed: - ----- Method: BrowserTest>>testGetSystemCategoryListIndex (in category 'tests') ----- - testGetSystemCategoryListIndex - | cat | - cat := browser systemCategoryList first. - browser selectSystemCategory: cat. - self assert: browser systemCategoryListIndex = (browser systemCategoryList indexOf: browser selectedSystemCategory).! Item was removed: - ----- Method: BrowserTest>>testHasClassSelected (in category 'tests') ----- - testHasClassSelected - browser selectSystemCategory: browser class category. - self deny: browser hasClassSelected. - - browser selectClass: browser class. - self assert: browser hasClassSelected. - - browser selectClass: nil. - self deny: browser hasClassSelected. - - browser selectClassNamed: browser class name asString. - self assert: browser hasClassSelected.! Item was removed: - ----- Method: BrowserTest>>testHasMessageCategorySelected (in category 'tests') ----- - testHasMessageCategorySelected - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser messageCategoryListIndex: 0. - self deny: browser hasMessageCategorySelected. - - browser messageCategoryListIndex: 1. - self assert: browser hasMessageCategorySelected. - - browser messageCategoryListIndex: 0. - self deny: browser hasMessageCategorySelected.! Item was removed: - ----- Method: BrowserTest>>testHasMessageSelected (in category 'tests') ----- - testHasMessageSelected - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser messageCategoryListIndex: 1. - - self deny: browser hasMessageSelected. - - browser messageListIndex: 0. - self deny: browser hasMessageSelected. - - browser messageListIndex: 1. - self assert: browser hasMessageSelected. - - browser messageListIndex: 0. - self deny: browser hasMessageSelected.! Item was removed: - ----- Method: BrowserTest>>testHomeCategory (in category 'tests') ----- - testHomeCategory - "This also 'just happens' to test #selectOriginalCategoryForCurrentMethod. It's not appropriate to directly test a private method. (It's a private method because its comment says so, not its category.)" - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser messageCategoryListIndex: 0. "Select -- all --" - browser selectMessageNamed: browser messageList first. - browser showHomeCategory. - - self assert: browser selectedMessageCategoryName = (browser class organization categoryOfElement: browser selectedMessageName).! Item was removed: - ----- Method: BrowserTest>>testKeepMethodSelectedWhenChangingClass (in category 'tests - message list') ----- - testKeepMethodSelectedWhenChangingClass - browser selectSystemCategory: SequenceableCollection category. - browser selectClass: SequenceableCollection. - browser selectMessageNamed: #add:. - self assert: browser selectedMessageName = #add:. - - "Even though we have no message category selected, stay looking at the #add: method." - browser selectClass: Collection. - self assert: browser selectedMessageName = #add:.! Item was removed: - ----- Method: BrowserTest>>testLabelStringAlwaysShowsBrowserType (in category 'tests') ----- - testLabelStringAlwaysShowsBrowserType - browser selectSystemCategory: browser class category. - self assert: (browser labelString includesSubstring: 'System Browser'). - browser selectClass: browser class. - self assert: (browser labelString includesSubstring: 'System Browser'). - browser selectSystemCategory: DependencyBrowser category. - browser selectClass: DependencyBrowser. - self assert: (browser labelString includesSubstring: 'System Browser').! Item was removed: - ----- Method: BrowserTest>>testLabelStringOfNewBrowserShowsBrowserType (in category 'tests') ----- - testLabelStringOfNewBrowserShowsBrowserType - self assert: 'System Browser' equals: browser labelString.! Item was removed: - ----- Method: BrowserTest>>testLabelStringShowsBrowsedClassName (in category 'tests') ----- - testLabelStringShowsBrowsedClassName - browser selectSystemCategory: DependencyBrowser category. - browser selectClass: DependencyBrowser. - self assert: (browser labelString includesSubstring: DependencyBrowser name).! Item was removed: - ----- Method: BrowserTest>>testMessageCatListSingleton (in category 'tests') ----- - testMessageCatListSingleton - | catName | - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - - self assert: browser messageCatListSingleton = #(). - - catName := browser messageCategoryList second. - browser selectMessageCategoryNamed: catName. - - self assert: browser messageCatListSingleton = {catName}.! Item was removed: - ----- Method: BrowserTest>>testMessageCategoryList (in category 'tests') ----- - testMessageCategoryList - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - - self assert: ({ClassOrganizer allCategory}, browser class organization categories) sorted equals: browser messageCategoryList sorted. - - browser selectClass: nil. - self assert: #() equals: browser messageCategoryList. - - browser selectClass: browser class. - browser metaClassIndicated: true. - self assert: ({ClassOrganizer allCategory}, browser class classSide organization categories) equals: browser messageCategoryList.! Item was removed: - ----- Method: BrowserTest>>testMessageCategoryListIndex (in category 'tests') ----- - testMessageCategoryListIndex - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - - self assert: browser messageCategoryList size > 1 description: 'Sanity check: test refers to first two categories.'. - - browser messageCategoryListIndex: 0. - self assert: browser selectedMessageCategoryName isNil. - - browser messageCategoryListIndex: 1. - self assert: browser selectedMessageCategoryName = browser messageCategoryList first. - - browser messageListIndex: 1. - browser messageCategoryListIndex: 2. - self assert: browser selectedMessageName isNil description: 'Changing category deselects method'.! Item was removed: - ----- Method: BrowserTest>>testMessageList (in category 'tests') ----- - testMessageList - browser selectSystemCategory: browser class category. - browser selectClass: nil. - self assert: browser messageList isEmpty. - - browser selectClass: browser class. - browser messageCategoryListIndex: 0. - self assert: browser messageList = browser classOrMetaClassOrganizer allMethodSelectors. - browser messageCategoryListIndex: 1. "-- all --" - self assert: browser messageList = browser classOrMetaClassOrganizer allMethodSelectors. - - browser messageCategoryListIndex: 2. - self assert: browser messageList = (browser classOrMetaClassOrganizer listAtCategoryNumber: 1). - - browser metaClassIndicated: true. - browser messageCategoryListIndex: 0. - self assert: browser messageList = browser classOrMetaClassOrganizer allMethodSelectors. - - browser messageCategoryListIndex: 1. "-- all --" - self assert: browser messageList = browser classOrMetaClassOrganizer allMethodSelectors. - - browser messageCategoryListIndex: 2. - self assert: browser messageList = (browser classOrMetaClassOrganizer listAtCategoryNumber: 1).! Item was removed: - ----- Method: BrowserTest>>testMetaClassIndicatedFalseOnExistingClass (in category 'tests') ----- - testMetaClassIndicatedFalseOnExistingClass - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser metaClassIndicated: false. - - self assert: browser messageListIndex = 0. - self assert: browser messageCategoryListIndex = 0. - self deny: browser contents isEmpty. "It shows the class definition." - - self deny: browser messageCategoryList isEmpty. - - self assert: browser messageList = (browser class organization allMethodSelectors). - self assert: browser editSelection = #editClass.! Item was removed: - ----- Method: BrowserTest>>testMetaClassIndicatedIsResetByChangedSystemCategory (in category 'tests') ----- - testMetaClassIndicatedIsResetByChangedSystemCategory - browser selectSystemCategory: browser class category. - browser metaClassIndicated: true. - browser selectSystemCategory: self class category. - - self deny: browser metaClassIndicated.! Item was removed: - ----- Method: BrowserTest>>testMetaClassIndicatedNotOnNoClass (in category 'tests') ----- - testMetaClassIndicatedNotOnNoClass - browser selectSystemCategory: browser class category. - browser selectClass: nil. - browser metaClassIndicated: false. - - self assert: browser messageListIndex = 0. - self assert: browser messageCategoryListIndex = 0. - self deny: browser contents isEmpty. "It shows the class definition." - - self assert: browser messageCategoryList isEmpty. - - self assert: browser messageList isEmpty. - self assert: browser editSelection = #newClass.! Item was removed: - ----- Method: BrowserTest>>testMetaClassIndicatedNotWithNoSystemCategorySelected (in category 'tests') ----- - testMetaClassIndicatedNotWithNoSystemCategorySelected - browser selectSystemCategory: nil. - browser metaClassIndicated: false. - - self assert: browser messageListIndex = 0. - self assert: browser messageCategoryListIndex = 0. - self assert: browser contents isEmpty. "It shows the Class definition." - self assert: browser messageCategoryList isEmpty. - self assert: browser editSelection = #none.! Item was removed: - ----- Method: BrowserTest>>testMetaClassIndicatedOnNoClass (in category 'tests') ----- - testMetaClassIndicatedOnNoClass - browser selectSystemCategory: browser class category. - browser selectClass: nil. - browser metaClassIndicated: true. - - self assert: browser messageListIndex = 0. - self assert: browser messageCategoryListIndex = 0. - self assert: browser contents isEmpty. - - self assert: browser messageCategoryList isEmpty. - - self assert: browser messageList isEmpty. - self assert: browser editSelection = #none.! Item was removed: - ----- Method: BrowserTest>>testMetaClassIndicatedTrueOnExistingClass (in category 'tests') ----- - testMetaClassIndicatedTrueOnExistingClass - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser metaClassIndicated: true. - - self assert: browser messageListIndex = 0. - self assert: browser messageCategoryListIndex = 0. - self deny: browser contents isEmpty. "It shows the Class definition." - self deny: browser messageCategoryList isEmpty. - - self assert: browser messageList = (browser class classSide organization allMethodSelectors).! Item was removed: - ----- Method: BrowserTest>>testMetaClassIndicatedWithNoSystemCategorySelected (in category 'tests') ----- - testMetaClassIndicatedWithNoSystemCategorySelected - browser selectSystemCategory: nil. - browser metaClassIndicated: true. - - self assert: browser messageListIndex = 0. - self assert: browser messageCategoryListIndex = 0. - self assert: browser contents isEmpty. "It shows the Class definition." - self assert: browser messageCategoryList isEmpty. - self assert: browser editSelection = #none.! Item was removed: - ----- Method: BrowserTest>>testRawMessageCategoryList (in category 'tests') ----- - testRawMessageCategoryList - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - - self assert: browser rawMessageCategoryList = browser class organization categories. - - browser selectClass: nil. - self assert: browser rawMessageCategoryList = #(). - - browser selectClass: browser class. - browser metaClassIndicated: true. - self assert: browser rawMessageCategoryList = browser class classSide organization categories.! Item was removed: - ----- Method: BrowserTest>>testSelectCategoryForClass (in category 'tests') ----- - testSelectCategoryForClass - browser selectCategoryForClass: Browser. - self assert: browser selectedSystemCategory = Browser category. - - browser selectCategoryForClass: TestCase. - self assert: browser selectedSystemCategory = TestCase category.! Item was removed: - ----- Method: BrowserTest>>testSelectClass (in category 'tests') ----- - testSelectClass - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - self assert: browser hasClassSelected. - - browser selectClass: nil. - self deny: browser hasClassSelected.! Item was removed: - ----- Method: BrowserTest>>testSelectClassEditSelectionNoClass (in category 'tests') ----- - testSelectClassEditSelectionNoClass - browser selectSystemCategory: browser class category. - - browser selectClass: nil. - self assert: browser editSelection = #newClass.! Item was removed: - ----- Method: BrowserTest>>testSelectClassEditSelectionWhenCommentSelected (in category 'tests') ----- - testSelectClassEditSelectionWhenCommentSelected - | editSelection | - browser selectSystemCategory: Heap category. - browser selectClass: Heap. - browser editComment. - browser messageListIndex: 0. - browser messageListIndex: 0. - - editSelection := browser editSelection. - browser selectClass: Interval. - self assert: browser editSelection = editSelection.! Item was removed: - ----- Method: BrowserTest>>testSelectClassEditSelectionWhenEditingClass (in category 'tests') ----- - testSelectClassEditSelectionWhenEditingClass - browser selectSystemCategory: Heap category. - browser selectClass: Heap. - browser metaClassIndicated: false. - browser messageListIndex: 0. - browser messageListIndex: 0. - - browser selectClass: Interval. - self assert: browser editSelection = #editClass.! Item was removed: - ----- Method: BrowserTest>>testSelectClassEditSelectionWhenEditingMetaclass (in category 'tests') ----- - testSelectClassEditSelectionWhenEditingMetaclass - browser selectSystemCategory: Heap category. - browser selectClass: Heap. - browser metaClassIndicated: true. - browser messageListIndex: 0. - browser messageListIndex: 0. - - browser selectClass: Interval. - self assert: browser editSelection = #editClass.! Item was removed: - ----- Method: BrowserTest>>testSelectClassEditSelectionWhenMsgSelected (in category 'tests') ----- - testSelectClassEditSelectionWhenMsgSelected - browser selectSystemCategory: Heap category. - browser selectClass: Heap. - browser selectMessageCategoryNamed: 'adding'. - browser messageListIndex: (browser messageList indexOf: #add:). - - browser selectClass: Interval. - self assert: browser editSelection = #editMessage.! Item was removed: - ----- Method: BrowserTest>>testSelectClassEditSelectionWhenNoMsgButCatSelected (in category 'tests') ----- - testSelectClassEditSelectionWhenNoMsgButCatSelected - browser selectSystemCategory: Heap category. - browser selectClass: Heap. - browser selectMessageCategoryNamed: 'adding'. - browser messageListIndex: 0. - - browser selectClass: Interval. - self assert: browser editSelection = #newMessage.! Item was removed: - ----- Method: BrowserTest>>testSelectClassNamed (in category 'tests') ----- - testSelectClassNamed - browser selectSystemCategory: browser class category. - browser selectClassNamed: browser class name. - self assert: browser selectedClassName = browser class name. - - browser selectClassNamed: nil. - self assert: browser selectedClassName isNil. - - browser selectClassNamed: browser class name asString. - self assert: browser selectedClassName = browser class name.! Item was removed: - ----- Method: BrowserTest>>testSelectClassNamedPreservesPlace (in category 'tests') ----- - testSelectClassNamedPreservesPlace - | commonCategory commonSelector otherClass | - browser selectSystemCategory: browser class category. - otherClass := HierarchyBrowser. "Unlikely to move out of Browser's package!!" - browser selectClassNamed: browser class name. - - commonCategory := (browser class organization categories intersection: otherClass organization categories) detect: [ :each | each == #'class list' ]. - commonSelector := #classList. - browser selectMessageCategoryNamed: commonCategory. - browser selectMessageNamed: commonSelector. - - browser selectClass: otherClass. - - self assert: browser selectedClassName = otherClass name. - self assert: browser selectedMessageCategoryName = commonCategory. - self assert: browser selectedMessageName = commonSelector.! Item was removed: - ----- Method: BrowserTest>>testSelectClassReselectsMessage (in category 'tests') ----- - testSelectClassReselectsMessage - "Colections-Sequences contains a number of classes with similar protocols. In particular, several classes have a method called #add: in a category 'adding'." - | selectedMsgCat selectedMethod | - selectedMsgCat := 'adding'. - selectedMethod := #add:. - browser selectSystemCategory: Heap category. - browser selectClass: Heap. - browser selectMessageCategoryNamed: selectedMsgCat. - browser messageListIndex: (browser messageList indexOf: selectedMethod). - - browser selectClass: Interval. - - self assert: browser selectedMessageCategoryName = selectedMsgCat. - self assert: browser selectedMessageName = selectedMethod.! Item was removed: - ----- Method: BrowserTest>>testSelectClassSelectsClass (in category 'tests') ----- - testSelectClassSelectsClass - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - self assert: browser classListIndex ~= 0. - self assert: browser selectedClass = browser class. - self assert: browser selectedClassName = browser class name.! Item was removed: - ----- Method: BrowserTest>>testSelectClassWhenNothingSelected (in category 'tests') ----- - testSelectClassWhenNothingSelected - self assert: browser editSelection = #none.! Item was removed: - ----- Method: BrowserTest>>testSelectMessageCategoryEditSelection (in category 'tests') ----- - testSelectMessageCategoryEditSelection - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser selectMessageCategoryNamed: browser messageCategoryList first. - - self assert: browser editSelection = #newMessage.! Item was removed: - ----- Method: BrowserTest>>testSelectMessageCategoryEditSelectionNoMsgCat (in category 'tests') ----- - testSelectMessageCategoryEditSelectionNoMsgCat - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - . - browser messageCategoryListIndex: 0. - - self assert: browser editSelection = #editClass.! Item was removed: - ----- Method: BrowserTest>>testSelectMessageCategoryEditSelectionNoMsgCatNoClass (in category 'tests') ----- - testSelectMessageCategoryEditSelectionNoMsgCatNoClass - browser selectSystemCategory: browser class category. - browser selectClass: nil. - . - browser messageCategoryListIndex: 0. - - self assert: browser editSelection = #newClass.! Item was removed: - ----- Method: BrowserTest>>testSelectMessageCategoryNamed (in category 'tests') ----- - testSelectMessageCategoryNamed - | catName | - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - - catName := browser messageCategoryList anyOne. - browser selectMessageCategoryNamed: catName. - self assert: browser selectedMessageCategoryName = catName.! Item was removed: - ----- Method: BrowserTest>>testSelectMessageNamed (in category 'tests') ----- - testSelectMessageNamed - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser messageCategoryListIndex: 1. - - browser selectMessageNamed: browser messageList first. - self assert: browser selectedMessageName = browser messageList first. - self assert: browser messageListIndex = 1. - - browser selectMessageNamed: nil. - self assert: browser selectedMessageName isNil. - self assert: browser messageListIndex = 0. - - browser selectMessageNamed: browser messageList second. - self assert: browser selectedMessageName = browser messageList second. - self assert: browser messageListIndex = 2. - - browser selectMessageNamed: browser messageList first asString. - self assert: browser selectedMessageName = browser messageList first. - self assert: browser messageListIndex = 1.! Item was removed: - ----- Method: BrowserTest>>testSelectedClass (in category 'tests') ----- - testSelectedClass - browser selectSystemCategory: browser class category. - browser classListIndex: 0. - self assert: browser classListIndex = 0. - self assert: browser selectedClass isNil. - - browser classListIndex: 1. - self assert: browser classListIndex = 1. - self assert: browser selectedClass notNil.! Item was removed: - ----- Method: BrowserTest>>testSelectedEnvironment (in category 'tests') ----- - testSelectedEnvironment - browser selectSystemCategory: browser class category. - self assert: browser selectedEnvironment = Smalltalk globals. - - "browser selectSystemCategory: nil. - self assert: browser selectedEnvironment isNil." - "selectedClass would not work in a hierarchy browser that has to display classes from different environments (because the correct categories might be missing)"! Item was removed: - ----- Method: BrowserTest>>testSelectedSystemCategory (in category 'tests') ----- - testSelectedSystemCategory - | cat newCat | - cat := browser systemCategoryList first. - newCat := browser systemCategoryList second. - browser selectSystemCategory: cat. - self assert: browser selectedSystemCategory = cat. - - browser systemCategoryListIndex: 2. - self assert: browser selectedSystemCategory = newCat.! Item was removed: - ----- Method: BrowserTest>>testShowHomeCategory (in category 'tests') ----- - testShowHomeCategory - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - "Select '--all--'." - browser selectMessageCategoryNamed: browser messageCategoryList first. - browser selectMessageNamed: browser messageList first. - - browser showHomeCategory. - self assert: browser messageCategoryListIndex > 1.! Item was removed: - ----- Method: BrowserTest>>testSpawnHierarchy (in category 'tests') ----- - testSpawnHierarchy - | spawn | - browser selectSystemCategory: browser class category. - browser selectClass: browser class. - browser selectMessageCategoryNamed: browser messageCategoryList last. - browser messageListIndex: (browser messageList size). - - spawn := browser spawnHierarchy. - [self assert: spawn selectedSystemCategory = browser selectedSystemCategory. - self assert: spawn selectedClassName = browser selectedClassName. - self assert: spawn selectedMessageCategoryName = browser selectedMessageCategoryName. - self assert: spawn messageListIndex = browser messageListIndex.] - ensure: [ ToolBuilder default close: spawn topView ].! Item was removed: - ----- Method: BrowserTest>>testSystemCategoryListIndex (in category 'tests') ----- - testSystemCategoryListIndex - | oldCat | - - browser systemCategoryListIndex: 1. - oldCat := browser selectedSystemCategory. - self assert: browser selectedSystemCategory = browser systemCategoryList first. - - browser systemCategoryListIndex: 2. - self deny: browser selectedSystemCategory = oldCat. - self assert: browser selectedSystemCategory = browser systemCategoryList second.! Item was removed: - InspectorTest subclass: #ClassInspectorTest - instanceVariableNames: '' - classVariableNames: 'InnerTestObject' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: ClassInspectorTest>>createObject (in category 'running') ----- - createObject - - InnerTestObject := super createObject. - ^ self class! Item was removed: - ----- Method: ClassInspectorTest>>makeObjectInvalid (in category 'support - error') ----- - makeObjectInvalid - - InnerTestObject beInvalid.! Item was removed: - ----- Method: ClassInspectorTest>>selectInvalidField (in category 'support - error') ----- - selectInvalidField - - self inspector selectFieldSuchThat: [:field | - field type = #classVar and: [field value == InnerTestObject]].! Item was removed: - ----- Method: ClassInspectorTest>>tearDown (in category 'running') ----- - tearDown - - InnerTestObject := nil. - super tearDown.! Item was removed: - ----- Method: ClassInspectorTest>>testCustomField (in category 'tests') ----- - testCustomField - - self - during: [self inspector addCustomField] - type: 'self packageInfo'. - - self assertFieldVisible: 'self packageInfo'. - self assertFieldSelected: 'self packageInfo'. - self assertValuePaneShows: '*ToolsTests*'.! Item was removed: - ----- Method: ClassInspectorTest>>testFieldList (in category 'tests') ----- - testFieldList - - #(self 'all inst vars' superclass InnerTestObject) do: [:label | - self assertFieldVisible: label].! Item was removed: - ----- Method: ClassInspectorTest>>testPoolDictionaries (in category 'tests') ----- - testPoolDictionaries - "All class inspectors should list the referenced pool dictionaries. Use an existing class from the base system that is known to rely of such a pool. If we would add our own references, loading these tests could raise extra dialog prompts." - - self denyFieldVisible: 'TextConstants'. - self inspector object: TextStyle. - self assertFieldVisible: 'TextConstants'.! Item was removed: - ----- Method: ClassInspectorTest>>testValuePaneModify (in category 'tests') ----- - testValuePaneModify - - self inspector selectFieldNamed: 'InnerTestObject'. - self assertFieldSelected: 'InnerTestObject'. - - self deny: 42 equals: InnerTestObject. - self inValuePaneTypeAndAccept: '42'. - self assert: 42 equals: InnerTestObject.! Item was removed: - InspectorTest subclass: #CollectionInspectorTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: CollectionInspectorTest>>createObject (in category 'running') ----- - createObject - - ^ OrderedCollection new - addAll: #(discovery navel smith); - yourself! Item was removed: - ----- Method: CollectionInspectorTest>>createObjectWithTruncation (in category 'running') ----- - createObjectWithTruncation - - ^ (1 to: 500) asOrderedCollection! Item was removed: - ----- Method: CollectionInspectorTest>>fieldTypeOfIndexedVariable (in category 'support') ----- - fieldTypeOfIndexedVariable - - ^ #element! Item was removed: - ----- Method: CollectionInspectorTest>>makeObjectInvalid (in category 'support - error') ----- - makeObjectInvalid - - self object at: 1 put: InspectorTestObject newInvalid. - self simulateStepping.! Item was removed: - ----- Method: CollectionInspectorTest>>selectInvalidField (in category 'support - error') ----- - selectInvalidField - - self inspector selectFieldNamed: '1'.! Item was removed: - ----- Method: CollectionInspectorTest>>testAddElement (in category 'tests') ----- - testAddElement - "Add a new element through the Smalltalk expression '6 * 7' and check whether the field representing that new element will be selected automatically." - - | objectSize | - objectSize := self object size. - - self assertFieldVisible: objectSize asString. - self deny: (self object includes: 42). - - self - during: [self inspector addElement] - type: '6 * 7'. "42" - - self assert: (self object includes: 42). - - self assertFieldVisible: (objectSize + 1) asString. - self assertFieldSelected: (objectSize + 1) asString. - self assertValuePaneShows: '42'.! Item was removed: - ----- Method: CollectionInspectorTest>>testAddElementError (in category 'tests - special') ----- - testAddElementError - "Not all collections support addition or removal of elements." - - self class == CollectionInspectorTest ifFalse: [^ self "Pass the test automatically"]. - - self inspector object: Array new. - self - should: [self inspector addElement: 1] - raise: Error.! Item was removed: - ----- Method: CollectionInspectorTest>>testAddElementMenu (in category 'tests') ----- - testAddElementMenu - - | testMenuEntry | - testMenuEntry := [self fieldListMenu items anySatisfy: [:item | '*add*element*' match: item contents ]]. - - self inspector selectField: nil. - self assert: testMenuEntry. - self inspector ensureSelectedField. - self assert: testMenuEntry.! Item was removed: - ----- Method: CollectionInspectorTest>>testAddElementMenuHidden (in category 'tests - special') ----- - testAddElementMenuHidden - - | testMenuEntry | - self class == CollectionInspectorTest ifFalse: [^ self "Pass the test automatically"]. - - testMenuEntry := [self fieldListMenu items anySatisfy: [:item | '*add*element*' match: item contents ]]. - - self inspector object: Array new. - self deny: testMenuEntry.! Item was removed: - ----- Method: CollectionInspectorTest>>testCustomField (in category 'tests') ----- - testCustomField - - self - during: [self inspector addCustomField] - type: 'self take: 5'. - - self assertFieldVisible: 'self take: 5'. - self assertFieldSelected: 'self take: 5'. - self assertValuePaneShows: '*navel*'.! Item was removed: - ----- Method: CollectionInspectorTest>>testFieldList (in category 'tests') ----- - testFieldList - - #(self 'all inst vars') do: [:label | self assertFieldVisible: label]. - 1 to: self object size do: [:index | self assertFieldVisible: index printString].! Item was removed: - ----- Method: CollectionInspectorTest>>testRemoveElement (in category 'tests') ----- - testRemoveElement - "Remove an element from the collection-under-inspection by selecting any element's field first and then removing that selected element." - - | element | - self assert: self object size > 1. - self inspector selectFieldSuchThat: [:field | field type = #element]. - - element := self inspector selection. - self assert: (self object includes: element). - - self inspector removeSelection. - self deny: (self object includes: element). - - "The next remaining element will automatically be selected." - self assert: #element equals: self inspector selectedField type. - self assert: (self object includes: self inspector selection).! Item was removed: - ----- Method: CollectionInspectorTest>>testUninitialized (in category 'tests') ----- - testUninitialized - "Single stepping through a debugger can observe the object state after creation but before initialization. Thus 'object size' may throw an exception for trying to do arithmetic on nil." - - self inspector selectFieldNamed: 'self'. - self assertFieldSelected: 'self'. - self assertValuePaneWorks. - - self inspector object: self object class basicNew. - self assertFieldSelected: 'self'. - self denyValuePaneWorks. "It's okay because the inspector is still working."! Item was removed: - ----- Method: CollectionInspectorTest>>testValuePaneModify (in category 'tests') ----- - testValuePaneModify - - | overwrittenElement | - self inspector selectFieldSuchThat: [:field | field type = #element]. - overwrittenElement := self inspector selection. - - self assert: (self object includes: overwrittenElement). - self deny: (self object includes: #ontario). - - self inValuePaneTypeAndAccept: '#ontario'. - self assertValuePaneShows: '#ontario'. - - self deny: (self object includes: overwrittenElement). - self assert: (self object includes: #ontario).! Item was removed: - InspectorTest subclass: #CompiledCodeInspectorTest - instanceVariableNames: '' - classVariableNames: 'InnerTestObject' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: CompiledCodeInspectorTest>>createObject (in category 'running') ----- - createObject - "Note that we cannot return the block directly but require the indirection of #evaluate: because the resulting block will be modified during the tests. A block directly embedded in this #createObject method, however, would be re-used across test runs." - - InnerTestObject := super createObject. - ^ Compiler new - evaluate: '[String withAll: #[67 97 114 112 101] "Carpe", #Squeak, InnerTestObject printString] method' - in: nil - to: self "Required for access to InnerTestObject"! Item was removed: - ----- Method: CompiledCodeInspectorTest>>evaluateObject (in category 'running') ----- - evaluateObject - - ^ (FullBlockClosure - receiver: nil - outerContext: nil - method: self object - copiedValues: nil) value! Item was removed: - ----- Method: CompiledCodeInspectorTest>>expectedFieldExpressionFailures (in category 'failures') ----- - expectedFieldExpressionFailures - - ^ #('source code')! Item was removed: - ----- Method: CompiledCodeInspectorTest>>makeObjectInvalid (in category 'support - error') ----- - makeObjectInvalid - - InnerTestObject beInvalid.! Item was removed: - ----- Method: CompiledCodeInspectorTest>>selectInvalidField (in category 'support - error') ----- - selectInvalidField - - self inspector selectFieldSuchThat: [:field | - field type = #literal and: [field value "binding" value == InnerTestObject]].! Item was removed: - ----- Method: CompiledCodeInspectorTest>>tearDown (in category 'running') ----- - tearDown - - InnerTestObject := nil. - super tearDown.! Item was removed: - ----- Method: CompiledCodeInspectorTest>>testCustomField (in category 'tests') ----- - testCustomField - - self - during: [self inspector addCustomField] - type: 'self allLiterals'. - - self assertFieldVisible: 'self allLiterals'. - self assertFieldSelected: 'self allLiterals'. - self assertValuePaneShows: '*#[*]*Squeak*'.! Item was removed: - ----- Method: CompiledCodeInspectorTest>>testFieldList (in category 'tests') ----- - testFieldList - - #(self '*bytecodes*' 'header' 'literal*') do: [:label | - self assertFieldVisible: label].! Item was removed: - ----- Method: CompiledCodeInspectorTest>>testValuePaneModify (in category 'tests') ----- - testValuePaneModify - "Overridden to specify the kind of value to modify in a compiled-code object: the bytecodes. Looking at #createObject, we try to replace the pushConstant of the second bytecode with the one for the third bytcode. So, the beginning of the resulting string will change from 'CarpeSqueak' to 'SqueakSqueak'." - - | initialPC | - self assert: 'SistaV1' equals: self object bytecodeSetName. "the test hard codes some bytecodes..." - initialPC := self object initialPC. - self assert: 35 equals: (self object at: initialPC + 1). "pushConstant: #[ ... ]" - self assert: 36 equals: (self object at: initialPC + 2). "pushConstant: #Squeak" - self assert: (self evaluateObject beginsWith: 'CarpeSqueak'). - - self inspector selectFieldNamed: (initialPC + 1) printString. "pushConstant: #[ ... ]" - self assertFieldSelected: (initialPC + 1) printString. - self inValuePaneTypeAndAccept: 36. "pushConstant: #Squeak" - - self assert: 36 equals: (self object at: initialPC + 1). "pushConstant: #Squeak" - self assert: 36 equals: (self object at: initialPC + 2). "pushConstant: #Squeak" - self assert: (self evaluateObject beginsWith: 'SqueakSqueak')! Item was removed: - ----- Method: CompiledCodeInspectorTest>>testValuePaneModifyLiteral (in category 'tests') ----- - testValuePaneModifyLiteral - - self inspector selectFieldSuchThat: [:field | - field type = #literal and: [field value = #Squeak]]. - - self assert: (self evaluateObject beginsWith: 'CarpeSqueak'). - self inValuePaneTypeAndAccept: '#Smalltalk'. - self assert: (self evaluateObject beginsWith: 'CarpeSmalltalk').! Item was removed: - InspectorTest subclass: #ContextInspectorTest - instanceVariableNames: '' - classVariableNames: 'InnerTestObject' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: ContextInspectorTest>>createObject (in category 'running') ----- - createObject - - InnerTestObject := super createObject. - [[:arg1 :arg2 | - | temp1 temp2 | - temp1 := arg1 printString size - 1. - temp2 := arg2 - 1. - temp1 / temp2] - value: InnerTestObject value: 1] - on: Error do: [:error | - ^ error signalerContext "Integer >> /" sender "SmallInteger >> /" sender "createObject" copy - push: 42; - yourself]. - self error: 'Failed to set up context to inspect'! Item was removed: - ----- Method: ContextInspectorTest>>makeObjectInvalid (in category 'support - error') ----- - makeObjectInvalid - - InnerTestObject beInvalid.! Item was removed: - ----- Method: ContextInspectorTest>>selectInvalidField (in category 'support - error') ----- - selectInvalidField - - self inspector selectFieldSuchThat: [:field | - field type = #tempVar and: [field value == InnerTestObject]]. - self inspector selectedField ifNil: [self fail: 'Could not select invalid field.'].! Item was removed: - ----- Method: ContextInspectorTest>>tearDown (in category 'running') ----- - tearDown - - InnerTestObject := nil. - super tearDown.! Item was removed: - ----- Method: ContextInspectorTest>>testCustomField (in category 'tests') ----- - testCustomField - - self - during: [self inspector addCustomField] - type: 'self isDead'. - - self assertFieldVisible: 'self isDead'. - self assertFieldSelected: 'self isDead'. - self assertValuePaneShows: 'false'.! Item was removed: - ----- Method: ContextInspectorTest>>testDebugConstruction (in category 'tests') ----- - testDebugConstruction - - self shouldntRaiseWhileDebugging: [ - [| foo | (foo := self) yourself] asContext]! Item was removed: - ----- Method: ContextInspectorTest>>testFieldList (in category 'tests') ----- - testFieldList - "No need to look for the fields for temporaries because those will be covered in other tests, which is more useful. Only list the mandatory fields here." - - #(self 'all inst vars' 'sender' 'pc' 'stackp' 'method' 'closureOrNil' 'receiver') - do: [:label | self assertFieldVisible: label].! Item was removed: - ----- Method: ContextInspectorTest>>testValuePaneModify (in category 'tests') ----- - testValuePaneModify - "Try to change the values of all arguments and temporary variables. Check if the object-under-inspection receives those changes." - - | testObjectFound | - testObjectFound := false. - - self object tempNames withIndexDo: [:temp :index | - | prior current input | - self inspector selectFieldSuchThat: [:field | field type = #tempVar and: [field key = temp]]. - self assertFieldSelected: '*', temp, '*'. "allow bells and whistles" - - prior := self object namedTempAt: index. - self assert: (prior isNumber or: [prior == InnerTestObject]). - - testObjectFound := testObjectFound or: [prior == InnerTestObject]. - current := (prior isNumber ifTrue: [prior + 1] ifFalse: [#smith]). - input := prior isNumber ifTrue: [self inspector contents, ' +1'] ifFalse: ['#smith']. - - self deny: current equals: (self object namedTempAt: index). - self inValuePaneTypeAndAccept: input. - self assert: current equals: (self object namedTempAt: index)]. - - self assert: testObjectFound.! Item was removed: - ContextInspectorTest subclass: #ContextVariablesInspectorTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Debugger'! Item was removed: - ----- Method: ContextVariablesInspectorTest>>expectedFieldExpressionFailures (in category 'failures') ----- - expectedFieldExpressionFailures - - ^ #('stack top')! Item was removed: - ----- Method: ContextVariablesInspectorTest>>testCustomField (in category 'tests') ----- - testCustomField - - self - during: [self inspector addCustomField] - type: 'thisContext isDead'. - - self assertFieldVisible: 'thisContext isDead'. - self assertFieldSelected: 'thisContext isDead'. - self assertValuePaneShows: 'false'.! Item was removed: - ----- Method: ContextVariablesInspectorTest>>testFieldList (in category 'tests') ----- - testFieldList - - #(thisContext 'stack top' 'all temp vars' '*arg*' '*temp*') - do: [:label | self assertFieldVisible: label].! Item was removed: - ----- Method: ContextVariablesInspectorTest>>testInspectorClass (in category 'tests') ----- - testInspectorClass - "This is inspector is a variation of regular context inspectors and is used in debuggers. So, after calling #inspect: the inspector class will indeed change to the regular one." - - | previousInspectorClass | - self assert: self object inspectorClass ~~ self inspector class. - previousInspectorClass := self inspector class. - self inspector inspect: self object. - self deny: previousInspectorClass equals: self inspector class. - self assert: self object inspectorClass equals: self inspector class.! Item was removed: - TestCase subclass: #DebuggerExtensionsTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Debugger'! Item was removed: - ----- Method: DebuggerExtensionsTest>>testBooleansGeneralise (in category 'tests - canonical argument names') ----- - testBooleansGeneralise - self assert: Boolean name equals: true canonicalArgumentName. - self assert: Boolean name equals: false canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testByteStringsGeneralise (in category 'tests - canonical argument names') ----- - testByteStringsGeneralise - self assert: String name equals: ByteString new canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testClassesGeneralise (in category 'tests - canonical argument names') ----- - testClassesGeneralise - self assert: Class name equals: Class new canonicalArgumentName. - self assert: Class name equals: 1 class canonicalArgumentName. - self assert: Class name equals: true class canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testCollectionsGeneralise (in category 'tests - canonical argument names') ----- - testCollectionsGeneralise - "ArrayedCollection and subclasses answer 'Array' " - self assert: Array name equals: Array new canonicalArgumentName. - "Otherwise answer the more general 'Collection' " - self assert: Collection name equals: OrderedCollection new canonicalArgumentName. - self assert: Collection name equals: LinkedList new canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testFloatsGeneralise (in category 'tests - canonical argument names') ----- - testFloatsGeneralise - self assert: Number name equals: 1.0 canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testFractionsGeneralise (in category 'tests - canonical argument names') ----- - testFractionsGeneralise - self assert: Number name equals: (1 / 2) canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testIntegersDontGeneralise (in category 'tests - canonical argument names') ----- - testIntegersDontGeneralise - self assert: Integer name equals: 1 canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testLargeNegativeIntegersGeneralise (in category 'tests - canonical argument names') ----- - testLargeNegativeIntegersGeneralise - self assert: Integer name equals: LargeNegativeInteger initializedInstance canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testLargePositiveIntegersGeneralise (in category 'tests - canonical argument names') ----- - testLargePositiveIntegersGeneralise - self assert: Integer name equals: LargePositiveInteger initializedInstance canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testOtherObjectsDontGeneralise (in category 'tests - canonical argument names') ----- - testOtherObjectsDontGeneralise - self assert: Behavior name equals: Behavior new canonicalArgumentName. - self assert: UndefinedObject name equals: nil canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testScaledDecimalsGeneralise (in category 'tests - canonical argument names') ----- - testScaledDecimalsGeneralise - self assert: Number name equals: 2.00s2 canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testStringsDontGeneralise (in category 'tests - canonical argument names') ----- - testStringsDontGeneralise - self assert: String name equals: String new canonicalArgumentName! Item was removed: - ----- Method: DebuggerExtensionsTest>>testWideStringsGeneralise (in category 'tests - canonical argument names') ----- - testWideStringsGeneralise - self assert: String name equals: WideString new canonicalArgumentName! Item was removed: - TestCase subclass: #DebuggerTests - instanceVariableNames: 'process debugger window reset' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Debugger'! - - !DebuggerTests commentStamp: 'mt 10/1/2019 14:24' prior: 0! - You must be in a Morphic project to run these tests!! Note that *ALL* tests construct new processes and leave the current UI process as is. Even errors are injected in helper processes. So, the test runner will not suspend or terminate when running these tests. - - Note that many of these tests depend on the StandardToolSet. So, if you have a custom tool set, maybe reset it first.! Item was removed: - ----- Method: DebuggerTests>>doTestUserInterruptFor:priority: (in category 'support') ----- - doTestUserInterruptFor: block priority: priority - "Note that we cannot signal the InterruptSemaphore because there is already the regular process waiting for it. We simulate that semaphore with a custom delay." - - | work wait interruptHelper | - work := Semaphore new. - wait := Semaphore new. "Maybe not necessary?" - - process := [ work wait. block value ] newProcess. - process priority: priority. - self assert: process priority >= Processor activeProcess priority. "You cannot interrupt lower priority processes." - process resume. - - interruptHelper := [ wait wait. 10 milliSeconds wait. Smalltalk handleUserInterrupt ] newProcess. - interruptHelper priority: Processor lowIOPriority. - self assert: interruptHelper priority > process priority. - interruptHelper resume. - - [wait signal. work signal] valueNoContextSwitch. - process priority = Processor activeProcess priority ifTrue: [Processor yield]. - - self assert: interruptHelper isTerminated. - - self ensureDebugger.! Item was removed: - ----- Method: DebuggerTests>>ensureDebugger (in category 'support') ----- - ensureDebugger - - debugger ifNotNil: [debugger close]. - - debugger := nil. - window := nil. - - self assert: process notNil. - self assert: process isSuspended. - - self findDebugger. - - self assert: window notNil. - self assert: debugger notNil.! Item was removed: - ----- Method: DebuggerTests>>expectedFailures (in category 'failures') ----- - expectedFailures - - ^ #( - test23TerminateDoubleErrorInEnsure - test24TerminateTripleErrorInEnsure)! Item was removed: - ----- Method: DebuggerTests>>findDebugger (in category 'support') ----- - findDebugger - - window := nil. - debugger := nil. - - self findDebuggerWindowFor: process. - - window ifNil: [ - self updateUserInterface. - self findDebuggerWindowFor: process]. - - window ifNotNil: [debugger := window model]! Item was removed: - ----- Method: DebuggerTests>>findDebuggerWindowFor: (in category 'support') ----- - findDebuggerWindowFor: process - - window := (Project current world in: [:world | world submorphs, world firstHand submorphs]) - detect: [:m | (m isSystemWindow and: [m model isKindOf: Debugger]) and: [m model interruptedProcess == process]] - ifNone: [].! Item was removed: - ----- Method: DebuggerTests>>installToolSet (in category 'support') ----- - installToolSet - - ToolSet default: DebuggerTestsToolSet new.! Item was removed: - ----- Method: DebuggerTests>>setUp (in category 'running') ----- - setUp - - super setUp. - - Project current isMorphic ifFalse: [self fail]. - Project current uiProcess isActiveProcess ifFalse: [self fail]. - - reset := { - [:enable | [enable ifTrue: [Preferences enable: #logDebuggerStackToFile]]] - value: Preferences logDebuggerStackToFile. - [:ts | [self uninstallToolSet. ToolSet default: ts]] - value: ToolSet default. - }. - - Preferences disable: #logDebuggerStackToFile.! Item was removed: - ----- Method: DebuggerTests>>tearDown (in category 'running') ----- - tearDown - - debugger ifNotNil: [debugger close]. - process ifNotNil: [process terminateAggressively]. - - process := nil. - debugger := nil. - window := nil. - - reset ifNotNil: [ - reset do: #value]. - - super tearDown.! Item was removed: - ----- Method: DebuggerTests>>test01UserInterrupt (in category 'tests') ----- - test01UserInterrupt - - | counter | - counter := nil. - { - [ [counter := counter + 1] repeat ]. - [ [counter := counter + 1. true] whileTrue ]. - "[ counter := counter + 1. Smalltalk createStackOverflow ]." "Disabled because VM may actually crash under certain conditions." - } do: [:workBlock | - "Interrupt must work for all common process priorities below lowIOPriority. Test it for some example priorities based on the existing priority constants." - { - Processor userSchedulingPriority. - Processor userSchedulingPriority + 1. - Processor userInterruptPriority. - "Processor userInterruptPriority + 1." "Disabled because this might hit the finalization process." - } do: [:workPriority | - counter := 0. - self doTestUserInterruptFor: workBlock priority: workPriority. - self assert: counter > 0. - self assert: debugger isNotifier]].! Item was removed: - ----- Method: DebuggerTests>>test02UnhandledException (in category 'tests') ----- - test02UnhandledException - - | counter | - { - [ counter := counter + 1. 7/0 ]. 'ZeroDivide'. - [ counter := counter + 1. Halt signal ]. 'Halt'. - [ counter := counter + 1. Warning signal: 'Test' ]. 'Warning' - } pairsDo: [:errorBlock :label | - Processor systemBackgroundPriority - to: Processor timingPriority - by: 10 - do: [:priority | - counter := 0. - - process := errorBlock forkAt: priority. - - "Let lower priority processes run to raise their exception." - priority <= Processor activeProcess priority ifTrue: [ - 3 timesRepeat: [process isSuspended not ifTrue: [50 milliSeconds wait]]]. - - self ensureDebugger. - - self assert: counter > 0. - self assert: (window label beginsWith: label). - self assert: debugger isNotifier]]! Item was removed: - ----- Method: DebuggerTests>>test03AsyncronousExceptions (in category 'tests') ----- - test03AsyncronousExceptions - "We want to get n different debuggers from n different processes." - - ((1 to: 3) "... more than 1 ... so ... 3 sounds about right ..." - collect: [:inc | [ Error signal ] forkAt: Processor userSchedulingPriority + inc]) - do: [:errorProcess | - "There must be debuggers for all processes." - process := errorProcess. - self ensureDebugger]; - in: [:all | debugger close "Just close the last debugger."]; - do: [:errorProcess | - process := errorProcess. - self findDebugger. - - self assert: debugger isNil. - self assert: process isTerminated]! Item was removed: - ----- Method: DebuggerTests>>test04DebuggerSuspendsProcess (in category 'tests') ----- - test04DebuggerSuspendsProcess - "Opening the debugger on a running process means to suspend that process." - - process := [ [3 + 4] repeat ] newProcess. - - "Choose a priority lower than the active process so that we can use an endless loop." - process priority: Processor activeProcess priority - 1. - process resume. Processor yield. - - self deny: process isSuspended. - - debugger := process debug. - - self assert: process isSuspended.! Item was removed: - ----- Method: DebuggerTests>>test05DebuggerTerminatesProcess (in category 'tests') ----- - test05DebuggerTerminatesProcess - "Closing a debugger on a suspended process means terminating that process." - - process := [ [3 + 4] repeat ] newProcess. - - "Choose a priority lower than the active process so that we can use an endless loop." - process priority: Processor activeProcess priority - 1. - process resume. Processor yield. - - self deny: process isTerminated. - - debugger := process debug. - debugger close. - - self assert: process isTerminated.! Item was removed: - ----- Method: DebuggerTests>>test06DebugSpecificContext (in category 'tests') ----- - test06DebugSpecificContext - - | context | - - process := [ #(1 2 3) collect: [:ea | ea odd ifTrue: [ ea ] ifFalse: [ Processor activeProcess suspend ] ] ] newProcess. - process priority: Processor activeProcess priority + 1. - process resume. - - "Find specific context by following #sender chain." - context := process suspendedContext. - [context selector = #collect: ] whileFalse: [context := context sender]. - - debugger := ToolSet debugProcess: process context: context label: nil contents: nil fullView: true. - - self assert: debugger contextStackTop = context.! Item was removed: - ----- Method: DebuggerTests>>test07DebuggerNotifier (in category 'tests') ----- - test07DebuggerNotifier - - process := [ 3+4 ] newProcess. - debugger := process debugWithTitle: 'Test' full: false. - self assert: debugger isNotifier.! Item was removed: - ----- Method: DebuggerTests>>test08DebuggerFull (in category 'tests') ----- - test08DebuggerFull - - process := [ 3+4 ] newProcess. - debugger := process debugWithTitle: 'Test' full: true. - self assert: debugger isFull.! Item was removed: - ----- Method: DebuggerTests>>test09DebuggerNotifierOrFull (in category 'tests') ----- - test09DebuggerNotifierOrFull - "Test the defaults." - - process := [ 3+4 ] newProcess. - debugger := process debug. - self assert: debugger isFull. - - debugger close. - - process := [ 3+4 ] newProcess. - debugger := process debugWithTitle: 'Test'. - self assert: debugger isFull. - - debugger close. - - process := [ 3+4 ] newProcess. - debugger := process debugWithTitle: 'Test 2' full: false. - self assert: debugger isNotifier.! Item was removed: - ----- Method: DebuggerTests>>test10DebugBlock (in category 'tests') ----- - test10DebugBlock - "Used for debug-it in tools." - - process := Process forBlock: [3+4]. - debugger := process debug. - - self deny: 7 equals: process suspendedContext top. - debugger stepOver. - self assert: 7 equals: process suspendedContext top.! Item was removed: - ----- Method: DebuggerTests>>test11DebugBlockAtContext (in category 'tests') ----- - test11DebugBlockAtContext - "Similar to the run-to feature in the debugger, run the process until a certain condition is met." - - process := Process - forBlock: [(#(1 2 3) collect: [:ea | ea + 1]) in: [:all | all sum]] - runUntil: [:context | context selector = #sum]. - debugger := process debug. - - self deny: 9 equals: process suspendedContext top. - debugger stepOver. - self assert: 9 equals: process suspendedContext top.! Item was removed: - ----- Method: DebuggerTests>>test12ToolSetHandleError (in category 'tests') ----- - test12ToolSetHandleError - "Test whether the #handle* callback is reached as expected." - - self installToolSet. - - process := [ Error signal ] newProcess. - process priority: Processor userSchedulingPriority + 1. - - self assert: 0 equals: self toolSet handledErrors size. - process resume. - self assert: 1 equals: self toolSet handledErrors size.! Item was removed: - ----- Method: DebuggerTests>>test13ToolSetHandleWarning (in category 'tests') ----- - test13ToolSetHandleWarning - "Test whether the #handle* callback is reached as expected." - - self installToolSet. - - process := [ Warning signal ] newProcess. - process priority: Processor userSchedulingPriority + 1. - - self assert: 0 equals: self toolSet handledWarnings size. - process resume. - self assert: 1 equals: self toolSet handledWarnings size.! Item was removed: - ----- Method: DebuggerTests>>test14ToolSetHandleUserInterruptRequest (in category 'tests') ----- - test14ToolSetHandleUserInterruptRequest - "Test whether the #handle* callback is reached as expected." - - self installToolSet. - - process := [ Smalltalk handleUserInterrupt ] newProcess. - process priority: Processor userSchedulingPriority + 1. - - self assert: 0 equals: self toolSet handledUserInterruptRequests size. - process resume. - self assert: 1 equals: self toolSet handledUserInterruptRequests size.! Item was removed: - ----- Method: DebuggerTests>>test15ToolSetDebugProcess (in category 'tests') ----- - test15ToolSetDebugProcess - "Test whether the #debug* callback is reached as expected." - - self installToolSet. - - process := [ 3+4 ] newProcess. - - self assert: 0 equals: self toolSet debuggedProcesses size. - process debug. - self assert: 1 equals: self toolSet debuggedProcesses size.! Item was removed: - ----- Method: DebuggerTests>>test16HandleSimulationError (in category 'tests') ----- - test16HandleSimulationError - "Regression test. In the past, the scenario below led to an infinite debugger chain freezing your image. Be careful when running this test in an unpatched image!! For more information, see http://forum.world.st/I-broke-the-debugger-td5110752.html." - - | userProcess | - process := Process forBlock: [ - "the faulty user code" - thisContext pc: nil]. - debugger := process debug. - - [userProcess := [debugger stepThrough] fork. - Processor yield. - - self deny: [process isTerminated]. - self assert: [userProcess isSuspended]] - - ensure: [ - process destroy. - debugger close. - process := userProcess. - self findDebugger "for correct tearDown"].! Item was removed: - ----- Method: DebuggerTests>>test17HandleBlockCannotReturn (in category 'tests') ----- - test17HandleBlockCannotReturn - "Regression test. In the past, the scenario below led to an infinite debugger chain freezing your image. Be careful when running this test in an unpatched image!! For more information, see http://forum.world.st/I-broke-the-debugger-td5110752.html." - - | userProcess | - process := Process forBlock: [ - "the faulty user code" - [] ensure: [thisContext privSender: nil]]. - debugger := process debug. - - [userProcess := [debugger stepOver] fork. - Processor yield. - - self assert: [process isTerminated]. - self deny: [userProcess isRunnable]] - - ensure: [ - process terminateAggressively. - debugger close. - process := userProcess. - self findDebugger "for correct tearDown"].! Item was removed: - ----- Method: DebuggerTests>>test18HandleNestedBlockCannotReturn (in category 'tests') ----- - test18HandleNestedBlockCannotReturn - "Regression test. In the past, the scenario below led to an infinite debugger chain freezing your image. Be careful when running this test in an unpatched image!! For more information, see http://forum.world.st/I-broke-the-debugger-td5110752.html." - - | metaProcess metaDebugger userProcess | - process := Process forBlock: [ - "the faulty user code" - [] ensure: [thisContext privSender: nil]]. - debugger := process debug. - metaProcess := Process forBlock: [ - debugger stepOver]. - metaDebugger := metaProcess debug. - - [userProcess := [metaDebugger stepOver] fork. - Processor yield. - - self assert: [process isTerminated]. - self deny: [userProcess isRunnable]] - - ensure: [ - process terminateAggressively. - debugger close. - metaProcess terminateAggressively. - metaDebugger close. - process := userProcess. - self findDebugger "for correct tearDown"].! Item was removed: - ----- Method: DebuggerTests>>test19Abandon (in category 'tests') ----- - test19Abandon - "When the debugger is abandoned, the interrupted process is terminated aggressively, i.e., all not yet started unwind contexts are executed. Further errors that occur during unwinding lead to another debugger showing up. This is the acceptance test equivalent for ProcessTest >> #testTerminateNestedUnwindAggressively." - - | x y z userProcess | - process := Process - forBlock: - [[x := 1] ensure: - [[y := 1. - self error: #first. - y := 2] ensure: - [z := 1. - self error: #second. - z := 2]]. - x := 2] - runUntil: [:ctx | y = 1]. - self should: {x. y. z} = {1. 1. nil}. - debugger := process debug. - - userProcess := [debugger proceed] forkAt: Processor activePriority + 1. - Processor yield. - self findDebugger. - - self deny: process isTerminated. - self assert: userProcess isTerminated. - self deny: debugger isNil. - self assert: {1. 1. nil} equals: {x. y. z}. - self assert: (debugger containingWindow label includesSubstring: #first). - - userProcess := [debugger abandon] forkAt: Processor activePriority + 1. - Processor yield. - self findDebugger. - - self deny: process isTerminated. - self assert: userProcess isTerminated. - self deny: debugger isNil. - self assert: {1. 1. 1} equals: {x. y. z}. - self assert: (debugger containingWindow label includesSubstring: #second). - - userProcess := [debugger proceed] forkAt: Processor activePriority + 1. - Processor yield. - self findDebugger. - - self assert: process isTerminated. - self assert: userProcess isTerminated. - self assert: debugger isNil. - self assert: {1. 1. 2} equals: {x. y. z}.! Item was removed: - ----- Method: DebuggerTests>>test20TerminateProcess (in category 'tests') ----- - test20TerminateProcess - "When the debugger's process is terminated, all unwind contexts, including already entered ones, are executed. Further errors that occur during unwinding lead to another debugger showing up. This is the acceptance test equivalent for ProcessTest >> #testTerminateNestedUnwind." - - | x y z userProcess userProcess2 | - process := Process - forBlock: - [[x := 1] ensure: - [[y := 1. - self error: #first. - y := 2] ensure: - [z := 1. - self error: #second. - z := 2]]. - x := 2] - runUntil: [:ctx | y = 1]. - self should: {x. y. z} = {1. 1. nil}. - debugger := process debug. - - userProcess := [debugger proceed] forkAt: Processor activePriority + 1. - Processor yield. - self findDebugger. - - self deny: process isTerminated. - self assert: userProcess isTerminated. - self deny: debugger isNil. - self assert: {1. 1. nil} equals: {x. y. z}. - self assert: (debugger containingWindow label includesSubstring: #first). - - userProcess := [debugger terminateProcess] forkAt: Processor activePriority + 1. - Processor yield. - self findDebugger. - - self deny: process isTerminated. - self deny: userProcess isTerminated. - self deny: debugger isNil. - self assert: {1. 2. 1} equals: {x. y. z}. - self assert: (debugger containingWindow label includesSubstring: #second). - - userProcess2 := [debugger proceed] forkAt: Processor activePriority + 1. - Processor yield. - self findDebugger. - - self assert: process isTerminated. - self assert: userProcess isTerminated. - self assert: userProcess2 isTerminated. - self assert: debugger isNil. - self assert: {1. 2. 2} equals: {x. y. z}.! Item was removed: - ----- Method: DebuggerTests>>test21TerminateErrorInEnsureBlock (in category 'tests') ----- - test21TerminateErrorInEnsureBlock - "Closing a debugger on a suspended process means terminating that process." - - | x1 x2 x3 x4 | - x1 := x2 := x3 := x4 := false. - process := - [ - [ - [ ] ensure: [ - [self error: 'outer error'] ensure: [ - x1 := true]. - x2 := true] - ] ensure: [ - x3 := true]. - x4 := true - ] fork. - Processor yield. - - "make sure process is suspended and none of the unwind blocks has finished yet" - self assert: process isSuspended. - self deny: x1 | x2 | x3 | x4. - - "now find and close the debugger and make sure all unwind blocks have finished" - self ensureDebugger. - debugger terminateProcess. - - self assert: process isTerminated. - self assert: x1 & x2 & x3. - self deny: x4! Item was removed: - ----- Method: DebuggerTests>>test22TerminateErrorInNestedEnsureBlock (in category 'tests') ----- - test22TerminateErrorInNestedEnsureBlock - "Closing a debugger on a suspended process means terminating that process." - - | x1 x2 x3 x4 | - x1 := x2 := x3 := x4 := false. - process := - [ - [ - [ ] ensure: [ - [] ensure: [ - self error: 'inner error'. - x1 := true]. - x2 := true] - ] ensure: [ - x3 := true]. - x4 := true - ] fork. - Processor yield. - - "make sure process is suspended and none of the unwind blocks has finished yet" - self assert: process isSuspended. - self deny: x1 | x2 | x3 | x4. - - "now find and close the debugger and make sure all unwind blocks have finished" - self ensureDebugger. - debugger terminateProcess. - - self assert: process isTerminated. - self assert: x1 & x2 & x3. - self deny: x4! Item was removed: - ----- Method: DebuggerTests>>test23TerminateDoubleErrorInEnsure (in category 'tests') ----- - test23TerminateDoubleErrorInEnsure - "Closing a debugger on a suspended process means terminating that process." - - | x1 x2 x3 x4 | - x1 := x2 := x3 := x4 := false. - process := - [ - [ - [ ] ensure: [ - [self error: 'outer error'] ensure: [ - self error: 'inner error'. - x1 := true]. - x2 := true] - ] ensure: [ - x3 := true]. - x4 := true - ] fork. - Processor yield. - - "make sure process is suspended and none of the unwind blocks has finished yet" - self assert: process isSuspended. - self deny: x1 | x2 | x3 | x4. - - "now find and close the debugger and let the unwind continue to the next error" - self ensureDebugger. - process := [debugger terminateProcess] fork. - Processor yield. - - "make sure process is suspended and none of the unwind blocks has finished yet" - self assert: process isSuspended. - self deny: x1 | x2 | x3 | x4. - - "now find and close the debugger and make sure all unwind blocks have finished" - self ensureDebugger. - debugger terminateProcess. - - self assert: process isTerminated. - self assert: x1 & x2 & x3. - self deny: x4! Item was removed: - ----- Method: DebuggerTests>>test24TerminateTripleErrorInEnsure (in category 'tests') ----- - test24TerminateTripleErrorInEnsure - "Closing a debugger on a suspended process means terminating that process." - - | x1 x2 x3 x4 | - x1 := x2 := x3 := x4 := false. - process := - [ - [ - [self error: 'outer error'] ensure: [ - [self error: 'middle error'] ensure: [ - self error: 'inner error'. - x1 := true]. - x2 := true] - ] ensure: [ - x3 := true]. - x4 := true - ] fork. - Processor yield. - - "make sure process is suspended and none of the unwind blocks has finished yet" - self assert: process isSuspended. - self deny: x1 | x2 | x3 | x4. - - "now find and close the debugger and let the unwind continue to the next error" - self ensureDebugger. - process := [debugger terminateProcess] fork. - Processor yield. - - "make sure process is suspended and none of the unwind blocks has finished yet" - self assert: process isSuspended. - self deny: x1 | x2 | x3 | x4. - - "now find and close the debugger and let the unwind continue to the next error" - self ensureDebugger. - process := [debugger terminateProcess] fork. - Processor yield. - - "make sure process is suspended and none of the unwind blocks has finished yet" - self assert: process isSuspended. - self deny: x1 | x2 | x3 | x4. - - "now find and close the debugger and make sure all unwind blocks have finished" - self ensureDebugger. - debugger terminateProcess. - - self assert: process isTerminated. - self assert: x1 & x2 & x3. - self deny: x4! Item was removed: - ----- Method: DebuggerTests>>toolSet (in category 'support') ----- - toolSet - - ^ ToolSet default! Item was removed: - ----- Method: DebuggerTests>>uninstallToolSet (in category 'support') ----- - uninstallToolSet - - (ToolSet default isKindOf: DebuggerTestsToolSet) ifTrue: [ - ToolSet unregister: ToolSet default].! Item was removed: - ----- Method: DebuggerTests>>updateUserInterface (in category 'support') ----- - updateUserInterface - - Project current world doOneCycle.! Item was removed: - StandardToolSet subclass: #DebuggerTestsToolSet - instanceVariableNames: 'data' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Debugger'! Item was removed: - ----- Method: DebuggerTestsToolSet>>debugProcess:context:label:contents:fullView: (in category 'debugging') ----- - debugProcess: aProcess context: aContext label: aString contents: contents fullView: aBool - - (data at: #debuggedProcesses ifAbsentPut: [OrderedCollection new]) - add: aProcess. - - aProcess suspend.! Item was removed: - ----- Method: DebuggerTestsToolSet>>doesNotUnderstand: (in category 'error handling') ----- - doesNotUnderstand: aMessage - - aMessage numArgs = 0 - ifTrue: [^ data at: aMessage selector ifAbsent: [{}]]. - - (self class respondsTo: aMessage selector) - ifTrue: [^ aMessage sendTo: self class]. - - ^ super doesNotUnderstand: aMessage! Item was removed: - ----- Method: DebuggerTestsToolSet>>handleError: (in category 'debugging - handlers') ----- - handleError: anError - - (data at: #handledErrors ifAbsentPut: [OrderedCollection new]) - add: anError. - - Processor activeProcess suspend.! Item was removed: - ----- Method: DebuggerTestsToolSet>>handleUserInterruptRequest: (in category 'debugging - handlers') ----- - handleUserInterruptRequest: aString - - (data at: #handledUserInterruptRequests ifAbsentPut: [OrderedCollection new]) - add: aString.! Item was removed: - ----- Method: DebuggerTestsToolSet>>handleWarning: (in category 'debugging - handlers') ----- - handleWarning: aWarning - - (data at: #handledWarnings ifAbsentPut: [OrderedCollection new]) - add: aWarning. - - Processor activeProcess suspend.! Item was removed: - ----- Method: DebuggerTestsToolSet>>initialize (in category 'initialize-release') ----- - initialize - - super initialize. - data := Dictionary new.! Item was removed: - TestCase subclass: #DebuggerUnwindBug - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Debugger'! Item was removed: - ----- Method: DebuggerUnwindBug>>testUnwindBlock (in category 'tests') ----- - testUnwindBlock - "test if unwind blocks work properly" - | sema process | - sema := Semaphore forMutualExclusion. - self assert: sema isSignaled. - "deadlock on the semaphore" - process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. - self deny: sema isSignaled. - "terminate process" - process terminate. - self assert: sema isSignaled. - ! Item was removed: - ----- Method: DebuggerUnwindBug>>testUnwindDebugger (in category 'tests') ----- - testUnwindDebugger - "test if unwind blocks work properly when a debugger is closed" - | sema process debugger top | - sema := Semaphore forMutualExclusion. - self assert: sema isSignaled. - process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. - self deny: sema isSignaled. - - "everything set up here - open a debug notifier" - debugger := Debugger - openOn: process - context: process suspendedContext - label: 'test' - contents: nil - fullView: false. - "get into the debugger" - debugger debug. - top := debugger topView. - "set top context" - debugger toggleContextStackIndex: 1. - "close debugger" - top delete. - - "and see if unwind protection worked" - self assert: sema isSignaled.! Item was removed: - TestCase subclass: #DependencyBrowserTest - instanceVariableNames: 'browser' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! Item was removed: - ----- Method: DependencyBrowserTest>>setUp (in category 'running') ----- - setUp - browser := DependencyBrowser new.! Item was removed: - ----- Method: DependencyBrowserTest>>testBrowse (in category 'tests - buttons') ----- - testBrowse - | b | - browser packageListIndex: (browser packageList indexOf: #Collections). - browser packageDepsIndex: (browser packageDeps indexOf: #Compiler). - browser classDepsIndex: (browser classDeps indexOf: #Scanner). - browser classListIndex: (browser classList indexOf: #Symbol). - browser messageListIndex: 1. - - b := browser browseMethodFull. - self assert: b notNil. - [self assert: b selectedMessageName = (browser messageList at: browser messageListIndex) ] - ensure: [ToolBuilder default close: b topView]! Item was removed: - ----- Method: DependencyBrowserTest>>testClassList (in category 'tests - class list') ----- - testClassList - "Warning!! When Collections' dependencies change, this test may start to fail!!" - self assert: #() equals: browser classList description: 'classList before package selection'. - - browser packageListIndex: (browser packageList indexOf: #Collections). - self - assert: #() - equals: browser classList - description: 'classList after selecting Collections'. - - browser packageDepsIndex: (browser packageDeps indexOf: #Compiler). - self - assert: browser classList notEmpty - description: 'classList after selecting Compiler'. - - browser classDepsIndex: (browser classDeps indexOf: #Scanner). - self - assert: #(Character String Symbol 'Symbol class') - equals: browser classList - description: 'classList after selecting Scanner class'. - - browser classListIndex: (browser classList indexOf: #Symbol). - self - assert: #(Character String Symbol 'Symbol class') - equals: browser classList - description: 'classList after selecting Symbol class'.! Item was removed: - ----- Method: DependencyBrowserTest>>testHasPackageSelected (in category 'tests - metaclass') ----- - testHasPackageSelected - self deny: browser hasPackageSelected. - - browser packageListIndex: 1. - self assert: browser hasPackageSelected. - - browser packageListIndex: 0. - self deny: browser hasPackageSelected.! Item was removed: - ----- Method: DependencyBrowserTest>>testSelectedClassOrMetaClass (in category 'tests - metaclass') ----- - testSelectedClassOrMetaClass - "Warning!! When Collections' dependencies change, this test may start to fail!!" - self assert: browser selectedClassOrMetaClass isNil. - - browser packageListIndex: (browser packageList indexOf: #Collections). - self assert: browser selectedClassOrMetaClass isNil. - - browser packageDepsIndex: (browser packageDeps indexOf: #Compiler). - self assert: browser selectedClassOrMetaClass isNil. - - browser classDepsIndex: (browser classDeps indexOf: #Scanner). - self assert: browser selectedClassOrMetaClass isNil. - - browser classListIndex: (browser classList indexOf: #Symbol). - - self deny: browser selectedClassOrMetaClass isNil. - self assert: browser selectedClassOrMetaClass == Symbol.! Item was removed: - ----- Method: DependencyBrowserTest>>testSelectedMessageClassSideShowsSource (in category 'tests - message list') ----- - testSelectedMessageClassSideShowsSource - "Warning!! When Collections' dependencies change, this test may start to fail!!" - - browser packageListIndex: (browser packageList indexOf: #'Chronology-Core'). - browser packageDepsIndex: (browser packageDeps indexOf: #Collections). - browser classDepsIndex: (browser classDeps indexOf: #'Array'). - browser classListIndex: (browser classList indexOf: #'DateAndTime'). - browser messageListIndex: 1. - self assert: browser selectedMessageName == #ticks. - - self assert: browser contents = (DateAndTime sourceCodeAt: #ticks) - ! Item was removed: - ----- Method: DependencyBrowserTest>>testSelectedMessageName (in category 'tests - message list') ----- - testSelectedMessageName - "Warning!! When Collections' dependencies change, this test may start to fail!!" - self assert: browser selectedMessageName isNil. - - browser packageListIndex: (browser packageList indexOf: #Collections). - self assert: browser selectedMessageName isNil. - - browser packageDepsIndex: (browser packageDeps indexOf: #Compiler). - self assert: browser selectedMessageName isNil. - - browser classDepsIndex: (browser classDeps indexOf: #Scanner). - self assert: browser selectedMessageName isNil. - - browser classListIndex: (browser classList indexOf: #Symbol). - self assert: browser selectedMessageName == #isMessageSelector. - - browser messageListIndex: 1. - self assert: browser selectedMessageName == #isMessageSelector. - - browser messageListIndex: 0. - self assert: browser selectedMessageName isNil.! Item was removed: - ----- Method: DependencyBrowserTest>>testSelectedMessageNameClassSide (in category 'tests - message list') ----- - testSelectedMessageNameClassSide - "Warning!! When Collections' dependencies change, this test may start to fail!!" - self assert: browser selectedMessageName isNil. - - browser packageListIndex: (browser packageList indexOf: #'Chronology-Core'). - self assert: browser selectedMessageName isNil. - - browser packageDepsIndex: (browser packageDeps indexOf: #Collections). - self assert: browser selectedMessageName isNil. - - browser classDepsIndex: (browser classDeps indexOf: #Array). - self assert: browser selectedMessageName isNil. - - browser classListIndex: (browser classList indexOf: #'DateAndTime'). - self assert: browser selectedMessageName == #ticks. - - browser messageListIndex: 1. - self assert: browser selectedMessageName == #ticks. - ! Item was removed: - CollectionInspectorTest subclass: #DictionaryInspectorTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: DictionaryInspectorTest>>createObject (in category 'running') ----- - createObject - - ^ Dictionary withAll: { - 1 -> #discovery. - 7 -> #navel. - 11 -> #smith }! Item was removed: - ----- Method: DictionaryInspectorTest>>createObjectWithTruncation (in category 'running') ----- - createObjectWithTruncation - - ^ (1 to: 150) - collect: [:number | number -> #genericApple] - as: Dictionary! Item was removed: - ----- Method: DictionaryInspectorTest>>testAddElement (in category 'tests') ----- - testAddElement - "The user will add a new key to the dictionary, not a value behind that key. That value needs to be set separatedly." - - self deny: (self object includesKey: 9). - - self - during: [self inspector addElement] - type: '3 ** 2'. "9" - - self assert: (self object includesKey: 9). - - self assertFieldVisible: '9'. - self assertFieldSelected: '9'. - - self assertValuePaneShows: 'nil'. - self inValuePaneTypeAndAccept: '#ontario'. - self assertValuePaneShows: '#ontario'. - - self assert: #ontario equals: (self object at: 9).! Item was removed: - ----- Method: DictionaryInspectorTest>>testFieldList (in category 'tests') ----- - testFieldList - "Check whether the most important fields are visible." - - #(self 'all inst vars' tally array) do: [:label | - self assertFieldVisible: label]. - - self object keysDo: [:key | self assertFieldVisible: key printString].! Item was removed: - ----- Method: DictionaryInspectorTest>>testObjectChanged (in category 'tests') ----- - testObjectChanged - - "1) Add a new key, which adds a new field to the list of fields." - self denyFieldVisible: '9'. - self object at: 9 put: nil. - self denyFieldVisible: '9'. - self simulateStepping. - self assertFieldVisible: '9'. - - "2) Change the value behind the key, which changes the value-pane's contents." - self inspector selectFieldNamed: '9'. - self assertFieldSelected: '9'. - self assertValuePaneShows: 'nil'. - self object at: 9 put: #ontario. - self assertValuePaneShows: 'nil'. - self simulateStepping. - self assertValuePaneShows: '#ontario'.! Item was removed: - Object subclass: #DummyToolWorkingWithFileList - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-FileList'! - - !DummyToolWorkingWithFileList commentStamp: '<historical>' prior: 0! - I'm a dummy class for testing that the registration of the tool to the FileList of actually happens. - In the future the tests should cover that the class register when loaded in memory and unregister when unloaded.! Item was removed: - ----- Method: DummyToolWorkingWithFileList class>>fileReaderServicesForFile:suffix: (in category 'class initialization') ----- - fileReaderServicesForFile: fullName suffix: suffix - - ^ (suffix = 'kkk') - ifTrue: [ self services] - ifFalse: [#()] ! Item was removed: - ----- Method: DummyToolWorkingWithFileList class>>initialize (in category 'class initialization') ----- - initialize - "self initialize" - - FileServices registerFileReader: self - - ! Item was removed: - ----- Method: DummyToolWorkingWithFileList class>>loadAFileForTheDummyTool: (in category 'class initialization') ----- - loadAFileForTheDummyTool: aFileListOrAPath - - "attention. if the file list selects a file the argument will be a fullpath of the selected file else it will pass the filelist itself"! Item was removed: - ----- Method: DummyToolWorkingWithFileList class>>serviceLoadAFilForDummyTool (in category 'class initialization') ----- - serviceLoadAFilForDummyTool - "Answer a service for opening the Dummy tool" - - ^ SimpleServiceEntry - provider: self - label: 'menu label' - selector: #loadAFileForTheDummyTool: - description: 'Menu label for dummy tool' - buttonLabel: 'test'! Item was removed: - ----- Method: DummyToolWorkingWithFileList class>>services (in category 'class initialization') ----- - services - - ^ Array with: self serviceLoadAFilForDummyTool - - ! Item was removed: - ----- Method: DummyToolWorkingWithFileList class>>unload (in category 'class initialization') ----- - unload - - FileServices unregisterFileReader: self ! Item was removed: - ----- Method: DummyToolWorkingWithFileList class>>unregister (in category 'class initialization') ----- - unregister - - FileServices unregisterFileReader: self. - ! Item was removed: - TestCase subclass: #FileContentsBrowserTest - instanceVariableNames: 'browser' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! Item was removed: - ----- Method: FileContentsBrowserTest>>setUp (in category 'running') ----- - setUp - | fileout testCat | - testCat := self class category. - fileout := WriteStream on: (String new: 10000). - SystemOrganization fileOutCategory: testCat on: fileout. - browser := FileContentsBrowser createBrowserForStream: fileout readStream named: testCat.! Item was removed: - ----- Method: FileContentsBrowserTest>>testBrowsingAChangesetShowsMethods (in category 'tests') ----- - testBrowsingAChangesetShowsMethods - - | newChangeSet fileContents internalStream class | - newChangeSet := ChangeSet basicNewNamed: 'fooTestSet' , (Random new nextLargeInt: 10000) asString. - SystemChangeNotifier uniqueInstance doSilently: [ - class := Object subclass: #FileContentsBrowserTestTestObject - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: self class category name asString. - class compileSilently: 'theTestMethod ^ false']. - - newChangeSet adoptSelector: #theTestMethod forClass: class. - - internalStream := WriteStream on: (String new: 10000). - newChangeSet fileOutOn: internalStream. - fileContents := internalStream contents. - class removeFromSystem. - - browser := FileContentsBrowser createBrowserForStream: (MultiByteBinaryOrTextStream with: fileContents) named: 'testFoo'. - - browser selectSystemCategory: browser systemCategoryList first. - browser selectClassNamed: browser classList first. - - self assert: browser messageList size = 1.! Item was removed: - ----- Method: FileContentsBrowserTest>>testChangeMessageCategoriesLeavesClassSelected (in category 'tests') ----- - testChangeMessageCategoriesLeavesClassSelected - browser selectSystemCategory: browser systemCategoryList first. - browser selectClassNamed: self class name. - - "This is a no-op." - browser changeMessageCategories: browser classOrMetaClassOrganizer printString. - self assert: browser selectedClassName = self class name.! Item was removed: - TestCase subclass: #FileList2ModalDialogsTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-FileList'! - - !FileList2ModalDialogsTest commentStamp: '<historical>' prior: 0! - TestRunner open! Item was removed: - ----- Method: FileList2ModalDialogsTest>>testModalFileSelector (in category 'tests') ----- - testModalFileSelector - | window fileList2 | - window := FileList2 morphicViewFileSelector. - window openCenteredInWorld. - fileList2 := window valueOfProperty: #fileListModel. - fileList2 fileListIndex: 1. - window delete. - self assert: fileList2 getSelectedFile isNil. - fileList2 okHit. - self deny: fileList2 getSelectedFile isNil - - - ! Item was removed: - ----- Method: FileList2ModalDialogsTest>>testModalFileSelectorForSuffixes (in category 'tests') ----- - testModalFileSelectorForSuffixes - | window fileList2 | - window := FileList2 morphicViewFileSelectorForSuffixes: nil. - window openCenteredInWorld. - fileList2 := window valueOfProperty: #fileListModel. - fileList2 fileListIndex: 1. - window delete. - self assert: fileList2 getSelectedFile isNil. - fileList2 okHit. - self deny: fileList2 getSelectedFile isNil - ! Item was removed: - ----- Method: FileList2ModalDialogsTest>>testModalFolderSelector (in category 'tests') ----- - testModalFolderSelector - | window fileList2 | - window := FileList2 morphicViewFolderSelector. - fileList2 := window model. - window openInWorld: self currentWorld extent: 300@400. - fileList2 fileListIndex: 1. - window delete. - self assert: fileList2 getSelectedDirectory withoutListWrapper isNil. - fileList2 okHit. - self deny: fileList2 getSelectedDirectory withoutListWrapper isNil - - ! Item was removed: - ----- Method: FileList2ModalDialogsTest>>testModalFolderSelectorForProjectLoad (in category 'tests') ----- - testModalFolderSelectorForProjectLoad - | window fileList2 w | - window := FileList2 - morphicViewProjectLoader2InWorld: self currentWorld - reallyLoad: false. - fileList2 := window valueOfProperty: #FileList. - w := self currentWorld. - window position: w topLeft + (w extent - window extent // 2). - window openInWorld: w. - window delete. - self assert: fileList2 getSelectedDirectory withoutListWrapper isNil. - fileList2 okHit. - self deny: fileList2 getSelectedDirectory withoutListWrapper isNil - ! Item was removed: - ClassTestCase subclass: #FileListTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-FileList'! Item was removed: - ----- Method: FileListTest>>checkIsServiceIsFromDummyTool: (in category 'private') ----- - checkIsServiceIsFromDummyTool: service - - ^ (service instVarNamed: #provider) = DummyToolWorkingWithFileList and: [ - service label = 'menu label' and: [ - (service instVarNamed: #selector) = #loadAFileForTheDummyTool: ] ]! Item was removed: - ----- Method: FileListTest>>setUp (in category 'initialize') ----- - setUp - - DummyToolWorkingWithFileList initialize.! Item was removed: - ----- Method: FileListTest>>tearDown (in category 'initialize') ----- - tearDown - - DummyToolWorkingWithFileList unregister.! Item was removed: - ----- Method: FileListTest>>testAllRegisteredServices (in category 'tests') ----- - testAllRegisteredServices - "(self selector: #testAllRegisteredServices) debug" - - "This should not throw an exception." - FileServices allRegisteredServices.! Item was removed: - ----- Method: FileListTest>>testMenuReturned (in category 'tests') ----- - testMenuReturned - "(self selector: #testToolRegistered) debug" - - self assert: (FileServices registeredFileReaderClasses includes: DummyToolWorkingWithFileList)! Item was removed: - ----- Method: FileListTest>>testService (in category 'tests') ----- - testService - "a stupid test to check that the class returns a service" - "(self selector: #testService) debug" - - | service | - service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'abab.kkk' suffix: 'kkk') first. - self assert: (self checkIsServiceIsFromDummyTool: service). - service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'zkk.gz' suffix: 'gz'). - self assert: service isEmpty! Item was removed: - ----- Method: FileListTest>>testServicesForFileEnding (in category 'tests') ----- - testServicesForFileEnding - "(self selector: #testServicesForFileEnding) debug" - - | items | - items := (FileList new directory: FileDirectory default; yourself) - itemsForFile: (FileDirectory default fullNameFor: 'aaa.kkk'). - self assert: (items anySatisfy: [ :ea | self checkIsServiceIsFromDummyTool: ea ]). - ! Item was removed: - ----- Method: FileListTest>>testToolRegistered (in category 'tests') ----- - testToolRegistered - "(self selector: #testToolRegistered) debug" - - self assert: (FileServices registeredFileReaderClasses includes: DummyToolWorkingWithFileList)! Item was removed: - ----- Method: FileListTest>>testToolRegisteredUsingInterface (in category 'tests') ----- - testToolRegisteredUsingInterface - "(self selector: #testToolRegisteredUsingInterface) debug" - - self assert: (FileServices isReaderNamedRegistered: #DummyToolWorkingWithFileList)! Item was removed: - TestCase subclass: #HierarchyBrowserTest - instanceVariableNames: 'browser' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! Item was removed: - ----- Method: HierarchyBrowserTest>>setUp (in category 'running') ----- - setUp - browser := HierarchyBrowser new.! Item was removed: - ----- Method: HierarchyBrowserTest>>testClassList (in category 'tests') ----- - testClassList - | c displayedClasses hierarchy | - browser initHierarchyForClass: browser class. - - c := browser class theNonMetaClass. - displayedClasses := browser classList collect: [:each | each withoutLeadingBlanks ]. - hierarchy := (c allSuperclasses reversed, {browser class}, c allSubclasses) collect: [ :each | each name ]. - self assert: displayedClasses = hierarchy.! Item was removed: - ----- Method: HierarchyBrowserTest>>testClassListIndex (in category 'tests') ----- - testClassListIndex - | expectedCat | - expectedCat := [:i | (Smalltalk at: (browser classList at: i) withoutLeadingBlanks asSymbol) category ]. - browser initHierarchyForClass: browser class. - self deny: browser classListIndex = 0. - - 1 to: 3 do: - [:n | - browser classListIndex: n. - self assert: browser classListIndex = n. - self assert: browser selectedSystemCategory = (expectedCat value: n)]! Item was removed: - ----- Method: HierarchyBrowserTest>>testClassListSansWhitespace (in category 'tests') ----- - testClassListSansWhitespace - | c displayedClasses hierarchy | - browser initHierarchyForClass: browser class. - - c := browser class theNonMetaClass. - displayedClasses := browser classList collect: [:each | each withoutLeadingBlanks ]. - hierarchy := (c allSuperclasses reversed, {browser class}, c allSubclasses) collect: [ :each | each name ]. - self assert: displayedClasses = hierarchy.! Item was removed: - ----- Method: HierarchyBrowserTest>>testInitHierarchyForClass (in category 'tests') ----- - testInitHierarchyForClass - | b | - - b := HierarchyBrowser new initHierarchyForClass: browser class. - self assert: b selectedClassName = browser class name.! Item was removed: - ----- Method: HierarchyBrowserTest>>testSelectClass (in category 'tests') ----- - testSelectClass - browser initHierarchyForClass: browser class. - browser selectClass: ProtoObject. - self assert: browser selectedClass = ProtoObject. - - browser selectClass: CodeHolder. - self assert: browser selectedClass = CodeHolder.! Item was removed: - ----- Method: HierarchyBrowserTest>>testSelectedClassName (in category 'tests') ----- - testSelectedClassName - browser initHierarchyForClass: browser class. - self assert: browser selectedClassName = browser class name. - - browser classListIndex: 0. - self assert: browser selectedClassName isNil.! Item was removed: - ClassTestCase subclass: #InspectorTest - instanceVariableNames: 'inspector' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: InspectorTest class>>shouldInheritSelectors (in category 'testing') ----- - shouldInheritSelectors - - ^ true! Item was removed: - ----- Method: InspectorTest>>assert:matches: (in category 'assertions - matching') ----- - assert: pattern matches: actual - - self - assert: [(actual isString or: [actual isText]) and: [pattern match: actual]] - description: [self comparingStringBetweenMatch: pattern and: actual]! Item was removed: - ----- Method: InspectorTest>>assertFieldSelected: (in category 'assertions - ui') ----- - assertFieldSelected: fieldName - "Looking at the inspector's #fieldList, which contains the list of labels visible to the user, check whether that list contains fieldName, which is the label the user is looking for." - - self - assert: (self inspector selectionIndex - between: 1 - and: self inspector fieldList size); - assert: fieldName - matches: (self inspector fieldList at: self inspector selectionIndex) asString.! Item was removed: - ----- Method: InspectorTest>>assertFieldVisible: (in category 'assertions - ui') ----- - assertFieldVisible: fieldNameOrPattern - - self assert: (self inspector fieldList anySatisfy: [:label | - label asString = fieldNameOrPattern - or: [fieldNameOrPattern match: label] ]).! Item was removed: - ----- Method: InspectorTest>>assertMenuWorks (in category 'assertions') ----- - assertMenuWorks - - | aMenu | - aMenu := self fieldListMenu. - self - assert: aMenu items notEmpty; - assert: (aMenu items allSatisfy: [:item | item contents notEmpty]).! Item was removed: - ----- Method: InspectorTest>>assertNoFieldSelected (in category 'assertions - ui') ----- - assertNoFieldSelected - - self assert: self inspector selectionIndex = 0.! Item was removed: - ----- Method: InspectorTest>>assertValuePaneShows: (in category 'assertions - ui') ----- - assertValuePaneShows: contents - - self assert: contents matches: self inspector contents.! Item was removed: - ----- Method: InspectorTest>>assertValuePaneWorks (in category 'assertions') ----- - assertValuePaneWorks - - ^ self denyValuePaneShows: '<*error*debug*>'! Item was removed: - ----- Method: InspectorTest>>comparingStringBetweenMatch:and: (in category 'assertions - matching') ----- - comparingStringBetweenMatch: pattern and: actual - - ^ 'Pattern {1} is not matched by actual {2}' format: ( - {pattern. actual} collect: [:arg | arg printStringLimitedTo: 10])! Item was removed: - ----- Method: InspectorTest>>createObject (in category 'running') ----- - createObject - - ^ InspectorTestObject new - apple: #discovery; - orange: #navel; - yourself! Item was removed: - ----- Method: InspectorTest>>createObjectWithTruncation (in category 'running') ----- - createObjectWithTruncation - "Create an object that will surely trigger truncation of inspector fields when being inspected." - - ^ (InspectorTestObject new: 500) - apple: #discovery; - orange: #navel; - yourself! Item was removed: - ----- Method: InspectorTest>>deny:matches: (in category 'assertions - matching') ----- - deny: pattern matches: actual - - self - deny: [(actual isString or: [actual isText]) and: [pattern match: actual]] - description: ['Actually matches {1}' format: {pattern}]! Item was removed: - ----- Method: InspectorTest>>denyFieldSelected: (in category 'assertions - ui') ----- - denyFieldSelected: fieldName - - self deny: (self inspector fieldList at: self inspector selectionIndex) asString = fieldName.! Item was removed: - ----- Method: InspectorTest>>denyFieldVisible: (in category 'assertions - ui') ----- - denyFieldVisible: fieldName - - self assert: (self inspector fieldList noneSatisfy: [:label | - label asString = fieldName]).! Item was removed: - ----- Method: InspectorTest>>denyNoFieldSelected (in category 'assertions - ui') ----- - denyNoFieldSelected - - self assert: self inspector selectionIndex > 0.! Item was removed: - ----- Method: InspectorTest>>denyValuePaneShows: (in category 'assertions - ui') ----- - denyValuePaneShows: contents - - self deny: contents matches: self inspector contents.! Item was removed: - ----- Method: InspectorTest>>denyValuePaneWorks (in category 'assertions') ----- - denyValuePaneWorks - - ^ self assertValuePaneShows: '*error*debug*'! Item was removed: - ----- Method: InspectorTest>>during:confirm: (in category 'support - ui') ----- - during: block confirm: boolean - "When evaluating the block, there will be a dialog showing up that requests the user to confirm something. Simulate that interaction here." - - block valueSupplyingAnswer: {'*'. boolean}.! Item was removed: - ----- Method: InspectorTest>>during:type: (in category 'support - ui') ----- - during: block type: expression - "When evaluating the block, there will be a dialog showing up that requests the user to type something. Simulate that interaction here." - - block valueSupplyingAnswer: {'*'. expression}.! Item was removed: - ----- Method: InspectorTest>>expectedFieldExpressionFailures (in category 'failures') ----- - expectedFieldExpressionFailures - "List all fields whose 'Get field expression' feature does not yet work." - - ^ #()! Item was removed: - ----- Method: InspectorTest>>fieldListMenu (in category 'support') ----- - fieldListMenu - - ^ self inspector fieldListMenu: MenuMorph new! Item was removed: - ----- Method: InspectorTest>>fieldTypeOfIndexedVariable (in category 'support') ----- - fieldTypeOfIndexedVariable - - ^ #indexed! Item was removed: - ----- Method: InspectorTest>>inValuePaneTypeAndAccept: (in category 'support - ui') ----- - inValuePaneTypeAndAccept: aString - "The user types aString in the value pane and accepts those contents." - - self inspector contents: aString notifying: nil.! Item was removed: - ----- Method: InspectorTest>>inspector (in category 'accessing') ----- - inspector - - ^ inspector! Item was removed: - ----- Method: InspectorTest>>makeObjectInvalid (in category 'support - error') ----- - makeObjectInvalid - "Violate some contract so that the inspector cannot call #printString on some field anymore without getting an error." - - self object beInvalid.! Item was removed: - ----- Method: InspectorTest>>object (in category 'accessing') ----- - object - - ^ self inspector object! Item was removed: - ----- Method: InspectorTest>>selectInvalidField (in category 'support - error') ----- - selectInvalidField - - self inspector selectFieldNamed: 'self'.! Item was removed: - ----- Method: InspectorTest>>setUp (in category 'running') ----- - setUp - - super setUp. - inspector := self classToBeTested on: self createObject.! Item was removed: - ----- Method: InspectorTest>>shouldntRaiseWhileDebugging: (in category 'assertions') ----- - shouldntRaiseWhileDebugging: aBlock - - aBlock newProcess runUntil: [:ctxt | - self - shouldnt: [inspector inspect: ctxt receiver] - raise: Error, Warning, Halt. - false].! Item was removed: - ----- Method: InspectorTest>>simulateStepping (in category 'support - ui') ----- - simulateStepping - - self inspector stepAt: 0 in: nil.! Item was removed: - ----- Method: InspectorTest>>tearDown (in category 'running') ----- - tearDown - - inspector object: nil. "Make sure we don't leave anything invalid in there, as that can break other tests." - inspector := nil. "Better get rid of that as well." - super tearDown! Item was removed: - ----- Method: InspectorTest>>testCustomField (in category 'tests') ----- - testCustomField - - self - during: [self inspector addCustomField] - type: 'self fruits'. - - self assertFieldVisible: 'self fruits'. - self assertFieldSelected: 'self fruits'. - self assertValuePaneShows: '*discovery*navel*'.! Item was removed: - ----- Method: InspectorTest>>testCustomFieldRemove (in category 'tests') ----- - testCustomFieldRemove - - self assert: 0 equals: self inspector customFields size. - self during: [self inspector addCustomField] type: 'self'. - self assert: 1 equals: self inspector customFields size. - - self assert: self inspector selectedField type = #custom. - self during: [self inspector removeSelection] confirm: true. - self assert: 0 equals: self inspector customFields size.! Item was removed: - ----- Method: InspectorTest>>testDebugConstruction (in category 'tests') ----- - testDebugConstruction - - self shouldntRaiseWhileDebugging: [ - self createObject]! Item was removed: - ----- Method: InspectorTest>>testExpressions (in category 'tests') ----- - testExpressions - "All fields should provide an evaluable expression to be evaluated on the inspected objects to retrieve that field's value. Try to test that by re-setting that expression as a getter and compare the resulting values." - - self inspector fields - reject: [:field | self expectedFieldExpressionFailures includes: field name asString] - thenDo: [:field | - | expression content | - (expression := self inspector expressionForField: field) ifNil: [self fail]. - content := field getValueFor: self inspector. - field setGetterFor: self inspector to: expression ifFail: [self fail]. - self assert: content equals: (field getValueFor: self inspector)].! Item was removed: - ----- Method: InspectorTest>>testFieldList (in category 'tests') ----- - testFieldList - "Check whether the most important fields are visible." - - #(self 'all inst vars' apple orange) do: [:label | - self assertFieldVisible: label].! Item was removed: - ----- Method: InspectorTest>>testFieldListError (in category 'tests - special') ----- - testFieldListError - "Choose an inspector that messes up field streaming. Check whether the field list shows still something informative." - - self class == InspectorTest ifFalse: [^ self "Pass the test automatically."]. - - inspector := InspectorTestInspector on: Object new. - - self assertFieldVisible: '<error>'. - inspector ensureSelectedField. - self assertFieldSelected: '<error>'. - self assertValuePaneShows: '*error*debug*'.! Item was removed: - ----- Method: InspectorTest>>testFieldListMenu (in category 'tests') ----- - testFieldListMenu - "Select one field after another and check whether the menu can be invoked." - - self assertNoFieldSelected. - self assertMenuWorks. - - 1 to: self inspector fieldList size do: [:index | - self inspector selectionIndex: index. - self denyNoFieldSelected. - self assertMenuWorks]. - ! Item was removed: - ----- Method: InspectorTest>>testFieldSelf (in category 'tests') ----- - testFieldSelf - "There should be at least one field pointing to the inspected object itself." - - self assert: (self inspector fields anySatisfy: [:field | field value == self object]).! Item was removed: - ----- Method: InspectorTest>>testInspectorClass (in category 'tests') ----- - testInspectorClass - "Be sure to use the correct inspector for our object-under-inspection. If this test fails, #targetClass or #setUp might be wrong." - - | previousInspectorClass | - previousInspectorClass := self inspector class. - self inspector inspect: self object. - self assert: previousInspectorClass equals: self inspector class.! Item was removed: - ----- Method: InspectorTest>>testObjectChanged (in category 'tests - special') ----- - testObjectChanged - - self class == InspectorTest ifFalse: [^ self "Pass the test automatically."]. - - self inspector selectFieldNamed: 'self'. - self denyValuePaneShows: '*ontario*'. - - self object apple: #ontario. - self denyValuePaneShows: '*ontario*'. - - self simulateStepping. - self assertValuePaneShows: '*ontario*'.! Item was removed: - ----- Method: InspectorTest>>testTruncationEllipsis (in category 'tests - special') ----- - testTruncationEllipsis - "Even the most generic inspector supports truncation of indexed variables." - - | ellipsis | - (self class includesSelector: #createObjectWithTruncation) - ifFalse: [^ self "Run this test only if explicitely refined."]. - - self inspector object: self createObjectWithTruncation. - self assert: self inspector class = self classToBeTested. "No change." - - self assert: self inspector fields size >= self inspector truncationLimit. - self assertFieldVisible: '...'. - - self inspector selectFieldSuchThat: [:field | field type = #ellipsis]. - ellipsis := self inspector selectedField. - - self assert: '*...*' matches: ellipsis name. - self assertValuePaneShows: '*not shown*'. - - self inspector fields do: [:field | - "All visible elements are from that object." - self assert: (field type = #element) ==> [self inspector object includes: field value]].! Item was removed: - ----- Method: InspectorTest>>testTruncationEllipsisInspectOne (in category 'tests - special') ----- - testTruncationEllipsisInspectOne - - (self class includesSelector: #createObjectWithTruncation) - ifFalse: [^ self "Run this test only if explicitely refined."]. - - self inspector object: self createObjectWithTruncation. - self inspector selectFieldSuchThat: [:field | field type = #ellipsis]. - - self - shouldnt: [self inspector elementAt: self inspector truncationLimit - self inspector truncationTail] - raise: NotFound.! Item was removed: - ----- Method: InspectorTest>>testTruncationEllipsisMenu (in category 'tests - special') ----- - testTruncationEllipsisMenu - - (self class includesSelector: #createObjectWithTruncation) - ifFalse: [^ self "Run this test only if explicitely refined."]. - - self inspector object: self createObjectWithTruncation. - self inspector selectFieldSuchThat: [:field | field type = #ellipsis]. - self assertMenuWorks.! Item was removed: - ----- Method: InspectorTest>>testTruncationTail (in category 'tests - special') ----- - testTruncationTail - - | ellipsisIndex firstElementIndex | - (self class includesSelector: #createObjectWithTruncation) - ifFalse: [^ self "Run this test only if explicitely refined."]. - - self inspector object: self createObjectWithTruncation. - - firstElementIndex := self inspector fields - findFirst: [:field | field type = self fieldTypeOfIndexedVariable]. - ellipsisIndex := self inspector fields - findFirst: [:field | field type = #ellipsis]. - - self - assert: self inspector truncationLimit - equals: ellipsisIndex - firstElementIndex + 1 + self inspector truncationTail; - assert: self inspector truncationTail - equals: self inspector fields size - ellipsisIndex.! Item was removed: - ----- Method: InspectorTest>>testValuePane (in category 'tests') ----- - testValuePane - "Select one field after another and check whether the value pane shows non-error contents." - - self assertNoFieldSelected. - self assertValuePaneWorks. - - 1 to: self inspector fieldList size do: [:index | - self inspector selectionIndex: index. - self denyNoFieldSelected. - self assertValuePaneWorks].! Item was removed: - ----- Method: InspectorTest>>testValuePaneError (in category 'tests') ----- - testValuePaneError - - self makeObjectInvalid. - self assertValuePaneWorks. - - self selectInvalidField. - self denyValuePaneWorks.! Item was removed: - ----- Method: InspectorTest>>testValuePaneModify (in category 'tests') ----- - testValuePaneModify - - self inspector selectFieldNamed: #apple. - - self deny: #ontario equals: self object apple. - self assertValuePaneShows: '#discovery'. - - self inValuePaneTypeAndAccept: '#ontario'. - - self assert: #ontario equals: self object apple. - self assertValuePaneShows: '#ontario'.! Item was removed: - Inspector variableSubclass: #InspectorTestInspector - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: InspectorTestInspector>>streamFieldsOn: (in category 'fields - streaming') ----- - streamFieldsOn: aStream - - self error.! Item was removed: - Object variableSubclass: #InspectorTestObject - instanceVariableNames: 'apple orange' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: InspectorTestObject class>>newInvalid (in category 'instance creation') ----- - newInvalid - "Creates an instance that cannot #printOn: without raising an error." - - ^ self new - beInvalid; - yourself! Item was removed: - ----- Method: InspectorTestObject>>apple (in category 'accessing') ----- - apple - - ^ apple! Item was removed: - ----- Method: InspectorTestObject>>apple: (in category 'accessing') ----- - apple: aSymbol - - apple := aSymbol.! Item was removed: - ----- Method: InspectorTestObject>>beInvalid (in category 'initialization') ----- - beInvalid - - self apple: 5.! Item was removed: - ----- Method: InspectorTestObject>>fruits (in category 'accessing') ----- - fruits - - ^ {self apple. self orange} select: [:fruit | fruit notNil and: [fruit size > 0]]! Item was removed: - ----- Method: InspectorTestObject>>orange (in category 'accessing') ----- - orange - - ^ orange! Item was removed: - ----- Method: InspectorTestObject>>orange: (in category 'accessing') ----- - orange: aSymbol - - orange := aSymbol.! Item was removed: - ----- Method: InspectorTestObject>>printOn: (in category 'printing') ----- - printOn: aStream - - aStream nextPutAll: 'Today''s offers: '. - self fruits do: [:fruit | aStream print: fruit].! Item was removed: - TestCase subclass: #MessageNamesTest - instanceVariableNames: 'browser' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! Item was removed: - ----- Method: MessageNamesTest>>setUp (in category 'running') ----- - setUp - browser := MessageNames openMessageNames.! Item was removed: - ----- Method: MessageNamesTest>>tearDown (in category 'running') ----- - tearDown - browser topView ifNotNil: [:v | - ToolBuilder default close: v].! Item was removed: - ----- Method: MessageNamesTest>>testCannotUnselectCategory (in category 'tests') ----- - testCannotUnselectCategory - | selectorList | - browser searchString: 'cull'. - browser selectorListIndex: 1. - selectorList := browser selectorList copy. - - browser selectorListIndex: 0. - self assert: selectorList = browser selectorList.! Item was removed: - ----- Method: MessageNamesTest>>testOpenMessageNames (in category 'tests') ----- - testOpenMessageNames - | b | - b := MessageNames openMessageNames. - [self assert: (b isKindOf: MessageNames)] - ensure: [ToolBuilder default close: b topView].! Item was removed: - ----- Method: MessageNamesTest>>testSearchString (in category 'tests') ----- - testSearchString - | cCount cullCount cullCullCount | - browser searchString: 'c'. - cCount := browser selectorList size. - - browser searchString: 'cull:'. - cullCount := browser selectorList size. - - self assert: cullCount < cCount. - - browser searchString: 'cull:cull:'. - cullCullCount := browser selectorList size. - - self assert: cullCullCount < cullCount.! Item was removed: - ----- Method: MessageNamesTest>>testSelectedClassOrMetaClass (in category 'tests') ----- - testSelectedClassOrMetaClass - | firstClass | - browser searchString: 'cull:'. - firstClass := browser messageList first actualClass. - - browser messageListIndex: 1. - self assert: browser selectedClassOrMetaClass = firstClass. - - browser messageListIndex: 0. - self assert: browser selectedClassOrMetaClass isNil. - - "And just to be sure:" - browser messageListIndex: 1. - self assert: browser selectedClassOrMetaClass = firstClass.! Item was removed: - ----- Method: MessageNamesTest>>testSelectedMessageCategoryName (in category 'tests') ----- - testSelectedMessageCategoryName - browser searchString: 'cull:'. - browser selectorListIndex: 1. - browser messageListIndex: 1. - self deny: browser selectedMessageCategoryName isNil. - - browser messageListIndex: 0. - self assert: browser selectedMessageCategoryName isNil.! Item was removed: - ----- Method: MessageNamesTest>>testSelection (in category 'tests') ----- - testSelection - browser searchString: 'cull:'. - browser selectorListIndex: 1. - browser messageListIndex: 1. - self assert: (browser selection isKindOf: MethodReference). - browser messageListIndex: 0. - self assert: browser selection isNil.! Item was removed: - TestCase subclass: #MessageSetTest - instanceVariableNames: 'browser updates' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! Item was removed: - ----- Method: MessageSetTest>>initialize (in category 'initialize-release') ----- - initialize - super initialize. - - "Contains the triggers sent by the model during its updates." - updates := OrderedCollection new.! Item was removed: - ----- Method: MessageSetTest>>setUp (in category 'running') ----- - setUp - browser := (MessageSet - openMessageList: (SystemNavigation default allImplementorsOf: #browseAllImplementorsOf:) - name: 'Test MessageSet' - autoSelect: nil) model. - - browser addDependent: self.! Item was removed: - ----- Method: MessageSetTest>>tearDown (in category 'running') ----- - tearDown - ToolBuilder default close: browser topView.! Item was removed: - ----- Method: MessageSetTest>>testAutoSelectString (in category 'tests') ----- - testAutoSelectString - browser autoSelectString: 'browseAllImplementorsOf:'. - self assert: browser autoSelectString = 'browseAllImplementorsOf:'. - browser messageListIndex: 2. - self assert: (updates includes: #autoSelect).! Item was removed: - ----- Method: MessageSetTest>>testContents (in category 'tests') ----- - testContents - browser messageListIndex: 0. - self assert: browser contents = ''. - - browser messageListIndex: 1. - self deny: browser contents = ''. - ! Item was removed: - ----- Method: MessageSetTest>>testHasMessageSelected (in category 'tests') ----- - testHasMessageSelected - browser messageListIndex: 1. - self assert: browser hasMessageSelected. - - browser messageListIndex: 0. - self deny: browser hasMessageSelected. - - "And just to be sure:" - browser messageListIndex: 1. - self assert: browser hasMessageSelected.! Item was removed: - ----- Method: MessageSetTest>>testRemoveMessageFromBrowser (in category 'tests') ----- - testRemoveMessageFromBrowser - | count sel | - browser messageListIndex: 1. - sel := browser selection. - - browser removeMessageFromBrowser. - self deny: (browser messageList includes: sel) description: 'Method not removed'. - - browser messageListIndex: 0. - count := browser messageList size. - browser removeMessageFromBrowser. - self assert: count = browser messageList size description: 'Some method was removed'.! Item was removed: - ----- Method: MessageSetTest>>testSelectedClassOrMetaClass (in category 'tests') ----- - testSelectedClassOrMetaClass - | firstClass | - firstClass := browser messageList first actualClass. - - browser messageListIndex: 1. - self assert: browser selectedClassOrMetaClass = firstClass. - - browser messageListIndex: 0. - self assert: browser selectedClassOrMetaClass isNil. - - "And just to be sure:" - browser messageListIndex: 1. - self assert: browser selectedClassOrMetaClass = firstClass.! Item was removed: - ----- Method: MessageSetTest>>testSelectedMessageCategoryName (in category 'tests') ----- - testSelectedMessageCategoryName - | firstCat methodRef | - methodRef := browser messageList first. - firstCat := methodRef actualClass organization categoryOfElement: methodRef selector. - - browser messageListIndex: 1. - self assert: browser selectedMessageCategoryName = firstCat. - - browser messageListIndex: 0. - self assert: browser selectedMessageCategoryName isNil. - - "And just to be sure:" - browser messageListIndex: 1. - self assert: browser selectedMessageCategoryName = firstCat.! Item was removed: - ----- Method: MessageSetTest>>testSelectedMessageName (in category 'tests') ----- - testSelectedMessageName - | firstSel | - firstSel := browser messageList first selector. - - browser messageListIndex: 1. - self assert: browser selectedMessageName = firstSel. - - browser messageListIndex: 0. - self assert: browser selectedMessageName isNil. - - "And just to be sure:" - browser messageListIndex: 1. - self assert: browser selectedMessageName = firstSel.! Item was removed: - ----- Method: MessageSetTest>>testSelection (in category 'tests') ----- - testSelection - | firstRef | - firstRef := browser messageList first. - - browser messageListIndex: 1. - self assert: browser selection = firstRef. - - browser messageListIndex: 0. - self assert: browser selection isNil. - - "And just to be sure:" - browser messageListIndex: 1. - self assert: browser selection = firstRef.! Item was removed: - ----- Method: MessageSetTest>>update: (in category 'private') ----- - update: aSelector - updates addLast: aSelector.! Item was removed: - MessageSetTest subclass: #MessageTraceTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! Item was removed: - ----- Method: MessageTraceTest>>setUp (in category 'running') ----- - setUp - browser := (MessageTrace - openMessageList: (SystemNavigation default allImplementorsOf: #browseAllImplementorsOf:) - name: 'Test MessageSet' - autoSelect: nil) model. - - browser addDependent: self.! Item was removed: - ----- Method: MessageTraceTest>>testRemoveMessageFromBrowser (in category 'tests') ----- - testRemoveMessageFromBrowser - | count sel | - browser messageListIndex: 1. - sel := browser selection. - - browser removeMessageFromBrowser. - self deny: (browser messageList includes: sel) description: 'Method not removed'. - - "In a MessageTrace, having an unselected message and then removing it means 'remove the first message'." - browser messageListIndex: 0. - count := browser messageList size. - browser removeMessageFromBrowser. - self assert: count - 1 = browser messageList size description: 'Method not removed'.! Item was removed: - TestCase subclass: #PackagePaneBrowserTest - instanceVariableNames: 'browser' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Browser'! Item was removed: - ----- Method: PackagePaneBrowserTest>>setUp (in category 'running') ----- - setUp - browser := PackagePaneBrowser new.! Item was removed: - ----- Method: PackagePaneBrowserTest>>testClassList (in category 'tests') ----- - testClassList - browser selectSystemCategory: browser class category. - self assert: browser classList = (SystemOrganization listAtCategoryNamed: browser class category). - - browser selectSystemCategory: nil. - self assert: browser classList isEmpty.! Item was removed: - ----- Method: PackagePaneBrowserTest>>testPackageListIndex (in category 'tests') ----- - testPackageListIndex - browser packageListIndex: 0. - self assert: browser selectedClass isNil. - - browser selectCategoryForClass: browser class. - - "Clicking the selected package unselects the selected class." - browser packageListIndex: browser packageListIndex. - self assert: browser selectedClass isNil.! Item was removed: - ----- Method: PackagePaneBrowserTest>>testSelectCategoryForClass (in category 'tests') ----- - testSelectCategoryForClass - | pkgName | - pkgName := browser class category copyUpTo: $-. - browser selectCategoryForClass: browser class. - self assert: browser selectedSystemCategory = browser class category. - self assert: browser packageListIndex = (browser packageList indexOf: pkgName). - browser selectSystemCategory: nil. - self assert: browser classList isEmpty.! Item was removed: - CollectionInspectorTest subclass: #SetInspectorTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: SetInspectorTest>>createObject (in category 'running') ----- - createObject - - ^ Set new - addAll: #(navel discovery smith boskoop); - yourself - ! Item was removed: - ----- Method: SetInspectorTest>>createObjectWithTruncation (in category 'running') ----- - createObjectWithTruncation - - ^ (1 to: 150) asSet! Item was removed: - ----- Method: SetInspectorTest>>makeObjectInvalid (in category 'support - error') ----- - makeObjectInvalid - - self object add: InspectorTestObject newInvalid. - self simulateStepping.! Item was removed: - ----- Method: SetInspectorTest>>selectInvalidField (in category 'support - error') ----- - selectInvalidField - - self inspector selectFieldSuchThat: [:field | - field type = #element and: [field value class == InspectorTestObject]].! Item was removed: - ----- Method: SetInspectorTest>>testAddElement (in category 'tests') ----- - testAddElement - "Like super implementation but not checking the field names since we cannot now the exact indices of a set's internal array." - - self deny: (self object includes: 42). - - self - during: [self inspector addElement] - type: '6 * 7'. "42" - - self assert: (self object includes: 42). - self assertValuePaneShows: '42'.! Item was removed: - ----- Method: SetInspectorTest>>testFieldList (in category 'tests') ----- - testFieldList - - #(self 'all inst vars') do: [:label | self assertFieldVisible: label]. - - self object do: [:element | self assert: ( - self inspector fields anySatisfy: [:field | - field type =#element and: [field value == element]] )]! Item was removed: - ----- Method: SetInspectorTest>>testNil (in category 'tests') ----- - testNil - "Check proper use of a set's enclosed elements." - - self deny: (self object includes: nil). - self deny: (self inspector fields anySatisfy: [:field | field value isNil]). - - self object add: nil. - self simulateStepping. - - self assert: (self inspector fields anySatisfy: [:field | field value isNil]).! Item was removed: - TestCase subclass: #ToolMenusTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Menus'! Item was removed: - ----- Method: ToolMenusTest>>testCodePaneMenu (in category 'tests') ----- - testCodePaneMenu - "Checks whether all menu actions are implemented in either the model or the widget." - - | builder builderSelector menuSelector result | - builder := ToolBuilder default. - builderSelector := #buildCodePaneWith:. - menuSelector := #menu. - result := Dictionary new. - - Model withAllSubclasses - select: [:modelClass | modelClass includesSelector: builderSelector] - thenDo: [:modelClass | - | model spec widget menu selectors | - result at: modelClass put: OrderedCollection new. - model := modelClass new. - spec := model perform: builderSelector with: builder. - (spec respondsTo: menuSelector) ifFalse: [ - "Little hack to allow code panes being wrapped in panels." - spec := spec children detect: [:child | - (child respondsTo: menuSelector) and: [(child perform: menuSelector) notNil]]]. - [widget := builder build: spec] on: Error do: [:ex | ex resume: nil]. - #(false true) do: [:shifted | - menu := builder build: (builder pluggableMenuSpec new items; yourself). - menu := model perform: spec menu withEnoughArguments: {menu. shifted}. - selectors := menu items collect: [:item | item selector]. - "MVC: selectors := menu selections select: [:sel | sel isSymbol]" - (result at: modelClass) - addAll: (selectors reject: [:selector | - (model respondsTo: selector) or: [widget respondsTo: selector]])]]. - - self assert: (result values allSatisfy: [:notImplementedSelectors | notImplementedSelectors isEmpty]).! Item was removed: - SetInspectorTest subclass: #WeakSetInspectorTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'ToolsTests-Inspector'! Item was removed: - ----- Method: WeakSetInspectorTest>>createObject (in category 'running') ----- - createObject - - | weakSet | - weakSet := WeakSet withAll: super createObject. - Smalltalk garbageCollect. - ^ weakSet! Item was removed: - ----- Method: WeakSetInspectorTest>>testDebugConstruction (in category 'tests') ----- - testDebugConstruction - "Ignore."! Item was removed: - ----- Method: WeakSetInspectorTest>>testSymbolTableM6812 (in category 'tests') ----- - testSymbolTableM6812 - "This test is related to http://bugs.squeak.org/view.php?id=6812. Check whether field selection and garbage collection are somehow interfering." - - | getRandomSymbol symbols priorContents currentContents currentIndex | - <timeout: 30> - self object removeAll. - - getRandomSymbol := [ - | token | - token := (1 to: 10) collect: [:ea | ($a to: $z) atRandom] as: String. - (Symbol lookup: token) ifNil: [token asSymbol] ifNotNil: [nil]]. - - symbols := OrderedCollection new. - 10 timesRepeat: [ - getRandomSymbol value ifNotNil: [:symbol | symbols add: symbol]]. - - self object addAll: symbols. - Smalltalk garbageCollect. - self assert: symbols size equals: self object size. - self assert: symbols notEmpty. - - 1 to: symbols size do: [:round | - currentIndex := 1. - symbols removeLast. - - [(currentIndex := currentIndex + 1) <= self inspector fieldList size] - whileTrue: [ - self inspector selectionIndex: currentIndex. - self assert: priorContents ~= (currentContents := self inspector contents). - priorContents := currentContents. - - Smalltalk garbageCollect. "Removes symbol from weak set" - self simulateStepping. "Removes field from weak-set inspector"]]. - - self assert: symbols isEmpty. - self assert: self object isEmpty.!

1 0

The Treated Inbox: ToolsTests-jar.111.mcz
by commits＠source.squeak.org 15 Feb '23

15 Feb '23

Marcel Taeumel uploaded a new version of ToolsTests to project The Treated Inbox: http://source.squeak.org/treated/ToolsTests-jar.111.mcz ==================== Summary ==================== Name: ToolsTests-jar.111 Author: jar Time: 9 June 2022, 1:57:53.457529 pm UUID: 3119b2a0-1c29-5d47-ab08-9a95a4691027 Ancestors: ToolsTests-ct.109 Fix two failing and/or incorrect tests; complement Tools-jar.1161. For further info see http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-January/218167.… This changeset replaces Tools-jar.1159 (i.e. please remove from Inbox) =============== Diff against ToolsTests-ct.109 =============== Item was changed: ----- Method: DebuggerTests>>test19Abandon (in category 'tests') ----- test19Abandon "When the debugger is abandoned, the interrupted process is terminated aggressively, i.e., all not yet started unwind contexts are executed. Further errors that occur during unwinding lead to another debugger showing up. This is the acceptance test equivalent for ProcessTest >> #testTerminateNestedUnwindAggressively." | x y z userProcess | process := Process forBlock: + [[x := 1] ensure: + [[y := 1. + self error: #first. + y := 2] ensure: + [z := 1. + self error: #second. + z := 2]]. - [x := 1. - [y := 1. - self error: #first. - y := 2] ensure: - [z := 1. - self error: #second. - z := 2]. x := 2] runUntil: [:ctx | y = 1]. self should: {x. y. z} = {1. 1. nil}. debugger := process debug. userProcess := [debugger proceed] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self deny: process isTerminated. self assert: userProcess isTerminated. self deny: debugger isNil. self assert: {1. 1. nil} equals: {x. y. z}. self assert: (debugger containingWindow label includesSubstring: #first). userProcess := [debugger abandon] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self deny: process isTerminated. self assert: userProcess isTerminated. self deny: debugger isNil. self assert: {1. 1. 1} equals: {x. y. z}. self assert: (debugger containingWindow label includesSubstring: #second). userProcess := [debugger proceed] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self assert: process isTerminated. self assert: userProcess isTerminated. self assert: debugger isNil. self assert: {1. 1. 2} equals: {x. y. z}.! Item was changed: ----- Method: DebuggerTests>>test20TerminateProcess (in category 'tests') ----- test20TerminateProcess "When the debugger's process is terminated, all unwind contexts, including already entered ones, are executed. Further errors that occur during unwinding lead to another debugger showing up. This is the acceptance test equivalent for ProcessTest >> #testTerminateNestedUnwind." | x y z userProcess | process := Process forBlock: + [[x := 1] ensure: + [[y := 1. + self error: #first. + y := 2] ensure: + [z := 1. + self error: #second. + z := 2]]. - [x := 1. - [y := 1. - self error: #first. - y := 2] ensure: - [z := 1. - self error: #second. - z := 2]. x := 2] runUntil: [:ctx | y = 1]. self should: {x. y. z} = {1. 1. nil}. debugger := process debug. userProcess := [debugger proceed] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self deny: process isTerminated. self assert: userProcess isTerminated. self deny: debugger isNil. self assert: {1. 1. nil} equals: {x. y. z}. self assert: (debugger containingWindow label includesSubstring: #first). userProcess := [debugger terminateProcess] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self deny: process isTerminated. self assert: userProcess isTerminated. self deny: debugger isNil. self assert: {1. 2. 1} equals: {x. y. z}. self assert: (debugger containingWindow label includesSubstring: #second). userProcess := [debugger proceed] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self assert: process isTerminated. self assert: userProcess isTerminated. self assert: debugger isNil. + self assert: {1. 2. 2} equals: {x. y. z}.! - self assert: {2. 2. 2} equals: {x. y. z}.!

1 0

The Treated Inbox: ToolsTests-jar.110.mcz
by commits＠source.squeak.org 15 Feb '23

15 Feb '23

Marcel Taeumel uploaded a new version of ToolsTests to project The Treated Inbox: http://source.squeak.org/treated/ToolsTests-jar.110.mcz ==================== Summary ==================== Name: ToolsTests-jar.110 Author: jar Time: 29 May 2022, 5:12:47.102993 pm UUID: e91394a0-163c-e046-ac57-f020cef82f24 Ancestors: ToolsTests-ct.109 Fix failing/incorrect tests; complement Tools-jar.1159. For further info see http://lists.squeakfoundation.org/pipermail/squeak-dev/2022-January/218167.… =============== Diff against ToolsTests-ct.109 =============== Item was changed: ----- Method: DebuggerTests>>test19Abandon (in category 'tests') ----- test19Abandon "When the debugger is abandoned, the interrupted process is terminated aggressively, i.e., all not yet started unwind contexts are executed. Further errors that occur during unwinding lead to another debugger showing up. This is the acceptance test equivalent for ProcessTest >> #testTerminateNestedUnwindAggressively." | x y z userProcess | process := Process forBlock: + [[x := 1] ensure: + [[y := 1. + self error: #first. + y := 2] ensure: + [z := 1. + self error: #second. + z := 2]]. - [x := 1. - [y := 1. - self error: #first. - y := 2] ensure: - [z := 1. - self error: #second. - z := 2]. x := 2] runUntil: [:ctx | y = 1]. self should: {x. y. z} = {1. 1. nil}. debugger := process debug. userProcess := [debugger proceed] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self deny: process isTerminated. self assert: userProcess isTerminated. self deny: debugger isNil. self assert: {1. 1. nil} equals: {x. y. z}. self assert: (debugger containingWindow label includesSubstring: #first). userProcess := [debugger abandon] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self deny: process isTerminated. self assert: userProcess isTerminated. self deny: debugger isNil. self assert: {1. 1. 1} equals: {x. y. z}. self assert: (debugger containingWindow label includesSubstring: #second). userProcess := [debugger proceed] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self assert: process isTerminated. self assert: userProcess isTerminated. self assert: debugger isNil. self assert: {1. 1. 2} equals: {x. y. z}.! Item was changed: ----- Method: DebuggerTests>>test20TerminateProcess (in category 'tests') ----- test20TerminateProcess "When the debugger's process is terminated, all unwind contexts, including already entered ones, are executed. Further errors that occur during unwinding lead to another debugger showing up. This is the acceptance test equivalent for ProcessTest >> #testTerminateNestedUnwind." | x y z userProcess | process := Process forBlock: + [[x := 1] ensure: + [[y := 1. + self error: #first. + y := 2] ensure: + [z := 1. + self error: #second. + z := 2]]. - [x := 1. - [y := 1. - self error: #first. - y := 2] ensure: - [z := 1. - self error: #second. - z := 2]. x := 2] runUntil: [:ctx | y = 1]. self should: {x. y. z} = {1. 1. nil}. debugger := process debug. userProcess := [debugger proceed] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self deny: process isTerminated. self assert: userProcess isTerminated. self deny: debugger isNil. self assert: {1. 1. nil} equals: {x. y. z}. self assert: (debugger containingWindow label includesSubstring: #first). userProcess := [debugger terminateProcess] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self deny: process isTerminated. self assert: userProcess isTerminated. self deny: debugger isNil. self assert: {1. 2. 1} equals: {x. y. z}. self assert: (debugger containingWindow label includesSubstring: #second). userProcess := [debugger proceed] forkAt: Processor activePriority + 1. Processor yield. self findDebugger. self assert: process isTerminated. self assert: userProcess isTerminated. self assert: debugger isNil. + self assert: {1. 2. 2} equals: {x. y. z}.! - self assert: {2. 2. 2} equals: {x. y. z}.!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages February 2023