#FEATURE by cg
authorClaus Gittinger <cg@exept.de>
Wed, 08 Feb 2017 09:11:17 +0100
changeset 17372 902487791641
parent 17371 ffbfab2b0c09
child 17373 62c44bf0d8d5
#FEATURE by cg class: DebugView convenient menu function to redefine an inherited method. added: #argumentNamesForNewMethodOfContext: #canRedefineMethodInReceiverClass #doRedefineMethodInReceiverClass changed: #doDefine #selectorMenuSpec
DebugView.st
--- 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.