drag and drop methods (for category change)
authorClaus Gittinger <cg@exept.de>
Fri, 28 Sep 2001 15:23:12 +0200
changeset 3230 ed23b649b4ae
parent 3229 ddcfc1680304
child 3231 c55230c60f43
drag and drop methods (for category change)
NewSystemBrowser.st
Tools__NewSystemBrowser.st
--- a/NewSystemBrowser.st	Fri Sep 28 13:46:54 2001 +0200
+++ b/NewSystemBrowser.st	Fri Sep 28 15:23:12 2001 +0200
@@ -6106,6 +6106,21 @@
                   #isVisible: false
                 )
                #(#MenuItem
+                  #label: 'Back to previous Version'
+                  #translateLabel: true
+                  #value: #selectorMenuBackToPrevious
+                  #enabled: #methodHasPreviousVersionHolder
+                )
+               #(#MenuItem
+                  #label: 'Previous Versions'
+                  #translateLabel: true
+                  #value: #selectorMenuBrowsePreviousVersions
+                  #enabled: #methodHasPreviousVersionHolder
+                )
+               #(#MenuItem
+                  #label: '-'
+                )
+               #(#MenuItem
                   #label: 'Inspect Method'
                   #translateLabel: true
                   #value: #selectorMenuInspect
@@ -21260,6 +21275,23 @@
     ^ versions
 !
 
+moveMethods:methods toProtocol:newCategory
+    "move some methods to some other category"
+
+    newCategory isNil ifTrue:[^ self].
+
+    lastMethodCategory := newCategory.
+
+    methods do:[:mthd |
+        |mClass|
+
+        mthd category:newCategory.
+
+        mClass := mthd mclass.
+        mthd mclass addChangeRecordForMethodCategory:mthd category:newCategory.
+    ].
+!
+
 renameMethod:oldSelector in:aClass 
         | selector tree dialog args newArgs map refactoring  senders nSenders classes nClasses infoMsg
           rslt firstClassName secondClassName answer brwsr|
@@ -21779,25 +21811,8 @@
                         okLabel:'move' 
                         list:someCategories
                         initialAnswer:(initialAnswer ? (lastMethodCategory ? self theSingleSelectedProtocol)).
-    newCategory isNil ifTrue:[^ self].
-
-    lastMethodCategory := newCategory.
-
-    methodSelection do:[:mthd |
-        |mClass|
-
-        mthd category:newCategory.
-
-        mClass := mthd mclass.
-        mthd mclass addChangeRecordForMethodCategory:mthd category:newCategory.
-    ].
-
-"/    "/ reselect the methods.
-"/    self selectedProtocols value:(Array with:newCategory).
-"/
-"/    self selectMethods:methodSelection
-
-    "Modified: / 29.2.2000 / 11:12:00 / cg"
+
+    self moveMethods:methodSelection toProtocol:newCategory
 !
 
 selectorMenuNewImageSpec
@@ -34620,7 +34635,7 @@
           #name: 'ProtocolList'
           #min: #(#Point 0 0)
           #max: #(#Point 1024 721)
-          #bounds: #(#Rectangle 218 175 518 475)
+          #bounds: #(#Rectangle 16 46 316 346)
         )
         #component: 
        #(#SpecCollection
@@ -34639,6 +34654,13 @@
               #useIndex: true
               #sequenceList: #protocolList
               #doubleClickChannel: #doubleClickChannel
+              #properties: 
+             #(#PropertyListDictionary
+                #dragArgument: nil
+                #dropArgument: nil
+                #canDropSelector: #canDrop:
+                #dropSelector: #doDrop:
+              )
             )
            )
          
@@ -34661,20 +34683,21 @@
 
     ^ #(
         #(#doubleClickChannel #action )
+        #filterClassVars
         #forceGeneratorTrigger
         #immediateUpdate
         #inGeneratorHolder
         #menuHolder
+        #noAllItem
         #outGeneratorHolder
         #packageFilter
         #packageFilterOnInput
         #selectedProtocols
         #selectionChangeCondition
         #updateTrigger
-        #noAllItem
         #variableFilter
-        #filterClassVars
       ).
+
 ! !
 
 !NewSystemBrowser::MethodCategoryList methodsFor:'aspects'!
@@ -35087,6 +35110,48 @@
     super update:something with:aParameter from:changedObject.
 ! !
 
