--- /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 $'
+! !