#FEATURE by cg
class: DebugView
convenient menu function to redefine an inherited
method.
added:
#argumentNamesForNewMethodOfContext:
#canRedefineMethodInReceiverClass
#doRedefineMethodInReceiverClass
changed:
#doDefine
#selectorMenuSpec
--- a/DebugView.st Wed Feb 08 00:58:59 2017 +0100
+++ b/DebugView.st Wed Feb 08 09:11:17 2017 +0100
@@ -1,5 +1,3 @@
-"{ Encoding: utf8 }"
-
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
@@ -1475,10 +1473,17 @@
label: 'Define Missing Method'
itemValue: doDefineMethod
)
+ (MenuItem
+ enabled: canRedefineMethodInReceiverClass
+ label: 'Redefine Method in Receiver Class'
+ itemValue: doRedefineMethodInReceiverClass
+ )
)
nil
nil
)
+
+ "Modified: / 08-02-2017 / 08:46:50 / cg"
!
viewMenuSpec
@@ -5092,8 +5097,12 @@
!
doDefine
- |selectionIndex selector argNames receiversClass proto haltStmtDef haltStmtFix code cat
- bagOfClassNames bagOfUsedClassNames implClass idx callee restart varName argName|
+ "when we hit an unimplemented message, the define button becomes visible.
+ This is the action of it, when clicked.
+ Define a new halting method in the faulting class,
+ and restart the context so we end up in the halt of the new method"
+
+ |selectionIndex selector argNames receiversClass proto haltStmtDef haltStmtFix code cat implClass idx callee restart varName argName|
selectionIndex := contextView selection.
restart := true.
@@ -5121,22 +5130,7 @@
].
"generate nice argument names"
- bagOfClassNames := (actualContext args collect:[:eachArg | eachArg class name]) asBag.
- bagOfUsedClassNames := Bag new.
- argNames := actualContext args
- collect:
- [:eachArg |
- |nm|
-
- nm := eachArg class nameWithoutPrefix.
- (bagOfClassNames occurrencesOf:nm) == 1 ifTrue:[
- nm article , nm
- ] ifFalse:[
- bagOfUsedClassNames add:nm.
- nm asLowercaseFirst , (bagOfUsedClassNames occurrencesOf:nm) printString
- ].
- ].
-
+ argNames := self argumentNamesForNewMethodOfContext:actualContext.
proto := Method methodDefinitionTemplateForSelector:selector andArgumentNames:argNames.
haltStmtDef := ' self halt:''please define %2 here''.'.
@@ -5205,7 +5199,7 @@
self doRestart
]
- "Modified: / 23-03-2012 / 09:49:31 / cg"
+ "Modified: / 08-02-2017 / 08:58:50 / cg"
!
doGotoApplicationActionMethod
@@ -5413,6 +5407,42 @@
"Modified: / 20-09-2007 / 12:40:40 / cg"
!
+doRedefineMethodInReceiverClass
+ |con selectionIndex argNames proto receiverClass implClass implMethod selector code cat|
+
+ (con := actualContext) notNil ifTrue:[
+ selectionIndex := contextView selection.
+
+ (actualContext home) notNil ifTrue:[
+ con := actualContext home
+ ].
+ selector := con selector.
+ receiverClass := con receiver class.
+ (receiverClass implements:selector) ifFalse:[
+ implClass := receiverClass whichClassIncludesSelector:selector.
+ implMethod := implClass compiledMethodAt:selector.
+
+ argNames := self argumentNamesForNewMethodOfContext:con.
+ proto := Method methodDefinitionTemplateForSelector:selector andArgumentNames:argNames.
+
+ code := '%1\ self halt:''please redefine %2 here''.\ ^ super %1'.
+ cat := implMethod category.
+
+ self
+ codeAccept:(code bindWith:proto with:selector) withCRs
+ inClass:receiverClass
+ unwind:false
+ category:cat
+ onCancel:[^ self].
+
+ self doShowSelection:selectionIndex.
+ self doRestart
+ ].
+ ].
+
+ "Created: / 08-02-2017 / 09:07:25 / cg"
+!
+
doResend
"resend - the selected context is unwound and its message resent.
To be done after a cde change, to get nto the new method"
@@ -7218,6 +7248,28 @@
"Modified: / 25-11-2016 / 13:17:20 / cg"
!
+canRedefineMethodInReceiverClass
+ "true if a context is selected, where an inherited method was called.
+ Used to enable the redefine menu option"
+
+ |con selector receiverClass implClass|
+
+ (con := actualContext) notNil ifTrue:[
+ (actualContext home) notNil ifTrue:[
+ con := actualContext home
+ ].
+ selector := con selector.
+ receiverClass := con receiver class.
+ (receiverClass implements:selector) ifFalse:[
+ implClass := receiverClass whichClassIncludesSelector:selector.
+ ^ implClass notNil
+ ].
+ ].
+ ^ false
+
+ "Created: / 08-02-2017 / 08:45:38 / cg"
+!
+
canRestart
^ restartButton isEnabled
@@ -7462,6 +7514,34 @@
"Modified: 31.7.1997 / 21:20:11 / cg"
! !
+!DebugView methodsFor:'private-code generation helpers'!
+
+argumentNamesForNewMethodOfContext:context
+ "generate argument names for a prototypeMethod for the message in context.
+ Used by doDefine and doRedefine"
+
+ |bagOfClassNames bagOfUsedClassNames argNames|
+
+ bagOfClassNames := (actualContext args collect:[:eachArg | eachArg class name]) asBag.
+ bagOfUsedClassNames := Bag new.
+ argNames := actualContext args
+ collect:
+ [:eachArg |
+ |nm|
+
+ nm := eachArg class nameWithoutPrefix.
+ (bagOfClassNames occurrencesOf:nm) == 1 ifTrue:[
+ nm article , nm
+ ] ifFalse:[
+ bagOfUsedClassNames add:nm.
+ nm asLowercaseFirst , (bagOfUsedClassNames occurrencesOf:nm) printString
+ ].
+ ].
+ ^ argNames
+
+ "Created: / 08-02-2017 / 08:57:24 / cg"
+! !
+
!DebugView methodsFor:'private-code view'!
codeAspect
@@ -9564,7 +9644,7 @@
printConditionOn:aStream
ignoredSendingClassAndSelectors notEmptyOrNil ifTrue:[
- aStream nextPutAll:(' if called from %1 » %2'
+ aStream nextPutAll:(' if called from %1 » %2'
bindWith:ignoredSendingClassAndSelectors first first
with:ignoredSendingClassAndSelectors first second).
^ self.