--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Tools__ViewTreeApplication.st Fri Sep 21 13:45:33 2007 +0200
@@ -0,0 +1,1564 @@
+"{ Package: 'stx:libtool2' }"
+
+"{ NameSpace: Tools }"
+
+ApplicationModel subclass:#ViewTreeApplication
+ instanceVariableNames:'model treeView hasSingleSelectionHolder clickedItem clickedPoint
+ motionAction infoChannel testModeChannel process
+ followFocusChannel'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'A-Views-Support'
+!
+
+Object subclass:#MenuDesc
+ instanceVariableNames:'title value action'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:ViewTreeApplication
+!
+
+!ViewTreeApplication class methodsFor:'documentation'!
+
+documentation
+"
+ Small application showing a ViewTreeModel use.
+
+ It displays a hierarchical list of a selected TopView and
+ all its contained subViews.
+ Useful to have a look at subcomponents - to see how views
+ are structured.
+
+
+ [Instance variables:]
+ model <ViewTreeModel> the used ViewTreeModel
+ clickedItem <ViewTreeItem> item under the clickedPoint (motion action)
+ clickedPoint <Point> point where the motion action started from.
+ motionAction <Action> (oneArg-) action called durring buttonMotion.
+
+
+ [author:]
+ Claus Atzkern
+
+ [see also:]
+ ViewTreeModel
+ ViewTreeItem
+"
+! !
+
+!ViewTreeApplication class methodsFor:'initialization'!
+
+initialize
+ "add myself to the launcher menu
+ "
+ self installInLauncher.
+!
+
+installInLauncher
+ "add myself to the launcher menu
+ "
+ |menuItem icon|
+
+ NewLauncher isNil ifTrue:[^ self].
+
+ icon := ToolbarIconLibrary inspectLocals20x20Icon magnifiedTo:28@28.
+
+ menuItem := MenuItem new
+ label: 'View Inspector';
+ value: [ ViewTreeApplication open];
+ isButton: true;
+ icon: icon;
+ nameKey: #viewInspect.
+
+ menuItem startGroup:#right.
+ NewLauncher addMenuItem:menuItem in:'toolbar'
+ position:#( #before #help)
+ space:false.
+
+"
+self installInLauncher
+self removeFromLauncher
+"
+!
+
+postAutoload
+ "add myself to the launcher menu
+ "
+ self installInLauncher.
+"
+self installInLauncher
+self removeFromLauncher
+"
+!
+
+removeFromLauncher
+ "remove myself from the launcher menu
+ "
+ NewLauncher isNil ifTrue:[^ self].
+ NewLauncher removeUserTool:#viewInspect
+
+"
+self installInLauncher
+self removeFromLauncher
+"
+!
+
+unload
+ "class is about to be unloaded - remove myself from the launcher menu
+ "
+ self removeFromLauncher.
+ super unload.
+! !
+
+!ViewTreeApplication class methodsFor:'interface specs'!
+
+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:ViewTreeApplication andSelector:#windowSpec
+ ViewTreeApplication new openInterface:#windowSpec
+ ViewTreeApplication open
+ "
+
+ <resource: #canvas>
+
+ ^
+ #(FullSpec
+ name: windowSpec
+ window:
+ (WindowSpec
+ label: 'ViewTreeInspector'
+ name: 'ViewTreeInspector'
+ min: (Point 10 10)
+ max: (Point 1024 9999)
+ bounds: (Rectangle 0 0 325 654)
+ menu: menu
+ )
+ component:
+ (SpecCollection
+ collection: (
+ (MenuPanelSpec
+ name: 'toolbarMenu'
+ layout: (LayoutFrame 0 0.0 0 0 0 1.0 32 0)
+ menu: toolbarMenu
+ textDefault: true
+ )
+ (HierarchicalListViewSpec
+ name: 'List'
+ layout: (LayoutFrame 0 0.0 32 0.0 0 1.0 -24 1.0)
+ level: 1
+ model: model
+ menu: middleButtonMenu
+ hasHorizontalScrollBar: true
+ hasVerticalScrollBar: true
+ miniScrollerHorizontal: true
+ miniScrollerVertical: false
+ backgroundColor: (Color 49.999237048905 49.999237048905 100.0)
+ listModel: listOfItems
+ multipleSelectOk: true
+ useIndex: false
+ highlightMode: label
+ doubleClickSelector: doubleClicked:
+ valueChangeSelector: selectionChanged
+ showLeftIndicators: false
+ indicatorSelector: indicatorClicked:
+ useDefaultIcons: false
+ postBuildCallback: postBuildTree:
+ )
+ (LabelSpec
+ name: 'infoChannel'
+ layout: (LayoutFrame 0 0.0 -24 1.0 0 1.0 0 1.0)
+ level: 1
+ translateLabel: true
+ labelChannel: infoChannel
+ adjust: left
+ )
+ )
+
+ )
+ )
+! !
+
+!ViewTreeApplication class methodsFor:'menu specs'!
+
+menu
+ "This resource specification was automatically generated
+ by the MenuEditor of ST/X."
+
+ "Do not manually edit this!! If it is corrupted,
+ the MenuEditor may not be able to read the specification."
+
+ "
+ MenuEditor new openOnClass:ViewTreeApplication andSelector:#menu
+ (Menu new fromLiteralArrayEncoding:(ViewTreeApplication menu)) startUp
+ "
+
+ <resource: #menu>
+
+ ^
+ #(Menu
+ (
+ (MenuItem
+ label: 'File'
+ translateLabel: true
+ submenu:
+ (Menu
+ (
+ (MenuItem
+ label: 'Pick a View'
+ itemValue: doPickViews
+ translateLabel: true
+ )
+ (MenuItem
+ enabled: hasPickedView
+ label: 'Release Picked View'
+ itemValue: doUnpick
+ translateLabel: true
+ )
+ (MenuItem
+ label: '-'
+ )
+ (MenuItem
+ label: 'Exit'
+ itemValue: closeRequest
+ translateLabel: true
+ )
+ )
+ nil
+ nil
+ )
+ )
+ (MenuItem
+ label: ''
+ )
+ (MenuItem
+ enabled: hasSingleSelectionHolder
+ label: 'Menu'
+ translateLabel: true
+ submenuChannel: middleButtonMenu
+ )
+ (MenuItem
+ label: 'Components'
+ translateLabel: true
+ startGroup: right
+ submenuChannel: submenuComponents:
+ )
+ (MenuItem
+ label: 'Applications'
+ translateLabel: true
+ submenuChannel: submenuApplications:
+ )
+ )
+ nil
+ nil
+ )
+!
+
+middleButtonMenu
+ "This resource specification was automatically generated
+ by the MenuEditor of ST/X."
+
+ "Do not manually edit this!! If it is corrupted,
+ the MenuEditor may not be able to read the specification."
+
+ "
+ MenuEditor new openOnClass:ViewTreeApplication andSelector:#middleButtonMenu
+ (Menu new fromLiteralArrayEncoding:(ViewTreeApplication middleButtonMenu)) startUp
+ "
+
+ <resource: #menu>
+
+ ^
+ #(Menu
+ (
+ (MenuItem
+ label: 'Geometry'
+ translateLabel: true
+ submenuChannel: submenuGeometry:
+ keepLinkedMenu: true
+ )
+ (MenuItem
+ label: 'Interface'
+ translateLabel: true
+ submenuChannel: submenuInterface:
+ keepLinkedMenu: true
+ )
+ (MenuItem
+ label: 'Visibility'
+ translateLabel: true
+ submenuChannel: submenuVisibility:
+ keepLinkedMenu: true
+ )
+ (MenuItem
+ label: '-'
+ )
+ (MenuItem
+ label: 'Browse View Class'
+ itemValue: doBrowse:
+ translateLabel: true
+ argument: view
+ )
+ (MenuItem
+ label: 'Browse Model Class'
+ itemValue: doBrowse:
+ translateLabel: true
+ isVisible: hasModel
+ argument: model
+ )
+ (MenuItem
+ label: 'Browse Application Class'
+ itemValue: doBrowse:
+ translateLabel: true
+ isVisible: hasApplication
+ argument: application
+ )
+ (MenuItem
+ label: 'Browse Controller Class'
+ itemValue: doBrowse:
+ translateLabel: true
+ isVisible: hasController
+ argument: controller
+ )
+ (MenuItem
+ label: '-'
+ )
+ (MenuItem
+ label: 'Inspect View'
+ itemValue: doInspect:
+ translateLabel: true
+ argument: view
+ )
+ (MenuItem
+ label: 'Inspect Window Group'
+ itemValue: doInspect:
+ translateLabel: true
+ argument: group
+ )
+ (MenuItem
+ label: 'Inspect Model'
+ itemValue: doInspect:
+ translateLabel: true
+ isVisible: hasModel
+ argument: model
+ )
+ (MenuItem
+ label: 'Inspect Application'
+ itemValue: doInspect:
+ translateLabel: true
+ isVisible: hasApplication
+ argument: application
+ )
+ (MenuItem
+ label: 'Inspect Controller'
+ itemValue: doInspect:
+ translateLabel: true
+ isVisible: hasController
+ argument: controller
+ )
+ (MenuItem
+ label: '-'
+ )
+ (MenuItem
+ label: 'Flash'
+ itemValue: doFlash
+ translateLabel: true
+ )
+ (MenuItem
+ label: '-'
+ )
+ (MenuItem
+ label: 'Destroy'
+ itemValue: doDestroy
+ translateLabel: true
+ )
+ (MenuItem
+ label: '-'
+ )
+ (MenuItem
+ label: 'Instance Variables'
+ translateLabel: true
+ submenuChannel: submenuInspector:
+ keepLinkedMenu: true
+ )
+ (MenuItem
+ label: '='
+ )
+ (MenuItem
+ label: ''
+ )
+ (MenuItem
+ enabled: selectedComponentHasChildren
+ label: 'Applications'
+ nameKey: single
+ translateLabel: true
+ submenuChannel: submenuApplications:
+ keepLinkedMenu: true
+ )
+ (MenuItem
+ enabled: selectedComponentHasChildren
+ label: 'Components'
+ nameKey: single
+ translateLabel: true
+ submenuChannel: submenuComponents:
+ keepLinkedMenu: true
+ )
+ )
+ nil
+ nil
+ )
+!
+
+toolbarMenu
+ "This resource specification was automatically generated
+ by the MenuEditor of ST/X."
+
+ "Do not manually edit this!! If it is corrupted,
+ the MenuEditor may not be able to read the specification."
+
+ "
+ MenuEditor new openOnClass:ViewTreeApplication andSelector:#toolbarMenu
+ (Menu new fromLiteralArrayEncoding:(ViewTreeApplication toolbarMenu)) startUp
+ "
+
+ <resource: #menu>
+
+ ^
+ #(Menu
+ (
+ (MenuItem
+ label: 'Test Mode'
+ translateLabel: true
+ indication: testModeChannel
+ )
+ (MenuItem
+ enabled: testModeChannel
+ label: 'Follow Focus'
+ translateLabel: true
+ indication: followFocusChannel
+ )
+ (MenuItem
+ label: 'Select On Click'
+ translateLabel: true
+ indication: selectOnClickHolder
+ )
+ )
+ nil
+ nil
+ )
+! !
+
+!ViewTreeApplication methodsFor:'actions'!
+
+doubleClicked:anIndex
+ self doInspect:#view.
+!
+
+indicatorClicked:anIndex
+ |item sensor|
+
+ item := model listOfItems at:anIndex ifAbsent:nil.
+
+ item notNil ifTrue:[
+ ( (sensor := self window sensor) notNil
+ and:[(sensor ctrlDown or:[sensor shiftDown])]
+ ) ifTrue:[
+ item recursiveToggleExpand
+ ] ifFalse:[
+ item toggleExpand
+ ]
+ ].
+! !
+
+!ViewTreeApplication methodsFor:'aspects'!
+
+followFocusChannel
+ "boolean holder, which indicates whether selection changed dependend on the focus view
+ "
+ ^ followFocusChannel
+!
+
+hasSingleSelectionHolder
+ "boolean holder, true if one item is selected
+ "
+ ^ hasSingleSelectionHolder
+!
+
+infoChannel
+ "channel, which keeps a printable information
+ "
+ ^ infoChannel
+!
+
+listOfItems
+ "returns the hierarchical list of items
+ "
+ ^ model listOfItems
+!
+
+model
+ "returns my selection model, a ViewTreeModel
+ "
+ ^ model
+!
+
+selectOnClickHolder
+ "boolean holder, which indicates whether the selection will change on click
+ "
+ ^ model selectOnClickHolder
+!
+
+testModeChannel
+ "boolean holder, which indicates whether running in test or edit mode (eat input events)
+ "
+ ^ testModeChannel
+! !
+
+!ViewTreeApplication methodsFor:'change & update'!
+
+selectionChanged
+ "called if the selection changed
+ "
+ |info view item|
+
+ item := model selectedItem.
+
+ item notNil ifTrue:[ |state|
+ view := item widget.
+
+ view id isNil ifTrue:[
+ state := 'no ID'.
+ ] ifFalse:[
+ view shown ifTrue:[
+ state := 'visible'.
+ ] ifFalse:[
+ state := 'invisible'
+ ].
+ ].
+ info := '%1 [%2] - %3' bindWith:(view class name)
+ with:(view name ? '') with:state allBold.
+
+ ] ifFalse:[
+ info := ''
+ ].
+ hasSingleSelectionHolder value:(view notNil).
+ infoChannel value:info.
+!
+
+update:something with:someArgument from:aModel
+
+ aModel == testModeChannel ifTrue:[
+ model testMode:(testModeChannel value).
+ ^ self
+ ].
+ super update:something with:someArgument from:aModel.
+! !
+
+!ViewTreeApplication methodsFor:'event processing'!
+
+processButtonMotionEvent:ev
+ "handle a button motion event
+ "
+ |click|
+
+ motionAction notNil ifTrue:[
+ click := ev view sensor mousePoint.
+
+ click = clickedPoint ifFalse:[
+ (clickedItem isNil or:[(click dist:clickedPoint) > 5.0]) ifTrue:[
+ motionAction value:click
+ ]
+ ]
+ ].
+!
+
+processButtonPressEvent:ev
+ "handle a buttopn press event
+ "
+ |sensor lastRectangle|
+
+ sensor := model rootView sensor.
+ clickedItem := model listOfItems detectItemRespondsToView:(ev view).
+
+ (sensor ctrlDown or:[sensor shiftDown]) ifTrue:[
+ clickedItem notNil ifTrue:[
+ self selectOnClickHolder value ifTrue:[
+ model toggleSelectItem:clickedItem
+ ].
+ ].
+ clickedItem := motionAction := nil.
+ ] ifFalse:[
+ clickedPoint := ev view sensor mousePoint.
+ lastRectangle := nil.
+
+ motionAction :=[:p| |rootView|
+ rootView := model rootView device rootView.
+ clickedItem := nil.
+
+ rootView xoring:[
+ lastRectangle notNil ifTrue:[ rootView displayRectangle:lastRectangle ]
+ ifFalse:[ rootView clippedByChildren:false ].
+
+ p isNil ifTrue:[
+ rootView clippedByChildren:true.
+ motionAction := nil.
+ ] ifFalse:[
+ lastRectangle := Rectangle origin:(clickedPoint min:p) corner:(clickedPoint max:p).
+ rootView displayRectangle:lastRectangle.
+ ].
+ rootView flush.
+ ].
+ lastRectangle
+ ]
+ ]
+!
+
+processButtonReleaseEvent:anEvent
+ "handle a button release event
+ "
+ |rootView rectangle newItems widget origin|
+
+ motionAction isNil ifTrue:[ ^ self ].
+ clickedItem notNil ifTrue:[ ^ model selectItem:clickedItem ].
+
+ (rectangle := motionAction value:nil) notNil ifTrue:[
+ rootView := model rootView device rootView.
+ newItems := OrderedCollection new.
+
+ model rootItem recursiveDo:[:anItem|
+ widget := anItem widget.
+ origin := widget originRelativeTo:rootView.
+
+ (rectangle containsRect:(Rectangle origin:origin extent:(widget extent))) ifTrue:[
+ newItems add:anItem.
+ ]
+ ].
+ model value:newItems.
+ ].
+!
+
+processEvent:anEvent
+ "process an event
+ "
+ |button menu|
+
+ anEvent isKeyPressEvent ifTrue:[ ^ self processKeyPressEvent:anEvent ].
+ anEvent isButtonEvent ifFalse:[ ^ self ].
+
+ button := anEvent button.
+
+ (button == 2 or:[button == #menu]) ifTrue:[
+ motionAction isNil ifTrue:[
+ anEvent isButtonPressEvent ifTrue:[
+ self selectOnClickHolder value ifTrue:[
+ menu := self middleButtonMenu value.
+ menu notNil ifTrue:[
+ menu := MenuPanel menu:(Menu new fromLiteralArrayEncoding:menu)
+ receiver:self.
+ menu startUp.
+ ]
+ ].
+ ].
+ clickedItem := nil.
+ ].
+ ^ self
+ ].
+
+ anEvent isButtonPressEvent ifTrue:[ ^ self processButtonPressEvent:anEvent ].
+ anEvent isButtonMotionEvent ifTrue:[ ^ self processButtonMotionEvent:anEvent ].
+
+ anEvent isButtonReleaseEvent ifTrue:[
+ self selectOnClickHolder value ifTrue:[
+ self processButtonReleaseEvent:anEvent
+ ].
+ ].
+ clickedItem := motionAction := nil.
+
+ anEvent type == #'buttonMultiPress:x:y:' ifTrue:[
+ self selectOnClickHolder value ifTrue:[
+ self doInspect:#view.
+ ].
+ ].
+!
+
+processKeyPressEvent:anEvent
+ "process an key press event
+ "
+ |item prnt idx key max next|
+
+ key := anEvent key.
+ key isSymbol ifFalse:[^ self].
+
+ key == #Delete ifTrue:[ ^ self doDestroy ].
+ key == #InspectIt ifTrue:[ ^ self doInspect:#view ].
+
+ ( key == #CursorUp
+ or:[key == #CursorDown
+ or:[key == #CursorLeft
+ or:[key == #CursorRight]]]
+ ) ifFalse:[
+ ^ self
+ ].
+ item := model selectedItem.
+
+ item isNil ifTrue:[
+ ^ model selectedItem:(model first ? model rootItem)
+ ].
+
+ prnt := item parent.
+ prnt isNil ifTrue:[
+ "/ is the root item
+ (key == #CursorUp or:[key == #CursorLeft]) ifTrue:[item := model listOfItems last]
+ ifFalse:[item := item at:1 ifAbsent:item].
+
+ ^ model selectedItem:item
+ ].
+ key == #CursorLeft ifTrue:[ ^ model selectedItem:prnt ].
+
+ key == #CursorRight ifTrue:[
+ next := item at:1 ifAbsent:nil.
+ next notNil ifTrue:[ model selectedItem:next ].
+ ^ self
+ ].
+
+ max := prnt size.
+
+ key == #CursorUp ifTrue:[
+ idx := prnt identityIndexOf:item.
+ idx == 1 ifTrue:[idx := max + 1].
+ model selectedItem:(prnt at:idx - 1).
+ ^ self.
+ ].
+
+ key == #CursorDown ifTrue:[
+ idx := prnt identityIndexOf:item.
+ idx == max ifTrue:[idx := 0].
+ model selectedItem:(prnt at:idx + 1).
+ ^ self.
+ ].
+!
+
+processMappedView:aView
+ "process a mapped event
+ "
+ |parent anchor|
+
+ parent := self listOfItems detectItemRespondsToView:aView.
+ parent isNil ifTrue:[ ^ self ].
+
+ NotFoundSignal handle:[:ex|
+ "contained subvies used by spec are not yet created;
+ thus we have to wait until last used subview is build
+ "
+ anchor := nil.
+ ] do:[
+ anchor := parent class buildViewsFrom:(parent widget).
+ ].
+ anchor notNil ifTrue:[
+ parent updateFromChildren:anchor children.
+ ].
+! !
+
+!ViewTreeApplication methodsFor:'initialization & release'!
+
+closeDownViews
+ "release the grapped application
+ "
+ process := nil.
+ super closeDownViews.
+ self doUnpick.
+!
+
+initialize
+ "setup my model and channels
+ "
+ super initialize.
+
+ infoChannel := '' asValue.
+ hasSingleSelectionHolder := false asValue.
+ followFocusChannel := false asValue.
+
+ model := ViewTreeModel new.
+ model inputEventAction:[:ev| self processEvent:ev ].
+ model mappedViewAction:[:vw| self processMappedView:vw ].
+ model application:self.
+
+ testModeChannel := model testMode asValue.
+ testModeChannel addDependent:self.
+!
+
+postBuildTree:aTree
+ treeView := aTree scrolledView.
+ treeView hasConstantHeight:true.
+! !
+
+!ViewTreeApplication methodsFor:'menu queries'!
+
+hasApplication
+ "returns true if the current selected view has an application
+ "
+ |view|
+
+ view := self selectedView.
+ ^ (view notNil and:[view application notNil])
+!
+
+hasController
+ "returns true if the current selected item's view has a controller
+ other than nil or the view itself
+ "
+ |view controller|
+
+ view := self selectedView.
+
+ view notNil ifTrue:[
+ controller := view controller.
+ ^ (controller notNil and:[controller ~~ view])
+ ].
+ ^ false
+!
+
+hasModel
+ "returns true if the current selected view has a model
+ "
+ |view|
+
+ view := self selectedView.
+ ^ (view notNil and:[view model notNil])
+!
+
+hasPickedView
+ "returns true if a view is picked
+ "
+ ^ model rootItem notNil
+! !
+
+!ViewTreeApplication methodsFor:'menu specs'!
+
+middleButtonMenu
+ "returns the middleButton menu for the single selected item or nil
+ "
+ ^ [ model selectedItem notNil ifTrue:[self class middleButtonMenu]
+ ifFalse:[nil]
+ ]
+!
+
+submenuApplications:aMenu
+ |applications menu item list addBlock|
+
+ item := aMenu selection nameKey == #single ifTrue:[model selectedItem]
+ ifFalse:[model rootItem].
+ item isNil ifTrue:[^ nil].
+
+ applications := IdentityDictionary new.
+
+ addBlock := [:el| |cls ctr|
+ cls := self resolveApplicationClassFor:el.
+
+ cls notNil ifTrue:[
+ ctr := applications at:cls ifAbsent:0.
+ applications at:cls put:(ctr + 1).
+ ].
+ ].
+ item recursiveDo:addBlock.
+ addBlock value:item.
+
+ applications isEmpty ifTrue:[^ nil ].
+ list := SortedCollection sortBlock:[:a :b| a title < b title ].
+
+ applications keysAndValuesDo:[:cls :ctr|
+ list add:(MenuDesc title:(cls name)
+ value:(ctr printString)
+ action:[self doSelectNextOfApplicationClass:cls startingIn:item]
+ ).
+ ].
+
+ menu := MenuDesc buildFromList:list onGC:aMenu.
+ menu do:[:el|
+ el hideMenuOnActivated:false
+ ].
+ ^ menu
+!
+
+submenuComponents:aMenu
+ |widgets list total menu item|
+
+ item := aMenu selection nameKey == #single ifTrue:[model selectedItem]
+ ifFalse:[model rootItem].
+ item isNil ifTrue:[^ nil].
+
+ widgets := IdentityDictionary new.
+ total := 0.
+
+ item recursiveDo:[:el| |cls ctr|
+ cls := el widget.
+
+ cls notNil ifTrue:[
+ cls := cls class.
+ ctr := widgets at:cls ifAbsent:0.
+ widgets at:cls put:(ctr + 1).
+ total := total + 1.
+ ].
+ ].
+ total == 0 ifTrue:[^ nil].
+ list := SortedCollection sortBlock:[:a :b| a title < b title ].
+
+ widgets keysAndValuesDo:[:cls :ctr|
+ list add:(MenuDesc title:(cls name)
+ value:(ctr printString)
+ action:[self doSelectNextOfClass:cls startingIn:item]
+ ).
+ ].
+ list := list asOrderedCollection.
+ list add:(MenuDesc separator).
+ list add:(MenuDesc title:'Total' value:(total printString)).
+ menu := MenuDesc buildFromList:list onGC:aMenu.
+ menu do:[:el|
+ el hideMenuOnActivated:false
+ ].
+ ^ menu
+!
+
+submenuGeometry:aMenu
+ "builds and returns the geometry submenu
+ "
+ |view point inst list x y|
+
+ view := self selectedView.
+ view isNil ifTrue:[^ nil].
+
+ list := OrderedCollection new.
+
+ "/ origin
+ point := view relativeOrigin.
+ point isNil ifTrue:[ point := view origin ].
+
+ x := view left.
+ y := view top.
+
+ (x == point x and:[y == point y]) ifTrue:[ inst := point ]
+ ifFalse:[ inst := '%1 --> (%2@%3)' bindWith:point with:x with:y ].
+
+ list add:(MenuDesc title:'origin' value:inst).
+
+ "/ corner
+ point := view relativeCorner.
+ point isNil ifTrue:[ point := view corner ].
+
+ x := view right.
+ y := view bottom.
+
+ (x == point x and:[y == point y]) ifTrue:[ inst := point ]
+ ifFalse:[ inst := '%1 --> (%2@%3)' bindWith:point with:x with:y ].
+
+ list add:(MenuDesc title:'corner' value:inst).
+
+ "/ extent
+ (point := view relativeExtent) isNil ifTrue:[point := view extent].
+ list add:(MenuDesc title:'extent' value:point).
+
+ "/ preferred extent
+ list add:(MenuDesc title:'pref. extent' value:(view preferredExtent)).
+ list add:(MenuDesc separator).
+
+ "/ view insets
+ inst := 'l:%1 r:%2 t:%3 b:%4' bindWith:(view leftInset)
+ with:(view rightInset)
+ with:(view topInset)
+ with:(view bottomInset).
+
+ list add:(MenuDesc title:'insets' value:inst).
+ list add:(MenuDesc title:'borderWidth' value:(view borderWidth)).
+ list add:(MenuDesc title:'level' value:(view level)).
+ list add:(MenuDesc separator).
+
+ (inst := view layout) notNil ifTrue:[ inst := inst displayString ].
+ list add:(MenuDesc title:'layout' value:inst).
+
+ (inst := view transformation) notNil ifTrue:[ inst := inst displayString ].
+ list add:(MenuDesc title:'transformation' value:inst).
+
+ ^ MenuDesc buildFromList:list onGC:aMenu
+!
+
+submenuInspector:aMenu
+ "builds and returns the inspector submenu
+ "
+ |view list n names label value|
+
+ view := self selectedView.
+ view isNil ifTrue:[^ nil].
+
+ n := view class instSize.
+ n > 0 ifFalse:[^ nil ].
+
+ list := OrderedCollection new:n.
+ names := view class allInstVarNames.
+
+ 1 to:n do:[:i| |action|
+ label := (names at:i) printString.
+ value := view instVarAt:i.
+ value isNil ifTrue:[
+ value := '------'.
+ action := nil.
+ ] ifFalse:[
+ value := value displayString contractAtEndTo:40.
+ action := [(view instVarAt:i) inspect].
+ ].
+ list add:(MenuDesc title:label value:value action:action).
+ ].
+
+ ^ MenuDesc buildFromList:list onGC:aMenu
+!
+
+submenuInterface:aMenu
+ "builds and returns the interface submenu
+ "
+ |view label inst value list|
+
+ view := self selectedView.
+ view isNil ifTrue:[^ nil].
+
+ list := OrderedCollection new.
+
+ inst := view controller.
+ value := nil.
+
+ inst isNil ifTrue:[
+ label := nil
+ ] ifFalse:[
+ inst == view ifTrue:[ label := '== view itself' ]
+ ifFalse:[ label := inst displayString.
+ value := [view controller inspect].
+ ].
+ ].
+ list add:(MenuDesc title:'controller' value:label action:value).
+
+ inst := view delegate.
+ inst notNil ifTrue:[
+ list add:(MenuDesc title:'delegate' value:(inst displayString) action:[ view delegate inspect ]).
+ ].
+
+ inst := view application.
+
+ inst notNil ifTrue:[ |topAppl|
+ list add:(MenuDesc title:'application' value:inst action:[ view application inspect ]).
+
+ topAppl := inst topApplication.
+
+ (topAppl notNil and:[topAppl ~~ inst]) ifTrue:[
+ list add:(MenuDesc title:'topApplication' value:topAppl action:[ inst topApplication inspect ]).
+ ].
+ ].
+ list add:(MenuDesc separator).
+
+ (view respondsTo:#'model:') ifTrue:[
+ inst := model.
+
+ inst isNil ifTrue:[ label := value := nil ]
+ ifFalse:[ label := inst displayString.
+ value := [ view model inspect ].
+ ].
+
+ list add:(MenuDesc title:'model' value:label action:value).
+
+ (inst notNil and:[view respondsTo:#modelInterface]) ifTrue:[
+ view modelInterface keysAndValuesDo:[:key : val|
+ val isNil ifTrue:[ label := nil ]
+ ifFalse:[ label := val displayString ].
+
+ list add:(MenuDesc title:(' - ', key) value:label ).
+ ]
+ ].
+ ].
+
+ (view respondsTo:#enableChannel) ifTrue:[
+ inst := view enableChannel.
+
+ inst isNil ifTrue:[ label := value := nil ]
+ ifFalse:[ label := inst displayString.
+ value := [ view enableChannel inspect ].
+ ].
+
+ list add:(MenuDesc title:'enableChannel' value:label action:value).
+ ].
+
+ list last isSeparator ifFalse:[ list add:(MenuDesc separator) ].
+
+ (view respondsTo:#listHolder) ifTrue:[
+ inst := view listHolder.
+
+ inst isNil ifTrue:[ label := value := nil ]
+ ifFalse:[ label := inst class printString.
+ value := [ view listHolder inspect ].
+ ].
+ list add:(MenuDesc title:'listHolder' value:label action:value).
+ ].
+
+ (view respondsTo:#list) ifTrue:[
+ inst := view list.
+
+ inst isNil ifTrue:[ label := value := nil ]
+ ifFalse:[ label := '%1 [%2]' bindWith:(inst class printString) with:(inst size).
+ value := [ view list inspect ].
+ ].
+
+ list add:(MenuDesc title:'list' value:label action:value).
+ ].
+
+ list last isSeparator ifTrue:[ list removeLast ].
+ ^ MenuDesc buildFromList:list onGC:aMenu
+!
+
+submenuVisibility:aMenu
+ "builds and returns the geometry submenu
+ "
+ |view list value|
+
+ view := self selectedView.
+ view isNil ifTrue:[^ nil].
+
+ list := OrderedCollection new.
+
+ list add:(MenuDesc title:'device' value:(view device printString)).
+ list add:(MenuDesc title:'drawableId' value:(view id)).
+ list add:(MenuDesc title:'gcId' value:(view gcId)).
+
+ list add:(MenuDesc separator).
+
+ list add:(MenuDesc title:'shown' value:(view shown)).
+ list add:(MenuDesc title:'realized' value:(view realized)).
+
+ list add:(MenuDesc separator).
+
+ list add:(MenuDesc title:'hiddenOnRealize' value:(view isHiddenOnRealize)).
+
+ (value := view visibilityChannel) isNil ifTrue:[
+ list add:(MenuDesc title:'visibilityChannel' value:'------').
+ ] ifFalse:[
+ list add:(MenuDesc title:'visibilityChannel'
+ value:(value displayString)
+ action:[view visibilityChannel inspect]).
+ ].
+
+
+ ^ MenuDesc buildFromList:list onGC:aMenu
+! !
+
+!ViewTreeApplication methodsFor:'private'!
+
+selectFocusView
+ |rootView focusItem focusView|
+
+ rootView := model rootView.
+
+ (rootView notNil and:[rootView shown]) ifTrue:[
+ focusView := rootView windowGroup focusView.
+ ].
+ focusView isNil ifTrue:[^ self ].
+
+ focusItem := model selectedItem.
+
+ (focusItem notNil and:[focusItem widget == focusView]) ifTrue:[
+ ^ self
+ ].
+ focusItem := model listOfItems recursiveDetect:[:el| el widget == focusView ].
+
+ focusItem notNil ifTrue:[
+ model selectItem:focusItem.
+ ].
+!
+
+setRootItem:aRootItemOrNil
+ |theProcess|
+
+ aRootItemOrNil isNil ifTrue:[
+ process := nil.
+ ] ifFalse:[
+ "/ expand tree to level 3
+ aRootItemOrNil do:[:aRootChild|
+ aRootChild do:[:aSubChild| aSubChild expand ].
+ aRootChild expand.
+ ].
+ aRootItemOrNil expand.
+
+ process isNil ifTrue:[
+ theProcess := process :=
+ Process for:[ |update|
+
+ update := false.
+
+ [process == theProcess] whileTrue:[
+ Delay waitForSeconds:0.5.
+
+ (treeView notNil and:[process == theProcess and:[treeView shown]]) ifTrue:[
+ (self isInTestmode and:[followFocusChannel value == true]) ifTrue:[
+ self selectFocusView.
+ ].
+ update ifTrue:[
+ self updateShownStatus.
+ ].
+ update := update not.
+ ].
+ ].
+
+ ] priority:8.
+ theProcess name:'ViewTreeApplication::Follow Focus'.
+ theProcess resume.
+ ].
+ ].
+ model rootItem:aRootItemOrNil.
+!
+
+updateShownStatus
+ |rootItem min max visState listIdx visY0 visY1 height damage|
+
+ rootItem := model rootItem.
+ (rootItem notNil and:[rootItem widget shown]) ifFalse:[^ self].
+
+ max := 0.
+ min := 9999999.
+
+ rootItem recursiveEachVisibleItemDo:[:anItem|
+ visState := (anItem widget shown).
+
+ visState ~~ anItem isDrawnShown ifTrue:[
+ anItem isDrawnShown:visState.
+ listIdx := treeView identityIndexOf:anItem.
+
+ listIdx > 0 ifTrue:[
+ max := max max:listIdx.
+ min := min min:listIdx.
+ ].
+ ].
+ ].
+ max < min ifTrue:[^ self].
+ max := max + 1.
+
+ visY0 := (treeView yVisibleOfLine:min) max:0.
+ visY1 := (treeView yVisibleOfLine:max) min:(treeView height).
+ height := visY1 - visY0.
+
+ height > 2 ifTrue:[
+ treeView shown ifTrue:[
+ damage := Rectangle left:0 top:visY0 width:(treeView width) height:height.
+ treeView invalidateDeviceRectangle:damage repairNow:false.
+ ].
+ ].
+! !
+
+!ViewTreeApplication methodsFor:'queries'!
+
+isInTestmode
+ "returns true if running in test mode - no events eaten
+ "
+ ^ testModeChannel value == true
+! !
+
+!ViewTreeApplication methodsFor:'selection'!
+
+selectedView
+ "returns the selected view or nil
+ "
+ |item|
+
+ item := model selectedItem.
+ item notNil ifTrue:[ ^ item widget ].
+ ^ nil
+! !
+
+!ViewTreeApplication methodsFor:'testing'!
+
+resolveApplicationClassFor:aTreeItem
+ aTreeItem isApplicationClass ifTrue:[
+ ^ aTreeItem applicationClass
+ ].
+ ^ nil
+!
+
+selectedComponentHasChildren
+ |item|
+
+ item := model selectedItem.
+ ^ (item notNil and:[item hasChildren])
+! !
+
+!ViewTreeApplication methodsFor:'user operations'!
+
+doBrowse:what
+ "open browser on:
+ #view browse class
+ #model browse model class
+ #application browse application class
+ #controller browse controller class
+ "
+ |view inst|
+
+ view := self selectedView.
+ view isNil ifTrue:[^ self].
+
+ what == #view ifTrue:[ inst := view ]
+ ifFalse:[what == #model ifTrue:[ inst := view model ]
+ ifFalse:[what == #application ifTrue:[ inst := view application ]
+ ifFalse:[what == #controller ifTrue:[ inst := view controller ]
+ ifFalse:[
+ ^ self
+ ]]]].
+
+ inst notNil ifTrue:[
+ inst class browserClass openInClass:(inst class) selector:nil
+ ].
+!
+
+doDestroy
+ "destroy the current selected view
+ "
+ |item parent|
+
+ item := model selectedItem.
+ item isNil ifTrue:[ ^ self].
+
+ parent := item parent.
+
+ parent isNil ifTrue:[
+ "/ the root
+ model withSelectionHiddenDo:[item deleteAll].
+ ^ self
+ ].
+
+ model withSelectionHiddenDo:[
+ |idx nsel|
+
+ idx := parent identityIndexOf:item.
+
+ idx == parent size ifTrue:[
+ nsel := parent at:(idx - 1) ifAbsent:parent
+ ] ifFalse:[
+ nsel := parent at:(idx + 1)
+ ].
+ model setValue:nil.
+ item delete.
+
+ parent isLayoutContainer ifTrue:[
+ parent widget sizeChanged:nil
+ ].
+ model value:nsel.
+ ].
+!
+
+doFlash
+ "flash the selected view
+ "
+ |view|
+
+ view := self selectedView.
+ view isNil ifTrue:[ ^ self].
+
+ view shown ifTrue:[
+ model withSelectionHiddenDo:[
+ view perform:#flash ifNotUnderstood:nil.
+ ].
+ ].
+!
+
+doInspect:what
+ "open inspector on:
+ #view inspect class
+ #group inspect windowGroup
+ #model inspect model
+ #application inspect application
+ #controller inspect controller
+ "
+ |inst|
+
+ inst := self selectedView.
+ inst isNil ifTrue:[^ self].
+
+ what == #group ifTrue:[ inst := inst windowGroup ]
+ ifFalse:[what == #model ifTrue:[ inst := inst model ]
+ ifFalse:[what == #application ifTrue:[ inst := inst application ]
+ ifFalse:[what == #controller ifTrue:[ inst := inst controller ]]]].
+
+ inst notNil ifTrue:[ inst inspect ].
+!
+
+doPickViews
+ "pick a window's topView
+ "
+ |window|
+
+ self doUnpick.
+
+ window := Screen current viewFromUser.
+ window isNil ifTrue:[^ self].
+
+ window := window topView.
+
+ ( window == Screen current rootView
+ or:[window == self window topView]
+ ) ifTrue:[
+ ^ self
+ ].
+ self setRootItem:(ViewTreeItem buildViewsFrom:window).
+!
+
+doSelectNextOfApplicationClass:aClass startingIn:anItem
+ |startItem firstFound searchNext|
+
+ startItem := model last.
+ searchNext := startItem notNil.
+ firstFound := nil.
+
+ anItem recursiveDo:[:el|
+ el == startItem ifTrue:[
+ searchNext := false
+ ] ifFalse:[
+ (self resolveApplicationClassFor:el) == aClass ifTrue:[
+ searchNext ifFalse:[^ model selectItem:el].
+
+ firstFound isNil ifTrue:[
+ firstFound := el
+ ]
+ ]
+ ]
+ ].
+ firstFound notNil ifTrue:[
+ self window beep.
+ model selectItem:firstFound
+ ].
+!
+
+doSelectNextOfClass:aClass startingIn:anItem
+ |startItem firstFound searchNext|
+
+ startItem := model last.
+ searchNext := startItem notNil.
+ firstFound := nil.
+
+ anItem recursiveDo:[:el|
+ el == startItem ifTrue:[
+ searchNext := false
+ ] ifFalse:[
+ el widget class == aClass ifTrue:[
+ searchNext ifFalse:[^ model selectItem:el].
+
+ firstFound isNil ifTrue:[
+ firstFound := el
+ ]
+ ]
+ ]
+ ].
+ firstFound notNil ifTrue:[
+ self window beep.
+ model selectItem:firstFound
+ ].
+!
+
+doUnpick
+ "release current picked window and contained subwindows
+ "
+ self setRootItem:nil.
+! !
+
+!ViewTreeApplication::MenuDesc class methodsFor:'building'!
+
+buildFromList:aList onGC:aMenu
+ |tabSpec menu w menuPanel|
+
+ w := 0.
+ aList do:[:el| w := w max:(el widthOn:aMenu) ].
+
+ tabSpec := TabulatorSpecification new.
+ tabSpec unit:#pixel.
+ tabSpec positions:#(0 1.5 ).
+ tabSpec align:#(#left #left).
+
+ w := w + 15.
+ tabSpec positions:(Array with:0 with:w).
+
+ menu := Menu new.
+
+ aList do:[:el|
+ menu addItem:(el asMenuItemWithTabulatorSpecification:tabSpec).
+ ].
+ menuPanel := MenuPanel menu:menu.
+ ^ menuPanel
+! !
+
+!ViewTreeApplication::MenuDesc class methodsFor:'instance creation'!
+
+separator
+ ^ self new
+!
+
+title:aTitle value:aValue
+ ^ self title:aTitle value:aValue action:nil
+!
+
+title:aTitle value:aValue action:anAction
+ ^ self new title:aTitle value:aValue action:anAction
+! !
+
+!ViewTreeApplication::MenuDesc methodsFor:'accessing'!
+
+title
+ ^ title
+! !
+
+!ViewTreeApplication::MenuDesc methodsFor:'building'!
+
+asMenuItemWithTabulatorSpecification:aTabSpec
+ |array|
+
+ title isNil ifTrue:[ ^ MenuItem label:value ]. "/ separator
+
+ array := Array with:(title, ':') with:'------'.
+
+ value notNil ifTrue:[
+ array at:2 put:(value printString, ' ')
+ ].
+
+ ^ MenuItem label:(MultiColListEntry fromStrings:array tabulatorSpecification:aTabSpec)
+ value:action
+! !
+
+!ViewTreeApplication::MenuDesc methodsFor:'instance creation'!
+
+title:aTitle value:aValue action:anAction
+ "test for separator
+ "
+ title := aTitle withoutSeparators.
+ action := anAction.
+
+ aValue notNil ifTrue:[
+ value := aValue printString.
+
+ value size > 70 ifTrue:[
+ value := value copyFrom:1 to:70.
+ value := value, '...'
+ ]
+ ].
+! !
+
+!ViewTreeApplication::MenuDesc methodsFor:'queries'!
+
+isSeparator
+ ^ title isNil
+!
+
+widthOn:aGC
+ title isNil ifTrue:[^ 5]. "/ separator
+ ^ title widthOn:aGC
+! !
+
+!ViewTreeApplication class methodsFor:'documentation'!
+
+version
+ ^ '$Header$'
+! !
+
+ViewTreeApplication initialize!