Mercurial Mercurial > hg > stx-libtool / changeset
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | raw | zip | gz | bz2 | help
Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
*** empty log message ***
authorClaus Gittinger <cg@exept.de>
Tue, 01 Jun 2004 13:18:52 +0200
changeset 5889 394c4b0f74cc
parent 5888 f2758e87cb4f
child 5890 1de9510f48f3
*** empty log message ***
NewSystemBrowser.st file | annotate | diff | comparison | revisions
Tools__NewSystemBrowser.st file | annotate | diff | comparison | revisions 
--- a/NewSystemBrowser.st	Tue Jun 01 13:16:09 2004 +0200
+++ b/NewSystemBrowser.st	Tue Jun 01 13:18:52 2004 +0200
@@ -5633,7 +5633,7 @@
          #(#MenuItem
             #label: 'Variables'
             #translateLabel: true
-            #enabled: #canUseRefactoringSupportAndHasClassSelected
+            #enabled: #canUseRefactoringSupport
             #submenu: 
            #(#Menu
               #(
@@ -8017,6 +8017,12 @@
                   itemValue: selectorMenuGenerateCorrespondingInstanceCreationInClass
                   translateLabel: true
                 )
+               (MenuItem
+                  enabled: hasMetaMethodSelectedHolder
+                  label: 'Forwarding Method in Instance Protocol'
+                  itemValue: selectorMenuGenerateForwardingMethodForInstances
+                  translateLabel: true
+                )
                )
               nil
               nil
@@ -11186,6 +11192,14 @@
     ^ [ self hasLocalVariableSelectedInCodeView ]
 !
 
+hasMetaMethodSelectedHolder
+    ^ [ self hasMetaSelected and:[self hasMethodSelected] ]
+!
+
+hasMetaSelected
+    ^ self meta value
+!
+
 hasMetaSelectedAndClassSelectedHolder
     ^ [ self meta value and:[ self hasClassSelected] ]
 !
@@ -25836,6 +25850,33 @@
         ]
 !
 
+selectorMenuGenerateForwardingMethodForInstances
+    "generate a forwarding method on the instance side"
+
+    self 
+        generateUndoableChangeOverSelectedMethods:'Generate Forwarder for %(singleMethodNameOrNumberOfMethods)'
+        via:[:generator :eachMethod |
+            |selector category mclass implClass defineIt parser spec code|
+
+            selector := eachMethod selector.
+            category := eachMethod category.
+            mclass := eachMethod mclass.
+            mclass isMeta ifTrue:[
+                parser := Parser for:eachMethod source.
+                parser parseMethod.
+                spec := Parser methodSpecificationForSelector:selector argNames:parser methodArgs.
+
+                (mclass theNonMetaclass implements:selector) ifFalse:[
+                    code := (spec , '\    ^ self class ' , spec , '.') withCRs.
+                    generator
+                        compile:code 
+                        forClass:mclass theNonMetaclass 
+                        inCategory:category
+                ].
+            ].
+        ]
+!
+
 selectorMenuGenerateSubclassResponsibilityHere
     "generate a subclassResponsibility method (for the selected string)
      in the current class"
@@ -32900,30 +32941,43 @@
 !
 
 methodImplementorsInfo
-    |singleSelectedMethod implementors msg|
-
-    self codeInfoVisible value ifTrue:[
-        singleSelectedMethod := self theSingleSelectedMethod.
-        singleSelectedMethod notNil ifTrue:[
-            implementors := SystemBrowser
-                findImplementorsOf:singleSelectedMethod selector
-                in:(Smalltalk allClasses)
-                ignoreCase:false.
-
-            implementors notEmpty ifTrue:[
-                implementors remove:singleSelectedMethod ifAbsent:nil.
-                implementors notEmpty ifTrue:[
-                    implementors := implementors collect:[:mthd | mthd mclass].
-                    msg := 'Also implemented in '.
-                    msg := msg , (self infoStringForClasses:implementors withPrefix:'other ').
-                    msg := msg , '.'.
-                ] ifFalse:[
-                    msg := 'Only implemented here.'.
-                ].
-            ].
-        ]
-    ].
-    ^ msg
+    |singleSelectedMethod implementors msg senders msg2|
+
+    self codeInfoVisible value ifFalse:[ ^ nil ].
+
+    singleSelectedMethod := self theSingleSelectedMethod.
+    singleSelectedMethod isNil ifTrue:[ ^ nil ].
+
+    implementors := SystemBrowser
+        findImplementorsOf:singleSelectedMethod selector
+        in:(Smalltalk allClasses)
+        ignoreCase:false.
+
+    implementors notEmpty ifTrue:[
+        implementors remove:singleSelectedMethod ifAbsent:nil.
+        implementors notEmpty ifTrue:[
+            implementors := implementors collect:[:mthd | mthd mclass].
+            msg := 'Also implemented in '.
+            msg := msg , (self infoStringForClasses:implementors withPrefix:'other ').
+            msg := msg , '.'.
+        ] ifFalse:[
+            msg := 'Only implemented here.'.
+        ].
+    ].
+
+false ifTrue:[  "/ too slow
+    senders := SystemBrowser
+        findSendersOf:singleSelectedMethod selector
+        in:(Smalltalk allClasses)
+        ignoreCase:false.
+    senders notEmpty ifTrue:[
+        msg2 := 'Sent from ' , senders size printString, ' methods.'.
+    ] ifFalse:[
+        msg2 := 'No senders.'.
+    ].
+    msg := msg , '/' , msg2
+].
+    ^ msg 
 !
 
 methodInheritanceInfo