+!NewSystemBrowser::MethodCategoryList methodsFor:'drag & drop'!
+
+canDrop:aDropContext
+    |cat|
+
+    self selectedProtocols value size > 0 ifFalse:[^ false].
+    (aDropContext dropObjects contains:[:aDropObject | aDropObject theObject isMethod not]) ifTrue:[^ false].
+
+    cat := self categoryAtTargetPointOf:aDropContext.
+    ^ cat notNil
+!
+
+categoryAtTargetPointOf:aDropContext
+    |p methodListView lineNr cat|
+
+    p := aDropContext targetPoint.
+
+    methodListView := self builder componentAt:'List'.
+    methodListView isNil ifTrue:[^ nil].
+
+    lineNr := methodListView lineAtY:p y.
+    lineNr isNil ifTrue:[^ nil].
+
+    cat := protocolList at:lineNr.
+    cat = self class nameListEntryForALL ifTrue:[^ nil].
+
+    ^ cat
+!
+
+doDrop:aDropContext
+    |cat methods|
+
+    self selectedProtocols value size > 0 ifFalse:[^ self].
+    methods := aDropContext dropObjects collect:[:aDropObject | aDropObject theObject].
+    (methods contains:[:something | something isMethod not]) ifTrue:[^ self].
+
+    cat := self categoryAtTargetPointOf:aDropContext.
+    cat notNil ifTrue:[
+        self masterApplication moveMethods:methods toProtocol:cat.
+    ].
+! !
+
 !NewSystemBrowser::MethodCategoryList methodsFor:'generators'!
 
 makeGenerator
@@ -37408,6 +37473,28 @@
     ].
 ! !
 
+!NewSystemBrowser::MethodList methodsFor:'setup'!
+
+postBuildWith:aBuilder
+    |methodListView|
+
+    super postBuildWith:aBuilder.
+
+    methodListView := aBuilder componentAt:'List'.
+    methodListView notNil ifTrue:[
+        methodListView allowDrag:true.
+        methodListView dragObjectConverter:[:obj | 
+                                            |nm method idx|
+
+                                            nm := obj theObject asString.
+                                            idx := browserNameList value indexOf:nm.
+
+                                            method := methodList value at:idx.
+                                            DropObject newMethod:method.
+                                         ].
+    ]
+! !
+
 !NewSystemBrowser::ImplementingMethodList class methodsFor:'plugIn spec'!
 
 aspectSelectors
@@ -49752,6 +49839,6 @@
 !NewSystemBrowser class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libtool/Attic/NewSystemBrowser.st,v 1.178 2001-09-28 11:13:28 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libtool/Attic/NewSystemBrowser.st,v 1.179 2001-09-28 13:23:12 cg Exp $'
 ! !
 NewSystemBrowser initialize!
--- a/Tools__NewSystemBrowser.st	Fri Sep 28 13:46:54 2001 +0200
+++ b/Tools__NewSystemBrowser.st	Fri Sep 28 15:23:12 2001 +0200
@@ -6106,6 +6106,21 @@
                   #isVisible: false
                 )
                #(#MenuItem
+                  #label: 'Back to previous Version'
+                  #translateLabel: true
+                  #value: #selectorMenuBackToPrevious
+                  #enabled: #methodHasPreviousVersionHolder
+                )
+               #(#MenuItem
+                  #label: 'Previous Versions'
+                  #translateLabel: true
+                  #value: #selectorMenuBrowsePreviousVersions
+                  #enabled: #methodHasPreviousVersionHolder
+                )
+               #(#MenuItem
+                  #label: '-'
+                )
+               #(#MenuItem
                   #label: 'Inspect Method'
                   #translateLabel: true
                   #value: #selectorMenuInspect
@@ -21260,6 +21275,23 @@
     ^ versions
 !
 
+moveMethods:methods toProtocol:newCategory
+    "move some methods to some other category"
+
+    newCategory isNil ifTrue:[^ self].
+
+    lastMethodCategory := newCategory.
+
+    methods do:[:mthd |
+        |mClass|
+
+        mthd category:newCategory.
+
+        mClass := mthd mclass.
+        mthd mclass addChangeRecordForMethodCategory:mthd category:newCategory.
+    ].
+!
+
 renameMethod:oldSelector in:aClass 
         | selector tree dialog args newArgs map refactoring  senders nSenders classes nClasses infoMsg
           rslt firstClassName secondClassName answer brwsr|
@@ -21779,25 +21811,8 @@
                         okLabel:'move' 
                         list:someCategories
                         initialAnswer:(initialAnswer ? (lastMethodCategory ? self theSingleSelectedProtocol)).
