diff -r eef25c370979 -r 87bb1815460b Tools__ViewTreeApplication.st --- /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 the used ViewTreeModel + clickedItem item under the clickedPoint (motion action) + clickedPoint point where the motion action started from. + motionAction (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 + " + + + + ^ + #(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 + " + + + + ^ + #(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 + " + + + + ^ + #(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 + " + + + + ^ + #(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!