# HG changeset patch
# User Claus Gittinger <cg@exept.de>
# Date 963570127 -7200
# Node ID 9dbc51022bd74232d0248034a527cc29a30ea00a
# Parent  603aa9c77741fe7684c83309682d11e679b5e2d6
add method-copy

diff -r 603aa9c77741 -r 9dbc51022bd7 BrowserView.st
--- a/BrowserView.st	Thu Jul 13 17:50:51 2000 +0200
+++ b/BrowserView.st	Fri Jul 14 12:22:07 2000 +0200
@@ -8874,6 +8874,89 @@
     "Modified: 7.11.1996 / 18:53:55 / cg"
 !
 
+methodCopy
+    "copy the current method into another class; typically a brother-sister class"
+
+    |newClass newClassName sup initial copiedMethod 
+     supers subs list holders|
+
+    self checkMethodSelected ifFalse:[^ self].
+
+    lastMethodMoveClass ~= currentClass name ifTrue:[
+        initial := lastMethodMoveClass.
+    ].
+
+    initial isNil ifTrue:[
+        (sup := currentClass superclass) notNil ifTrue:[
+            initial := sup name
+        ] ifFalse:[
+            initial := nil.
+        ].
+    ].
+
+    supers := (currentClass allSuperclasses reverse collect:[:cls | cls name]).
+    subs := (currentClass allSubclasses collect:[:cls | cls name]).
+    list := supers.
+    (supers notEmpty and:[subs notEmpty]) ifTrue:[
+        list := list , (Array with:'---- ' , currentClass name , ' ----')
+    ].
+    list := list , subs.
+
+
+"/ preps to use windowSpecs ...
+"/
+"/    holders := IdentityDictionary new.
+"/    holders at:#className put:initial asValue.
+"/    holders at:#classList put:list.
+"/
+"/    (SystemBrowser 
+"/      openDialogInterface:#methodMoveDialogSpec
+"/      withBindings:holders) ifFalse:[
+"/        ^ self
+"/    ].
+"/    newClassName := (holders at:#className) value.
+
+    newClassName := Dialog 
+                    request:(resources string:'copy this method to which class:')
+                    initialAnswer:initial
+                    okLabel:(resources string:'copy')
+                    title:(resources string:'copy method')
+                    onCancel:nil
+                    list:list.
+    newClassName isNil ifTrue:[^ self].
+    (newClassName startsWith:'---- ') ifTrue:[^ self].
+
+    newClass := Smalltalk classNamed:newClassName.
+    newClass isNil ifTrue:[
+        self warn:'no such class'.
+        ^ self
+    ].
+
+    showInstance ifFalse:[
+        newClass isMeta ifFalse:[
+            newClass := newClass class
+        ]
+    ].
+
+    (newClass implements:currentSelector) ifTrue:[
+        (self confirm:(newClass name asText allBold , ' already implements ' , currentSelector
+                      , '\\Redefine anyway ?' withCRs)) ifFalse:[
+            ^ self
+        ]
+    ].
+
+    lastMethodMoveClass := newClassName.
+
+    copiedMethod := newClass 
+                        compile:(currentMethod source) 
+                        classified:currentMethodCategory.
+
+    (copiedMethod isNil or:[copiedMethod == #Error]) ifTrue:[
+        self warn:'not copied - compilation failed due to an error'.
+        ^ self
+    ].
+!
+
 methodDecompile
     "decompile the current methods bytecodes.
      The Decompiler is delivered as an extra, and not normally
@@ -9323,11 +9406,12 @@
 
         mthdItems :=           #(
                                 ('change category...'      methodChangeCategory )
-                                ('move...'                 methodMove           )
-                                ('remove'                   methodRemove         )
-                                ('-'                        nil                              )
-                                ('compare with previous'    methodCompareWithPreviousVersion )
-                                ('back to previous'         methodPreviousVersion            )
+                                ('move to...'              methodMove           )
+                                ('copy to...'              methodCopy           )
+                                ('remove'                  methodRemove         )
+                                ('-'                       nil                              )
+                                ('compare with previous'   methodCompareWithPreviousVersion )
+                                ('back to previous'        methodPreviousVersion            )
                                 ).
 
     ] ifFalse:[
@@ -9501,7 +9585,7 @@
                         classified:currentMethodCategory.
 
     (movedMethod isNil or:[movedMethod == #Error]) ifTrue:[
-        self warn:'not moved - compilation failed due to a compilation error'.
+        self warn:'not moved - compilation failed due to an error'.
         ^ self
     ].
 
@@ -14051,6 +14135,6 @@
 !BrowserView class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libtool/BrowserView.st,v 1.623 2000-07-13 15:50:51 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libtool/BrowserView.st,v 1.624 2000-07-14 10:22:07 cg Exp $'
 ! !
 BrowserView initialize!