Squeak-dev January 2022

squeak-dev@lists.squeakfoundation.org

33 participants
361 discussions

The Inbox: KernelTests-jar.421.mcz
by commits＠source.squeak.org 05 Jan '22

05 Jan '22

A new version of KernelTests was added to project The Inbox: http://source.squeak.org/inbox/KernelTests-jar.421.mcz ==================== Summary ==================== Name: KernelTests-jar.421 Author: jar Time: 5 January 2022, 3:15:22.031959 pm UUID: 97065f2d-925e-d04e-9bfb-69efecc5f415 Ancestors: KernelTests-ct.418 a battery of tests to complement new #terminate (Kernel-jar.1443 or later). replacing individual changesets: KernelTests-jar.406 KernelTests-jar.407 KernelTests-jar.415 KernelTests-jar.416 KernelTests-jar.417 KernelTests-jar.419 KernelTests-jar.420 please kindly remove these from the Inbox =============== Diff against KernelTests-ct.418 =============== Item was added: + ----- Method: MutexTest>>testMutexInCriticalEnsureArgument (in category 'tests') ----- + testMutexInCriticalEnsureArgument "self run: #testMutexInCriticalEnsureArgument" + "This tests whether a process that is in the ensure argument block in critical: but has yet to evaluate the primitiveExitCriticalSection + leaves it with the mutex unlocked." + + | terminatee mutex | + mutex := Mutex new. + terminatee := [mutex critical: []] newProcess. + self assert: terminatee isSuspended. + terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #primitiveExitCriticalSection]. + self assert: terminatee isSuspended. + terminatee terminate. + self deny: mutex isOwned. + self assert: mutex isEmpty! Item was changed: ----- Method: ProcessTest>>testAtomicSuspend (in category 'tests') ----- testAtomicSuspend "Test atomic suspend of foreign processes" | list p | p := [semaphore wait] fork. Processor yield. list := p suspendPrimitivelyOrFail. + self assert: + (Smalltalk processSuspensionUnblocks + ifFalse: [list isNil] + ifTrue: [list == semaphore])! - self assert: list == semaphore. - ! Item was added: + ----- Method: ProcessTest>>testResumeTerminatingProcess (in category 'tests') ----- + testResumeTerminatingProcess + + | terminatee terminator resumed semaphore | + semaphore := Semaphore new. + terminatee := [semaphore critical:[]. resumed := true] fork. + Processor yield. + terminator := [terminatee terminate] newProcess. + self assert: terminatee suspendingList == semaphore. + self assert: terminator isSuspended. + "run terminator and stop inside #releaseCriticalSection:" + terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #selectorJustSentOrSelf]. + self assert: terminator isSuspended. + "resume the terminatee process and and check if the VM raises an error; + an error is expected because terminatee's suspendedContext equals nil" + self should: [terminatee resume] raise: Error. + "now let the terminator finish terminating the terminatee process" + terminator resume. + Processor yield. + self assert: resumed isNil. + self assert: terminatee isTerminated. + self assert: terminator isTerminated! Item was added: + ----- Method: ProcessTest>>testRevisedSuspendExpectations (in category 'tests') ----- + testRevisedSuspendExpectations + "Test revised suspend expectations vs. pre-2022 VM's suspend" + + | s p list | + s := Semaphore new. + p := [s critical:[]] forkAt: Processor activePriority + 1. + list := p suspend. + + Smalltalk processSuspensionUnblocks + ifFalse: [ + self assert: p suspendingList equals: nil. + self assert: list equals: nil. + self deny: p suspendedContext selectorJustSentOrSelf equals: #wait + ] + ifTrue: [ + self assert: p suspendingList equals: nil. + self assert: list equals: s. + self assert: p suspendedContext selectorJustSentOrSelf equals: #wait + ]! Item was added: + ----- Method: ProcessTest>>testTerminateEnsureAsStackTop (in category 'tests') ----- + testTerminateEnsureAsStackTop + "Test #ensure unwind block is executed even when #ensure context is on stack's top." + + | p1 p2 p3 x1 x2 x3 | + x1 := x2 := x3 := false. + + "p1 is at the beginning of the ensure block and the unwind block hasn't run yet" + p1 := Process + forBlock: [[] ensure: [x1 := x1 not]] + runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) isNil]]. + + "p2 has already set complete to true (tempAt: 2) but the unwind block hasn't run yet" + p2 := Process + forBlock: [[] ensure: [x2 := x2 not]] + runUntil: [:ctx | ctx isUnwindContext and: [(ctx tempAt: 2) notNil]]. + + "p3 has already set complete to true AND the unwind block has run already run; + we have to verify the unwind block is not executed again during termination" + p3 := Process + forBlock: [[] ensure: [x3 := x3 not]] + runUntil: [:ctx | ctx isUnwindContext and: [ctx willReturn]]. + + "make sure all processes are running and only the p3's unwind block has finished" + self deny: p1 isTerminated | p2 isTerminated | p3 isTerminated. + self deny: x1 | x2. + self assert: x3. "p3 has already run its unwind block; we test it won't run it again" + "terminate all processes and verify all unwind blocks have finished correctly" + p1 terminate. p2 terminate. p3 terminate. + self assert: p1 isTerminated & p2 isTerminated & p3 isTerminated. + self assert: x1 & x2 & x3! Item was added: + ----- Method: ProcessTest>>testTerminateInTerminate (in category 'tests') ----- + testTerminateInTerminate + "Terminating a terminator process should unwind both the terminator and its terminatee process" + + | terminator terminatee unwound | + unwound := false. + terminatee := [[Processor activeProcess suspend] ensure: [unwound := true]] fork. + Processor yield. + terminator := [terminatee terminate] newProcess. + self assert: terminatee isSuspended. + self assert: terminator isSuspended. + terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #suspend]. "first #suspend in #terminate" + self assert: terminator isSuspended. + terminator terminate. + self assert: terminator isTerminated. + self assert: unwound! Item was added: + ----- Method: ProcessTest>>testTerminateTerminatingProcess (in category 'tests') ----- + testTerminateTerminatingProcess + + | terminatee terminator resumed semaphore | + semaphore := Semaphore new. + terminatee := [semaphore critical:[]. resumed := true] fork. + Processor yield. + terminator := [terminatee terminate] newProcess. + self assert: terminatee suspendingList == semaphore. + self assert: terminator isSuspended. + "run terminator and stop inside #releaseCriticalSection:" + terminator runUntil: [:ctx | ctx selectorToSendOrSelf = #selectorJustSentOrSelf]. + self assert: terminator isSuspended. + "terminate the terminatee process again and let the termination finish; + an error is expected because #terminate detected multiple termination" + self should: [terminatee terminate] raise: Error. + "now let the terminator finish terminating the terminatee process" + terminator resume. + Processor yield. + self assert: resumed isNil. + self assert: terminatee isTerminated. + self assert: terminator isTerminated! Item was added: + ----- Method: SemaphoreTest>>testSemaInCriticalEnsureArgument (in category 'tests') ----- + testSemaInCriticalEnsureArgument "self run: #testSemaInCriticalEnsureArgument" + "This tests whether a process that is in ensure argument block but has yet to evaluate the signal + leaves it with signaling the associated semaphore." + + | terminatee sema | + sema := Semaphore forMutualExclusion. + terminatee := [sema critical: []] newProcess. + self assert: terminatee isSuspended. + terminatee runUntil: [:ctx | ctx selectorToSendOrSelf = #signal]. + self assert: terminatee isSuspended. + terminatee terminate. + self assert: terminatee isTerminated. + self assert: sema excessSignals = 1 ! Item was added: + ProcessTest subclass: #UnwindTest + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'KernelTests-Processes'! Item was added: + ----- Method: UnwindTest>>testTerminateActiveInNestedEnsure1 (in category 'tests') ----- + testTerminateActiveInNestedEnsure1 + "Terminate active process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [Processor activeProcess terminate] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateActiveInNestedEnsure2 (in category 'tests') ----- + testTerminateActiveInNestedEnsure2 + "Terminate active process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [ ] ensure: [ + Processor activeProcess terminate. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateBlockedInNestedEnsure1 (in category 'tests') ----- + testTerminateBlockedInNestedEnsure1 + "Terminate blocked process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [semaphore wait] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is blocked and none of the unwind blocks has finished yet" + self assert: p isBlocked. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + Smalltalk processSuspensionUnblocks ifFalse: [ + "terminate will suspend the process first and suspend will put the process back at #wait and + so unwind will put the process back at the wait; to continue, semaphore needs to be signaled" + "self assert: p isBlocked. <-- this wouldn't work because terminate set suspendedContext to nil" + self deny: x1 | x2 | x3 | x4. + semaphore signal. + Processor yield]. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateBlockedInNestedEnsure2 (in category 'tests') ----- + testTerminateBlockedInNestedEnsure2 + "Terminate blocked process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [ ] ensure: [ + semaphore wait. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is blocked and none of the unwind blocks has finished yet" + self assert: p isBlocked. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + Smalltalk processSuspensionUnblocks ifFalse: [ + "terminate will suspend the process first and suspend will put the process back at #wait and + so unwind will put the process back at the wait; to continue, semaphore needs to be signaled" + "self assert: p isBlocked. <-- this wouldn't work because terminate set suspendedContext to nil" + self deny: x1 | x2 | x3 | x4. + semaphore signal. + Processor yield]. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn1 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn1 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true. return value]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x3. + self deny: x2 & x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn2 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn2 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [] ensure: [ + Processor activeProcess suspend. + x1 := true. return value]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x3. + self deny: x2 & x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn3 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn3 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true]. + x2 := true. return value] + ] ensure: [ + x3 := true]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn4 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn4 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [] ensure: [ + Processor activeProcess suspend. + x1 := true]. + x2 := true. return value] + ] ensure: [ + x3 := true]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn5 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn5 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true. return value]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn6 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn6 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [] ensure: [ + Processor activeProcess suspend. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true. return value]. + x4 := true. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn7 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn7 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. return value. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateInNestedEnsureWithReturn8 (in category 'tests') ----- + testTerminateInNestedEnsureWithReturn8 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [:return | + [ + [ ] ensure: [ + [] ensure: [ + Processor activeProcess suspend. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. return value. + ] valueWithExit + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateRunnableInNestedEnsure1 (in category 'tests') ----- + testTerminateRunnableInNestedEnsure1 + "Terminate runnable process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [Processor yield] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is runnable and none of the unwind blocks has finished yet" + self assert: p isRunnable. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateRunnableInNestedEnsure2 (in category 'tests') ----- + testTerminateRunnableInNestedEnsure2 + "Terminate runnable process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [ ] ensure: [ + Processor yield. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is runnable and none of the unwind blocks has finished yet" + self assert: p isRunnable. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateSuspendedInNestedEnsure1 (in category 'tests') ----- + testTerminateSuspendedInNestedEnsure1 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [Processor activeProcess suspend] ensure: [ + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.! Item was added: + ----- Method: UnwindTest>>testTerminateSuspendedInNestedEnsure2 (in category 'tests') ----- + testTerminateSuspendedInNestedEnsure2 + "Terminate suspended process. + Test all nested unwind blocks are correctly executed; + all unwind blocks halfway through their execution should be completed." + + | p x1 x2 x3 x4 | + x1 := x2 := x3 := x4 := false. + p := + [ + [ + [ ] ensure: [ + [ ] ensure: [ + Processor activeProcess suspend. + x1 := true]. + x2 := true] + ] ensure: [ + x3 := true]. + x4 := true. + ] newProcess. + p resume. + Processor yield. + "make sure p is suspended and none of the unwind blocks has finished yet" + self assert: p isSuspended. + self deny: x1 | x2 | x3 | x4. + "now terminate the process and make sure all unwind blocks have finished" + [p terminate] forkAt: Processor activePriority + 1. + self assert: p isTerminated. + self assert: x1 & x2 & x3. + self deny: x4.!

1 0

Should a non-resumable exception proceed from a debugger?
by tim Rowledge 05 Jan '22

05 Jan '22

Maybe I'm simply not understanding but... Try `WebUtils jsonDecode: 'Hello World' readStream` You get a notifier because quite rightly there is an error. But you can proceed. And that actually just returns the Error exception object. Which seems wrong, given that Error>>#isResumable returns false. tim -- tim Rowledge; tim(a)rowledge.org; http://www.rowledge.org/tim Strange OpCodes: SDD: Scratch Disk and Die

2 1