-    newCategory isNil ifTrue:[^ self].
-
-    lastMethodCategory := newCategory.
-
-    methodSelection do:[:mthd |
-        |mClass|
-
-        mthd category:newCategory.
-
-        mClass := mthd mclass.
-        mthd mclass addChangeRecordForMethodCategory:mthd category:newCategory.
-    ].
-
-"/    "/ reselect the methods.
-"/    self selectedProtocols value:(Array with:newCategory).
-"/
-"/    self selectMethods:methodSelection
-
-    "Modified: / 29.2.2000 / 11:12:00 / cg"
+
+    self moveMethods:methodSelection toProtocol:newCategory
 !
 
 selectorMenuNewImageSpec
@@ -34620,7 +34635,7 @@
           #name: 'ProtocolList'
           #min: #(#Point 0 0)
           #max: #(#Point 1024 721)
-          #bounds: #(#Rectangle 218 175 518 475)
+          #bounds: #(#Rectangle 16 46 316 346)
         )
         #component: 
        #(#SpecCollection
@@ -34639,6 +34654,13 @@
               #useIndex: true
               #sequenceList: #protocolList
               #doubleClickChannel: #doubleClickChannel
+              #properties: 
+             #(#PropertyListDictionary
+                #dragArgument: nil
+                #dropArgument: nil
+                #canDropSelector: #canDrop:
+                #dropSelector: #doDrop:
+              )
             )
            )
          
@@ -34661,20 +34683,21 @@
 
     ^ #(
         #(#doubleClickChannel #action )
+        #filterClassVars
         #forceGeneratorTrigger
         #immediateUpdate
         #inGeneratorHolder
         #menuHolder
+        #noAllItem
         #outGeneratorHolder
         #packageFilter
         #packageFilterOnInput
         #selectedProtocols
         #selectionChangeCondition
         #updateTrigger
-        #noAllItem
         #variableFilter
-        #filterClassVars
       ).
+
 ! !
 
 !NewSystemBrowser::MethodCategoryList methodsFor:'aspects'!
@@ -35087,6 +35110,48 @@
     super update:something with:aParameter from:changedObject.
 ! !
 
+!NewSystemBrowser::MethodCategoryList methodsFor:'drag & drop'!
+
+canDrop:aDropContext
+    |cat|
+
+    self selectedProtocols value size > 0 ifFalse:[^ false].
+    (aDropContext dropObjects contains:[:aDropObject | aDropObject theObject isMethod not]) ifTrue:[^ false].
+
+    cat := self categoryAtTargetPointOf:aDropContext.
+    ^ cat notNil
+!
+
+categoryAtTargetPointOf:aDropContext
+    |p methodListView lineNr cat|
+
+    p := aDropContext targetPoint.
+
+    methodListView := self builder componentAt:'List'.
+    methodListView isNil ifTrue:[^ nil].
+
+    lineNr := methodListView lineAtY:p y.
+    lineNr isNil ifTrue:[^ nil].
+
+    cat := protocolList at:lineNr.
+    cat = self class nameListEntryForALL ifTrue:[^ nil].
+
+    ^ cat
+!
+
+doDrop:aDropContext
+    |cat methods|
+
+    self selectedProtocols value size > 0 ifFalse:[^ self].
+    methods := aDropContext dropObjects collect:[:aDropObject | aDropObject theObject].
+    (methods contains:[:something | something isMethod not]) ifTrue:[^ self].
+
+    cat := self categoryAtTargetPointOf:aDropContext.
+    cat notNil ifTrue:[
+        self masterApplication moveMethods:methods toProtocol:cat.
+    ].
+! !
+
 !NewSystemBrowser::MethodCategoryList methodsFor:'generators'!
 
 makeGenerator
@@ -37408,6 +37473,28 @@
     ].
 ! !
 
+!NewSystemBrowser::MethodList methodsFor:'setup'!
+
+postBuildWith:aBuilder
+    |methodListView|
+
+    super postBuildWith:aBuilder.
+
+    methodListView := aBuilder componentAt:'List'.
+    methodListView notNil ifTrue:[
+        methodListView allowDrag:true.
+        methodListView dragObjectConverter:[:obj | 
+                                            |nm method idx|
+
+                                            nm := obj theObject asString.
+                                            idx := browserNameList value indexOf:nm.
+
+                                            method := methodList value at:idx.
+                                            DropObject newMethod:method.
+                                         ].
+    ]
+! !
+
 !NewSystemBrowser::ImplementingMethodList class methodsFor:'plugIn spec'!
 
 aspectSelectors
@@ -49752,6 +49839,6 @@
 !NewSystemBrowser class methodsFor:'documentation'!
 
 version
-    ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.178 2001-09-28 11:13:28 cg Exp $'
+    ^ '$Header: /cvs/stx/stx/libtool/Tools__NewSystemBrowser.st,v 1.179 2001-09-28 13:23:12 cg Exp $'
 ! !
 NewSystemBrowser initialize!