[Cuis-dev] Some experimental libraries based on method wrappers
Mariano Montone
marianomontone at gmail.com
Sat Jul 30 06:31:39 PDT 2022
Hello Juan, Hernán,
I'm attaching a set of packages for you to consider for inclusion into Cuis.
I've improved them and wrote tests for them.
If there's something you don't like, please let me know and I'll try to
improve.
If you decide to include, I think Packages/DevTools could be a good home
for them.
I'm also attaching a FlatFileList tool. It can be helpful to have for
setups like mine where the normal FileList browser is too slow.
But that's up to you if you want to include or not.
Thank you!
Mariano
El 22/6/22 a las 09:20, Juan Vuletich escribió:
> On 6/17/2022 4:41 PM, Mariano Montone via Cuis-dev wrote:
>> Hello,
>>
>> I've been looking at CodeCoverage package by Nicolas Papagna (it is
>> excellently written btw), to try to understand how it worked, in
>> particular the method wrapping.
>>
>> Once I learned how they are implemented, I got the idea of trying
>> some experiments with them.
>>
>> So I'm implementing three packages: MethodAdvisers,
>> BreakpointsManager and MessageTracer.
>>
>> ...
>>
>> These are all very much in the making, with missing things, tests,
>> and tools that would be cool to add; but I think they have potential
>> to be a good set of utilities.
>>
>>
>> Cheers,
>>
>> Mariano
>>
>
> Hi Mariano,
>
> This is very interesting! I think we'd host a package with such
> utilities in the main Cuis repo.
>
> Thanks,
>
-------------- next part --------------
'From Cuis 6.0 [latest update: #5399] on 30 July 2022 at 10:17:53 am'!
'Description Utility library for managing breakpoints via the installation of Method Wrappers.'!
!provides: 'BreakpointsManager' 1 19!
SystemOrganization addCategory: 'BreakpointsManager-Tests'!
SystemOrganization addCategory: 'BreakpointsManager'!
!classDefinition: #BreakpointsManagerTests category: 'BreakpointsManager-Tests'!
TestCase subclass: #BreakpointsManagerTests
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'BreakpointsManager-Tests'!
!classDefinition: 'BreakpointsManagerTests class' category: 'BreakpointsManager-Tests'!
BreakpointsManagerTests class
instanceVariableNames: ''!
!classDefinition: #BreakpointsManagerTestSubject category: 'BreakpointsManager-Tests'!
Object subclass: #BreakpointsManagerTestSubject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'BreakpointsManager-Tests'!
!classDefinition: 'BreakpointsManagerTestSubject class' category: 'BreakpointsManager-Tests'!
BreakpointsManagerTestSubject class
instanceVariableNames: ''!
!classDefinition: #BreakpointMethodWrapper category: 'BreakpointsManager'!
Object subclass: #BreakpointMethodWrapper
instanceVariableNames: 'compiledMethod when enabled methodClass'
classVariableNames: ''
poolDictionaries: ''
category: 'BreakpointsManager'!
!classDefinition: 'BreakpointMethodWrapper class' category: 'BreakpointsManager'!
BreakpointMethodWrapper class
instanceVariableNames: ''!
!classDefinition: #BreakpointsManager category: 'BreakpointsManager'!
Object subclass: #BreakpointsManager
instanceVariableNames: 'installedBreakpoints'
classVariableNames: ''
poolDictionaries: ''
category: 'BreakpointsManager'!
!classDefinition: 'BreakpointsManager class' category: 'BreakpointsManager'!
BreakpointsManager class
instanceVariableNames: 'singleton'!
!BreakpointsManager commentStamp: '<historical>' prior: 0!
I provide an api for managing the installation of breakpoints.
Example:
|subject|
subject _ BreakpointsManagerTestSubject new.
subject foo.
BreakpointsManager setBreakOnEntry: BreakpointsManagerTestSubject selector: #foo.
subject foo.
BreakpointsManagerTestSubject setBreakOnEntry: #foo.
BreakpointsManager disableAllBreakpoints.
BreakpointsManager enableAllBreakpoints.
BreakpointsManager toggleAllBreakpoints.
BreakpointsManager uninstallAll !
!BreakpointsManagerTests methodsFor: 'as yet unclassified' stamp: 'MM 7/30/2022 10:02:14'!
tearDown
BreakpointsManager uninstallAll ! !
!BreakpointsManagerTests methodsFor: 'as yet unclassified' stamp: 'MM 7/30/2022 10:11:10'!
testBreakOnEntry
|subject|
subject _ BreakpointsManagerTestSubject new.
subject foo.
self assert: subject foo = 'foo'.
BreakpointsManager setBreakOnEntry: BreakpointsManagerTestSubject selector: #foo.
self should: [subject foo] raise: Exception.
BreakpointsManager disableBreakpointIn: BreakpointsManagerTestSubject selector: #foo.
self assert: subject foo = 'foo'.
BreakpointsManager enableBreakpointIn: BreakpointsManagerTestSubject selector: #foo.
self should: [subject foo] raise: Exception.
BreakpointsManager unsetBreakpoint: BreakpointsManagerTestSubject selector: #foo.
self assert: subject foo = 'foo'. ! !
!BreakpointsManagerTests methodsFor: 'as yet unclassified' stamp: 'MM 7/30/2022 10:13:06'!
testBreakOnExit
|subject|
subject _ BreakpointsManagerTestSubject new.
subject foo.
self assert: subject foo = 'foo'.
BreakpointsManager setBreakOnExit: BreakpointsManagerTestSubject selector: #foo.
self should: [subject foo] raise: Exception.
BreakpointsManager disableBreakpointIn: BreakpointsManagerTestSubject selector: #foo.
self assert: subject foo = 'foo'.
BreakpointsManager enableBreakpointIn: BreakpointsManagerTestSubject selector: #foo.
self should: [subject foo] raise: Exception.
BreakpointsManager unsetBreakpoint: BreakpointsManagerTestSubject selector: #foo.
self assert: subject foo = 'foo'. ! !
!BreakpointsManagerTests methodsFor: 'as yet unclassified' stamp: 'MM 7/30/2022 10:17:46'!
testSetManyBreaks
|subject|
subject _ BreakpointsManagerTestSubject new.
BreakpointsManagerTestSubject setBreakOnEntry: #foo.
BreakpointsManagerTestSubject setBreakOnEntry: #foo.
BreakpointsManagerTestSubject setBreakOnEntry: #foo.
self should: [subject foo] raise: Exception.
BreakpointsManagerTestSubject unsetBreakAt: #foo.
self assert: subject foo = 'foo'! !
!BreakpointsManagerTestSubject methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 10:09:29'!
bar: aString
^ 'bar: ', aString! !
!BreakpointsManagerTestSubject methodsFor: 'as yet unclassified' stamp: 'MM 7/30/2022 10:04:10'!
foo
Transcript show: 'foo'.
^ 'foo'! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:29:08'!
breakOnEntry
when _ #onEntry! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:30:52'!
breakOnExit
when _ #onExit! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:31:12'!
disable
enabled _ false! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:06:30'!
doesNotUnderstand: aMessage
^ aMessage sendTo: compiledMethod! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:31:05'!
enable
enabled _ true! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:31:20'!
enabled
^ enabled! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:28:47'!
initialize: aClass selector: aSelector
methodClass _ aClass.
compiledMethod _ aClass compiledMethodAt: aSelector.
enabled _ true.
when _ #onEntry
! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:47:28'!
install
methodClass
addSelectorSilently: compiledMethod selector
withMethod: self! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 10:16:56'!
run: aSelector with: arguments in: aReceiver
"Main entry point"
| result |
enabled ifFalse: [^ compiledMethod valueWithReceiver: aReceiver arguments: arguments].
when == #onEntry ifTrue: [self break].
result _ compiledMethod valueWithReceiver: aReceiver arguments: arguments.
when == #onExit ifTrue: [self break].
^ result! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 10:06:35'!
toggle
enabled _ enabled not! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:47:40'!
uninstall
methodClass
addSelectorSilently: compiledMethod selector
withMethod: compiledMethod! !
!BreakpointMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:31:27'!
when
^ when! !
!BreakpointMethodWrapper class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:45:46'!
on: aClass selector: selector
^ self new initialize: aClass selector: selector! !
!BreakpointsManager methodsFor: 'initialization' stamp: 'MM 6/17/2022 09:48:55'!
initialize
installedBreakpoints _ OrderedCollection new! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 6/17/2022 10:05:59'!
disableAllBreakpoints
installedBreakpoints do: [:bp | bp disable]! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 7/29/2022 13:55:30'!
disableBreakpointIn: aClass selector: selector
|bp|
bp _ self breakpointIn: aClass at: selector.
bp disable! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 6/17/2022 10:06:05'!
enableAllBreakpoints
installedBreakpoints do: [:bp | bp enable]! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 7/29/2022 13:55:46'!
enableBreakpointIn: aClass selector: selector
|bp|
bp _ self breakpointIn: aClass at: selector.
bp enable! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 6/17/2022 09:54:11'!
installedBreakpoints
^ installedBreakpoints! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 6/17/2022 09:51:04'!
setBreakOnEntry: aClass selector: selector
| compiledMethod breakpointWrapper |
compiledMethod _ aClass compiledMethodAt: selector.
"If breakpoint already installed, setup and enable."
compiledMethod class isCompiledMethodClass ifFalse: [
(compiledMethod isKindOf: BreakpointMethodWrapper)
ifTrue: [
compiledMethod breakOnEntry; enable.
^ self]].
"Install a new breakpoint wrapper"
breakpointWrapper _ BreakpointMethodWrapper on: aClass selector: selector.
breakpointWrapper breakOnEntry; install.
installedBreakpoints add: breakpointWrapper
! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 6/17/2022 09:53:27'!
setBreakOnExit: aClass selector: selector
| compiledMethod breakpointWrapper |
compiledMethod _ aClass compiledMethodAt: selector.
"If breakpoint already installed, setup and enable."
compiledMethod class isCompiledMethodClass ifFalse: [
(compiledMethod isKindOf: BreakpointMethodWrapper)
ifTrue: [
compiledMethod breakOnExit; enable.
^ self]].
"Install a new breakpoint wrapper"
breakpointWrapper _ BreakpointMethodWrapper on: aClass selector: selector.
breakpointWrapper breakOnExit; install.
installedBreakpoints add: breakpointWrapper
! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 6/17/2022 10:06:13'!
toggleAllBreakpoints
installedBreakpoints do: [:bp | bp toggle]! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 7/29/2022 13:54:16'!
toggleBreakpointIn: aClass selector: selector
|bp|
bp _ self breakpointIn: aClass at: selector.
bp toggle! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 6/17/2022 10:25:23'!
uninstallAll
installedBreakpoints do: [:bp | bp uninstall].
installedBreakpoints _ OrderedCollection new! !
!BreakpointsManager methodsFor: 'api' stamp: 'MM 7/29/2022 13:58:03'!
unsetBreakpoint: aClass selector: selector
|breakpointWrapper|
breakpointWrapper _ self breakpointIn: aClass at: selector.
breakpointWrapper uninstall.
installedBreakpoints remove: breakpointWrapper.! !
!BreakpointsManager methodsFor: 'as yet unclassified' stamp: 'MM 7/29/2022 14:01:58'!
breakpointIn: aClass at: aSelector
|breakpointMethod|
breakpointMethod _ aClass methodDict at: aSelector.
self assert: (breakpointMethod isKindOf: BreakpointMethodWrapper) description: 'No breakpoint installed'.
^ breakpointMethod! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 10:05:13'!
disableAllBreakpoints
self singleton disableAllBreakpoints! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 10:13:46'!
disableBreakpointIn: aClass selector: aSelector
self singleton disableBreakpointIn: aClass selector: aSelector! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 10:05:28'!
enableAllBreakpoints
self singleton enableAllBreakpoints! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 7/30/2022 10:09:16'!
enableBreakpointIn: aClass selector: aSelector
self singleton enableBreakpointIn: aClass selector: aSelector! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:54:37'!
installedBreakpoints
^ self singleton installedBreakpoints! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:38:41'!
setBreakOnEntry: aClass selector: selector
self singleton setBreakOnEntry: aClass selector: selector! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:38:56'!
setBreakOnExit: aClass selector: selector
self singleton setBreakOnExit: aClass selector: selector! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:04:55'!
singleton
^ singleton ifNil: [singleton _ self new]! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 10:05:37'!
toggleAllBreakpoints
self singleton toggleAllBreakpoints! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 10:24:55'!
uninstallAll
self singleton uninstallAll! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 7/29/2022 14:01:00'!
uninstallBreakpoint: aClass selector: selector
self singleton unsetBreakpoint: aClass selector: selector! !
!BreakpointsManager class methodsFor: 'as yet unclassified' stamp: 'MM 7/29/2022 14:01:21'!
unsetBreakpoint: aClass selector: selector
self singleton unsetBreakpoint: aClass selector: selector! !
!Behavior methodsFor: '*BreakpointsManager' stamp: 'MM 6/17/2022 09:37:40'!
setBreakOnEntry: selector
BreakpointsManager setBreakOnEntry: self selector: selector! !
!Behavior methodsFor: '*BreakpointsManager' stamp: 'MM 6/17/2022 09:37:54'!
setBreakOnExit: selector
BreakpointsManager setBreakOnExit: self selector: selector! !
!Behavior methodsFor: '*BreakpointsManager' stamp: 'MM 7/30/2022 10:17:26'!
unsetBreakAt: aSelector
BreakpointsManager unsetBreakpoint: self selector: aSelector ! !
-------------- next part --------------
'From Cuis 6.0 [latest update: #5069] on 9 May 2022 at 5:59:48 pm'!
'Description Flat file browser tool. Alternative to Cuis default FileList tool.'!
!provides: 'FlatFileList' 1 42!
SystemOrganization addCategory: 'FlatFileList'!
!classDefinition: #FlatFileListWindow category: 'FlatFileList'!
SystemWindow subclass: #FlatFileListWindow
instanceVariableNames: 'directoryList fileList directoryIndex fileIndex directoryInput'
classVariableNames: ''
poolDictionaries: ''
category: 'FlatFileList'!
!classDefinition: 'FlatFileListWindow class' category: 'FlatFileList'!
FlatFileListWindow class
instanceVariableNames: ''!
!classDefinition: #FlatFileContentsBrowserWindow category: 'FlatFileList'!
FlatFileListWindow subclass: #FlatFileContentsBrowserWindow
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'FlatFileList'!
!classDefinition: 'FlatFileContentsBrowserWindow class' category: 'FlatFileList'!
FlatFileContentsBrowserWindow class
instanceVariableNames: ''!
!classDefinition: #FlatFileSelectionWindow category: 'FlatFileList'!
FlatFileListWindow subclass: #FlatFileSelectionWindow
instanceVariableNames: 'selectionAction filenameFilter'
classVariableNames: ''
poolDictionaries: ''
category: 'FlatFileList'!
!classDefinition: 'FlatFileSelectionWindow class' category: 'FlatFileList'!
FlatFileSelectionWindow class
instanceVariableNames: ''!
!classDefinition: #FlatFileList category: 'FlatFileList'!
Object subclass: #FlatFileList
instanceVariableNames: 'currentDirectory selectedFile sortBy sortAscending'
classVariableNames: ''
poolDictionaries: ''
category: 'FlatFileList'!
!classDefinition: 'FlatFileList class' category: 'FlatFileList'!
FlatFileList class
instanceVariableNames: ''!
!FlatFileListWindow commentStamp: '<historical>' prior: 0!
A flat file browser.!
!FlatFileContentsBrowserWindow commentStamp: '<historical>' prior: 0!
A flat file list browser that displays file contents in a panel.!
!FlatFileSelectionWindow commentStamp: '<historical>' prior: 0!
A file selection morph.
selectionAction block is evaluated with the selected FileEntry object.
When set, filenameFilter is a block for filtering the type of files allowed. For example: [:fileEntry | fileEntry extension = 'txt']
FlatFileSelectionWindow withFileDo: [:fileEntry | fileEntry inspect]!
!FlatFileList commentStamp: '<historical>' prior: 0!
Model of FlatFileListWindow.!
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 23:12:52'!
addSortMenuItems: aMenu
aMenu add: 'sort by name' action: #sortByName.
aMenu add: 'sort by size' action: #sortBySize.
aMenu add: 'sort by modification time' action: #sortByModificationTime.
aMenu add: 'sort by extension' action: #sortByExtension.! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 23:08:52'!
browseFileChanges
ChangeList browseRecentLogOn: model selectedFile! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 17:31:36'!
buildMorphicWindow
| upperPanel directoryPanel toolbar gotoParentButton refreshButton statusBar |
upperPanel _ LayoutMorph newRow.
directoryPanel _ LayoutMorph newColumn.
toolbar _ LayoutMorph newRow.
gotoParentButton _ PluggableButtonMorph model: self
action: #gotoParentDirectory.
gotoParentButton icon: Theme current goUpIcon.
toolbar addMorph: gotoParentButton.
refreshButton _ PluggableButtonMorph model: self action: #refreshDirectory.
refreshButton icon: Theme current changesIcon .
toolbar addMorph: refreshButton.
directoryInput _ TextModelMorph textProvider: self
textGetter: #currentDirectoryName
textSetter: #currentDirectoryName:.
directoryInput acceptOnCR: true.
toolbar addMorph: directoryInput fixedHeight: 30.
layoutMorph addMorph: toolbar fixedHeight: 30.
directoryList _ PluggableListMorph model: self
listGetter: #directoryListNames
indexGetter: #directoryIndex
indexSetter: #directoryIndex:.
directoryList doubleClickSelector: #selectDirectory.
directoryPanel addMorphUseAll: directoryList.
upperPanel addMorph: directoryPanel proportionalWidth: 0.4.
fileList _ PluggableListMorph model: self
listGetter: #fileListNames
indexGetter: #fileIndex
indexSetter: #fileIndex:
mainView: self
menuGetter: #fileListMenu
keystrokeAction: #fileListKey:from:.
fileList doubleClickSelector: #doubleClickFile.
upperPanel addAdjusterAndMorph: fileList layoutSpec: LayoutSpec useAll.
layoutMorph addMorph: upperPanel.
statusBar _ TextModelMorph textProvider: self textGetter: #statusMessage.
layoutMorph addMorph: statusBar fixedHeight: 30.
! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 18:37:14'!
currentDirectoryName
^ model currentDirectory asString! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 19:59:23'!
currentDirectoryName: aDirectoryName
model currentDirectory: aDirectoryName asString asDirectoryEntry.
directoryInput hasUnacceptedEdits: false.
self directoryChanged.! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 10:00:30'!
directoryChanged
self changed: #directoryListNames.
self changed: #fileListNames.
self changed: #currentDirectoryName.
fileIndex _ nil.
self changed: #fileIndex.
! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/8/2022 10:48:23'!
directoryList
^ model currentDirectoryList! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/8/2022 10:52:02'!
directoryListNames
^ model currentDirectoryList collect: [:dir | dir name]! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 10:17:52'!
doubleClickFile
| selectedFile |
selectedFile _ self fileList at: self fileIndex .
model selectedFile: selectedFile.
self viewSelectedFile! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 22:30:54'!
fileInFile
ChangeSet fileIn: model selectedFile! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 20:21:58'!
fileListMenu
^model selectedFile
ifNil: [ self noFileSelectedMenu ]
ifNotNil: [ self fileSelectedMenu ]! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 23:08:12'!
fileSelectedMenu
| menu |
menu _ MenuMorph entitled: model selectedFile name.
menu defaultTarget: self.
menu add: 'view' action: #viewSelectedFile.
menu add: 'workspace with contents' action: #viewContentsInWorkspace.
({'pck'. 'pck.st'} includes: model selectedFile extension)
ifTrue: [menu add: 'install package' action: #installPackageFile].
model selectedFile extension = 'st'
ifTrue: [menu add: 'file in' action: #fileInFile].
model selectedFile extension = 'cs.st'
ifTrue: [menu add: 'install changeset' action: #installChangeSet].
model selectedFile extension = 'changes'
ifTrue: [menu add: 'browse changes in file' action: #browseFileChanges].
menu addLine .
self addSortMenuItems: menu.
^ menu! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 17:35:20'!
fileSelectionChanged
self changed: #statusMessage! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 09:52:10'!
gotoParentDirectory
model gotoParentDirectory! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 22:31:22'!
installChangeSet
ChangeSet install: model selectedFile! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 20:58:05'!
installPackageFile
CodePackageFile installPackage: model selectedFile! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 22:20:02'!
noFileSelectedMenu
| menu |
menu _ MenuMorph entitled: model selectedFile name.
menu defaultTarget: self.
self addSortMenuItems: menu.
^ menu! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 20:35:19'!
openSelectedFile
model selectedFile fileContents editLabel: model selectedFile asString! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 19:57:04'!
refreshDirectory
self directoryChanged.! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 09:50:06'!
selectDirectory
| selectedDirectory |
selectedDirectory _ self selectedDirectory.
model currentDirectory: selectedDirectory! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/8/2022 10:49:48'!
selectedDirectory
^ model currentDirectoryList at: self directoryIndex! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 23:13:03'!
sortByExtension
model sortBy: #extension.
self directoryChanged.! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 22:18:49'!
sortByModificationTime
model sortBy: #modificationTime.
self directoryChanged.! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 22:18:06'!
sortByName
model sortBy: #name.
self directoryChanged.! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 22:18:40'!
sortBySize
model sortBy: #size.
self directoryChanged.! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 17:58:56'!
statusMessage
^ model selectedFile ifNotNil: [:file |
file name , ' ° ', file fileSize printStringAsBytes , ' ° last modified: ', file modificationTime asString]
ifNil: [model currentDirectory name, ' ° ', model currentDirectory children size asString, ' elements']! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 09:51:14'!
update: aSymbol
aSymbol == #currentDirectory ifTrue: [ self directoryChanged].
aSymbol == #selectedFile ifTrue: [self fileSelectionChanged].! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 20:31:11'!
viewContentsInWorkspace
"View the contents of my selected file in a new workspace"
| aString aName |
model selectedFile readStreamDo: [ :stream |
stream ifNil: [^ 'For some reason, this file cannot be read'].
aString _ stream next: stream size.
aName _ stream localName ].
(Workspace new contents: aString) openLabel: 'Workspace from ', aName! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 21:24:46'!
viewSelectedFile
model selectedFile fileContents editLabel: model selectedFile asString! !
!FlatFileListWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 18:30:53'!
windowColor
^ Theme current fileList! !
!FlatFileListWindow methodsFor: 'accessing' stamp: 'MM 5/7/2022 18:14:25'!
directoryIndex
"Answer the value of directoryIndex"
^ directoryIndex ifNil: [0]! !
!FlatFileListWindow methodsFor: 'accessing' stamp: 'MM 5/7/2022 18:14:08'!
directoryIndex: anObject
"Set the value of directoryIndex"
directoryIndex _ anObject! !
!FlatFileListWindow methodsFor: 'accessing' stamp: 'MM 5/7/2022 18:14:08'!
directoryList: anObject
"Set the value of directoryList"
directoryList _ anObject! !
!FlatFileListWindow methodsFor: 'accessing' stamp: 'MM 5/7/2022 18:14:33'!
fileIndex
"Answer the value of fileIndex"
^ fileIndex ifNil: [0]! !
!FlatFileListWindow methodsFor: 'accessing' stamp: 'MM 5/9/2022 17:58:08'!
fileIndex: anObject
"Set the value of fileIndex"
fileIndex _ anObject.
fileIndex isZero ifFalse: [
model selectedFile: (model currentDirectoryFiles at: fileIndex)]
ifTrue: [model selectedFile: nil]! !
!FlatFileListWindow methodsFor: 'accessing' stamp: 'MM 5/7/2022 21:33:22'!
fileList
"Answer the value of fileList"
^ model currentDirectoryFiles! !
!FlatFileListWindow methodsFor: 'accessing' stamp: 'MM 5/7/2022 18:14:08'!
fileList: anObject
"Set the value of fileList"
fileList _ anObject! !
!FlatFileListWindow methodsFor: 'accessing' stamp: 'MM 5/8/2022 10:53:06'!
fileListNames
"Answer the value of fileList"
^ model currentDirectoryFiles collect: [:file | file name]! !
!FlatFileListWindow class methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 10:21:58'!
open
^ self open: (FlatFileList new currentDirectory: DirectoryEntry currentDirectory) label: 'File browser'.! !
!FlatFileListWindow class methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 21:21:37'!
worldMenuForOpenGroup
^ `{{
#itemGroup -> 40.
#itemOrder -> 10.
#label -> 'Flat File List'.
#object -> FlatFileListWindow.
#selector -> #open.
#icon -> #systemFileManagerIcon.
#balloonText -> 'A flat explorer of the File System'.
} asDictionary}`! !
!FlatFileContentsBrowserWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 09:45:51'!
buildMorphicWindow
| fileContents |
super buildMorphicWindow .
fileContents _ TextModelMorph textProvider: self textGetter: #fileContents textSetter: #fileContents:.
layoutMorph addAdjusterAndMorph: fileContents layoutSpec: LayoutSpec useAll. ! !
!FlatFileContentsBrowserWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 09:55:00'!
fileContents
^ model selectedFile ifNotNil: [:file | file fileContents] ifNil: ['']! !
!FlatFileContentsBrowserWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 17:48:23'!
fileSelectionChanged
super fileSelectionChanged.
self changed: #fileContents.! !
!FlatFileSelectionWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 10:15:29'!
buildMorphicWindow
| buttonsBar selectButton cancelButton |
super buildMorphicWindow .
buttonsBar _ LayoutMorph newRow.
selectButton _ PluggableButtonMorph model: self action: #selectFile label: 'select'.
buttonsBar addMorph: selectButton.
cancelButton _ PluggableButtonMorph model: self action: #cancel label: 'cancel'.
buttonsBar addMorph: cancelButton.
layoutMorph addMorph: buttonsBar fixedHeight: 30. ! !
!FlatFileSelectionWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 10:19:08'!
cancel
self delete! !
!FlatFileSelectionWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 10:18:38'!
doubleClickFile
self selectFile! !
!FlatFileSelectionWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 10:22:24'!
selectFile
selectionAction value: model selectedFile.
self delete! !
!FlatFileSelectionWindow methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 10:21:04'!
selectionAction: aBlock
selectionAction _ aBlock! !
!FlatFileSelectionWindow class methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 10:21:12'!
withFileDo: aBlock
self open selectionAction: aBlock! !
!FlatFileList methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 09:55:34'!
currentDirectory: aDirectory
currentDirectory _ aDirectory.
self changed: #currentDirectory.
self selectedFile: nil! !
!FlatFileList methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 23:12:28'!
currentDirectoryFiles
|files|
files _ self currentDirectory files.
^ sortBy caseOf: {
[#name] -> [|sorter| sorter _ sortAscending
ifTrue: [[:f1 :f2 | f1 name < f2 name]]
ifFalse: [[:f1 :f2 | f1 name > f2 name]].
files asSortedCollection: sorter].
[#modificationTime] -> [|sorter| sorter _ sortAscending
ifTrue: [[:f1 :f2 | f1 modificationTime < f2 modificationTime]]
ifFalse: [[:f1 :f2 | f1 modificationTime > f2 modificationTime]].
files asSortedCollection: sorter].
[#size] -> [|sorter| sorter _ sortAscending
ifTrue: [[:f1 :f2 | f1 fileSize < f2 fileSize]]
ifFalse: [[:f1 :f2 | f1 fileSize > f2 fileSize]].
files asSortedCollection: sorter].
[#extension] -> [|sorter| sorter _ sortAscending
ifTrue: [[:f1 :f2 | f1 extension < f2 extension]]
ifFalse: [[:f1 :f2 | f1 extension > f2 extension]].
files asSortedCollection: sorter].
}! !
!FlatFileList methodsFor: 'as yet unclassified' stamp: 'MM 5/8/2022 10:48:37'!
currentDirectoryList
^ currentDirectory directories asSortedCollection: [:d1 :d2 | d1 name < d2 name]! !
!FlatFileList methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 21:11:20'!
defaultInitialDirectory
^ Preferences initialFileListDirectories
caseOf: {
[ #roots ] -> [ DirectoryEntry roots first].
[ #image ] -> [ DirectoryEntry smalltalkImageDirectory ].
[ #vm ] -> [ DirectoryEntry vmDirectory ].
[ #current ] -> [DirectoryEntry currentDirectory]}
otherwise: [DirectoryEntry currentDirectory]! !
!FlatFileList methodsFor: 'as yet unclassified' stamp: 'MM 5/9/2022 09:52:34'!
gotoParentDirectory
currentDirectory parent ifNotNil: [:parent |
self currentDirectory: parent]! !
!FlatFileList methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 22:15:06'!
initialize
currentDirectory _ self defaultInitialDirectory.
sortBy _ #name.
sortAscending _ true.! !
!FlatFileList methodsFor: 'as yet unclassified' stamp: 'MM 5/7/2022 22:10:42'!
toggleSortDirection
sortAscending _ sortAscending not! !
!FlatFileList methodsFor: 'accessing' stamp: 'MM 5/7/2022 18:12:53'!
currentDirectory
"Answer the value of currentDirectory"
^ currentDirectory! !
!FlatFileList methodsFor: 'accessing' stamp: 'MM 5/7/2022 18:12:53'!
selectedFile
"Answer the value of selectedFile"
^ selectedFile! !
!FlatFileList methodsFor: 'accessing' stamp: 'MM 5/9/2022 09:48:40'!
selectedFile: anObject
"Set the value of selectedFile"
selectedFile _ anObject.
self changed: #selectedFile! !
!FlatFileList methodsFor: 'accessing' stamp: 'MM 5/7/2022 21:34:38'!
sortBy
"Answer the value of sortBy"
^ sortBy! !
!FlatFileList methodsFor: 'accessing' stamp: 'MM 5/7/2022 22:12:24'!
sortBy: anObject
"Set the value of sortBy"
sortBy == anObject ifTrue: [self toggleSortDirection ].
sortBy _ anObject
! !
-------------- next part --------------
'From Cuis 6.0 [latest update: #5399] on 29 July 2022 at 1:42:26 pm'!
'Description Utility library for tracing the sending of messages.'!
!provides: 'MessageTracer' 1 22!
SystemOrganization addCategory: 'MessageTracer-Tests'!
SystemOrganization addCategory: 'MessageTracer'!
!classDefinition: #MessageTracerTestSubject category: 'MessageTracer-Tests'!
Object subclass: #MessageTracerTestSubject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'MessageTracer-Tests'!
!classDefinition: 'MessageTracerTestSubject class' category: 'MessageTracer-Tests'!
MessageTracerTestSubject class
instanceVariableNames: ''!
!classDefinition: #MessageTracer category: 'MessageTracer'!
Object subclass: #MessageTracer
instanceVariableNames: 'outputStream tracing'
classVariableNames: ''
poolDictionaries: ''
category: 'MessageTracer'!
!classDefinition: 'MessageTracer class' category: 'MessageTracer'!
MessageTracer class
instanceVariableNames: 'singleton'!
!classDefinition: #TracedMethodWrapper category: 'MessageTracer'!
Object subclass: #TracedMethodWrapper
instanceVariableNames: 'compiledMethod methodClass enabled when'
classVariableNames: 'InvocationLevel'
poolDictionaries: ''
category: 'MessageTracer'!
!classDefinition: 'TracedMethodWrapper class' category: 'MessageTracer'!
TracedMethodWrapper class
instanceVariableNames: ''!
!MessageTracer commentStamp: 'MM 7/29/2022 12:51:13' prior: 0!
I provide an api for tracing the sending of messages.
The message traces are sent to the Transcript.
For example, open a Transcript and evaluate:
subject _ MessageTracerTestSubject new.
subject foo.
MessageTracer trace: MessageTracerTestSubject selector: #foo.
subject foo.
MessageTracer untrace: MessageTracerTestSubject selector: #foo.
MessageTracerTestSubject trace: #add:to:.
subject add: 4 to: 5.
MessageTracerTestSubject trace: #fact:.
subject fact: 5.
MessageTracerTestSubject trace: #fib:.
subject fib: 10.
MessageTracerTestSubject untrace: #fib:.!
!MessageTracerTestSubject methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 13:33:48'!
add: x to: y
^ x + y! !
!MessageTracerTestSubject methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 12:51:53'!
bar
^ 'bar'! !
!MessageTracerTestSubject methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 13:36:43'!
fact: x
^ x = 1 ifTrue: [x]
ifFalse: [x * (self fact: x - 1)]! !
!MessageTracerTestSubject methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 13:39:28'!
fib: x
^ x <= 1 ifTrue: [x]
ifFalse: [(self fib: x - 1) + (self fib: x - 2)]! !
!MessageTracerTestSubject methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 12:51:47'!
foo
^ 'foo'! !
!MessageTracer methodsFor: 'accessing' stamp: 'MM 6/17/2022 12:35:45'!
outputStream
"Answer the value of outputStream"
^ outputStream! !
!MessageTracer methodsFor: 'accessing' stamp: 'MM 6/17/2022 12:35:45'!
outputStream: anObject
"Set the value of outputStream"
outputStream := anObject! !
!MessageTracer methodsFor: 'api' stamp: 'MM 6/17/2022 13:01:41'!
trace: aClass selector: selector
|methodWrapper compiledMethod |
compiledMethod _ aClass compiledMethodAt: selector.
"If breakpoint already installed, setup and enable."
compiledMethod class isCompiledMethodClass ifFalse: [
(compiledMethod isKindOf: TracedMethodWrapper)
ifTrue: [
compiledMethod when: #around; enable.
^ self]].
"Install a new trace wrapper"
methodWrapper _ TracedMethodWrapper on: aClass selector: selector.
methodWrapper install.
tracing add: methodWrapper! !
!MessageTracer methodsFor: 'api' stamp: 'MM 6/17/2022 13:03:39'!
untrace: aClass selector: selector
|compiledMethod |
compiledMethod _ aClass compiledMethodAt: selector.
compiledMethod class isCompiledMethodClass ifFalse: [
(compiledMethod isKindOf: TracedMethodWrapper)
ifTrue: [
compiledMethod uninstall.
tracing remove: compiledMethod.
^ self]]! !
!MessageTracer methodsFor: 'api' stamp: 'MM 6/17/2022 13:45:08'!
untraceAll
tracing do: [:tracedMethod |
tracedMethod uninstall].
tracing _ OrderedCollection new! !
!MessageTracer methodsFor: 'initialization' stamp: 'MM 6/17/2022 12:54:23'!
initialize
tracing _ OrderedCollection new.
outputStream _ Transcript! !
!MessageTracer class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 12:35:28'!
outputStream
^ self singleton outputStream! !
!MessageTracer class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 12:35:13'!
singleton
^ singleton ifNil: [singleton _ self new]! !
!MessageTracer class methodsFor: 'api' stamp: 'MM 6/17/2022 12:53:20'!
trace: aClass selector: aSelector
self singleton trace: aClass selector: aSelector! !
!MessageTracer class methodsFor: 'api' stamp: 'MM 6/17/2022 13:02:37'!
untrace: aClass selector: aSelector
self singleton untrace: aClass selector: aSelector! !
!MessageTracer class methodsFor: 'api' stamp: 'MM 6/17/2022 13:44:35'!
untraceAll
self singleton untraceAll! !
!TracedMethodWrapper methodsFor: 'initialization' stamp: 'MM 6/17/2022 12:30:37'!
initialize: aClass selector: aSelector
methodClass _ aClass.
compiledMethod _ aClass compiledMethodAt: aSelector.
enabled _ true.
when _ #around
! !
!TracedMethodWrapper methodsFor: 'installation' stamp: 'MM 6/17/2022 12:59:34'!
enable
enabled _ true! !
!TracedMethodWrapper methodsFor: 'installation' stamp: 'MM 6/17/2022 12:58:58'!
install
methodClass
addSelectorSilently: compiledMethod selector
withMethod: self! !
!TracedMethodWrapper methodsFor: 'installation' stamp: 'MM 6/17/2022 12:59:25'!
toggle
enabled _ enabled not! !
!TracedMethodWrapper methodsFor: 'installation' stamp: 'MM 6/17/2022 12:59:15'!
uninstall
methodClass
addSelectorSilently: compiledMethod selector
withMethod: compiledMethod! !
!TracedMethodWrapper methodsFor: 'testing' stamp: 'MM 6/17/2022 12:59:42'!
enabled
^ enabled! !
!TracedMethodWrapper methodsFor: 'implementation' stamp: 'MM 7/29/2022 12:57:46'!
decreaseInvocationLevel
InvocationLevel _ InvocationLevel - 1.! !
!TracedMethodWrapper methodsFor: 'implementation' stamp: 'MM 6/17/2022 12:03:30'!
doesNotUnderstand: aMessage
^ aMessage sendTo: compiledMethod! !
!TracedMethodWrapper methodsFor: 'implementation' stamp: 'MM 7/29/2022 13:11:57'!
increaseInvocationLevel
InvocationLevel _ self invocationLevel + 1.! !
!TracedMethodWrapper methodsFor: 'implementation' stamp: 'MM 7/29/2022 13:06:06'!
invocationLevel
^ InvocationLevel ifNil: [1]! !
!TracedMethodWrapper methodsFor: 'implementation' stamp: 'MM 7/29/2022 13:01:01'!
outputMethodEntry: aReceiver arguments: arguments
|stream|
stream _ MessageTracer outputStream.
self printIndentation: stream.
stream nextPutAll: 'Calling ';
nextPutAll: aReceiver printString;
nextPutAll: '>>';
nextPutAll: compiledMethod selector printString;
newLine.
self printIndentation: stream.
stream nextPutAll: ' arguments: '; nextPutAll: arguments printString;
newLine.
! !
!TracedMethodWrapper methodsFor: 'implementation' stamp: 'MM 7/29/2022 13:03:02'!
outputMethodExit: aReceiver result: result
|stream|
stream _ MessageTracer outputStream.
self printIndentation: stream.
stream nextPutAll: 'Returning from ';
nextPutAll: aReceiver printString;
nextPutAll: '>>';
nextPutAll: compiledMethod selector;
newLine.
self printIndentation: stream.
stream nextPutAll: ' returned: ';
nextPutAll: result printString;
newLine
! !
!TracedMethodWrapper methodsFor: 'implementation' stamp: 'MM 7/29/2022 13:15:36'!
printIndentation: aStream
(self invocationLevel - 1) timesRepeat: [
aStream nextPutAll: ' |'].! !
!TracedMethodWrapper methodsFor: 'implementation' stamp: 'MM 7/29/2022 13:41:35'!
run: aSelector with: arguments in: aReceiver
"Main entry point"
| result |
enabled ifFalse: [^ compiledMethod valueWithReceiver: aReceiver arguments: arguments].
(#(onEntry around) includes: when) ifTrue: [
self outputMethodEntry: aReceiver arguments: arguments].
self increaseInvocationLevel .
[result _ compiledMethod valueWithReceiver: aReceiver arguments: arguments] ensure:
[self decreaseInvocationLevel].
(#(onExit around) includes: when) ifTrue: [
self outputMethodExit: aReceiver result: result].
^ result! !
!TracedMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 12:59:50'!
disable
enabled _ false! !
!TracedMethodWrapper methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 13:02:08'!
when: aSymbol
when _ aSymbol! !
!TracedMethodWrapper class methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 12:03:49'!
on: aClass selector: selector
^ self new initialize: aClass selector: selector! !
!Behavior methodsFor: '*MessageTracer' stamp: 'MM 6/17/2022 13:35:02'!
trace: aSelector
MessageTracer trace: self selector: aSelector! !
!Behavior methodsFor: '*MessageTracer' stamp: 'MM 6/17/2022 13:40:56'!
untrace: aSelector
MessageTracer untrace: self selector: aSelector! !
-------------- next part --------------
'From Cuis 6.0 [latest update: #5399] on 25 July 2022 at 11:16:33 pm'!
'Description '!
!provides: 'MethodAdvisers' 1 26!
SystemOrganization addCategory: 'MethodAdvisers-Tests'!
SystemOrganization addCategory: 'MethodAdvisers'!
!classDefinition: #MethodAdvisersTests category: 'MethodAdvisers-Tests'!
TestCase subclass: #MethodAdvisersTests
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'MethodAdvisers-Tests'!
!classDefinition: 'MethodAdvisersTests class' category: 'MethodAdvisers-Tests'!
MethodAdvisersTests class
instanceVariableNames: ''!
!classDefinition: #MethodAdviserTestSubject category: 'MethodAdvisers-Tests'!
Object subclass: #MethodAdviserTestSubject
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'MethodAdvisers-Tests'!
!classDefinition: 'MethodAdviserTestSubject class' category: 'MethodAdvisers-Tests'!
MethodAdviserTestSubject class
instanceVariableNames: ''!
!classDefinition: #AdvisedMethod category: 'MethodAdvisers'!
Object subclass: #AdvisedMethod
instanceVariableNames: 'before after around compiledMethod methodClass'
classVariableNames: ''
poolDictionaries: ''
category: 'MethodAdvisers'!
!classDefinition: 'AdvisedMethod class' category: 'MethodAdvisers'!
AdvisedMethod class
instanceVariableNames: ''!
!AdvisedMethod commentStamp: '<historical>' prior: 0!
I use the Objects as Method Wrappers facility provided by the VM to wrap compiled methods.
My entry point is my #run:with:in: method, which will be executed by the VM when I install myself in the target class's method dictionary.
Examples:
MethodAdviserTestSubject after: #test1 do: [:receiver | Transcript show: 'After test1'].
MethodAdviserTestSubject new test1.
MethodAdviserTestSubject removeAllAdvice .
MethodAdviserTestSubject new test1.
MethodAdviserTestSubject after: #test1 do: [:receiver | Transcript show: 'After test1'].
MethodAdviserTestSubject after: #test1 do: [:receiver | Transcript show: 'After test1 again'].
MethodAdviserTestSubject new test1.
MethodAdviserTestSubject removeAllAdvice .
MethodAdviserTestSubject before: #test1 do: [:receiver | Transcript show: 'Before test1'].
MethodAdviserTestSubject after: #test1 do: [:receiver | Transcript show: 'After test1'].
MethodAdviserTestSubject new test1.
MethodAdviserTestSubject removeAllAdvice .
MethodAdviserTestSubject around: #test1 do: [:receiver :nextMethod |
Transcript show: 'Start around'.
nextMethod value.
Transcript show: 'End around'.
'wrapped test1'].
MethodAdviserTestSubject new test1!
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:09:23'!
tearDown
MethodAdviserTestSubject removeAdviceFrom: #test1:. ! !
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:09:58'!
testAfter
| output result |
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.'.
self assert: result = #test1.
MethodAdviserTestSubject after: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'after.'.
#after].
output _ String streamContents: [:s | result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.after.'.
self assert: result = #test1.
MethodAdviserTestSubject removeAdviceFrom: #test1:. ! !
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:13:12'!
testAfterTwice
| output result |
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.'.
self assert: result = #test1.
MethodAdviserTestSubject after: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'after1.'.
#after1].
MethodAdviserTestSubject after: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'after2.'.
#after2].
output _ String streamContents: [:s | result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.after1.after2.'.
self assert: result = #test1.
MethodAdviserTestSubject removeAdviceFrom: #test1:. ! !
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:03:56'!
testAll
| output result |
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.'.
self assert: result = #test1.
MethodAdviserTestSubject around: #test1: do: [:receiver :nextMethod :aStream |
aStream nextPutAll: 'before around.'.
nextMethod value.
aStream nextPutAll: 'after around.'.
#testAround].
MethodAdviserTestSubject before: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'before.'.
#before].
MethodAdviserTestSubject after: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'after.'.
#after].
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'before.before around.test1.after around.after.'.
self assert: result = #testAround.
MethodAdviserTestSubject removeAdviceFrom: #test1:.! !
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:16:23'!
testAllMany
| output result |
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.'.
self assert: result = #test1.
MethodAdviserTestSubject around: #test1: do: [:receiver :nextMethod :aStream |
aStream nextPutAll: 'before around1.'.
nextMethod value.
aStream nextPutAll: 'after around1.'.
#testAround1].
MethodAdviserTestSubject around: #test1: do: [:receiver :nextMethod :aStream |
aStream nextPutAll: 'before around2.'.
nextMethod value.
aStream nextPutAll: 'after around2.'.
#testAround2].
MethodAdviserTestSubject before: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'before1.'.
#before1].
MethodAdviserTestSubject before: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'before2.'.
#before2].
MethodAdviserTestSubject after: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'after1.'.
#after1].
MethodAdviserTestSubject after: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'after2.'.
#after2].
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'before2.before1.before around2.before around1.test1.after around1.after around2.after1.after2.'.
self assert: result = #testAround2.
MethodAdviserTestSubject removeAdviceFrom: #test1:.! !
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:04:14'!
testAround
| output result |
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.'.
self assert: result = #test1.
MethodAdviserTestSubject around: #test1: do: [:receiver :nextMethod :aStream |
aStream nextPutAll: 'before around.'.
nextMethod value.
aStream nextPutAll: 'after around.'.
#testAround].
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'before around.test1.after around.'.
self assert: result = #testAround.
MethodAdviserTestSubject removeAdviceFrom: #test1:.! !
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:10:42'!
testAroundTwice
| output result |
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.'.
self assert: result = #test1.
MethodAdviserTestSubject around: #test1: do: [:receiver :nextMethod :aStream |
aStream nextPutAll: 'before around.'.
nextMethod value.
aStream nextPutAll: 'after around.'.
#testAround].
MethodAdviserTestSubject around: #test1: do: [:receiver :nextMethod :aStream |
aStream nextPutAll: 'before around around.'.
nextMethod value.
aStream nextPutAll: 'after around around.'.
#testAroundAround].
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'before around around.before around.test1.after around.after around around.'.
self assert: result = #testAroundAround.
MethodAdviserTestSubject removeAdviceFrom: #test1:.! !
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:04:44'!
testBefore
| output result |
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.'.
self assert: result = #test1.
MethodAdviserTestSubject before: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'before.'.
#before].
output _ String streamContents: [:s | result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'before.test1.'.
self assert: result = #test1.
MethodAdviserTestSubject removeAdviceFrom: #test1:.! !
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:10:57'!
testBeforeAndAfter
| output result |
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.'.
self assert: result = #test1.
MethodAdviserTestSubject before: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'before.'.
#after].
MethodAdviserTestSubject after: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'after.'.
#after].
output _ String streamContents: [:s | result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'before.test1.after.'.
self assert: result = #test1.
MethodAdviserTestSubject removeAdviceFrom: #test1:.! !
!MethodAdvisersTests methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 23:12:33'!
testBeforeTwice
| output result |
output _ String streamContents: [:s |
result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'test1.'.
self assert: result = #test1.
MethodAdviserTestSubject before: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'before1.'.
#before1].
MethodAdviserTestSubject before: #test1: do: [:receiver :aStream |
aStream nextPutAll: 'before2.'.
#before2].
output _ String streamContents: [:s | result _ MethodAdviserTestSubject new test1: s].
self assert: output = 'before2.before1.test1.'.
self assert: result = #test1.
MethodAdviserTestSubject removeAdviceFrom: #test1:.! !
!MethodAdviserTestSubject methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 21:13:04'!
test1
Transcript show: 'test1'.
^ 'test1'! !
!MethodAdviserTestSubject methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 22:42:36'!
test1: aStream
aStream nextPutAll: 'test1.'.
^ 'test1'! !
!AdvisedMethod methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 20:33:32'!
afterDo: aBlock
after addLast: aBlock! !
!AdvisedMethod methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 22:38:45'!
aroundDo: aBlock
around addFirst: aBlock! !
!AdvisedMethod methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 20:33:43'!
beforeDo: aBlock
before addFirst: aBlock! !
!AdvisedMethod methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:15:09'!
doesNotUnderstand: aMessage
"Any message I don't understand is forwarded to the compiledMethod."
^ aMessage sendTo: compiledMethod! !
!AdvisedMethod methodsFor: 'as yet unclassified' stamp: 'MM 7/25/2022 10:10:36'!
evaluate: aroundList around: aBlock with: arguments in: aReceiver
^ aroundList isEmpty
ifTrue: [ aBlock value]
ifFalse: [ |args|
args _ (Array with: aReceiver with: [self evaluate: aroundList allButFirst around: aBlock with: arguments in: aReceiver]), arguments.
aroundList first valueWithArguments: args]! !
!AdvisedMethod methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 20:31:46'!
initialize: aClass selector: aSelector
methodClass _ aClass.
compiledMethod _ aClass compiledMethodAt: aSelector.
after _ OrderedCollection new.
before _ OrderedCollection new.
around _ OrderedCollection new.! !
!AdvisedMethod methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 19:59:33'!
install
methodClass
addSelectorSilently: compiledMethod selector
withMethod: self! !
!AdvisedMethod methodsFor: 'as yet unclassified' stamp: 'MM 6/17/2022 09:19:08'!
run: aSelector with: arguments in: aReceiver
"Main entry point"
| result |
"Evaluate before blocks"
before do: [:aBlock | aBlock valueWithArguments: ({aReceiver}, arguments)].
result _ self evaluate: around
around: [ compiledMethod
valueWithReceiver: aReceiver
arguments: arguments]
with: arguments
in: aReceiver.
after do: [:aBlock | aBlock valueWithArguments: ({aReceiver}, arguments)].
^ result! !
!AdvisedMethod methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 20:52:29'!
uninstall
methodClass
addSelectorSilently: compiledMethod selector
withMethod: compiledMethod! !
!AdvisedMethod class methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 20:26:48'!
ensureOn: aClass selector: aSelector
| compiledMethod |
compiledMethod _ aClass compiledMethodAt: aSelector.
compiledMethod class isCompiledMethodClass
ifTrue: ["The compiled method is unwrapped"
^ (self on: aClass selector: aSelector)
install;
yourself]
ifFalse: ["We assume this is an AdvicedMethod"
^ compiledMethod]! !
!AdvisedMethod class methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 19:52:21'!
on: aCompiledMethod
self assert: aCompiledMethod class isCompiledMethodClass! !
!AdvisedMethod class methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 20:00:46'!
on: aClass selector: aSelector
^ self new initialize: aClass selector: aSelector! !
!AdvisedMethod class methodsFor: 'as yet unclassified' stamp: 'MM 6/16/2022 20:53:45'!
uninstallFrom: aClass selector: aSelector
| compiledMethod |
compiledMethod _ aClass compiledMethodAt: aSelector.
compiledMethod class isCompiledMethodClass
ifTrue: [self error: 'No AdvisedMethod installed.']
ifFalse: [compiledMethod uninstall]! !
!Behavior methodsFor: '*MethodAdvisers' stamp: 'MM 7/25/2022 22:48:27'!
after: aSelector do: aBlock
|methodAdviser|
methodAdviser _ AdvisedMethod ensureOn: self selector: aSelector.
methodAdviser afterDo: aBlock.
^ methodAdviser! !
!Behavior methodsFor: '*MethodAdvisers' stamp: 'MM 7/25/2022 22:48:14'!
around: aSelector do: aBlock
|methodAdviser|
methodAdviser _ AdvisedMethod ensureOn: self selector: aSelector.
methodAdviser aroundDo: aBlock.
^ methodAdviser! !
!Behavior methodsFor: '*MethodAdvisers' stamp: 'MM 7/25/2022 22:48:36'!
before: aSelector do: aBlock
|methodAdviser|
methodAdviser _ AdvisedMethod ensureOn: self selector: aSelector.
methodAdviser beforeDo: aBlock.
^ methodAdviser! !
!Behavior methodsFor: '*MethodAdvisers' stamp: 'MM 6/16/2022 21:23:20'!
removeAdviceFrom: aSelector
| compiledMethod |
compiledMethod _ self compiledMethodAt: aSelector.
(compiledMethod isKindOf: AdvisedMethod)
ifTrue: [compiledMethod uninstall]! !
!Behavior methodsFor: '*MethodAdvisers' stamp: 'MM 6/16/2022 21:04:48'!
removeAllAdvice
methodDict values do: [:compiledMethod |
compiledMethod class isCompiledMethodClass ifFalse: [
(compiledMethod isKindOf: AdvisedMethod) ifTrue: [
compiledMethod uninstall]]]! !
More information about the Cuis-dev
mailing list