The Trunk: ToolBuilder-Morphic-ct.285.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of ToolBuilder-Morphic to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Morphic-ct.285.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-ct.285 Author: ct Time: 3 January 2022, 11:54:06.309397 pm UUID: 6e4aa81c-9483-3a4e-843a-98df1c30189d Ancestors: ToolBuilder-Morphic-mt.284 Improved multilingual support and recategorizations for the entire package. =============== Diff against ToolBuilder-Morphic-mt.284 =============== Item was changed: ----- Method: DirectoryChooserDialog>>userMessage (in category 'ui details') ----- userMessage "return the string to present to the user in order to explain the purpose of this dialog appearing" + ^message ifNil: ['Choose a directory name' translated]! - ^message ifNil:['Choose a directory name']! Item was changed: ----- Method: DirectoryChooserDialog>>windowTitle (in category 'ui details') ----- windowTitle + ^ 'Choose Directory' translated! - ^ 'Choose Directory'! Item was changed: ----- Method: FileAbstractSelectionDialog>>buildButtonsWith: (in category 'toolbuilder') ----- buildButtonsWith: builder ^ { builder pluggableButtonSpec new model: self; label: 'Accept' translated; color: (self userInterfaceTheme get: #okColor for: #DialogWindow); action: #acceptFileName. builder pluggableButtonSpec new model: self; + label: 'Cancel' translated; - label: 'Cancel'; color: (self userInterfaceTheme get: #cancelColor for: #DialogWindow); action: #cancelFileChooser}! Item was changed: ----- Method: FileChooserDialog>>userMessage (in category 'ui details') ----- userMessage "return the string to present to the user in order to explain the purpose of this dialog appearing" + ^message ifNil: ['Choose a file name' translated]! - ^message ifNil:['Choose a file name']! Item was changed: ----- Method: FileChooserDialog>>windowTitle (in category 'ui details') ----- windowTitle "return the window label; would be some application dependent string but I suspect we will want to make the outer morph a dialogue box with no label anyway" + ^ 'Choose File' translated! - ^ 'Choose File'! Item was changed: ----- Method: FileSaverDialog>>selectFilename: (in category 'filename') ----- selectFilename: aText "The user has entered a potential filename in the text field. Check it against the current pattern; if it is ok we can accept it and then if it is a file in the current list, highlight it. If it would not match the pattern, alert the user." fileName := aText asString. ^ self selectExistingFilename ifTrue: [ self changed: #fileListIndex. true ] ifFalse: [ suffixList size = 1 ifTrue: [ | suffix | ((suffix := '.' , suffixList anyOne) compare: (fileName last: (suffix size min: fileName size)) caseSensitive: FileDirectory default isCaseSensitive) = 2 ifFalse: [ fileName := fileName , suffix ]. true ] ifFalse: [ suffixList at: (UIManager default chooseFrom: suffixList + title: 'Please choose the type of file to save.' translated) - title: 'Please choose the type of file to save.') ifPresent: [ : choice | fileName := fileName , '.' , choice. true ] ifAbsent: [ suffixList isEmpty or: + [ self inform: ('WARNING: File not saved!! A filename matching one of {1} patterns is required.' translated format: {patternList asArray}). - [ UIManager default inform: 'WARNING: File not saved!! A filename matching one of ' , patternList asArray asString , ' patterns is required.'. false ] ] ] ]! Item was changed: ----- Method: FileSaverDialog>>userMessage (in category 'ui details') ----- userMessage "return the string to present to the user in order to explain the purpose of this dialog appearing" + ^message ifNil: ['Choose a file name; you can also edit the name below to create a new file name' translated]! - ^message ifNil:['Choose a file name; you can also edit the name below to create a new file name']! Item was changed: ----- Method: FileSaverDialog>>windowTitle (in category 'ui details') ----- windowTitle "return the window label; would be some application dependent string but I suspect we will want to make the outer morph a dialogue box with no label anyway" + ^ 'Save As File' translated! - ^ 'Save As File'! Item was changed: ----- Method: ListChooser>>buildWith: (in category 'building') ----- buildWith: builder | dialogSpec searchBarHeight listSpec fieldSpec | searchBarHeight := self searchBarHeight. dialogSpec := builder pluggableDialogSpec new model: self; title: #title; closeAction: #closed; extent: self initialExtent; autoCancel: true; "Behave like a pop-up menu. Historical reasons." children: OrderedCollection new; buttons: OrderedCollection new; yourself. listSpec := builder pluggableListSpec new. listSpec model: self; list: #items; getIndex: #selectedIndex; setIndex: #selectedIndex:; doubleClick: #accept; "keystrokePreview: #keyStrokeFromList:;" autoDeselect: false; filterableList: true; clearFilterAutomatically: false; name: #list; frame: (LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@searchBarHeight corner: 0@0)). dialogSpec children add: listSpec. fieldSpec := builder pluggableInputFieldSpec new. fieldSpec model: self; name: #searchText ; getText: #searchText; editText: #searchText:; setText: #acceptText:; selection: #textSelection; menu: nil; indicateUnacceptedChanges: false; askBeforeDiscardingEdits: false; help: (self addAllowed ifTrue: ['Type new or filter existing...' translated] ifFalse: ['Type to filter existing...' translated]); frame: (LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@searchBarHeight)). dialogSpec children add: fieldSpec. "Buttons" dialogSpec buttons add: ( builder pluggableButtonSpec new model: self; label: #acceptLabel; action: #accept; enabled: #canAcceptOrAdd; color: #acceptColor). dialogSpec buttons add: ( builder pluggableButtonSpec new model: self; + label: 'Cancel' translated; - label: 'Cancel'; action: #cancel; color: #cancelColor). dialogMorph := builder build: dialogSpec. dialogMorph addKeyboardCaptureFilter: self ; positionOverWidgetNamed: #searchText. listMorph := builder widgetAt: #list. listMorph allowEmptyFilterResult: true. ^ dialogMorph! Item was changed: ----- Method: ListChooser>>title (in category 'accessing') ----- title + ^ title ifNil: [ title := 'Please choose' translated ]! - ^ title ifNil: [ title := 'Please choose' ]! Item was changed: ----- Method: MorphicUIManager>>chooseFrom:lines:title: (in category 'ui requests') ----- chooseFrom: aList lines: linesArray title: aString "Choose an item from the given list. Answer the index of the selected item. Cancel value is 0. There are several (historical) reasons for building a button dialog instead of a list chooser for small lists: 1) Unfortunately, there is existing code that uses this call to create simple confirmation dialogs with a list of #(yes no cancel). 2) Unfortunately, there is existing code that uses this call to mimick a drop-down menu with a (compact) pop-up menu." self askForProvidedAnswerTo: aString ifSupplied: [:answer | (answer = #cancel or: [answer isNil]) ifTrue: [^ 0]. ^ aList indexOf: answer]. aList ifEmpty: [^ 0]. aList size <= 7 ifTrue: [ | dialog | dialog := DialogWindow new + title: 'Please Choose' translated; - title: 'Please Choose'; message: aString; filterEnabled: true; autoCancel: true; "Like a pop-up menu, click anywhere to dismiss." yourself. aList withIndexDo: [:ea :index | dialog createButton: ea value: index]. dialog selectedButtonIndex: 1. ^ dialog getUserResponseAtHand ifNil: [0]]. ^ ListChooser chooseFrom: aList title: aString! Item was changed: ----- Method: PluggableButtonMorphPlus>>debugAction (in category 'debug menu') ----- debugAction action ifNil: [^ super debugAction]. (Process forBlock: [self performAction] runUntil: [:context | context closure = action]) + debugWithTitle: ('Debug button action "{1}" in model "{2}"' translated format: {self label. self target printString}).! - debugWithTitle: ('Debug button action "{1}" in model "{2}"' format: {self label. self target printString}).! Item was changed: + ----- Method: PluggableCheckBoxMorph class>>on:getState:action:label: (in category 'instance creation') ----- - ----- Method: PluggableCheckBoxMorph class>>on:getState:action:label: (in category 'as yet unclassified') ----- on: anObject getState: getStateSel action: actionSel label: labelSel ^ self new on: anObject getState: getStateSel action: actionSel label: labelSel menu: nil ! Item was changed: + ----- Method: PluggableTreeItemNode>>refresh (in category 'private') ----- - ----- Method: PluggableTreeItemNode>>refresh (in category 'as yet unclassified') ----- refresh self parent ifNil: [^ self]. self setItem: (self parent contents at: self index ifAbsent: [self error: 'No support for changed child count yet!!']) item.!

1 0

The Trunk: EToys-ct.456.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-ct.456.mcz ==================== Summary ==================== Name: EToys-ct.456 Author: ct Time: 3 January 2022, 11:24:44.399397 pm UUID: 3dc9971f-ab6e-3448-a995-12a039badca5 Ancestors: EToys-ct.455 Complements MorphicExtras-ct.305 (two fixes for MIDI). =============== Diff against EToys-ct.455 =============== Item was added: + ----- Method: MIDIPianoKeyboardMorph>>basicMouseDownPitch: (in category 'simple keyboard') ----- + basicMouseDownPitch: midiKey + + midiPort ifNil: [^ super basicMouseDownPitch: midiKey - 1]. + + soundPlaying + ifNil: [midiPort ensureOpen] + ifNotNil: [self turnOffNote]. + self turnOnNote: midiKey + 23.! Item was added: + ----- Method: MIDIPianoKeyboardMorph>>basicMouseUpPitch: (in category 'simple keyboard') ----- + basicMouseUpPitch: midiKey + + midiPort ifNil: [ + ^ super basicMouseUpPitch: midiKey]. + + soundPlaying ifNotNil: [self turnOffNote].! Item was removed: - ----- Method: MIDIPianoKeyboardMorph>>mouseDownPitch:event:noteMorph: (in category 'simple keyboard') ----- - mouseDownPitch: midiKey event: event noteMorph: noteMorph - - midiPort ifNil: [^ super mouseDownPitch: midiKey-1 event: event noteMorph: noteMorph]. - noteMorph color: playingKeyColor. - soundPlaying - ifNil: [midiPort ensureOpen] - ifNotNil: [self turnOffNote]. - self turnOnNote: midiKey + 23. - ! Item was removed: - ----- Method: MIDIPianoKeyboardMorph>>mouseUpPitch:event:noteMorph: (in category 'simple keyboard') ----- - mouseUpPitch: midiKey event: event noteMorph: noteMorph - - midiPort ifNil: [ - ^ super mouseUpPitch: midiKey event: event noteMorph: noteMorph]. - - noteMorph color: - ((#(0 1 3 5 6 8 10) includes: midiKey \\ 12) - ifTrue: [whiteKeyColor] - ifFalse: [blackKeyColor]). - soundPlaying ifNotNil: [self turnOffNote]. - !

1 0

The Trunk: MorphicExtras-ct.305.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of MorphicExtras to project The Trunk: http://source.squeak.org/trunk/MorphicExtras-ct.305.mcz ==================== Summary ==================== Name: MorphicExtras-ct.305 Author: ct Time: 3 January 2022, 11:23:47.016397 pm UUID: 50af01bc-e04f-7441-ac0d-3d7a1fac9363 Ancestors: MorphicExtras-mt.304 Two fixes for MIDI: - Ignore non-red mouse clicks to MIDIPianoKeyboardMorph - Honor users of SimpleSwitchMorph that do not take the new state via the actionSelector. =============== Diff against MorphicExtras-mt.304 =============== Item was added: + ----- Method: PianoKeyboardMorph>>basicMouseDownPitch: (in category 'simple keyboard') ----- + basicMouseDownPitch: midiKey + + | pitch | + pitch := AbstractSound pitchForMIDIKey: midiKey + 23. + soundPlaying ifNotNil: [soundPlaying stopGracefully]. + soundPlaying := soundPrototype soundForPitch: pitch dur: 100.0 loudness: 0.3. + SoundPlayer resumePlaying: soundPlaying quickStart: true.! Item was added: + ----- Method: PianoKeyboardMorph>>basicMouseUpPitch: (in category 'simple keyboard') ----- + basicMouseUpPitch: pitch + + soundPlaying ifNotNil: [soundPlaying stopGracefully].! Item was changed: ----- Method: PianoKeyboardMorph>>mouseDownPitch:event:noteMorph: (in category 'simple keyboard') ----- mouseDownPitch: midiKey event: event noteMorph: noteMorph + - | pitch | event redButtonPressed ifFalse: [^ self]. event hand hasSubmorphs ifTrue: [^ self "no response if drag something over me"]. event hand mouseFocus ifNil: ["If dragged into me, then establish focus so I'll see moves" event hand newMouseFocus: noteMorph event: event]. + noteMorph color: playingKeyColor. + + self basicMouseDownPitch: midiKey.! - pitch := AbstractSound pitchForMIDIKey: midiKey + 23. - soundPlaying ifNotNil: [soundPlaying stopGracefully]. - soundPlaying := soundPrototype soundForPitch: pitch dur: 100.0 loudness: 0.3. - SoundPlayer resumePlaying: soundPlaying quickStart: true. - ! Item was changed: ----- Method: PianoKeyboardMorph>>mouseUpPitch:event:noteMorph: (in category 'simple keyboard') ----- mouseUpPitch: pitch event: event noteMorph: noteMorph + noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch \\ 12) + ifTrue: [whiteKeyColor] + ifFalse: [blackKeyColor]). + + self basicMouseUpPitch: pitch.! - noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch\\12) - ifTrue: [whiteKeyColor] - ifFalse: [blackKeyColor]). - soundPlaying ifNotNil: [soundPlaying stopGracefully]. - ! Item was changed: ----- Method: SimpleSwitchMorph>>doButtonAction (in category 'button') ----- doButtonAction "Perform the action of this button. The last argument of the message sent to the target is the new state of this switch." | newState | (target notNil and: [actionSelector notNil]) ifTrue: [newState := color = onColor. target perform: actionSelector + withEnoughArguments: (arguments copyWith: newState)]! - withArguments: (arguments copyWith: newState)]!

1 0

The Trunk: XML-Explorer-ct.2.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of XML-Explorer to project The Trunk: http://source.squeak.org/trunk/XML-Explorer-ct.2.mcz ==================== Summary ==================== Name: XML-Explorer-ct.2 Author: ct Time: 3 January 2022, 10:29:11.972397 pm UUID: ab93eaa9-fa48-5f45-a686-beb9d3b8cdcc Ancestors: XML-Explorer-topa.1 Improves multilingual support. =============== Diff against XML-Explorer-topa.1 =============== Item was changed: ----- Method: XMLNodeWithElements>>explorerContents (in category '*XML-Explorer') ----- explorerContents ^ self elementsAndContents collect: [:element | | name | name := element isTag ifTrue: ['<{1}>' format: {element name}] ifFalse: [element isText + ifTrue: ['[character data]' translated] - ifTrue: ['[character data]'] ifFalse: [element]]. ObjectExplorerWrapper with: element name: (name asString contractTo: 32) + model: self ]! - model: self ] - !

3 3

The Trunk: Tools-ct.1100.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-ct.1100.mcz ==================== Summary ==================== Name: Tools-ct.1100 Author: ct Time: 3 January 2022, 11:12:14.826397 pm UUID: 05076dd9-0a0a-0740-ae13-3f82347e5112 Ancestors: Tools-mt.1099 Improves multilingual support. The dependency browser and all changes tools should be 100-% multilingual now! =============== Diff against Tools-mt.1099 =============== Item was changed: ----- Method: BasicInspector>>labelString (in category 'initialization') ----- labelString ^ '{1} {2}{3}' format: { + '[basic]' translated. - '[basic]'. self basicObjectPrintString. (self object isReadOnlyObject + ifTrue: [' (read-only)' translated] - ifTrue: [' (read-only)'] ifFalse: [''])}! Item was changed: ----- Method: Browser>>dropOnMessageCategories:at: (in category 'drag and drop') ----- dropOnMessageCategories: method at: index | sourceClass destinationClass category copy | copy := Sensor shiftPressed. (method isKindOf: CompiledMethod) ifFalse:[^self inform: 'Can only drop methods']. sourceClass := method methodClass. destinationClass := self selectedClassOrMetaClass. sourceClass == destinationClass ifTrue:[ category := self messageCategoryList at: index. category = ClassOrganizer allCategory ifTrue: [^false]. destinationClass organization classify: method selector under: category suppressIfDefault: false logged: true. self changed: #messageCategoryList. self changed: #messageList. ^true ]. (copy or: [ (destinationClass inheritsFrom: sourceClass) or: [ (sourceClass inheritsFrom: destinationClass) or: [ sourceClass theNonMetaClass == destinationClass theNonMetaClass ] ] ]) ifFalse: [ (self confirm: ( 'Classes "{1}" and "{2}" are unrelated.{3}Are you sure you want to move this method?' + translated format: { sourceClass. destinationClass. Character cr })) - format: { sourceClass. destinationClass. Character cr })) ifFalse: [ ^false ] ]. destinationClass compile: method getSource classified: (self messageCategoryList at: index) withStamp: method timeStamp notifying: nil. copy ifFalse: [ sourceClass removeSelector: method selector ]. ^true! Item was changed: ----- Method: ChangeList class>>browseMethodVersions (in category 'public access') ----- browseMethodVersions | changeList end changesFile filteredRecords | changesFile := (SourceFiles at: 2) readOnlyCopy. changesFile setConverterForCode. end := changesFile size. changeList := self new. Cursor read showWhile: [ [changeList scanFile: changesFile from: 0 to: end] on: InvalidUTF8 do: [:err | err resume: '']]. changesFile close. filteredRecords := Dictionary new. changeList changeList do: [:changeRecord | changeRecord methodSelector ifNotNil: [:selector | | class | class := changeRecord methodClass. "Only collect records that point to not-installed methods." (class isNil or: [(class includesSelector: selector) not]) ifTrue: [ (filteredRecords at: selector ifAbsentPut: [OrderedCollection new]) add: changeRecord]]] + displayingProgress: [:changeRecord | 'Parsing source code at {1}...' translated format: {changeRecord position}]. - displayingProgress: [:changeRecord | 'Parsing source code at {1}...' format: {changeRecord position}]. filteredRecords explore. "Open explorer to allow user to repeat the following step manually." self browseMethodVersions: filteredRecords.! Item was changed: ----- Method: ChangeList class>>browseMethodVersions: (in category 'public access') ----- browseMethodVersions: filteredRecords | changeList sortedKeys choice | sortedKeys := filteredRecords keys sorted. + choice := Project uiManager chooseFrom: sortedKeys values: sortedKeys title: 'Recover method versions' translated. - choice := Project uiManager chooseFrom: sortedKeys values: sortedKeys title: 'Recover method versions'. choice ifNil: [^ self]. "Only ChangeList can handle the mix of (maybe non-existing) class references in records. For example, VersionsBrowser is not supported." changeList := ChangeList new. (filteredRecords at: choice) do: [:changeRecord | changeList addItem: changeRecord text: ('{1} {2}{3}{4} \{{5}\}' format: { changeRecord stamp. changeRecord methodClassName. changeRecord isMetaClassChange ifTrue: [' class '] ifFalse: [' ']. choice. changeRecord category})]. changeList resetListSelections. self open: changeList + name: ('All local versions for {1}' translated format: {choice storeString}) - name: 'All local versions for ', choice storeString multiSelect: false! Item was changed: ----- Method: ChangeList class>>browseRecent:on: (in category 'public access') ----- browseRecent: charCount on: origChangesFile "Opens a changeList on the end of the specified changes log file" | changeList end changesFile | changesFile := origChangesFile readOnlyCopy. changesFile setConverterForCode. end := changesFile size. changeList := Cursor read showWhile: [self new scanFile: changesFile from: (0 max: end - charCount) to: end]. changesFile close. self open: changeList + name: 'Recent changes' translated - name: 'Recent changes' multiSelect: true! Item was changed: ----- Method: ChangeList class>>browseRecentLogOn: (in category 'public access') ----- browseRecentLogOn: origChangesFile "figure out where the last snapshot or quit was, then browse the recent entries." | end done block pos chunk changesFile position prevBlock | changesFile := origChangesFile readOnlyCopy. position := nil. end := changesFile size. prevBlock := end. block := end - 1024 max: 0. done := false. [done or: [position notNil]] whileFalse: [changesFile position: block. "ignore first fragment" changesFile nextChunk. [changesFile position < prevBlock] whileTrue: [pos := changesFile position. chunk := changesFile nextChunk. ((chunk indexOfSubCollection: '----' startingAt: 1) = 1) ifTrue: [ (#('----QUIT' '----SNAPSHOT') anySatisfy: [ :str | chunk beginsWith: str ]) ifTrue: [position := pos]]]. block = 0 ifTrue: [done := true] ifFalse: [prevBlock := block. block := block - 1024 max: 0]]. changesFile close. position + ifNil: [self inform: ('File {1} does not appear to be a changes file' translated format: {changesFile name})] - ifNil: [self inform: 'File ' , changesFile name , ' does not appear to be a changes file'] ifNotNil: [self browseRecentLogOn: origChangesFile startingFrom: position]! Item was changed: ----- Method: ChangeList class>>browseStream: (in category 'public access') ----- browseStream: changesFile "Opens a changeList on a fileStream" | changeList charCount | changesFile readOnly. changesFile setConverterForCode. charCount := changesFile size. charCount > 1000000 ifTrue: + [(self confirm: ('The file {1} + is really long ({2} characters). + Would you prefer to view only the last million characters?' translated format: {changesFile name. charCount})) - [(self confirm: 'The file ', changesFile name , ' - is really long (' , charCount printString , ' characters). - Would you prefer to view only the last million characters?') ifTrue: [charCount := 1000000]]. "changesFile setEncoderForSourceCodeNamed: changesFile name." changeList := Cursor read showWhile: [self new scanFile: changesFile from: changesFile size-charCount to: changesFile size]. changesFile close. self open: changeList name: changesFile localName , ' log' multiSelect: true! Item was changed: ----- Method: ChangeList>>acceptFrom: (in category 'menu actions') ----- acceptFrom: aView aView controller text = aView controller initialText ifFalse: [ aView flash. ^ self inform: 'You can only accept this version as-is. + If you want to edit, copy the text to a browser' translated]. - If you want to edit, copy the text to a browser']. (aView setText: aView controller text from: self) ifTrue: [aView ifNotNil: [aView controller accept]]. "initialText" ! Item was changed: ----- Method: ChangeList>>browseAllVersionsOfSelections (in category 'menu actions') ----- browseAllVersionsOfSelections "Opens a Versions browser on all the currently selected methods, showing each alongside all of their historical versions." | oldSelection aList | oldSelection := self listIndex. aList := OrderedCollection new. Cursor read showWhile: [ 1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [ listIndex := i. self browseVersions. aList add: i. ]]]. listIndex := oldSelection. + aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts' translated].! - aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. - ! Item was changed: ----- Method: ChangeList>>browseCurrentVersionsOfSelections (in category 'menu actions') ----- browseCurrentVersionsOfSelections "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" | aList | aList := OrderedCollection new. Cursor read showWhile: [ 1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [ | aClass aChange | aChange := changeList at: i. (aChange type = #method and: [(aClass := aChange methodClass) notNil and: [aClass includesSelector: aChange methodSelector]]) ifTrue: [ aList add: ( MethodReference class: aClass selector: aChange methodSelector ) ]]]]. + aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts' translated]. - aList size = 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. ToolSet browseMessageSet: aList + name: ('Current versions of selected methods in {1}' translated format: {file localName}) - name: 'Current versions of selected methods in ', file localName autoSelect: nil! Item was changed: ----- Method: ChangeList>>compareToCurrentSource: (in category 'menu actions') ----- compareToCurrentSource: currentSource "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" | change selectedSource | change := changeList at: listIndex ifAbsent: [^ self]. selectedSource := change string. currentSource = selectedSource + ifTrue: [^ self inform: 'Exact Match' translated]. - ifTrue: [^ self inform: 'Exact Match']. (StringHolder new textContents: (TextDiffBuilder buildDisplayPatchFrom: selectedSource to: currentSource inClass: change methodClass prettyDiffs: self showingPrettyDiffs)) + openLabel: 'Comparison to Current Version' translated.! - openLabel: 'Comparison to Current Version'.! Item was changed: ----- Method: ChangeList>>contents: (in category 'viewing access') ----- contents: aString listIndex = 0 ifTrue: [self changed: #flash. ^ false]. lostMethodPointer ifNotNil: [^ self restoreDeletedMethod]. self okToChange "means not dirty" ifFalse: ["is dirty" + self inform: 'This is a view of a method on a file.\Please cancel your changes. You may\accept, but only when the method is untouched.' withCRs translated. ^ false]. - self inform: 'This is a view of a method on a file.\Please cancel your changes. You may\accept, but only when the method is untouched.' withCRs. ^ false]. "Can't accept changes here. Method text must be unchanged!!" (changeList at: listIndex) fileIn. ^ true! Item was changed: ----- Method: ChangeList>>destroyCurrentCodeOfSelections (in category 'menu actions') ----- destroyCurrentCodeOfSelections "Actually remove from the system any in-memory methods with class and selector identical to items current selected. This may seem rather arcane but believe me it has its great uses, when trying to split out code. To use effectively, first file out a change set that you wish to split off. Then open a ChangeList browser on that fileout. Now look through the methods, and select any of them which you want to remove completely from the system, then issue this command. For those methods where you have made changes to pre-existing versions, of course, you won't want to remove them from the system, so use this mechanism with care!!" | aClass aChange aList | aList := OrderedCollection new. 1 to: changeList size do: [:index | (listSelections at: index) ifTrue: [aChange := changeList at: index. (aChange type = #method and: [(aClass := aChange methodClass) notNil and: [aClass includesSelector: aChange methodSelector]]) ifTrue: [aList add: {aClass. aChange methodSelector}]]]. aList size > 0 ifTrue: + [(self confirm: ('Warning!! This will actually remove {1} method(s) from the system!!' translated format: {aList size})) ifFalse: [^ self]]. - [(self confirm: 'Warning!! This will actually remove ', aList size printString, ' method(s) from the system!!') ifFalse: [^ self]]. aList do: [:aPair | Transcript cr; show: 'Removed: ', aPair first printString, '.', aPair second. aPair first removeSelector: aPair second]! Item was changed: ----- Method: ChangeList>>fileInSelections (in category 'menu actions') ----- fileInSelections | any | any := false. self selectedClass environment beCurrentDuring: [ listSelections with: changeList do: [:selected :item | selected ifTrue: [any := true. item fileIn]]]. any ifFalse: + [self inform: 'nothing selected, so nothing done' translated]! - [self inform: 'nothing selected, so nothing done']! Item was changed: ----- Method: ChangeList>>fileOutSelections (in category 'menu actions') ----- fileOutSelections | fileName internalStream | + fileName := Project uiManager request: 'Enter the base of file name' translated initialAnswer: 'Filename' translated. - fileName := UIManager default request: 'Enter the base of file name' initialAnswer: 'Filename'. internalStream := WriteStream on: (String new: 1000). internalStream header; timeStamp. listSelections with: changeList do: [:selected :item | selected ifTrue: [item fileOutOn: internalStream]]. + FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true useHtml: false.! - FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true useHtml: false. - ! Item was changed: ----- Method: ChangeList>>mainChangeListMenu: (in category 'menu actions') ----- mainChangeListMenu: aMenu "Fill aMenu up so that it comprises the primary changelist-browser menu" <changeListMenu> + aMenu addTitle: 'change list' translated. - aMenu addTitle: 'change list'. aMenu addStayUpItemSpecial. + aMenu addTranslatedList: #( - aMenu addList: #( ('fileIn selections' fileInSelections 'import the selected items into the image') ('fileOut selections...' fileOutSelections 'create a new file containing the selected items') - ('compare to current' compareToCurrentVersion 'open a separate window which shows the text differences between the on-file version and the in-image version.' ) ('toggle diffing (D)' toggleDiffing 'start or stop showing diffs in the code pane.') - ('select conflicts with any changeset' selectAllConflicts 'select methods in the file which also occur in any change-set in the system') ('select conflicts with current changeset' selectConflicts 'select methods in the file which also occur in the current change-set') ('select conflicts with...' selectConflictsWith 'allows you to designate a file or change-set against which to check for code conflicts.') - ('select unchanged definitions' selectUnchangedDefinitions 'select class definitions, class comments and methods in the file whose in-image versions are the same as their in-file counterparts' ) ('select unchanged methods' selectUnchangedMethods 'select methods in the file whose in-image versions are the same as their in-file counterparts' ) ('select new methods' selectNewMethods 'select methods in the file that do not current occur in the image') ('select methods for this class' selectMethodsForThisClass 'select all methods in the file that belong to the currently-selected class') ('select methods for extant classes' selectMethodsForExtantClasses 'select all methods in the file that belong to a class that exists in the image') ('select changes with contents matching' selectContentsMatching 'select all changes in the file whose text includes a pattern') - ('select all (a)' selectAll 'select all the items in the list') ('deselect all' deselectAll 'deselect all the items in the list') ('invert selections' invertSelections 'select every item that is not currently selected, and deselect every item that *is* currently selected') ('select all before' selectAllBefore 'select every item before the current selection') - ('browse all versions of single selection' browseVersions 'open a version browser showing the versions of the currently selected method') ('browse all versions of selections' browseAllVersionsOfSelections 'open a version browser showing all the versions of all the selected methods') ('browse current versions of selections' browseCurrentVersionsOfSelections 'open a message-list browser showing the current (in-image) counterparts of the selected methods') ('destroy current methods of selections' destroyCurrentCodeOfSelections 'remove (*destroy*) the in-image counterparts of all selected methods') - ('remove doIts' removeDoIts 'remove all items that are doIts rather than methods') ('remove older versions' removeOlderMethodVersions 'remove all but the most recent versions of methods in the list') ('remove up-to-date versions' removeExistingMethodVersions 'remove all items whose code is the same as the counterpart in-image code') ('remove selected items' removeSelections 'remove the selected items from the change-list') ('remove unselected items' removeNonSelections 'remove all the items not currently selected from the change-list')). + ^ aMenu! - ^ aMenu - - ! Item was changed: ----- Method: ChangeList>>removeNonSelections (in category 'menu actions') ----- removeNonSelections "Remove the unselected items from the receiver." | newChangeList newList | newChangeList := OrderedCollection new. newList := OrderedCollection new. 1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [newChangeList add: (changeList at: i). newList add: (list at: i)]]. newChangeList size = 0 ifTrue: [^ self inform: 'That would remove everything. + Why would you want to do that?' translated]. - Why would you want to do that?']. newChangeList size < changeList size ifTrue: [changeList := newChangeList. list := newList. listIndex := 0. listSelections := Array new: list size withAll: false]. + self changed: #list! - self changed: #list - - ! Item was changed: ----- Method: ChangeList>>scanFile:from:to: (in category 'scanning') ----- scanFile: aFile from: startPosition to: stopPosition file := aFile. changeList := OrderedCollection new. list := OrderedCollection new. listIndex := 0. file position: startPosition. + ('Scanning {1}...' translated format: {aFile localName}) - 'Scanning ', aFile localName, '...' displayProgressFrom: startPosition to: stopPosition during: [:bar | | prevChar itemPosition item | [file position < stopPosition] whileTrue: [bar value: file position. [file atEnd not and: [file peek isSeparator]] whileTrue: [prevChar := file next]. (file peekFor: $!!) ifTrue: [(prevChar = Character cr or: [prevChar = Character lf]) ifTrue: [self scanCategory]] ifFalse: [itemPosition := file position. item := file nextChunk. file skipStyleChunk. item size > 0 ifTrue: [(item beginsWith: '----') ifTrue: [self addItem: (ChangeRecord new file: file position: itemPosition type: #misc) text: 'misc: ' , (item contractTo: 50)] ifFalse: [self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) text: 'do it: ' , (item contractTo: 50)]]]]]. self resetListSelections.! Item was changed: ----- Method: ChangeList>>selectContentsMatching (in category 'menu actions') ----- selectContentsMatching | pattern | + pattern := Project uiManager request: 'pattern to match' translated. - pattern := UIManager default request: 'pattern to match'. pattern isEmpty ifTrue: [^self]. ^Cursor execute showWhile: [self selectSuchThat: ((pattern includesAnyOf: '?*') ifTrue: [[ :change | pattern match: change string]] ifFalse: [[ :change | change string includesSubstring: pattern]])]! Item was changed: ----- Method: ChangeList>>selectSuchThat (in category 'menu actions') ----- selectSuchThat "query the user for a selection criterio. By Lex Spoon. NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:" | code block | + code := Project uiManager request: ('selection criteria for a change named aChangeRecord?\For instance, "{1}"' withCRs translated format: {'aChangeRecord category = ''System-Network'''}). - code := UIManager default request: 'selection criteria for a change named aChangeRecord?\For instance, ''aChangeRecord category = ''System-Network''''' withCRs. code isEmpty ifTrue: [^ self ]. block := Compiler evaluate: '[:aChangeRecord | ', code, ']'. self selectSuchThat: block! Item was changed: ----- Method: ChangeSetBrowser>>addModelItemsToWindowMenu: (in category 'initialization') ----- addModelItemsToWindowMenu: aMenu "Add model-related items to the given window menu" | oldTarget | oldTarget := aMenu defaultTarget. aMenu defaultTarget: self. aMenu addLine. + aMenu add: 'rename change set' translated action: #rename. + aMenu add: 'make changes go to me' translated action: #newCurrent. - aMenu add: 'rename change set' action: #rename. - aMenu add: 'make changes go to me' action: #newCurrent. aMenu addLine. + aMenu add: 'file out' translated action: #fileOut. + aMenu add: 'browse methods' translated action: #browseChangeSet. - aMenu add: 'file out' action: #fileOut. - aMenu add: 'browse methods' action: #browseChangeSet. aMenu addLine. myChangeSet hasPreamble ifTrue: + [aMenu add: 'edit preamble...' translated action: #editPreamble. + aMenu add: 'remove preamble' translated action: #removePreamble] - [aMenu add: 'edit preamble...' action: #editPreamble. - aMenu add: 'remove preamble' action: #removePreamble] ifFalse: + [aMenu add: 'add preamble...' translated action: #editPreamble]. - [aMenu add: 'add preamble...' action: #editPreamble]. myChangeSet hasPostscript ifTrue: + [aMenu add: 'edit postscript...' translated action: #editPostscript. + aMenu add: 'remove postscript' translated action: #removePostscript] - [aMenu add: 'edit postscript...' action: #editPostscript. - aMenu add: 'remove postscript' action: #removePostscript] ifFalse: + [aMenu add: 'add postscript...' translated action: #editPostscript]. - [aMenu add: 'add postscript...' action: #editPostscript]. aMenu addLine. + aMenu add: 'destroy change set' translated action: #remove. - aMenu add: 'destroy change set' action: #remove. aMenu addLine. Smalltalk isMorphic ifTrue: [aMenu addLine. + aMenu add: 'what to show...' translated target: self action: #offerWhatToShowMenu]. - aMenu add: 'what to show...' target: self action: #offerWhatToShowMenu]. aMenu addLine. + aMenu add: 'more...' translated action: #offerShiftedChangeSetMenu. - aMenu add: 'more...' action: #offerShiftedChangeSetMenu. aMenu defaultTarget: oldTarget. ^ aMenu! Item was changed: ----- Method: ChangeSorter class>>browseChangeSetsWithClass:selector: (in category 'browse') ----- browseChangeSetsWithClass: class selector: selector "Put up a menu comprising a list of change sets that hold changes for the given class and selector. If the user selects one, open a single change-sorter onto it" | hits index | hits := ChangeSet allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. + hits isEmpty ifTrue: [^ self inform: ('{1}\is not in any change set' withCRs translated format: {class name, ' >> #', selector})]. - hits isEmpty ifTrue: [^ self inform: class name, '.', selector , ' - is not in any change set']. index := hits size = 1 ifTrue: [1] + ifFalse: [(Project uiManager chooseFrom: (hits collect: [:cs | cs name]) - ifFalse: [(UIManager default chooseFrom: (hits collect: [:cs | cs name]) lines: #())]. index = 0 ifTrue: [^ self]. (ChangeSorter new myChangeSet: (hits at: index)) open. ! Item was changed: ----- Method: ChangeSorter class>>browseChangeSetsWithSelector: (in category 'browse') ----- browseChangeSetsWithSelector: aSelector "Put up a list of all change sets that contain an addition, deletion, or change of any method with the given selector" | hits index | hits := ChangeSet allChangeSets select: [:cs | cs hasAnyChangeForSelector: aSelector]. + hits isEmpty ifTrue: [^ self inform: ('{1}\is not in any change set' withCRs translated format: {aSelector})]. - hits isEmpty ifTrue: [^ self inform: aSelector , ' - is not in any change set']. index := hits size = 1 ifTrue: [1] + ifFalse: [(Project uiManager chooseFrom: (hits collect: [:cs | cs name]) - ifFalse: [(UIManager default chooseFrom: (hits collect: [:cs | cs name]) lines: #())]. index = 0 ifTrue: [^ self]. (ChangeSetBrowser new myChangeSet: (hits at: index)) open "ChangeSorter browseChangeSetsWithSelector: #clearPenTrails" ! Item was changed: ----- Method: ChangeSorter>>addPriorVersionsCountForSelector:ofClass:to: (in category 'annotation') ----- addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior version is pointed to by the lost-method pointer in the change held on to by the changeset" (aClass includesSelector: aSelector) ifTrue: [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. aStream nextPutAll: ((myChangeSet methodInfoFromRemoval: {aClass name. aSelector}) ifNil: + ['no prior versions' translated] - ['no prior versions'] ifNotNil: + ['version(s) retrievable here' translated]), self annotationSeparator! - ['version(s) retrievable here']), self annotationSeparator! Item was changed: ----- Method: ChangeSorter>>browseMethodConflicts (in category 'changeSet menu') ----- browseMethodConflicts "Check to see if any other change set also holds changes to any methods in the selected change set; if so, open a browser on all such." | aList | aList := myChangeSet messageListForChangesWhich: [ :aClass :aSelector | (ChangesOrganizer allChangeSetsWithClass: aClass selector: aSelector) size > 1 ] ifNone: [^ self inform: 'No other change set has changes + for any method in this change set.' translated]. - for any method in this change set.']. ToolSet browseMessageSet: aList + name: ('Methods in "{1}" that are also in other change sets ({2})' translated format: {myChangeSet name. aList size}) - name: 'Methods in "', myChangeSet name, '" that are also in other change sets (', aList size printString, ')' autoSelect: nil! Item was changed: ----- Method: ChangeSorter>>changeSetMenuForDropInClassCats: (in category 'changeSet menu') ----- changeSetMenuForDropInClassCats: aMenu + aMenu add: 'remove contained in class categories...' translated action: #removeContainedInClassCategories. + aMenu balloonTextForLastItem: ' Drops any changes in given class categories' translated. - aMenu add: 'remove contained in class categories...' action: #removeContainedInClassCategories. - aMenu balloonTextForLastItem: ' Drops any changes in given class categories'. ^ aMenu ! Item was changed: ----- Method: ChangeSorter>>changeSetMenuForModification: (in category 'changeSet menu') ----- changeSetMenuForModification: aMenu aMenu addLine. + + aMenu add: 'file into new...' translated action: #fileIntoNewChangeSet. - - aMenu add: 'file into new...' action: #fileIntoNewChangeSet. aMenu balloonTextForLastItem: + 'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)' translated. + + aMenu add: 'reorder all change sets' translated action: #reorderChangeSets. - 'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)'. - - aMenu add: 'reorder all change sets' action: #reorderChangeSets. aMenu balloonTextForLastItem: + 'Applies a standard reordering of all change-sets in the system -- at the bottom will come the sets that come with the release; next will come all the numbered updates; finally, at the top, will come all other change sets' translated. + - 'Applies a standard reordering of all change-sets in the system -- at the bottom will come the sets that come with the release; next will come all the numbered updates; finally, at the top, will come all other change sets'. - - ^ aMenu! Item was changed: ----- Method: ChangeSorter>>changeSetMenuForOpposite: (in category 'changeSet menu') ----- changeSetMenuForOpposite: aMenu parent ifNotNil: + [aMenu add: 'conflicts with change set opposite' translated action: #methodConflictsWithOtherSide. - [aMenu add: 'conflicts with change set opposite' action: #methodConflictsWithOtherSide. aMenu balloonTextForLastItem: + 'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.' translated]. - 'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.'.]. ^ aMenu! Item was changed: ----- Method: ChangeSorter>>changeSetMenuForPromote: (in category 'changeSet menu') ----- changeSetMenuForPromote: aMenu + aMenu add: 'promote to top of list' translated action: #promoteToTopChangeSet. - aMenu add: 'promote to top of list' action: #promoteToTopChangeSet. aMenu balloonTextForLastItem: + 'Make this change set appear first in change-set lists in all change sorters.' translated. - 'Make this change set appear first in change-set lists in all change sorters.'. ^ aMenu! Item was changed: ----- Method: ChangeSorter>>clearChangeSet (in category 'changeSet menu') ----- clearChangeSet "Clear out the current change set, after getting a confirmation." | message | self okToChange ifFalse: [^ self]. myChangeSet isEmpty ifFalse: + [message := 'Are you certain that you want to\forget all the changes in this set?' withCRs translated. - [message := 'Are you certain that you want to\forget all the changes in this set?' withCRs. (self confirm: message) ifFalse: [^ self]]. myChangeSet clear. self changed: #classList. self changed: #messageList. self setContents. self contentsChanged. ! Item was changed: ----- Method: ChangeSorter>>contents:notifying: (in category 'code pane') ----- contents: aString notifying: aController "Compile the code in aString. Notify aController of any syntax errors. Create an error if the category of the selected message is unknown. Answer false if the compilation fails. Otherwise, if the compilation created a new method, deselect the current selection. Then answer true." | category selector class oldSelector | (class := self selectedClassOrMetaClass) ifNil: [(myChangeSet preambleString == nil or: [aString size = 0]) ifTrue: [ ^ false]. (aString count: [:char | char == $"]) odd + ifTrue: [self inform: 'unmatched double quotes in preamble' translated] - ifTrue: [self inform: 'unmatched double quotes in preamble'] ifFalse: [(Scanner new scanTokens: aString) size > 0 ifTrue: [ self inform: 'Part of the preamble is not within double-quotes. To put a double-quote inside a comment, type two double-quotes in a row. + (Ignore this warning if you are including a doIt in the preamble.)' translated]]. - (Ignore this warning if you are including a doIt in the preamble.)']]. myChangeSet preambleString: aString. self currentSelector: nil. "forces update with no 'unsubmitted chgs' feedback" ^ true]. oldSelector := self selectedMessageName. category := class organization categoryOfElement: oldSelector. selector := class compile: aString classified: category notifying: aController. selector ifNil: [^ false]. (self messageList includes: selector) ifTrue: [self currentSelector: selector] ifFalse: [self currentSelector: oldSelector]. self update. ^ true! Item was changed: ----- Method: ChangeSorter>>findCngSet (in category 'changeSet menu') ----- findCngSet "Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed" | index pattern candidates nameList | self okToChange ifFalse: [^ self]. + pattern := Project uiManager request: 'ChangeSet name or fragment?' translated. - pattern := UIManager default request: 'ChangeSet name or fragment?'. pattern isEmpty ifTrue: [^ self]. nameList := self changeSetList asSet. candidates := ChangeSet allChangeSets select: [:c | (nameList includes: c name) and: [c name includesSubstring: pattern caseSensitive: false]]. candidates size = 0 ifTrue: [^ Beeper beep]. candidates size = 1 ifTrue: [^ self showChangeSet: candidates first]. + index := Project uiManager chooseFrom: (candidates collect: [:each | each name]). - index := UIManager default chooseFrom: (candidates collect: [:each | each name]). index = 0 ifFalse: [self showChangeSet: (candidates at: index)]. ! Item was changed: ----- Method: ChangeSorter>>goToChangeSetsProject (in category 'changeSet menu') ----- goToChangeSetsProject "Transport the user to a project which bears the selected changeSet as its current changeSet" | aProject | (aProject := myChangeSet correspondingProject) ifNotNil: [aProject enter: false revert: false saveForRevert: false] ifNil: + [self inform: 'Has no project' translated]! - [self inform: 'Has no project']! Item was changed: ----- Method: ChangeSorter>>inspectChangeSet (in category 'changeSet menu') ----- inspectChangeSet "Open a message list browser on the new and changed methods in the current change set" + myChangeSet inspectWithLabel: ('Change set: {1}' translated format: {myChangeSet name}) - myChangeSet inspectWithLabel: 'Change set: ', myChangeSet name ! Item was changed: ----- Method: ChangeSorter>>labelString (in category 'access') ----- labelString "The label for my entire window. The large button that displays my name is gotten via mainButtonName" ^ String streamContents: [:aStream | aStream nextPutAll: (ChangeSet current == myChangeSet + ifTrue: ['Changes go to "{1}"' translated format: {myChangeSet name}] + ifFalse: ['ChangeSet: {1}' translated format: {myChangeSet name}])]! - ifTrue: ['Changes go to "', myChangeSet name, '"'] - ifFalse: ['ChangeSet: ', myChangeSet name])]! Item was changed: ----- Method: ChangeSorter>>mainClassListMenu: (in category 'class list') ----- mainClassListMenu: aMenu "Fill aMenu with items appropriate for the class list" <classListMenuShifted: false> + aMenu title: 'class list' translated. - aMenu title: 'class list'. aMenu addStayUpItemSpecial. parent ifNotNil: [ + aMenu addTranslatedList: #( "These two only apply to dual change sorters" - aMenu addList: #( "These two only apply to dual change sorters" ('copy class chgs to other side' copyClassToOther) ('move class chgs to other side' moveClassToOther))]. + aMenu addTranslatedList: #( - aMenu addList: #( - ('delete class from change set (d)' forgetClass) ('remove class from system (x)' removeClass) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse protocol (p)' browseFullProtocol) - ('printOut' printOutClass) ('fileOut' fileOutClass) - ('references... (r)' browseVariableReferences) ('assignments... (a)' browseVariableAssignments) ('class refs (N)' browseClassRefs) - ('more...' offerShiftedClassListMenu)). ^ aMenu! Item was changed: ----- Method: ChangeSorter>>methodConflictsWithOtherSide (in category 'changeSet menu') ----- methodConflictsWithOtherSide "Check to see if the change set on the other side shares any methods with the selected change set; if so, open a browser on all such." | aList other | self checkThatSidesDiffer: [^ self]. other := (parent other: self) changeSet. aList := myChangeSet messageListForChangesWhich: [ :aClass :aSelector | aClass notNil and: [(other methodChangesAtClass: aClass name) includesKey: aSelector] ] ifNone: [^ self inform: 'There are no methods that appear both in this change set and + in the one on the other side.' translated]. - in the one on the other side.']. ToolSet browseMessageSet: aList + name: ('Methods in "{1}" that are also in {2} ({3})' translated format: {myChangeSet name. other name. aList size}) - name: 'Methods in "', myChangeSet name, '" that are also in ', other name,' (', aList size printString, ')' autoSelect: nil! Item was changed: ----- Method: ChangeSorter>>packageNoteForClass:selector: (in category 'annotation') ----- packageNoteForClass: aClass selector: aSelector "return the category name that represents the package name for aClass>>aSelector. when selector is nil or in a normal catagory return " | package | package := (self annotationForPackageforSelector: aSelector + ofClass: aClass) ifNil: ['<class was deleted???>' translated] . - ofClass: aClass) ifNil: ['<class was deleted???>'] . ^ self noteString: package ! Item was changed: ----- Method: ChangeSorter>>removeContainedInClassCategories (in category 'changeSet menu') ----- removeContainedInClassCategories | matchExpression | myChangeSet removePreamble. + matchExpression := Project uiManager request: 'Enter class category name (wildcard is ok)' translated initialAnswer: 'System-*'. - matchExpression := UIManager default request: 'Enter class category name (wildcard is ok)' initialAnswer: 'System-*'. (Smalltalk organization categories select: [:each | matchExpression match: each]) do: [:eachCat | | classNames | classNames := Smalltalk organization listAtCategoryNamed: eachCat. classNames do: [:eachClassName | myChangeSet removeClassChanges: eachClassName. myChangeSet removeClassChanges: eachClassName , ' class']. self showChangeSet: myChangeSet]! Item was changed: ----- Method: ChangeSorter>>removePostscript (in category 'changeSet menu') ----- removePostscript (myChangeSet hasPostscript and: [myChangeSet postscriptHasDependents]) ifTrue: [^ self inform: 'Cannot remove the postscript right now because there is at least one window open on that postscript. + Close that window and try again.' translated]. - Close that window and try again.']. myChangeSet removePostscript.! Item was changed: ----- Method: ChangeSorter>>removePrompting: (in category 'changeSet menu') ----- removePrompting: doPrompt "Completely destroy my change set. Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first." | message aName changeSetNumber msg | aName := myChangeSet name. myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project" (myChangeSet isEmpty or: [doPrompt not]) ifFalse: [message := 'Are you certain that you want to remove (destroy) the change set + named "{1}" ?' translated format: {aName}. - named "', aName, '" ?'. (self confirm: message) ifFalse: [^ self]]. doPrompt ifTrue: [msg := myChangeSet hasPreamble ifTrue: [myChangeSet hasPostscript ifTrue: + ['a preamble and a postscript' translated] - ['a preamble and a postscript'] ifFalse: + ['a preamble' translated]] - ['a preamble']] ifFalse: [myChangeSet hasPostscript ifTrue: + ['a postscript' translated] - ['a postscript'] ifFalse: ['']]. msg isEmpty ifFalse: [(self confirm: + ('Caution!! This change set has + {1} which will be - 'Caution!! This change set has - ', msg, ' which will be lost if you destroy the change set. + Do you really want to go ahead with this?' translated format: {msg})) ifFalse: [^ self]]]. - Do you really want to go ahead with this?') ifFalse: [^ self]]]. "Go ahead and remove the change set" changeSetNumber := myChangeSet name initialIntegerOrNil. changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber]. ChangesOrganizer removeChangeSet: myChangeSet. self changed: #changeSetList. self showChangeSet: ChangeSet current.! Item was changed: ----- Method: ChangeSorter>>rename (in category 'changeSet menu') ----- rename "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" | newName | + newName := Project uiManager request: 'New name for this change set' translated - newName := UIManager default request: 'New name for this change set' initialAnswer: myChangeSet name. (newName = myChangeSet name or: [newName size = 0]) ifTrue: [^ Beeper beep]. (ChangeSet named: newName) ifNotNil: + [^ Project uiManager inform: 'Sorry that name is already used' translated]. - [^ UIManager default inform: 'Sorry that name is already used']. myChangeSet name: newName. self update. self changed: #mainButtonName. self changed: #relabel.! Item was changed: ----- Method: ChangeSorter>>setContents (in category 'code pane') ----- setContents "return the source code that shows in the bottom pane" | sel class strm changeType | self clearUserEditFlag. contentsAreStyleable := false. currentCompiledMethod := nil. myChangeSet ifNil: [^ contents := String empty]. "should not happen but can" currentClassName ifNil: [^ contents := myChangeSet preambleString ifNil: [String empty]]. class := self selectedClassOrMetaClass. (sel := self selectedMessageName) == nil ifFalse: [changeType := (myChangeSet atSelector: (sel := sel asSymbol) class: class). changeType == #remove + ifTrue: [^ contents := 'Method has been removed (see versions)' translated]. - ifTrue: [^ contents := 'Method has been removed (see versions)']. changeType == #addedThenRemoved + ifTrue: [^ contents := 'Added then removed (see versions)' translated]. + class ifNil: [^ contents := 'Method was added, but cannot be found!!' translated]. - ifTrue: [^ contents := 'Added then removed (see versions)']. - class ifNil: [^ contents := 'Method was added, but cannot be found!!']. (class includesSelector: sel) + ifFalse: [^ contents := 'Method was added, but cannot be found!!' translated]. - ifFalse: [^ contents := 'Method was added, but cannot be found!!']. contentsAreStyleable := true. currentCompiledMethod := class compiledMethodAt: sel. contents := class sourceCodeAt: sel. (#(prettyPrint prettyDiffs) includes: contentsSymbol) ifTrue: [contents := class prettyPrinterClass format: contents in: class notifying: nil]. self showingAnyKindOfDiffs ifTrue: [ contentsAreStyleable := false. contents := self diffFromPriorSourceFor: contents]. ^ contents := contents asText makeSelectorBoldIn: class] ifTrue: [strm := WriteStream on: (String new: 100). (myChangeSet classChangeAt: (self withoutItemAnnotation: currentClassName)) do: [:each | + each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.' translated; cr]. + each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.' translated]. + each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.' translated; cr]. + each = #add ifTrue: [strm nextPutAll: 'Class definition was added.' translated; cr]. + each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.' translated; cr]. + each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.' translated; cr]. + each = #comment ifTrue: [strm nextPutAll: 'New class comment.' translated; cr. - each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr]. - each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.']. - each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.'; cr]. - each = #add ifTrue: [strm nextPutAll: 'Class definition was added.'; cr]. - each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr]. - each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.'; cr]. - each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr. ]]. ^ contents := strm contents].! Item was changed: ----- Method: ChangeSorter>>setRecentUpdatesMarker (in category 'changeSet menu') ----- setRecentUpdatesMarker "Allow the user to change the recent-updates marker" | result | + result := Project uiManager request: - result := UIManager default request: ('Enter the lowest change-set number that you wish to consider "recent"? (note: highest change-set number + in this image at this time is {1})' translated format: {ChangeSet highestNumberedChangeSet}) initialAnswer: ChangesOrganizer recentUpdateMarker recentUpdateMarker asString. - in this image at this time is ', ChangeSet highestNumberedChangeSet asString, ')') initialAnswer: ChangesOrganizer recentUpdateMarker recentUpdateMarker asString. (result notNil and: [result startsWithDigit]) ifTrue: [ChangesOrganizer recentUpdateMarker: result asInteger. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]]! Item was changed: ----- Method: ChangeSorter>>shiftedChangeSetMenu: (in category 'changeSet menu') ----- shiftedChangeSetMenu: aMenu "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down" <changeSetMenuShifted: true> + aMenu title: 'Change set (shifted)' translated. - aMenu title: 'Change set (shifted)'. aMenu addStayUpItemSpecial. "CONFLICTS SECTION" + aMenu add: 'conflicts with other change sets' translated action: #browseMethodConflicts. - aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts. aMenu balloonTextForLastItem: + 'Browse all methods that occur both in this change set and in at least one other change set.' translated. - 'Browse all methods that occur both in this change set and in at least one other change set.'. self changeSetMenuForOpposite: aMenu. aMenu addLine. "CHECKS SECTION" + aMenu add: 'check for slips' translated action: #lookForSlips. - aMenu add: 'check for slips' action: #lookForSlips. aMenu balloonTextForLastItem: + 'Check this change set for halts and references to Transcript.' translated. - 'Check this change set for halts and references to Transcript.'. + aMenu add: 'check for unsent messages' translated action: #checkForUnsentMessages. - aMenu add: 'check for unsent messages' action: #checkForUnsentMessages. aMenu balloonTextForLastItem: + 'Check this change set for messages that are not sent anywhere in the system' translated. - 'Check this change set for messages that are not sent anywhere in the system'. + aMenu add: 'check for uncommented methods' translated action: #checkForUncommentedMethods. - aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods. aMenu balloonTextForLastItem: + 'Check this change set for methods that do not have comments' translated. - 'Check this change set for methods that do not have comments'. + aMenu add: 'check for uncommented classes' translated action: #checkForUncommentedClasses. - aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses. aMenu balloonTextForLastItem: + 'Check for classes with code in this changeset which lack class comments' translated. - 'Check for classes with code in this changeset which lack class comments'. Utilities authorInitialsPerSe isEmptyOrNil ifFalse: + [aMenu add: 'check for other authors' translated action: #checkForAlienAuthorship. - [aMenu add: 'check for other authors' action: #checkForAlienAuthorship. aMenu balloonTextForLastItem: + ('Check this change set for methods whose current authoring stamp does not start with "{1}"' translated format: {Utilities authorInitials}). - 'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'. + aMenu add: 'check for any other authors' translated action: #checkForAnyAlienAuthorship. - aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship. aMenu balloonTextForLastItem: + ('Check this change set for methods any of whose authoring stamps do not start with "{1}"' translated format: {Utilities authorInitials})]. - 'Check this change set for methods any of whose authoring stamps do not start with "', Utilities authorInitials, '"']. + aMenu add: 'check for uncategorized methods' translated action: #checkForUnclassifiedMethods. - aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods. aMenu balloonTextForLastItem: + 'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.' translated. - 'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'. aMenu addLine. + aMenu add: 'inspect change set' translated action: #inspectChangeSet. - aMenu add: 'inspect change set' action: #inspectChangeSet. aMenu balloonTextForLastItem: + 'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)' translated. - 'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'. + aMenu add: 'update' translated action: #update. - aMenu add: 'update' action: #update. aMenu balloonTextForLastItem: + 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)' translated. - 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'. + aMenu add: 'go to change set''s project' translated action: #goToChangeSetsProject. - aMenu add: 'go to change set''s project' action: #goToChangeSetsProject. aMenu balloonTextForLastItem: + 'If this change set is currently associated with a Project, go to that project right now.' translated. - 'If this change set is currently associated with a Project, go to that project right now.'. self changeSetMenuForPromote: aMenu. + aMenu add: 'trim history' translated action: #trimHistory. - aMenu add: 'trim history' action: #trimHistory. aMenu balloonTextForLastItem: + ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes' translated. - ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'. self changeSetMenuForDropInClassCats: aMenu. + aMenu add: 'clear this change set' translated action: #clearChangeSet. - aMenu add: 'clear this change set' action: #clearChangeSet. aMenu balloonTextForLastItem: + 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!' translated. + aMenu add: 'expunge uniclasses' translated action: #expungeUniclasses. - 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'. - aMenu add: 'expunge uniclasses' action: #expungeUniclasses. aMenu balloonTextForLastItem: + 'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.' translated. - 'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'. + aMenu add: 'uninstall this change set' translated action: #uninstallChangeSet. - aMenu add: 'uninstall this change set' action: #uninstallChangeSet. aMenu balloonTextForLastItem: + 'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!' translated. - 'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'. self changeSetMenuForModification: aMenu. aMenu addLine. + aMenu add: 'more...' translated action: #offerUnshiftedChangeSetMenu. - aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu. aMenu balloonTextForLastItem: + 'Takes you back to the primary change-set menu.' translated. - 'Takes you back to the primary change-set menu.'. ^ aMenu! Item was changed: ----- Method: ChangeSorter>>shiftedClassListMenu: (in category 'class list') ----- shiftedClassListMenu: aMenu "Fill aMenu with items appropriate for the class list" <classListMenuShifted: true> + aMenu title: 'class list' translated. - aMenu title: 'class list'. aMenu addStayUpItemSpecial. + aMenu addTranslatedList: #( - aMenu addList: #( - ('unsent methods' browseUnusedMethods) ('unreferenced inst vars' showUnreferencedInstVars) ('unreferenced class vars' showUnreferencedClassVars) - ('sample instance' makeSampleInstance) ('inspect instances' inspectInstances) ('inspect subinstances' inspectSubInstances) - ('more...' offerUnshiftedClassListMenu )). ^ aMenu! Item was changed: ----- Method: ChangeSorter>>shiftedMessageMenu: (in category 'message list') ----- shiftedMessageMenu: aMenu "Arm the menu so that it holds items appropriate to the message-list while the shift key is down. Answer the menu." <messageListMenuShifted: true> + ^ aMenu addTranslatedList: #( - ^ aMenu addList: #( - ('toggle diffing (D)' toggleDiffing) ('implementors of sent messages' browseAllMessages) ('change category...' changeCategory) - ('sample instance' makeSampleInstance) ('inspect instances' inspectInstances) ('inspect subinstances' inspectSubInstances) - ('change sets with this method' findMethodInChangeSets) ('revert to previous version' revertToPreviousVersion) ('revert & remove from changes' revertAndForget)); yourself ! Item was changed: ----- Method: ChangeSorter>>submergeIntoOtherSide (in category 'changeSet menu') ----- submergeIntoOtherSide "Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well." | other message nextToView i all | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ self]. other := (parent other: self) changeSet. + other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!' translated]. - other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!']. myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy. To remove, + simply choose "remove".' translated]. - simply choose "remove".']. myChangeSet okayToRemove ifFalse: [^ self]. message := 'Please confirm: copy all changes + in "{1}" into "{2}" - in "', myChangeSet name, '" into "', other name, '" and then destroy the change set + named "{3}"?' translated format: {myChangeSet name. other name. myChangeSet name}. - named "', myChangeSet name, '"?'. (self confirm: message) ifFalse: [^ self]. (myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue: [(self confirm: 'Caution!! This change set has a preamble or a postscript or both. If you submerge it into the other side, these will be lost. + Do you really want to go ahead with this?' translated) ifFalse: [^ self]]. - Do you really want to go ahead with this?') ifFalse: [^ self]]. other assimilateAllChangesFoundIn: myChangeSet. all := ChangeSet allChangeSets. nextToView := ((all includes: myChangeSet) and: [(i := all indexOf: myChangeSet) < all size]) ifTrue: [all at: i+1] ifFalse: [other]. self removePrompting: false. self showChangeSet: nextToView. + parent modelWakeUp.! - parent modelWakeUp. - ! Item was changed: ----- Method: ChangeSorter>>uninstallChangeSet (in category 'changeSet menu') ----- uninstallChangeSet "Attempt to uninstall the current change set, after confirmation." self okToChange ifFalse: [^ self]. (self confirm: 'Uninstalling a changeSet is unreliable at best. It will only work if the changeSet consists only of single changes, additions and removals of methods, and if no subsequent changes have been to any of them. No changes to classes will be undone. The changeSet will be cleared after uninstallation. + Do you still wish to attempt to uninstall this changeSet? translated') - Do you still wish to attempt to uninstall this changeSet?') ifFalse: [^ self]. myChangeSet uninstall. self changed: #relabel. self changed: #classList. self changed: #messageList. self setContents. + self contentsChanged.! - self contentsChanged. - ! Item was changed: ----- Method: ChangeSorter>>unshiftedChangeSetMenu: (in category 'changeSet menu') ----- unshiftedChangeSetMenu: aMenu "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" <changeSetMenuShifted: false> Smalltalk isMorphic ifTrue: + [aMenu title: 'Change Set' translated] - [aMenu title: 'Change Set'] ifFalse: [aMenu title: 'Change Set: + ' translated , myChangeSet name]. - ' , myChangeSet name]. aMenu addStayUpItemSpecial. + aMenu add: 'make changes go to me (m)' translated action: #newCurrent. - aMenu add: 'make changes go to me (m)' action: #newCurrent. aMenu addLine. + aMenu add: 'new change set... (n)' translated action: #newSet. + aMenu add: 'find...(f)' translated action: #findCngSet. + aMenu add: 'select change set...' translated action: #chooseCngSet. - aMenu add: 'new change set... (n)' action: #newSet. - aMenu add: 'find...(f)' action: #findCngSet. - aMenu add: 'select change set...' action: #chooseCngSet. aMenu addLine. + aMenu add: 'rename change set (r)' translated action: #rename. + aMenu add: 'file out (o)' translated action: #fileOut. + aMenu add: 'mail to list' translated action: #mailOut. + aMenu add: 'browse methods (b)' translated action: #browseChangeSet. + aMenu add: 'browse change set (B)' translated action: #openChangeSetBrowser. - aMenu add: 'rename change set (r)' action: #rename. - aMenu add: 'file out (o)' action: #fileOut. - aMenu add: 'mail to list' action: #mailOut. - aMenu add: 'browse methods (b)' action: #browseChangeSet. - aMenu add: 'browse change set (B)' action: #openChangeSetBrowser. aMenu addLine. parent ifNotNil: + [aMenu add: 'copy all to other side (c)' translated action: #copyAllToOther. + aMenu add: 'submerge into other side' translated action: #submergeIntoOtherSide. + aMenu add: 'subtract other side (-)' translated action: #subtractOtherSide. - [aMenu add: 'copy all to other side (c)' action: #copyAllToOther. - aMenu add: 'submerge into other side' action: #submergeIntoOtherSide. - aMenu add: 'subtract other side (-)' action: #subtractOtherSide. aMenu addLine]. myChangeSet hasPreamble ifTrue: + [aMenu add: 'edit preamble... (p)' translated action: #editPreamble. + aMenu add: 'remove preamble' translated action: #removePreamble] + ifFalse: [aMenu add: 'add preamble... (p)' translated action: #editPreamble]. - [aMenu add: 'edit preamble... (p)' action: #editPreamble. - aMenu add: 'remove preamble' action: #removePreamble] - ifFalse: [aMenu add: 'add preamble... (p)' action: #editPreamble]. myChangeSet hasPostscript ifTrue: + [aMenu add: 'edit postscript...' translated action: #editPostscript. + aMenu add: 'remove postscript' translated action: #removePostscript] + ifFalse: [aMenu add: 'add postscript...' translated action: #editPostscript]. - [aMenu add: 'edit postscript...' action: #editPostscript. - aMenu add: 'remove postscript' action: #removePostscript] - ifFalse: [aMenu add: 'add postscript...' action: #editPostscript]. aMenu addLine. + aMenu add: 'destroy change set (x)' translated action: #remove. - aMenu add: 'destroy change set (x)' action: #remove. aMenu addLine. + aMenu add: 'more...' translated action: #offerShiftedChangeSetMenu. - aMenu add: 'more...' action: #offerShiftedChangeSetMenu. ^ aMenu! Item was changed: ----- Method: ChangeSorter>>unshiftedMessageMenu: (in category 'message list') ----- unshiftedMessageMenu: aMenu "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" <messageListMenuShifted: false> + aMenu title: 'message list' translated. - aMenu title: 'message list'. aMenu addStayUpItemSpecial. parent ifNotNil: + [aMenu addTranslatedList: #( - [aMenu addList: #( ('copy method to other side' copyMethodToOther) ('move method to other side' moveMethodToOther))]. + aMenu addTranslatedList: #( - aMenu addList: #( ('delete method from changeSet (d)' forget) - ('remove method from system (x)' removeMessage) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions)). + ^ aMenu! - ^ aMenu - ! Item was changed: ----- Method: ChangesOrganizer class>>fileOutChangeSetsNamed: (in category 'utilities') ----- fileOutChangeSetsNamed: nameList "File out the list of change sets whose names are provided" "ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')" | notFound empty infoString | notFound := OrderedCollection new. empty := OrderedCollection new. nameList do: [:aName | | aChangeSet | (aChangeSet := self changeSetNamed: aName) ifNotNil: [aChangeSet isEmpty ifTrue: [empty add: aName] ifFalse: [aChangeSet fileOut]] ifNil: [notFound add: aName]]. + infoString := '{1} change set(s) filed out' translated format: {nameList size - notFound size}. - infoString := (nameList size - notFound size) printString, ' change set(s) filed out'. notFound size > 0 ifTrue: [infoString := infoString, ' + ', ('{1} change set(s) not found:' translated format: {notFound size}). - ', notFound size printString, ' change set(s) not found:'. notFound do: [:aName | infoString := infoString, ' ', aName]]. empty size > 0 ifTrue: [infoString := infoString, ' + ', ('{1} change set(s) were empty:' translated format: {empty size }). - ', empty size printString, ' change set(s) were empty:'. empty do: [:aName | infoString := infoString, ' ', aName]]. self inform: infoString! Item was changed: ----- Method: ChangesOrganizer class>>mostRecentChangeSetWithChangeForClass:selector: (in category 'enumerating') ----- mostRecentChangeSetWithChangeForClass: class selector: selector | hits | hits := self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. + hits isEmpty ifTrue: [^ 'not in any change set' translated]. + ^ 'recent cs: {1}' translated format: {hits last name}! - hits isEmpty ifTrue: [^ 'not in any change set']. - ^ 'recent cs: ', hits last name! Item was changed: ----- Method: ChangesOrganizer class>>newChangeSet (in category 'adding') ----- newChangeSet "Prompt the user for a name, and establish a new change set of that name (if ok), making it the current changeset. Return nil of not ok, else return the actual changeset." | newName newSet | + newName := Project uiManager + request: 'Please name the new change set:' translated - newName := UIManager default - request: 'Please name the new change set:' initialAnswer: ChangeSet defaultName. newName isEmptyOrNil ifTrue: [^ nil]. newSet := self basicNewChangeSet: newName. newSet ifNotNil: + [ChangeSet newChanges: newSet]. - [ChangeSet newChanges: newSet]. ^ newSet! Item was changed: ----- Method: ChangesOrganizer class>>removeEmptyUnnamedChangeSets (in category 'removing') ----- removeEmptyUnnamedChangeSets "Remove all change sets that are empty, whose names start with Unnamed, and which are not nailed down by belonging to a Project." "ChangeSorter removeEmptyUnnamedChangeSets" | toGo | (toGo := (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed']) select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]]) do: [:cs | self removeChangeSet: cs]. + self inform: ('{1} change set(s) removed.' translated format: {toGo size}).! - self inform: toGo size printString, ' change set(s) removed.'! Item was changed: ----- Method: ClassCommentVersionsBrowser class>>browseCommentOf: (in category 'instance creation') ----- browseCommentOf: class Cursor read showWhile: [| changeList | changeList := self new scanVersionsOf: class. + changeList ifNil: [^ self inform: 'No versions available' translated]. + self open: changeList name: ('Recent versions of {1}''s comments' translated format: {class name}) multiSelect: false ] - changeList ifNil: [^ self inform: 'No versions available']. - self open: changeList name: 'Recent versions of ',class name,'''s comments' multiSelect: false ] ! Item was changed: ----- Method: ClassCommentVersionsBrowser>>offerVersionsHelp (in category 'menu') ----- offerVersionsHelp (StringHolder new contents: self versionsHelpString) + openLabel: 'Class Comment Versions Browsers' translated! - openLabel: 'Class Comment Versions Browsers'! Item was changed: ----- Method: ClassCommentVersionsBrowser>>scanVersionsOf: (in category 'basic function') ----- scanVersionsOf: class "Scan for all past versions of the class comment of the given class" | oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex | classOfMethod := class. oldCommentRemoteStr := class organization commentRemoteStr. currentCompiledMethod := oldCommentRemoteStr. selectorOfMethod := #Comment. changeList := OrderedCollection new. list := OrderedCollection new. listIndex := 0. oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer]. sourceFilesCopy := SourceFiles collect: [:x | x isNil ifTrue: [ nil ] ifFalse: [x readOnlyCopy]]. position := oldCommentRemoteStr position. file := sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber. [position notNil & file notNil] whileTrue: [file position: (0 max: position-150). " Skip back to before the preamble" [file position < (position-1)] "then pick it up from the front" whileTrue: [preamble := file nextChunk]. prevPos := nil. stamp := ''. (preamble findString: 'commentStamp:' startingAt: 1) > 0 ifTrue: [tokens := Scanner new scanTokens: preamble. (tokens at: tokens size-3) = #commentStamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size-2. prevPos := tokens last. prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos]] ifFalse: ["The stamp get lost, maybe after a condenseChanges" + stamp := '<historical>' translated]. - stamp := '<historical>']. self addItem: (ChangeRecord new file: file position: position type: #classComment class: class name category: nil meta: class isMeta stamp: stamp) text: stamp , ' ' , class name , ' class comment'. prevPos = 0 ifTrue:[prevPos := nil]. position := prevPos. prevPos notNil ifTrue:[file := sourceFilesCopy at: prevFileIndex]]. sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. listSelections := Array new: list size withAll: false! Item was changed: ----- Method: DependencyBrowser class>>openInvertedOn: (in category 'opening') ----- openInvertedOn: requiredPackageNames "DependencyBrowser openInvertedOn: #(Monticello)" | model | model := self new. ^ ToolBuilder open: ( model packageList: (model packageList select: [:packageName | model computePackageAndClassDependencies: packageName. model packageDeps includesAnyOf: requiredPackageNames]); + windowTitle: ('Dependency Browser (inverted on {1})' translated format: {requiredPackageNames}); + yourself)! - windowTitle: ('Dependency Browser (inverted on {1})' format: {requiredPackageNames}); - yourself) - ! Item was changed: ----- Method: DependencyBrowser class>>openOn: (in category 'opening') ----- openOn: packageNames "DependencyBrowser openOn: #(Morphic EToys)" ^ ToolBuilder open: (self new packageList: packageNames; + windowTitle: 'Dependency Browser (on selected packages)' translated; - windowTitle: 'Dependency Browser (on selected packages)'; yourself)! Item was changed: ----- Method: DependencyBrowser>>classDepsList (in category 'class dependencies') ----- classDepsList "Class dependencies for the currently selected package" | checkDef checkExt | checkDef := [:mref | mref selector = #Definition]. checkExt := [:mref | mref category notNil and: [mref category first = $*]]. ^ classDepsList ifNil: [ classDepsList := self classDeps. classDepsList := classDepsList collect: [:className | String streamContents: [:label | label nextPutAll: className. (self depsForClassNamed: className allSatisfy: checkDef) + ifTrue: [label nextPutAll: ' (defs only)' translated] - ifTrue: [label nextPutAll: ' (defs only)'] ifFalse: [(self depsForClassNamed: className allSatisfy: checkExt) + ifTrue: [label nextPutAll: ' *exts only' translated] - ifTrue: [label nextPutAll: ' *exts only'] ifFalse: [ (self depsForClassNamed: className anySatisfy: checkDef) ifTrue: [label nextPutAll: ' ()']. (self depsForClassNamed: className anySatisfy: checkExt) ifTrue: [label nextPutAll: ' *']]]]]]! Item was changed: ----- Method: DependencyBrowser>>classList (in category 'class list') ----- classList "List of classes that refer to dependencies" | selectedPackage | classDeps ifNil: [^ #()]. self classDepsSelection ifNil: [^ #()]. selectedPackage := PackageOrganizer default packageNamed: self packageListSelection ifAbsent: [nil]. classList := (classDeps at: self classDepsSelection ifAbsent: [#()]) collect: [:mref | mref selector = #Definition + ifTrue: [mref actualClass name, ' (class definition)' translated] - ifTrue: [mref actualClass name, ' (class definition)'] ifFalse: [mref category first = $* + ifTrue: ['*extensions' translated] - ifTrue: ['*extensions'] ifFalse: [mref actualClass name]]] as: Set. ^ classList := classList asArray sort! Item was changed: ----- Method: DependencyBrowser>>contents:notifying: (in category 'contents') ----- contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass theMethodName | self changed: #annotation. aString := input asString. aText := input asText. theClass := self selectedClassOrMetaClass. theMethodName := self selectedMessageName. (theClass notNil and: [theMethodName notNil]) ifTrue: [ ^ self okayToAccept ifFalse: [false] ifTrue: [self defineMessageFrom: aText notifying: aController]]. + self error: 'unacceptable accept' translated! - self error: 'unacceptable accept' - ! Item was changed: ----- Method: DependencyBrowser>>messageList (in category 'message list') ----- messageList "List of messages creating dependencies" | selectedClass label filter | classDeps ifNil: [^ #()]. classList ifNil: [^ #()]. selectedClass := self classListSelection. label := classList at: classListIndex ifAbsent: ['']. filter := label ifEmpty: [ [:mref | false] ] ifNotEmpty: [ + (label first = $* or: [(label endsWith: '(class definition)' translated) not]) - (label first = $* or: [(label endsWith: '(class definition)') not]) ifTrue: [ [:mref | mref selector ~= #Definition and: [mref actualClass name = selectedClass]] ] ifFalse: [ [:mref | mref selector = #Definition and: [mref actualClass name = selectedClass]] ]]. ^((classDeps at: self classDepsSelection ifAbsent:[#()]) select: filter thenCollect:[:mref| mref methodSymbol]) asSet asArray sort! Item was changed: ----- Method: DependencyBrowser>>packageDepsList (in category 'package dependencies') ----- packageDepsList "Package dependencies for the currently selected package" | checkDef checkExt | checkDef := [:mref | mref selector = #Definition]. checkExt := [:mref | mref category notNil and: [mref category first = $*]]. ^ packageDepsList ifNil: [ packageDepsList := self packageDeps. packageDepsList := packageDepsList collect: [:packageName | String streamContents: [:label | label nextPutAll: packageName. (self depsForPackageNamed: packageName allSatisfy: checkDef) + ifTrue: [label nextPutAll: ' (defs only)' translated] - ifTrue: [label nextPutAll: ' (defs only)'] ifFalse: [(self depsForPackageNamed: packageName allSatisfy: checkExt) + ifTrue: [label nextPutAll: ' *exts only' translated] - ifTrue: [label nextPutAll: ' *exts only'] ifFalse: [ (self depsForPackageNamed: packageName anySatisfy: checkDef) ifTrue: [label nextPutAll: ' ()']. (self depsForPackageNamed: packageName anySatisfy: checkExt) ifTrue: [label nextPutAll: ' *']]]]]]! Item was changed: ----- Method: DependencyBrowser>>selectedClassName (in category 'class list') ----- selectedClassName | idx | idx := classListIndex ifNil: [0]. ^ (classList ifNotNil: [ :l | l at: idx ifAbsent: [nil]]) ifNotNil: [:label | label first = $* ifTrue: [nil "extension methods"] + ifFalse: [(label endsWith: '(class definition)' translated) - ifFalse: [(label endsWith: '(class definition)') ifTrue: [label findTokens first] ifFalse: [label "e.g., 'String' or 'String class'"]]]! Item was changed: ----- Method: DualChangeSorter>>labelString (in category 'other') ----- labelString + + ^ 'Changes go to "{1}"' translated format: {ChangeSet current name}! - "The window label" - ^'Changes go to "', ChangeSet current name, '"'.! Item was changed: ----- Method: FileList>>put: (in category 'private') ----- put: aText "Private - put the supplied text onto the file" + | ff newName contentTypeLabel | - | ff type newName | brevityState == #fullFile ifTrue: [ff := directory newFileNamed: self fullName. Cursor write showWhile: [ff nextPutAll: aText asString; close]. (directory = ff directory and: [fileName = ff localName]) ifTrue: [contents := aText asString] ifFalse: "user changed the directory and/or renamed the file" [self clearUserEditFlag. directory ~= ff directory ifTrue: [self directory: ff directory. self changed: #rootDirectoryList; changed: #selectedPath]. self updateFileList. contents := aText asString. newName := ff localName. listIndex := list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName]. listIndex > 0 ifTrue: [fileName := newName]. brevityState := #needToGetBrief. self changed: #fileListIndex]. self changed: #relabel. ^ true "accepted"]. listIndex = 0 ifTrue: [self inform: 'No fileName is selected' translated. ^ false "failed"]. + contentTypeLabel := 'These contents' translated. + brevityState = #briefFile ifTrue: [contentTypeLabel := 'Abbreviated contents' translated]. + brevityState = #briefHex ifTrue: [contentTypeLabel := 'Abbreviated contents' translated]. + brevityState = #fullHex ifTrue: [contentTypeLabel := 'Hexadecimal contents' translated]. + brevityState = #FileList ifTrue: [contentTypeLabel := 'Directory contents' translated]. + self inform: ('{1} cannot + meaningfully be saved at present.' translated format: {'Abbreviated contents' translated}). - type := 'These'. - brevityState = #briefFile ifTrue: [type := 'Abbreviated']. - brevityState = #briefHex ifTrue: [type := 'Abbreviated']. - brevityState = #fullHex ifTrue: [type := 'Hexadecimal']. - brevityState = #FileList ifTrue: [type := 'Directory']. - self inform: ('{1} contents cannot - meaningfully be saved at present.' translated format:{type translated}). ^ false "failed" ! Item was changed: ----- Method: Inspector>>inspectOneOf: (in category 'menu - commands') ----- inspectOneOf: someKeys | elements labels choice | someKeys size = 0 ifTrue: [^ self inform: 'Nothing to inspect.' translated]. someKeys size = 1 ifTrue: [^ (self elementAt: someKeys first) inspect]. someKeys size > 50 ifTrue: [^ self inspectOneOfFrom: someKeys first to: someKeys last]. elements := someKeys collect: [:key | [self elementAt: key] ifError: ['<???>']]. labels := someKeys with: elements collect: [:key :element | '{1} -> {2}' format: { key printString. [element printString withoutLineEndings withBlanksCondensed truncateWithElipsisTo: 75] ifError: ['<???>']}]. + choice := Project uiManager chooseFrom: labels title: 'Inspect which field?' translated. - choice := Project uiManager chooseFrom: labels title: 'Inspect which field?'. choice = 0 ifTrue: [^ self]. (elements at: choice) inspect.! Item was changed: ----- Method: Inspector>>labelString (in category 'user interface - window') ----- labelString "See #windowTitle. All tools chose to implement #labelString." ^ '{1}{2}' format: { self object defaultLabelForInspector. self object isReadOnlyObject + ifTrue: [' (read-only)' translated] - ifTrue: [' (read-only)'] ifFalse: ['']}! Item was changed: ----- Method: Model>>saveContents:accessMode: (in category '*Tools-file out') ----- saveContents: stringContents accessMode: accessMode "Interactive callback from TextEditor. Ask the user for a file name/path, suggesting a (cleaned-up) default name to accept. Answers whether the save request was successful." ^ (Project uiManager + saveFilenameRequest: 'Save text contents in file...' translated - saveFilenameRequest: 'Save text contents in file...' initialAnswer: self suggestedFileNameForSave) ifNil: [false] ifNotNil: [:answer | answer ifEmpty: [false] ifNotEmpty: [:fileName | self saveContents: stringContents onFileNamed: fileName accessMode: accessMode]].! Item was changed: ----- Method: Model>>saveContents:onFileNamed:accessMode:workBlock: (in category '*Tools-file out') ----- saveContents: stringContents onFileNamed: fileName accessMode: accessMode workBlock: workBlock "Save stringContents on fileName. Answers whether the save request was successful. On success, fileName will exist, including any new directories in the relative/absolute path. accessMode #create ... Prompt the user if file exists. #update ... Replace all contents if file exists. #append ... Append new contents if file exists." (FileDirectory default on: fileName) containingDirectory assureExistence. accessMode caseOf: { [#create] -> [FileStream newFileNamed: fileName do: workBlock]. [#update] -> [FileStream forceNewFileNamed: fileName do: workBlock]. [#append] -> [FileStream fileNamed: fileName do: [:s | s setToEnd. workBlock value: s]] } otherwise: [ + self error: ('Unknown file access mode: {1}' translated format: {accessMode printString}). - self error: 'Unknown file access mode: ', accessMode printString. ^ false]. Transcript showln: ('{1} contents saved (via {2}) to: {3}' format: { self class. accessMode printString. fileName }). ^ true! Item was changed: ----- Method: VersionsBrowser class>>browseVersionsOf:class:meta:category:selector:lostMethodPointer: (in category 'instance creation') ----- browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: sourcePointer | changeList browser | Cursor read showWhile: [changeList := (browser := self new) scanVersionsOf: method class: class meta: meta category: msgCategory selector: selector]. + changeList ifNil: [ self inform: 'No versions available' translated. ^nil ]. - changeList ifNil: [ self inform: 'No versions available'. ^nil ]. sourcePointer ifNotNil: [changeList setLostMethodPointer: sourcePointer]. + self open: changeList name: ('Recent versions of {1}' translated format: {selector}) multiSelect: false. - self open: changeList name: 'Recent versions of ' , - selector multiSelect: false. ^browser! Item was changed: ----- Method: VersionsBrowser>>addPriorVersionsCountForSelector:ofClass:to: (in category 'misc') ----- addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior versions are seen in a versions browser -- in this case, the inherited version of this method will not work." (aClass includesSelector: aSelector) ifTrue: [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. aStream nextPutAll: ((changeList size > 0 ifTrue: [changeList size = 1 ifTrue: + ['Deleted - one prior version' translated] - ['Deleted - one prior version'] ifFalse: ['Deleted - ', changeList size printString, ' prior versions']] ifFalse: + ['surprisingly, no prior versions' translated]), self annotationSeparator)! - ['surprisingly, no prior versions']), self annotationSeparator)! Item was changed: ----- Method: VersionsBrowser>>fileOutSelection (in category 'menu') ----- fileOutSelection | them it file | them := OrderedCollection new. listSelections with: changeList do: [:selected :item | selected ifTrue: [them add: item]]. them size ~= 1 + ifTrue: [self inform: 'single version not selected, so nothing done' translated] - ifTrue: [self inform: 'single version not selected, so nothing done'] ifFalse: [it := them first. file := FileStream newFileNamed: it methodClassName, (it isMetaClassChange ifTrue: [' class'] ifFalse: ['']), '-' , (it methodSelector copyReplaceAll: ':' with: ''). [file header; timeStamp. it fileOutOn: file] ensure: [file close]]! Item was changed: ----- Method: VersionsBrowser>>findOriginalChangeSet (in category 'menu') ----- findOriginalChangeSet | changeSet | self currentChange ifNil: [^ self]. changeSet := self currentChange originalChangeSetForSelector: self selectedMessageName. changeSet = #sources ifTrue: + [^ self inform: 'This version is in the .sources file.' translated]. - [^ self inform: 'This version is in the .sources file.']. changeSet ifNil: + [^ self inform: 'This version was not found in any changeset nor in the .sources file.' translated]. - [^ self inform: 'This version was not found in any changeset nor in the .sources file.']. (ChangeSorter new myChangeSet: changeSet) open! Item was changed: ----- Method: VersionsBrowser>>versionsHelpString (in category 'menu') ----- versionsHelpString ^ 'Each entry in the list pane represents a version of the source code for the same method; the topmost entry is the current version, the next entry is the next most recent, etc. To revert to an earlier version, select it (in the list pane) and then do any of the following: * Choose "revert to this version" from the list pane menu. * Hit the "revert" button, * Type ENTER in the code pane * Type cmd-s (alt-s) in the code pane. The code pane shows the source for the selected version. If "diffing" is in effect, then differences betwen the selected version and the version before it are pointed out in the pane. Turn diffing on and off by choosing "toggle diffing" from the list pane menu, or hitting the "diffs" button, or hitting cmd-D when the cursor is over the list pane. To get a comparison between the selected version and the current version, choose "compare to current" from the list pane menu or hit the "compare to current" button. (This is meaningless if the current version is selected, and is unnecessary if you''re interested in diffs from between the current version and the next-most-recent version, since the standard in-pane "diff" feature will give you that.) You can also compare the selected version with any other version using the "compare to version..." menu choice. If further versions of the method in question have been submitted elsewhere since you launched a particular Versions Browser, it will still stay nicely up-to-date if you''re in Morphic and have asked that smart updating be maintained; if you''re in mvc or in morphic but with smart-updating turned off, a versions browser is only brought up to date when you activate its window (and when you issue "revert" from within it, of course,) and you can also use the "update list" command to make certain the versions list is up to date. Hit the "remove from changes" button, or choose the corresponding command in the list pane menu, to have the method in question deleted from the current change set. This is useful if you''ve put debugging code into a method, and now want to strip it out and cleanse your current change set of all memory of the excursion. + Note: the annotation pane in versions browsers shows information about the *current* version of the method in the image, not about the selected version.' translated! - Note: the annotation pane in versions browsers shows information about the *current* version of the method in the image, not about the selected version.'!

1 0

The Trunk: UpdateStream-ct.18.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of UpdateStream to project The Trunk: http://source.squeak.org/trunk/UpdateStream-ct.18.mcz ==================== Summary ==================== Name: UpdateStream-ct.18 Author: ct Time: 3 January 2022, 10:33:39.363397 pm UUID: b48f8a5e-509e-324c-8bd6-4f75867a9e93 Ancestors: UpdateStream-dtl.17 Several improvements to multilingual support. =============== Diff against UpdateStream-dtl.17 =============== Item was changed: ----- Method: ImageReadWriter class>>formFromServerFile: (in category '*UpdateStream') ----- formFromServerFile: fileName "Answer a ColorForm stored on the file with the given name. Meant to be called from during the getting of updates from the server. That assures that (UpdateStreamDownloader default serverUrls) returns the right group of servers." | urls | urls := UpdateStreamDownloader default serverUrls collect: [:url | url, fileName]. " fileName starts with: 'updates/' " urls do: [:aURL | | form doc | (fileName findTokens: '.') last asLowercase = 'gif' ifTrue: [ form := HTTPSocket httpGif: aURL. form = (ColorForm extent: 20@20 depth: 8) + ifTrue: [self inform: ('The file {1} is ill-formed.' translated format: {aURL})]. - ifTrue: [self inform: 'The file ',aURL,' is ill formed.']. ^ form]. (fileName findTokens: '.') last asLowercase = 'bmp' ifTrue: [ doc := HTTPSocket httpGet: aURL accept: 'image/bmp'. form := Form fromBMPFile: doc. doc close. + form + ifNil: [ + self inform: ('The file {1} is ill-formed.' translated format: {aURL}). + ^ Form new] - form ifNil: [self inform: 'The file ',aURL,' is ill formed.'. ^ Form new] ifNotNil: [^ form]]. + self inform: ('File {1} does not end with .gif or .bmp' translated format: {fileName})]. + self inform: 'That file not found on any server we know' translated.! - self inform: 'File ', fileName, 'does not end with .gif or .bmp']. - self inform: 'That file not found on any server we know'.! Item was changed: ----- Method: UpdateStreamDownloader class>>applyUpdatesFromDiskToUpdateNumber:stopIfGap: (in category 'fetching updates') ----- applyUpdatesFromDiskToUpdateNumber: lastUpdateNumber stopIfGap: stopIfGapFlag "To use this mechanism, be sure all updates you want to have considered are in a folder named 'updates' which resides in the same directory as your image. Having done that, simply evaluate: UpdateStreamDownloader applyUpdatesFromDiskToUpdateNumber: 1234 stopIfGap: false and all numbered updates <= lastUpdateNumber not yet in the image will be loaded in numerical order." | previousHighest currentUpdateNumber done fileNames aMessage updateDirectory loaded | updateDirectory := self getUpdateDirectoryOrNil. updateDirectory ifNil: [^ self]. previousHighest := SystemVersion current highestUpdate. currentUpdateNumber := previousHighest. done := false. loaded := 0. [done] whileFalse: [currentUpdateNumber := currentUpdateNumber + 1. currentUpdateNumber > lastUpdateNumber ifTrue: [done := true] ifFalse: [fileNames := updateDirectory fileNamesMatching: currentUpdateNumber printString , '*'. fileNames size > 1 + ifTrue: [^ self inform: ('ambiguity -- two files both start with {1} - ifTrue: [^ self inform: 'ambiguity -- two files both start with ' , currentUpdateNumber printString , ' (at this point it is probably best to remedy + the situation on disk, then try again.)' translated format: {currentUpdateNumber})]. - the situation on disk, then try again.)']. fileNames size = 0 ifTrue: [Transcript cr; show: 'gap in updates from disk for update number '; print: currentUpdateNumber; show: ' found...'. done := stopIfGapFlag] ifFalse: [ChangeSet newChangesFromStream: (updateDirectory readOnlyFileNamed: fileNames first) named: fileNames first. SystemVersion current registerUpdate: currentUpdateNumber. loaded := loaded + 1]]]. aMessage := loaded = 0 + ifTrue: ['No new updates found.' translated] + ifFalse: ['{1} update(s) loaded.' translated format: {loaded printString}]. + self inform: ('{1} + Highest numbered update is now {2}.' translated format: {aMessage. currentUpdateNumber - 1}).! - ifTrue: ['No new updates found.'] - ifFalse: [loaded printString , ' update(s) loaded.']. - self inform: aMessage , ' - Highest numbered update is now ' , (currentUpdateNumber - 1) printString , '.'! Item was changed: ----- Method: UpdateStreamDownloader class>>newUpdatesOn:special:throughNumber: (in category 'fetching updates') ----- newUpdatesOn: serverList special: indexPrefix throughNumber: aNumber "Return a list of fully formed URLs of update files we do not yet have. Go to the listed servers and look at the file 'updates.list' for the names of the last N update files. We look backwards for the first one we have, and make the list from there. tk 9/10/97 No updates numbered higher than aNumber (if it is not nil) are returned " | existing out maxNumber | maxNumber := aNumber ifNil: [99999]. out := OrderedCollection new. existing := SystemVersion current updates. serverList do: [:server | | raw doc list char | doc := HTTPSocket httpGet: 'http://' , server,indexPrefix,'updates.list'. "test here for server being up" doc class == RWBinaryOrTextStream ifTrue: [raw := doc reset; contents. "one file name per line" list := self extractThisVersion: raw. list reverseDo: [:fileName | | ff itsNumber | ff := (fileName findTokens: '/') last. "allow subdirectories" itsNumber := ff initialIntegerOrNil. (existing includes: itsNumber) ifFalse: [ (itsNumber == nil or: [itsNumber <= maxNumber]) ifTrue: [out addFirst: 'http://' , server, fileName]] ifTrue: [^ out]]. ((out size > 0) or: [char := doc reset; skipSeparators; next. (char == $*) | (char == $#)]) ifTrue: [^ out "we have our list"]]. "else got error msg instead of file" "Server was down, try next one"]. + self inform: 'All code update servers seem to be unavailable' translated. - self inform: 'All code update servers seem to be unavailable'. ^ out! Item was changed: ----- Method: UpdateStreamDownloader class>>objectStrmFromUpdates: (in category 'fetching updates') ----- objectStrmFromUpdates: fileName "Go to the known servers and look for this file in the updates folder. It is an auxillery file, like .morph or a .gif. Return a RWBinaryOrTextStream on it. Meant to be called from during the getting of updates from the server. That assures that (UpdateStreamDownloader serverUrls) returns the right group of servers." Cursor wait showWhile: [ | urls | urls := UpdateStreamDownloader serverUrls collect: [:url | url, 'updates/', fileName]. urls do: [:aUrl | | doc | doc := HTTPSocket httpGet: aUrl accept: 'application/octet-stream'. "test here for server being up" doc class == RWBinaryOrTextStream ifTrue: [^ doc reset]]]. + self inform: 'All update servers are unavailable, or bad file name' translated. - self inform: 'All update servers are unavailable, or bad file name'. ^ nil! Item was changed: ----- Method: UpdateStreamDownloader class>>position:atVersion: (in category 'fetching updates') ----- position: updateStrm atVersion: version "Set the stream to the end of the last line of updates names for this version. Usually the end of the file. We will add a new update name. Return the contents of the rest of the file." | char foundIt where data | updateStrm reset; ascii. foundIt := false. [char := updateStrm next. updateStrm atEnd] whileFalse: [ (char == Character cr or: [char == Character lf]) ifTrue: [ updateStrm peek == $# ifTrue: [ foundIt ifTrue: ["Next section" where := updateStrm position. data := updateStrm upTo: (255 asCharacter). updateStrm position: where. ^ data]. "won't be found -- copy all the way to the end" updateStrm next. (updateStrm nextMatchAll: version) ifTrue: [ (updateStrm atEnd or: [(updateStrm peek = Character cr) | (updateStrm peek = Character lf)]) ifTrue: [ foundIt := true ]]]]]. foundIt ifTrue: [ updateStrm setToEnd. ^ '']. + self error: 'The current version does not have a section in the Updates file' translated.! - self error: 'The current version does not have a section in the Updates file'. - !

1 0

The Trunk: ReleaseBuilder-ct.226.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of ReleaseBuilder to project The Trunk: http://source.squeak.org/trunk/ReleaseBuilder-ct.226.mcz ==================== Summary ==================== Name: ReleaseBuilder-ct.226 Author: ct Time: 3 January 2022, 10:27:10.842397 pm UUID: 3639c022-82ea-7744-b68c-5cc171829185 Ancestors: ReleaseBuilder-mt.225 Improves multilingual support. =============== Diff against ReleaseBuilder-mt.225 =============== Item was changed: ----- Method: ReleaseBuilder class>>assureReleaseRepositoryReadAccess: (in category 'manual') ----- assureReleaseRepositoryReadAccess: repo self releaseLocally ifTrue: [ (FileDirectory on: repo description) assureExistence. ^ true]. [repo allFileNames] on: NetworkError, NotFound do: [ self + inform: ('Release Builder - Manual Step Required\\Please create the release repository:\{1}\...and ensure that you have global read access to it.' translated withCRs - inform: ('Release Builder - Manual Step Required\\Please create the release repository:\{1}\...and ensure that you have global read access to it.' withCRs format: {repo description}). ^ false]. ^ true! Item was changed: ----- Method: ReleaseBuilder class>>assureReleaseRepositoryWriteAccess: (in category 'manual') ----- assureReleaseRepositoryWriteAccess: repo self releaseLocally ifTrue: [^ self]. repo + user: (Project uiManager + request: ('Enter user for {1}' translated format: {repo description}) - user: (UIManager default - request: 'Enter user for ', repo description initialAnswer: (repo user ifEmpty: [Utilities authorInitials])); + password: (Project uiManager + requestPassword: ('Enter password for {1}' translated format: {repo description})).! - password: (UIManager default - requestPassword: 'Enter password for ' , repo description).! Item was changed: ----- Method: ReleaseBuilder class>>checkForDirtyPackages (in category 'scripts - support') ----- checkForDirtyPackages | modifiedWorkingCopies unmergedWorkingCopies | MCWorkingCopy checkModified: true. modifiedWorkingCopies := MCWorkingCopy allManagers select: [:wc | wc ancestors size = 1 and: [wc modified] ]. unmergedWorkingCopies := MCWorkingCopy allManagers select: [:wc | (wc ancestors size = 1) not ]. unmergedWorkingCopies ifNotEmpty: [ "Sort to simplify exploration. MC browser does also show packages sorted." (unmergedWorkingCopies sorted: [:wc1 :wc2 | wc1 packageName <= wc2 packageName]) explore. + Warning signal: 'There are unmerged packages.' translated]. - Warning signal: 'There are unmerged packages.']. modifiedWorkingCopies ifNotEmpty: [ "Sort to simplify exploration. MC browser does also show packages sorted." (modifiedWorkingCopies sorted: [:wc1 :wc2 | wc1 packageName <= wc2 packageName]) explore. (self + confirm: 'Do you want to discard all local changes?' translated + orCancel: [^ Error signal: 'Release building canceled.' translated] + title: 'Dirty Packages Found' translated) - confirm: 'Do you want to discard all local changes?' - orCancel: [^ Error signal: 'Release building canceled.'] - title: 'Dirty Packages Found') ifTrue: [modifiedWorkingCopies do: [:wc | [(self buildRepository versionWithInfo: wc ancestors first) load] on: Warning do: [:warning | warning resume]]]].! Item was changed: ----- Method: ReleaseBuilder class>>checkForNilCategories (in category 'scripts - support') ----- checkForNilCategories | nilClasses nilMethods | nilClasses := OrderedCollection new. nilMethods := OrderedCollection new. SystemNavigation default allClasses do: [:cls | cls category ifNil: [nilClasses add: cls]. {cls. cls class} do: [:b | b selectorsAndMethodsDo: [:selector :method | (method methodClass organization categoryOfElement: selector) in: [:category | (category isNil or: [category = 'nil']) ifTrue: [ nilMethods add: method methodReference]]]]] + displayingProgress: [:behavior | 'Checking for invalid categories...' translated]. - displayingProgress: [:behavior | 'Checking for invalid categories...']. nilMethods ifNotEmpty: [ + SystemNavigation default browseMessageList: nilMethods name: 'Messages with invalid categories' translated autoSelect: nil]. - SystemNavigation default browseMessageList: nilMethods name: 'Messages with invalid categories ', nilMethods size autoSelect: nil]. nilClasses ifNotEmpty: [ nilClasses explore]. (nilClasses notEmpty or: [nilMethods notEmpty]) ifTrue: [ + Warning signal: 'There are classes or methods with invalid categories!!' translated].! - Warning signal: 'There are classes or methods with invalid categories!!'].! Item was changed: ----- Method: ReleaseBuilder class>>checkForUndeclaredSymbols (in category 'scripts - support') ----- checkForUndeclaredSymbols "Parses through all source code in the image and looks for undeclard symbols in those." | msgs | msgs := OrderedCollection new. SystemNavigation default allClasses do: [:cls | {cls. cls class} do: [:b | b selectorsAndMethodsDo: [:selector :method | | parser ranges | parser := SHParserST80 new. parser parseAMethod: true. ranges := parser rangesIn: method getSource classOrMetaClass: method methodClass workspace: nil environment: method methodClass environment. (ranges anySatisfy: [:range | range type = #undefinedIdentifier]) ifTrue: [msgs add: method methodReference]]]] + displayingProgress: [:behavior | 'Checking for undeclared symbols...' translated]. - displayingProgress: [:behavior | 'Checking for undeclared symbols...']. msgs ifNotEmpty: [ + SystemNavigation default browseMessageList: msgs name: 'Invalid Messages' translated autoSelect: nil. + Warning signal: 'There is source code with undeclared symbols!!' translated].! - SystemNavigation default browseMessageList: msgs name: 'Invalid Messages ', msgs size autoSelect: nil. - Warning signal: 'There is source code with undeclared symbols!!'].! Item was changed: ----- Method: ReleaseBuilder class>>configureProjects (in category 'scripts') ----- configureProjects "Set up the desired configuration of projects, which might be a single project, multiple projects..." | homeProject rootProject | homeProject := Project current. rootProject := homeProject. homeProject isMorphic ifFalse: [ + Warning signal: 'The current project is not Morphic. Please create a new Morphic project, enter it, and restart the release building process.' translated]. - Warning signal: 'The current project is not Morphic. Please create a new Morphic project, enter it, and restart the release building process.']. "The home project is a single Morphic project. Let the home project have a parent MVC project as the root of the project tree. The MVC project supports emergency debugging in the event of unrecoverable Morphic problems, and will fall back on the traditional emergency evaluator if MVC debugging fails. If MVC is not installed in the image, then do nothing." Project current removeAllOtherProjects. (Smalltalk classNamed: #MVCProject) + ifNil: [Warning signal: 'MVC must be installed in the release image.' translated] - ifNil: [Warning signal: 'MVC must be installed in the release image.'] ifNotNil: [:mvc | rootProject := mvc new]. rootProject name: 'RootProject'. homeProject name: 'HomeProject'. self assert: homeProject isTopProject; assert: rootProject isTopProject not. rootProject beTopProject. self assert: rootProject isTopProject; assert: homeProject isTopProject not. self assert: rootProject subProjects size = 1; assert: homeProject parent == rootProject; assert: rootProject isMVC.! Item was changed: ----- Method: ReleaseBuilder class>>copyPackagesFrom:to:depth: (in category 'manual') ----- copyPackagesFrom: sourceRepository to: targetRepository depth: historyDepth "Copy the packages currently loaded in the image from the source repository to a target repository. Follow ancestry up to the depth specified." | currentDepth nextVersions currentVersions ignoredVersions | currentDepth := 0. nextVersions := (MCWorkingCopy allManagers gather: [:wc | wc ancestors]) asOrderedCollection. ignoredVersions := OrderedCollection new. [nextVersions notEmpty] whileTrue: [ currentVersions := nextVersions. nextVersions := OrderedCollection new. currentDepth := currentDepth + 1. currentVersions do: [:versionInfo | (targetRepository includesVersionNamed: versionInfo versionName) ifTrue: [Transcript showln: ('[ReleaseBuilder] Version {1} already exists in {2}' format: {versionInfo versionName. targetRepository description})] ifFalse: [(sourceRepository versionWithInfo: versionInfo) ifNil: [ignoredVersions add: versionInfo] ifNotNil: [:version | targetRepository storeVersion: version ] ]. currentDepth < historyDepth ifTrue: [ nextVersions addAll: versionInfo ancestors]]]. ignoredVersions ifNotEmpty: [ ignoredVersions explore. + Warning signal: 'There were versions not found in the source repository.' translated].! - Warning signal: 'There were versions not found in the source repository.'].! Item was changed: ----- Method: ReleaseBuilder class>>doNextStep (in category 'manual - steps') ----- doNextStep "Use this call to perform the manual steps in the release process." | versionString | SystemVersion current isRelease ifTrue: [ + ^ self inform: 'This is a release image. Please use a trunk image to prepare the next release' translated]. - ^ self inform: 'This is a release image. Please use a trunk image to prepare the next release']. versionString := SystemVersion current version. SystemVersion current isAlpha ifTrue: [^ self step1FeatureFreeze]. (SystemVersion current isFeatureFreeze and: [SystemVersion current isCodeFreeze not]) ifTrue: [^ self step2CodeFreeze]. SystemVersion current isReleaseCandidate ifTrue: [ "Still code freeze and another RC? Or do the release?" + (Project uiManager - (UIManager default chooseFrom: #('Create next release candidate' 'Create next release' 'Do nothing') lines: #(2) title: versionString) in: [:answer | answer = 1 ifTrue: [^ self step3NextReleaseCandidate]. answer = 2 ifTrue: [^ self step4Release]]. ^ self].! Item was changed: ----- Method: ReleaseBuilder class>>fileOutChangesBetweenReleases (in category 'scripts - changes') ----- fileOutChangesBetweenReleases "Generate mark-down files with all commit messages by release. To be used to write release notes." | fileNames | fileNames := OrderedCollection new. self changesBetweenReleases keysAndValuesDo: [:location :c | fileNames add: ('commits-{1}.md' format: {(location findTokens: '/') last}). FileStream forceNewFileNamed: fileNames last do: [:strm | c withKeysSortedSafely keysAndValuesDo: [:pkg :changes | strm nextPutAll: '# '; nextPutAll: pkg name; cr. (changes withKeysSorted: #dateAndTime ascending) keysAndValuesDo: [:ver :msg | strm nextPutAll: '- **'; nextPutAll: ver name; nextPutAll: ':** '. msg lines withIndexDo: [:line :index | line ifNotEmpty: [:m | index > 1 ifTrue: [strm nextPutAll: ' ']. strm nextPutAll: m. strm cr]]]]]]. + self inform: 'Files written:' translated translated, String cr, (fileNames joinSeparatedBy: String cr).! - self inform: 'Files written:\' withCRs, (fileNames joinSeparatedBy: String cr).! Item was changed: ----- Method: ReleaseBuilder class>>openWelcomeWorkspacesWith: (in category 'scripts - support') ----- openWelcomeWorkspacesWith: balloonForm | t browser balloon | + t := HelpTopic title: 'Welcome to Squeak' translated readOnlyContents: 'Please choose a topic from the left sidebar.' translated. - t := HelpTopic title: 'Welcome to Squeak' readOnlyContents: 'Please choose a topic from the left sidebar.'. t subtopics add: (SqueakHelp asHelpTopic subtopics detect: [:ea | ea key = #introduction]); add: SqueakLicenseHelp asHelpTopic; add: (SqueakProjectHelp asHelpTopic subtopics detect: [:ea | ea key = #squeakUserInterface]); add: (SqueakProjectHelp asHelpTopic subtopics detect: [:ea | ea key = #workingWithSqueak]); add: SqueakReleaseNotes asHelpTopic. browser := HelpBrowser openOn: t. browser extent: browser world extent * 0.6. browser center: browser world center. browser model showFirstTopic. balloonForm ifNil: [^ self]. balloon := balloonForm asMorph. browser addMorphFront: balloon. balloon layoutFrame: (LayoutFrame fractions: (0@1 corner: 0@1) offsets: (balloon width // 1.7 negated @ (balloon height * 0.9) negated corner: 0@0)).! Item was changed: ----- Method: ReleaseBuilder class>>recompileAll (in category 'scripts - support') ----- recompileAll (Smalltalk classNamed: #EncoderForSistaV1) ifNotNil: [:sistaBytecodeSet| CompiledCode preferredBytecodeSetEncoderClass ~~ sistaBytecodeSet ifTrue: [(self + confirm: 'Do you want to make it the default in this release?' translated - confirm: 'Do you want to make it the default in this release?' orCancel: [false] + title: 'The SistaV1 Bytecode Set Is Available' translated) ifTrue: - title: 'The SistaV1 Bytecode Set Is Available') ifTrue: [CompiledCode installSecondaryBytecodeSet: sistaBytecodeSet; preferredBytecodeSetEncoderClass: sistaBytecodeSet]]]. Compiler recompileAll! Item was changed: ----- Method: ReleaseBuilder class>>releaseRepository (in category 'accessing') ----- releaseRepository (MCRepositoryGroup default repositories detect: [:repo | repo description = self releaseRepositoryUrl] ifNone: [MCRepository location: self releaseRepositoryUrl]) in: [:repo | (self assureReleaseRepositoryReadAccess: repo) + ifFalse: [ReleaseBuilderFailed signal: 'Could not build the release.' translated]. - ifFalse: [ReleaseBuilderFailed signal: 'Could not build the release.']. MCRepositoryGroup default addRepository: repo. ^ repo]! Item was changed: ----- Method: ReleaseBuilder class>>requestNextReleaseVersion (in category 'manual') ----- requestNextReleaseVersion "self requestNextReleaseVersion" | nextMinor nextMajor current next | current := { SystemVersion current majorVersionNumber. SystemVersion current minorVersionNumber}. nextMinor := { current first. current second + 1}. nextMajor := { current first + 1. 0}. next := Project uiManager chooseFromLabeledValues: (OrderedDictionary new at: ('{1}.{2}' format: {nextMinor first. nextMinor second}) put: nextMinor; at: ('{1}.{2}' format: {nextMajor first. nextMajor second}) put: nextMajor; yourself) + title: 'Please Choose Next Version' translated. - title: 'Please Choose Next Version'. next ifNil: [^ self requestNextReleaseVersion]. NextMajorVersion := next first. NextMinorVersion := next second.! Item was changed: ----- Method: ReleaseBuilder class>>saveAsNewClean (in category 'saving') ----- saveAsNewClean "Use this to create clean up the current image and save it under a new name." | fileName | (Project uiManager + confirm: 'This will update and clean-up the current image,\which is then saved under a new name.\\Do you want to continue?' translated withCRs + title: 'Prepare Clean Image' translated) == true ifFalse: [^ self]. - confirm: 'This will update and clean-up the current image,\which is then saved under a new name.\\Do you want to continue?' withCRs - title: 'Prepare Clean Image') == true ifFalse: [^ self]. "Prepare first so that we can propose an appropriate file name." self prepareSourceCode; prepareEnvironment. fileName := ('{1}-{2}-{3}-{4}bit-i{5}.image' format: { SystemVersion current version. SystemVersion current highestUpdate. CompiledCode preferredBytecodeSetEncoderClass name allButFirst: 'EncoderFor' size. Smalltalk wordSize * 8. Smalltalk imageFormatVersion}). fileName := Project uiManager saveFilenameRequest: 'Save clean image as...' translated initialAnswer: fileName. fileName ifNil: [^ self]. Smalltalk saveAs: fileName. self saveAndQuit.! Item was changed: ----- Method: ReleaseBuilder class>>saveClean (in category 'saving') ----- saveClean "Use this to clean up the current image and save it under a new name." (Project uiManager + confirm: 'This will update and clean-up the current (!!) image,\which is then saved under the same (!!) name.\\Do you want to continue?' withCRs translated + title: 'Clean Image' translated) == true ifFalse: [^ self]. - confirm: 'This will update and clean-up the current (!!) image,\which is then saved under the same (!!) name.\\Do you want to continue?' withCRs - title: 'Clean Image') == true ifFalse: [^ self]. self prepareSourceCode; prepareEnvironment. self saveAndQuit.! Item was changed: ----- Method: ReleaseBuilder class>>setDisplayExtent: (in category 'scripts - support') ----- setDisplayExtent: extent [ DisplayScreen fullScreenOff; setNewScreenSize: extent. ] on: Error do: [:err | + Transcript showln: ('[ReleaseBuilder] Failed to set display extent to: {1}. Keep {2}.' translated format: {extent. Display extent})].! - Transcript showln: ('[ReleaseBuilder] Failed to set display extent to: {1}. Keep {2}.' format: {extent. Display extent})].! Item was changed: ----- Method: ReleaseBuilder class>>step1FeatureFreeze (in category 'manual - steps') ----- step1FeatureFreeze + (Project uiManager + confirm: ('Do you really want to feature-freeze the trunk\in preparation for the next release {1}?\Bugfixes only after this.' translated withCRs format: {self versionString}) + title: 'Release Builder Step 1 of 4: Feature Freeze' translated) ifFalse: [^ self]. - (UIManager default - confirm: ('Do you really want to feature-freeze the trunk\in preparation for the next release {1}?\Bugfixes only after this.' withCRs format: {self versionString}) - title: 'Release Builder Step 1 of 4: Feature Freeze') ifFalse: [^ self]. self setNewSystemVersion: self versionString, 'beta'.! Item was changed: ----- Method: ReleaseBuilder class>>step2CodeFreeze (in category 'manual - steps') ----- step2CodeFreeze "Creates the first release candidate." + (Project uiManager + confirm: ('Do you really want to code-freeze the trunk\in preparation for the next release {1}?\Urgent fixes only after this.' translated withCRs format: {self versionString}) - (UIManager default - confirm: ('Do you really want to code-freeze the trunk\in preparation for the next release {1}?\Urgent fixes only after this.' withCRs format: {self versionString}) title: 'Release Builder Step 2 of 4: Code Freeze') ifFalse: [^ self]. self setNewSystemVersion: self versionString, 'rc', (SystemVersion current releaseCandidateNumber + 1) asString.! Item was changed: ----- Method: ReleaseBuilder class>>step3NextReleaseCandidate (in category 'manual - steps') ----- step3NextReleaseCandidate "Creates additional release candidates." "update version, update post load script, add stuff commit" + (Project uiManager + confirm: ('Do you want create another release candidate\for the next release {1}?\Urgent fixes still possible.' translated withCRs format: {self versionString}) + title: 'Release Builder Step 3 of 4: Release Candidate' translated) ifFalse: [^ self]. - (UIManager default - confirm: ('Do you want create another release candidate\for the next release {1}?\Urgent fixes still possible.' withCRs format: {self versionString}) - title: 'Release Builder Step 3 of 4: Release Candidate') ifFalse: [^ self]. self setNewSystemVersion: self versionString, 'rc', (SystemVersion current releaseCandidateNumber + 1) asString.! Item was changed: ----- Method: ReleaseBuilder class>>step4Release (in category 'manual - steps') ----- step4Release "Creates the release. New file, cleaned up." + (Project uiManager + confirm: ('Do you want release {1}{2}?' translated withCRs format: { - (UIManager default - confirm: ('Do you want release {1}{2}?' withCRs format: { self versionString. + (self releaseLocally ifTrue: [' locally' translated] ifFalse: [''])}) + title: 'Release Builder Step 4 of 4: The Release' translated) - (self releaseLocally ifTrue: [' locally'] ifFalse: [''])}) - title: 'Release Builder Step 4 of 4: The Release') ifFalse: [^ self]. "If you re-open the current trunk image again, it will be an alpha version for the next release." DeferredTask := [self step0AssureAlpha]. "We continue with preparing the release image." NextTask := [self saveAsNewRelease]. "Now save it but do not quit." Smalltalk snapshot: true andQuit: false.!

1 0

The Trunk: Network-ct.255.mcz
by commits＠source.squeak.org 03 Jan '22

03 Jan '22

Christoph Thiede uploaded a new version of Network to project The Trunk: http://source.squeak.org/trunk/Network-ct.255.mcz ==================== Summary ==================== Name: Network-ct.255 Author: ct Time: 3 January 2022, 10:19:21.768397 pm UUID: 50fb6477-19e1-1444-a9ca-697aff405f6e Ancestors: Network-mt.254 Improves multilingual support. =============== Diff against Network-mt.254 =============== Item was changed: ----- Method: Socket>>connectTo:port:waitForConnectionFor: (in category 'connection open/close') ----- connectTo: hostAddress port: port waitForConnectionFor: timeout "Initiate a connection to the given port at the given host address. Waits until the connection is established or time outs." self connectNonBlockingTo: hostAddress port: port. self waitForConnectionFor: timeout + ifTimedOut: [ConnectionTimedOut signal: ('Cannot connect to {1}' translated format: {hostAddress})] + ifRefused: [ConnectionRefused signal: ('Cannot connect to {1}' translated format: {hostAddress})]! - ifTimedOut: [ConnectionTimedOut signal: 'Cannot connect to ', hostAddress printString] - ifRefused: [ConnectionRefused signal: 'Cannot connect to ', hostAddress printString]! Item was changed: ----- Method: Socket>>connectTo:waitForConnectionFor: (in category 'ipv6') ----- connectTo: aSocketAddress waitForConnectionFor: timeout self connectNonBlockingTo: aSocketAddress. self waitForConnectionFor: timeout + ifTimedOut: [ConnectionTimedOut signal: ('Cannot connect to {1}' translated format: {aSocketAddress})] + ifRefused: [ConnectionRefused signal: ('Cannot connect to {1}' translated format: {aSocketAddress})]! - ifTimedOut: [ConnectionTimedOut signal: 'Cannot connect to ', aSocketAddress printString] - ifRefused: [ConnectionRefused signal: 'Cannot connect to ', aSocketAddress printString]! Item was changed: ----- Method: Socket>>waitForDataFor: (in category 'waiting') ----- waitForDataFor: timeout "Wait for the given nr of seconds for data to arrive. Signal a time out or connection close exception if either happens before data becomes available." ^self waitForDataFor: timeout + ifClosed: [ConnectionClosed signal: 'Connection closed while waiting for data.' translated] + ifTimedOut: [ConnectionTimedOut signal: 'Data receive timed out.' translated] - ifClosed: [ConnectionClosed signal: 'Connection closed while waiting for data.'] - ifTimedOut: [ConnectionTimedOut signal: 'Data receive timed out.'] ! Item was changed: ----- Method: SocketAddressInformation>>connect (in category 'circuit setup') ----- connect | sock | socketType == SocketTypeStream ifFalse: [^nil]. sock := Socket newTCP: addressFamily. sock connectTo: socketAddress. sock waitForConnectionFor: Socket standardTimeout + ifTimedOut: [ConnectionTimedOut signal: ('Cannot connect to {1}' translated format: {self})] + ifRefused: [ConnectionRefused signal: ('Cannot connect to {1}' translated format: {self})]. - ifTimedOut: [ConnectionTimedOut signal: 'Cannot connect to ', self printString] - ifRefused: [ConnectionRefused signal: 'Cannot connect to ', self printString]. ^sock! Item was changed: ----- Method: SocketStream class>>openConnectionToHostNamed:port: (in category 'instance creation') ----- openConnectionToHostNamed: hostName port: portNumber | addressInformations stream | NetNameResolver useOldNetwork ifTrue: [ | hostIP | hostIP := NetNameResolver addressForName: hostName timeout: 20. + hostIP ifNil: [NetworkError signal: ('Cannot resolve {1}.' translated format: {hostName})]. - hostIP ifNil: [NetworkError signal: ('Cannot resolve {1}.' format: {hostName})]. ^self openConnectionToHost: hostIP port: portNumber]. addressInformations := SocketAddressInformation forHost: hostName service: portNumber asString flags: 0 addressFamily: 0 socketType: SocketAddressInformation socketTypeStream protocol: SocketAddressInformation protocolTCP. addressInformations ifEmpty: [ NoNetworkError signal: ('Could not find a network for {1} on port {2}' translated format: {hostName. portNumber})]. stream := addressInformations readStream. ^ [self on: stream next connect] on: NetworkError do: [:exc | stream atEnd ifTrue: ["No more address to retry, pass the exception to upper level" exc pass] ifFalse: ["retry with next address" exc retry]].! Item was changed: ----- Method: SocketStream>>signalClosed (in category 'private-socket') ----- signalClosed self shouldSignal ifFalse: [^ self]. + ConnectionClosed signal: 'Connection closed while waiting for data.' translated.! - ConnectionClosed signal: 'Connection closed while waiting for data.'! Item was changed: ----- Method: SocketStream>>signalTimeout (in category 'private-socket') ----- signalTimeout self shouldSignal ifFalse: [^ self]. + ConnectionTimedOut signal: 'Data receive timed out.' translated.! - ConnectionTimedOut signal: 'Data receive timed out.'!

1 0

Jump to page: