diff -r be5ae6091a00 -r 273637686948 Tools_ProjectList.st
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Tools_ProjectList.st	Thu Feb 26 19:57:02 2004 +0100
@@ -0,0 +1,623 @@
+"
+ COPYRIGHT (c) 2000 by eXept Software AG
+	      All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice.   This software may not
+ be provided or otherwise made available to, or used by, any
+ other person.  No title to or ownership of the software is
+ hereby transferred.
+"
+
+"{ Package: 'stx:__NoProject__' }"
+
+"{ NameSpace: Tools }"
+
+BrowserList subclass:#ProjectList
+	instanceVariableNames:'projectList'
+	classVariableNames:'AdditionalEmptyProjects'
+	poolDictionaries:''
+	category:'Interface-Browsers-New'
+!
+
+!ProjectList class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 2000 by eXept Software AG
+	      All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice.   This software may not
+ be provided or otherwise made available to, or used by, any
+ other person.  No title to or ownership of the software is
+ hereby transferred.
+"
+! !
+
+!ProjectList class methodsFor:'interface specs'!
+
+singleProjectWindowSpec
+    "This resource specification was automatically generated
+     by the UIPainter of ST/X."
+
+    "Do not manually edit this!! If it is corrupted,
+     the UIPainter may not be able to read the specification."
+
+    "
+     UIPainter new openOnClass:ClassCategoryList andSelector:#singleCategoryWindowSpec
+     ClassCategoryList new openInterface:#singleCategoryWindowSpec
+    "
+
+    <resource: #canvas>
+
+    ^ 
+     #(#FullSpec
+        #name: #singleProjectWindowSpec
+        #window: 
+       #(#WindowSpec
+          #label: 'ProjectList'
+          #name: 'ProjectList'
+          #min: #(#Point 0 0)
+          #max: #(#Point 1024 721)
+          #bounds: #(#Rectangle 218 175 518 475)
+        )
+        #component: 
+       #(#SpecCollection
+          #collection: #(
+           #(#LabelSpec
+              #label: 'ProjectName'
+              #name: 'ProjectLabel'
+              #layout: #(#LayoutFrame 0 0.0 0 0 0 1.0 25 0)
+              #translateLabel: true
+              #labelChannel: #projectLabelHolder
+              #menu: #menuHolder
+            )
+           )
+
+        )
+      )
+!
+
+windowSpec
+    "This resource specification was automatically generated
+     by the UIPainter of ST/X."
+
+    "Do not manually edit this!! If it is corrupted,
+     the UIPainter may not be able to read the specification."
+
+    "
+     UIPainter new openOnClass:ProjectList andSelector:#windowSpec
+     ProjectList new openInterface:#windowSpec
+     ProjectList open
+    "
+
+    <resource: #canvas>
+
+    ^ 
+     #(#FullSpec
+        #name: #windowSpec
+        #window: 
+       #(#WindowSpec
+          #label: 'ProjectList'
+          #name: 'ProjectList'
+          #min: #(#Point 0 0)
+          #max: #(#Point 1024 721)
+          #bounds: #(#Rectangle 13 23 313 323)
+        )
+        #component: 
+       #(#SpecCollection
+          #collection: #(
+           #(#SequenceViewSpec
+              #name: 'List'
+              #layout: #(#LayoutFrame 0 0.0 0 0.0 0 1.0 0 1.0)
+              #tabable: true
+              #model: #selectedProjects
+              #menu: #menuHolder
+              #hasHorizontalScrollBar: true
+              #hasVerticalScrollBar: true
+              #miniScrollerHorizontal: true
+              #isMultiSelect: true
+              #valueChangeSelector: #selectionChangedByClick
+              #useIndex: false
+              #sequenceList: #projectList
+              #doubleClickChannel: #doubleClickChannel
+              #properties: 
+             #(#PropertyListDictionary
+                #dragArgument: nil
+                #dropArgument: nil
+                #canDropSelector: #canDrop:
+                #dropSelector: #doDrop:
+              )
+            )
+           )
+
+        )
+      )
+
+    "Created: / 17.2.2000 / 23:45:47 / cg"
+    "Modified: / 17.2.2000 / 23:47:53 / cg"
+! !
+
+!ProjectList class methodsFor:'queries-plugin'!
+
+aspectSelectors
+    ^ #( 
+	#(#doubleClickChannel #action )
+	immediateUpdate 
+	selectedProjects 
+	menuHolder 
+	outGeneratorHolder 
+	inGeneratorHolder 
+	selectionChangeCondition
+	updateTrigger
+	forceGeneratorTrigger
+	hideUnloadedClasses
+	organizerMode
+	slaveMode
+       )
+
+    "Created: / 17.2.2000 / 23:46:18 / cg"
+    "Modified: / 25.2.2000 / 22:32:10 / cg"
+! !
+
+!ProjectList methodsFor:'aspects'!
+
+projectLabelHolder
+    ^ self pseudoListLabelHolder
+!
+
+projectList
+    projectList isNil ifTrue:[
+	projectList := ValueHolder new.
+	projectList addDependent:self.
+    ].
+    ^ projectList
+
+    "Created: / 17.2.2000 / 23:39:32 / cg"
+!
+
+selectedProjects
+    ^ self selectionHolder
+
+    "Created: / 17.2.2000 / 23:39:57 / cg"
+!
+
+selectedProjects:aValueHolder
+    ^ self selectionHolder:aValueHolder
+! !
+
+!ProjectList methodsFor:'change & update'!
+
+delayedUpdate:something with:aParameter from:changedObject
+    |cls sel pkg mthd|
+
+    self inSlaveModeOrInvisible 
+    "/ (self slaveMode value == true) 
+    ifTrue:[
+	changedObject == Smalltalk ifTrue:[ listValid := false].
+	something == #projectOrganization ifTrue:[ listValid := false].
+	^ self
+    ].
+
+    changedObject == slaveMode ifTrue:[
+	listValid ~~ true ifTrue:[
+	    self enqueueDelayedUpdateList
+	].
+	"/ self invalidateList.
+	^  self
+    ].
+
+
+    changedObject == Smalltalk ifTrue:[
+	something == #projectOrganization ifTrue:[
+	    self invalidateList.
+	    self enqueueDelayedUpdateOutputGenerator.
+	    ^ self.
+	].
+	something == #methodInClass ifTrue:[
+	    listValid == true ifTrue:[
+		cls := aParameter at:1.
+		sel := aParameter at:2.
+		mthd := cls compiledMethodAt:sel.
+		mthd notNil ifTrue:[
+		    pkg := mthd package.
+		    (projectList value includes:pkg) ifFalse:[
+			self invalidateList.
+		    ]
+		].
+	    ].
+	    ^ self
+	].
+
+	(something == #classDefinition
+	or:[something == #newClass]) ifTrue:[
+	    listValid == true ifTrue:[
+		cls := aParameter.
+		pkg := cls package.
+		(projectList value includes:pkg) ifFalse:[
+		    self invalidateList.
+		] ifTrue:[
+		    self enqueueDelayedUpdateOutputGenerator
+		].
+	    ] ifFalse:[
+		self invalidateList
+	    ].
+	    ^ self
+	].
+	(something == #classRemove) ifTrue:[
+	    listValid == true ifTrue:[
+		cls := aParameter.
+		pkg := cls package.
+	    ].
+	].
+	^ self
+    ].
+
+"/    something == #projectOrganization ifTrue:[
+"/        aParameter isSymbol ifTrue:[
+"/                    "/ a single method has changed
+"/"/                    sel := aParameter.
+"/"/                    mthd := changedObject compiledMethodAt:sel.
+"/            self enqueueDelayedUpdateOutputGenerator.
+"/        ].
+"/        ^ self
+"/    ].
+
+    (organizerMode notNil
+    and:[organizerMode value ~~ #project]) ifTrue:[
+	self invalidateList.
+	^ self
+    ].
+    super delayedUpdate:something with:aParameter from:changedObject
+
+    "Created: / 17.2.2000 / 23:41:02 / cg"
+    "Modified: / 26.2.2000 / 01:21:49 / cg"
+!
+
+selectionChangedByClick
+    "we are not interested in that - get another notification
+     via the changed valueHolder"
+
+    "Created: / 17.2.2000 / 23:41:17 / cg"
+!
+
+update:something with:aParameter from:changedObject
+    changedObject == Smalltalk ifTrue:[
+	something == #methodDictionary ifTrue:[
+	    ^ self 
+	].
+	something == #methodTrap ifTrue:[
+	    ^ self
+	].
+	something == #methodInClass ifTrue:[
+	    ^ self
+	].
+	something == #classVariables ifTrue:[
+	    ^ self
+	].
+	something == #classComment ifTrue:[
+	    ^ self.
+	].
+	something == #methodInClassRemoved ifTrue:[
+	    ^ self.
+	].
+    ].
+    super update:something with:aParameter from:changedObject
+! !
+
+!ProjectList methodsFor:'drag & drop'!
+
+canDrop:aDropContext
+    |methodsOrClasses package|
+
+    methodsOrClasses := aDropContext dropObjects collect:[:obj | obj theObject].
+
+    (methodsOrClasses contains:[:aMethodOrClass | (aMethodOrClass isMethod or:[aMethodOrClass isClass]) not]) ifTrue:[^ false].
+
+    package := self packageAtTargetPointOf:aDropContext.
+    package isNil ifTrue:[^ false].
+
+    (methodsOrClasses contains:[:aMethodOrClass | aMethodOrClass package ~= package]) ifFalse:[^ false].
+
+    ^ true
+!
+
+doDrop:aDropContext
+    |package methodsOrClasses methods classes|
+
+    methodsOrClasses := aDropContext dropObjects collect:[:aDropObject | aDropObject theObject].
+    (methodsOrClasses contains:[:something | (something isMethod or:[something isClass]) not]) ifTrue:[^ self].
+    methods := methodsOrClasses select:[:something | something isMethod].
+    classes := methodsOrClasses select:[:something | something isClass].
+
+    package := self packageAtTargetPointOf:aDropContext.
+    package notNil ifTrue:[
+	methods notEmpty ifTrue:[
+	    self masterApplication moveMethods:methods toProject:package.
+	].
+	classes notEmpty ifTrue:[
+	    self masterApplication moveClasses:classes toProject:package.
+	]
+    ].
+!
+
+packageAtTargetPointOf:aDropContext
+    |p packageListView lineNr item package dropInfo now 
+     overItem timeOverItem|
+
+    p := aDropContext targetPoint.
+
+    packageListView := aDropContext targetWidget.
+
+    dropInfo := aDropContext dropInfo.
+
+    lineNr := packageListView yVisibleToLineNr:p y.
+    lineNr isNil ifTrue:[^ nil].
+
+    item := packageListView list value at:lineNr.
+    item isNil ifTrue:[^ nil].
+
+    item canExpand ifTrue:[
+	now := AbsoluteTime now.
+	overItem := dropInfo at:#overItem ifAbsentPut:[item].
+	timeOverItem := dropInfo at:#timeOverItem ifAbsentPut:[now].
+
+	overItem ~~ item ifTrue:[
+	    dropInfo at:#timeOverItem put:now.
+	    dropInfo at:#overItem put:item.
+	    aDropContext passiveAction:[ self packageAtTargetPointOf:aDropContext ].
+	] ifFalse:[
+	    (now millisecondDeltaFrom:timeOverItem) >= (UserPreferences current timeToAutoExpandItemsWhenDraggingOver) ifTrue:[
+		aDropContext saveDraw:[ item expand. packageListView repairDamage ].
+		dropInfo removeKey:#timeOverItem.
+		dropInfo removeKey:#overItem.
+	    ] ifFalse:[
+		aDropContext passiveAction:[ self packageAtTargetPointOf:aDropContext ].
+	    ]
+	].
+    ].
+
+    package := item package.
+    package = self class nameListEntryForALL ifTrue:[^ nil].
+    ^ package.
+! !
+
+!ProjectList methodsFor:'generators'!
+
+makeGenerator
+    "return a generator which enumerates the classes from the selected project(s)."
+
+    |selectedPackages thePackage hideUnloadedClasses|
+
+    selectedPackages := self selectedProjects value.
+    selectedPackages size == 0 ifTrue:[
+	^ #()
+    ].
+
+    hideUnloadedClasses := self hideUnloadedClasses value.
+
+    (selectedPackages includes:(self class nameListEntryForALL)) ifTrue:[
+	hideUnloadedClasses ifTrue:[
+	    ^ Iterator on:[:whatToDo |
+			       Smalltalk allClassesDo:[:cls |
+				   cls isLoaded ifTrue:[
+				       (cls isNameSpace not or:[cls == Smalltalk]) ifTrue:[
+					   whatToDo value:cls
+				       ]
+				   ]
+			       ]
+			  ]
+	].
+	^ Iterator on:[:whatToDo |
+			   Smalltalk allClassesDo:[:cls |
+			       (cls isNameSpace not or:[cls == Smalltalk]) ifTrue:[
+				   whatToDo value:cls
+			       ]
+			   ]
+		      ]
+    ].
+
+    selectedPackages size == 1 ifTrue:[
+	"/ faster common case
+	thePackage := selectedPackages first.
+
+	^ Iterator on:[:whatToDo | |doInclude|
+			   Smalltalk allClassesDo:[:cls |
+			       (hideUnloadedClasses not or:[cls isLoaded])
+			       ifTrue:[
+				   (cls isNameSpace not or:[cls == Smalltalk]) ifTrue:[
+				       doInclude := (thePackage = cls package).
+				       doInclude ifFalse:[
+					    cls isJavaClass ifFalse:[
+					       doInclude := (cls methodDictionary contains:[:mthd | thePackage = mthd package])
+							    or:[ cls class methodDictionary contains:[:mthd | thePackage = mthd package]].
+					    ]
+				       ].
+				       doInclude ifTrue:[
+					   whatToDo value:cls
+				       ]
+				   ]
+			       ]
+			   ]
+		      ]
+    ].
+
+    ^ Iterator on:[:whatToDo |  |doInclude|
+		       Smalltalk allClassesDo:[:cls |
+			   (hideUnloadedClasses not or:[cls isLoaded])
+			   ifTrue:[
+			       (cls isNameSpace not or:[cls == Smalltalk]) ifTrue:[
+				   doInclude := (selectedPackages includes:cls package).
+				   doInclude ifFalse:[
+					cls isJavaClass ifFalse:[
+					   doInclude := (cls methodDictionary contains:[:mthd | thePackage = mthd package])
+							or:[ cls class methodDictionary contains:[:mthd | thePackage = mthd package]].
+					]
+				   ].
+				   doInclude ifTrue:[
+				       whatToDo value:cls
+				   ]
+			       ]
+			   ]
+		       ]
+		  ]
+
+    "Created: / 17.2.2000 / 23:49:37 / cg"
+    "Modified: / 24.2.2000 / 22:53:46 / cg"
+! !
+
+!ProjectList methodsFor:'private'!
+
+defaultSlaveModeValue
+    |org|
+
+    (org := self topApplication initialOrganizerMode) == #project ifTrue:[^ false].
+    org isNil ifTrue:[^ false].
+    ^ true
+!
+
+initialOrganizerMode
+    ^ #project
+!
+
+listOfProjects
+    |allProjects generator|
+
+    allProjects := IdentitySet new.
+
+    inGeneratorHolder isNil ifTrue:[
+	(self hideUnloadedClasses value) ifTrue:[
+	    Smalltalk allClassesDo:[:eachClass |
+		|cls pkg|
+
+		eachClass isLoaded ifTrue:[
+		    cls := eachClass theNonMetaclass.
+		    cls isPrivate ifTrue:[
+			cls := cls topOwningClass
+		    ].
+		    pkg := cls package.
+		    pkg withoutSeparators size > 0 ifTrue:[
+			allProjects add:pkg asSymbol.
+		    ] ifFalse:[
+			"/ for now, nameSpaces are not in any package;
+			"/ this might change. Then, 0-sized packages are
+			"/ illegal, and the following should be enabled.
+			"/ self halt
+		    ].
+		    cls isJavaClass ifFalse:[
+			cls instAndClassSelectorsAndMethodsDo:[:sel :mthd |
+			    allProjects add:mthd package asSymbol.
+			].
+		    ].
+		].
+	    ].
+	    allProjects := allProjects asOrderedCollection.
+	] ifFalse:[
+	    allProjects := NewSystemBrowser allProjectsIDs.
+	].
+
+	"/ those are simulated - in ST/X, empty projects do not
+	"/ really exist; however, during browsing, it makes sense.
+	AdditionalEmptyProjects size > 0 ifTrue:[
+	    "/ remove those that are present ...
+	    AdditionalEmptyProjects := AdditionalEmptyProjects select:[:pkg | (allProjects includes:pkg) not].
+	    allProjects addAll:AdditionalEmptyProjects.
+	].
+    ] ifFalse:[
+	generator := inGeneratorHolder value.
+	generator isNil ifTrue:[^ #() ].
+	generator do:[:prj | allProjects add:prj].
+	allProjects := allProjects asOrderedCollection.
+    ].
+
+    allProjects sort.
+    allProjects size == 1 ifTrue:[
+	"/ self projectLabelHolder value:(allProjects first , ' [Project]').
+	self projectLabelHolder value:(LabelAndIcon icon:(self class packageIcon) string:allProjects first).
+    ].
+    allProjects size > 1 ifTrue:[
+	allProjects addFirst:(self class nameListEntryForALL).
+    ].
+    ^ allProjects
+
+    "Created: / 17.2.2000 / 23:43:05 / cg"
+    "Modified: / 18.8.2000 / 20:26:04 / cg"
+!
+
+makeDependent
+    Smalltalk addDependent:self
+
+    "Created: / 17.2.2000 / 23:43:13 / cg"
+!
+
+makeIndependent
+    Smalltalk removeDependent:self.
+!
+
+release
+    super release.
+
+    projectList removeDependent:self.
+!
+
+updateList
+    |newList oldSelection newSelection selectedProjectsHolder|
+
+    selectedProjectsHolder := self selectedProjects.
+    oldSelection := selectedProjectsHolder value.
+    newList := self listOfProjects.
+    newList ~= projectList value ifTrue:[
+"/        oldSelection size > 0 ifTrue:[
+"/            selectedProjectsHolder removeDependent:self.
+"/            selectedProjectsHolder value:#().
+"/            selectedProjectsHolder addDependent:self.
+"/        ].
+
+	self projectList value:newList.
+
+	oldSelection size > 0 ifTrue:[
+	    newSelection := oldSelection select:[:prj | newList includes:prj].
+	    selectedProjectsHolder value:newSelection.
+	]
+    ].
+    listValid := true.
+
+    "Modified: / 25.2.2000 / 23:10:01 / cg"
+! !
+
+!ProjectList methodsFor:'special'!
+
+addAdditionalProject:aProject
+    "/ those are simulated - in ST/X, empty categories do not
+    "/ really exist; however, during browsing, it makes sense.
+    AdditionalEmptyProjects isNil ifTrue:[
+	AdditionalEmptyProjects := Set new.
+    ].
+    AdditionalEmptyProjects add:aProject.
+
+    Smalltalk changed:#projectOrganization   "/ not really ... to force update
+
+    "Created: / 17.2.2000 / 23:44:27 / cg"
+!
+
+removeAdditionalProjects:aListOfProjects
+    "/ those are simulated - in ST/X, empty categories do not
+    "/ really exist; however, during browsing, it makes sense.
+    AdditionalEmptyProjects notNil ifTrue:[
+	aListOfProjects do:[:eachProject |
+	    AdditionalEmptyProjects remove:eachProject ifAbsent:nil.
+	].
+    ].
+    Smalltalk changed:#projectOrganization   "/ not really ... to force update
+
+    "Created: / 17.2.2000 / 23:45:24 / cg"
+! !
+
+!ProjectList class methodsFor:'documentation'!
+
+version
+    ^ '$Header: /cvs/stx/stx/libtool/Tools_ProjectList.st,v 1.1 2004-02-26 18:56:15 cg Exp $'
+! !