@@ -35531,7 +35585,7 @@
 !NewSystemBrowser class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libtool/Attic/NewSystemBrowser.st,v 1.746 2004-05-27 14:30:02 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libtool/Attic/NewSystemBrowser.st,v 1.747 2004-06-01 11:18:52 cg Exp $'
 ! !
 
 NewSystemBrowser initialize!
--- a/Tools__NewSystemBrowser.st	Tue Jun 01 13:16:09 2004 +0200
+++ b/Tools__NewSystemBrowser.st	Tue Jun 01 13:18:52 2004 +0200
@@ -5633,7 +5633,7 @@
          #(#MenuItem
             #label: 'Variables'
             #translateLabel: true
-            #enabled: #canUseRefactoringSupportAndHasClassSelected
+            #enabled: #canUseRefactoringSupport
             #submenu: 
            #(#Menu
               #(
@@ -8017,6 +8017,12 @@
                   itemValue: selectorMenuGenerateCorrespondingInstanceCreationInClass
                   translateLabel: true
                 )
+               (MenuItem
+                  enabled: hasMetaMethodSelectedHolder
+                  label: 'Forwarding Method in Instance Protocol'
+                  itemValue: selectorMenuGenerateForwardingMethodForInstances
+                  translateLabel: true
+                )
                )
               nil
               nil
@@ -11186,6 +11192,14 @@
     ^ [ self hasLocalVariableSelectedInCodeView ]
 !
 
+hasMetaMethodSelectedHolder
+    ^ [ self hasMetaSelected and:[self hasMethodSelected] ]
+!
+
+hasMetaSelected
+    ^ self meta value
+!
+
 hasMetaSelectedAndClassSelectedHolder
     ^ [ self meta value and:[ self hasClassSelected] ]
 !
@@ -25836,6 +25850,33 @@
         ]
 !
 
+selectorMenuGenerateForwardingMethodForInstances
+    "generate a forwarding method on the instance side"
+
+    self 
+        generateUndoableChangeOverSelectedMethods:'Generate Forwarder for %(singleMethodNameOrNumberOfMethods)'
+        via:[:generator :eachMethod |
+            |selector category mclass implClass defineIt parser spec code|
+
+            selector := eachMethod selector.
+            category := eachMethod category.
+            mclass := eachMethod mclass.
+            mclass isMeta ifTrue:[
+                parser := Parser for:eachMethod source.
+                parser parseMethod.
+                spec := Parser methodSpecificationForSelector:selector argNames:parser methodArgs.
+
+                (mclass theNonMetaclass implements:selector) ifFalse:[
+                    code := (spec , '\    ^ self class ' , spec , '.') withCRs.
+                    generator
+                        compile:code 
+                        forClass:mclass theNonMetaclass 
+                        inCategory:category
+                ].
+            ].
+        ]
+!
+
 selectorMenuGenerateSubclassResponsibilityHere
     "generate a subclassResponsibility method (for the selected string)
      in the current class"
@@ -32900,30 +32941,43 @@
 !
 
 methodImplementorsInfo
-    |singleSelectedMethod implementors msg|
-
-    self codeInfoVisible value ifTrue:[
-        singleSelectedMethod := self theSingleSelectedMethod.
-        singleSelectedMethod notNil ifTrue:[
-            implementors := SystemBrowser
-                findImplementorsOf:singleSelectedMethod selector
-                in:(Smalltalk allClasses)
-                ignoreCase:false.
-
-            implementors notEmpty ifTrue:[
-                implementors remove:singleSelectedMethod ifAbsent:nil.
-                implementors notEmpty ifTrue:[
-                    implementors := implementors collect:[:mthd | mthd mclass].
-                    msg := 'Also implemented in '.
-                    msg := msg , (self infoStringForClasses:implementors withPrefix:'other ').
-                    msg := msg , '.'.
-                ] ifFalse:[
-                    msg := 'Only implemented here.'.
-                ].
-            ].
-        ]
-    ].
-    ^ msg
+    |singleSelectedMethod implementors msg senders msg2|
+
+    self codeInfoVisible value ifFalse:[ ^ nil ].
+
+    singleSelectedMethod := self theSingleSelectedMethod.
+    singleSelectedMethod isNil ifTrue:[ ^ nil ].
+
+    implementors := SystemBrowser
+        findImplementorsOf:singleSelectedMethod selector
+        in:(Smalltalk allClasses)
+        ignoreCase:false.
+
+    implementors notEmpty ifTrue:[
+        implementors remove:singleSelectedMethod ifAbsent:nil.
+        implementors notEmpty ifTrue:[
+            implementors := implementors collect:[:mthd | mthd mclass].
+            msg := 'Also implemented in '.
+            msg := msg , (self infoStringForClasses:implementors withPrefix:'other ').
+            msg := msg , '.'.
+        ] ifFalse:[
+            msg := 'Only implemented here.'.
+        ].
+    ].
+
+false ifTrue:[  "/ too slow
+    senders := SystemBrowser
+        findSendersOf:singleSelectedMethod selector
+        in:(Smalltalk allClasses)
+        ignoreCase:false.
+    senders notEmpty ifTrue:[
+        msg2 := 'Sent from ' , senders size printString, ' methods.'.
+    ] ifFalse:[
+        msg2 := 'No senders.'.
+    ].
+    msg := msg , '/' , msg2
+].
+    ^ msg 
 !
 
 methodInheritanceInfo
@@ -35531,7 +35585,7 @@
 !NewSystemBrowser class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.746 2004-05-27 14:30:02 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.747 2004-06-01 11:18:52 cg Exp $'
 ! !
 
 NewSystemBrowser initialize!
hg/stx-libtool