Tools__ViewTreeApplication.st
author Claus Gittinger <cg@exept.de>
Wed, 03 Feb 2010 11:10:20 +0100
changeset 2748 76f6fd319918
parent 2747 717a0dcc710d
child 2757 6c83d6b487b2
permissions -rw-r--r--
added: #copyright
     1 "
     2  COPYRIGHT (c) 2007 by eXept Software AG
     3               All Rights Reserved
     4 
     5  This software is furnished under a license and may be used
     6  only in accordance with the terms of that license and with the
     7  inclusion of the above copyright notice.   This software may not
     8  be provided or otherwise made available to, or used by, any
     9  other person.  No title to or ownership of the software is
    10  hereby transferred.
    11 "
    12 "{ Package: 'stx:libtool2' }"
    13 
    14 "{ NameSpace: Tools }"
    15 
    16 ToolApplicationModel subclass:#ViewTreeInspectorApplication
    17 	instanceVariableNames:'model treeView hasSingleSelectionHolder clickedItem clickedPoint
    18 		motionAction process followFocusChannel showNamesHolder'
    19 	classVariableNames:''
    20 	poolDictionaries:''
    21 	category:'Interface-Smalltalk'
    22 !
    23 
    24 Object subclass:#MenuDesc
    25 	instanceVariableNames:'title value action'
    26 	classVariableNames:''
    27 	poolDictionaries:''
    28 	privateIn:ViewTreeInspectorApplication
    29 !
    30 
    31 HierarchicalItem subclass:#ViewTreeItem
    32 	instanceVariableNames:'widget isDrawnShown exists xOffsetAdditionalName'
    33 	classVariableNames:'HandleExtent'
    34 	poolDictionaries:''
    35 	privateIn:ViewTreeInspectorApplication
    36 !
    37 
    38 ValueModel subclass:#ViewTreeModel
    39 	instanceVariableNames:'lockSema selectedSuperItems selection hiddenLevel listOfItems
    40 		inputEventAction mappedViewAction beforeSelectionChangedAction
    41 		icons timedUpdateTask selectOnClickHolder testModeChannel
    42 		hasTargetWidgetChannel'
    43 	classVariableNames:''
    44 	poolDictionaries:''
    45 	privateIn:ViewTreeInspectorApplication
    46 !
    47 
    48 HierarchicalList subclass:#ItemList
    49 	instanceVariableNames:'treeModel eventHook eventHookInitialized showWidgetNames'
    50 	classVariableNames:''
    51 	poolDictionaries:''
    52 	privateIn:ViewTreeInspectorApplication::ViewTreeModel
    53 !
    54 
    55 !ViewTreeInspectorApplication class methodsFor:'documentation'!
    56 
    57 copyright
    58 "
    59  COPYRIGHT (c) 2007 by eXept Software AG
    60               All Rights Reserved
    61 
    62  This software is furnished under a license and may be used
    63  only in accordance with the terms of that license and with the
    64  inclusion of the above copyright notice.   This software may not
    65  be provided or otherwise made available to, or used by, any
    66  other person.  No title to or ownership of the software is
    67  hereby transferred.
    68 "
    69 !
    70 
    71 documentation
    72 "
    73      Small application showing a ViewTreeModel use.
    74 
    75      It displays a hierarchical list of a selected TopView and
    76      all its contained subViews.
    77      Useful to have a look at subcomponents - to see how views
    78      are structured.
    79 
    80 
    81     [Instance variables:]
    82         model           <ViewTreeModel>      the used ViewTreeModel
    83         clickedItem     <ViewTreeItem>       item under the clickedPoint (motion action)
    84         clickedPoint    <Point>              point where the motion action started from.
    85         motionAction    <Action>             (oneArg-) action called durring buttonMotion.
    86 
    87 
    88     [author:]
    89         Claus Atzkern
    90 
    91     [see also:]
    92         ViewTreeModel
    93         ViewTreeItem
    94 "
    95 ! !
    96 
    97 !ViewTreeInspectorApplication class methodsFor:'initialization'!
    98 
    99 initialize
   100     "add myself to the launcher menu
   101     "
   102     self installInLauncher.
   103 !
   104 
   105 installInLauncher
   106     "add myself to the launcher menu"
   107 
   108     |menuItem icon|
   109 
   110     NewLauncher isNil ifTrue:[^ self].
   111     "/ cg - disabled. the icon is too ugly.
   112     ^ self.
   113 
   114     icon := ToolbarIconLibrary inspectLocals20x20Icon magnifiedTo:28@28.
   115 
   116     menuItem := MenuItem new 
   117                     label: 'View Tree Inspector';
   118                     value: [ ViewTreeInspectorApplication open];
   119                     isButton: true;
   120                     icon: icon;
   121                     nameKey: #viewInspect.
   122 
   123     menuItem startGroup:#right.
   124     NewLauncher addMenuItem:menuItem in:'toolbar'
   125                    position:#( #before #help)
   126                       space:false.
   127 
   128 "
   129 self installInLauncher
   130 self removeFromLauncher
   131 "
   132 !
   133 
   134 postAutoload
   135     "add myself to the launcher menu
   136     "
   137     self installInLauncher.
   138 "
   139 self installInLauncher
   140 self removeFromLauncher
   141 "
   142 !
   143 
   144 removeFromLauncher
   145     "remove myself from the launcher menu
   146     "
   147     NewLauncher isNil ifTrue:[^ self].
   148     NewLauncher removeUserTool:#viewInspect
   149 
   150 "
   151 self installInLauncher
   152 self removeFromLauncher
   153 "
   154 !
   155 
   156 unload
   157     "class is about to be unloaded - remove myself from the launcher menu
   158     "
   159     self removeFromLauncher.
   160     super unload.
   161 ! !
   162 
   163 !ViewTreeInspectorApplication class methodsFor:'image specs'!
   164 
   165 pickWindowIcon
   166     "This resource specification was automatically generated
   167      by the ImageEditor of ST/X."
   168 
   169     "Do not manually edit this!! If it is corrupted,
   170      the ImageEditor may not be able to read the specification."
   171 
   172     "
   173      self pickWindowIcon inspect
   174      ImageEditor openOnClass:self andSelector:#pickWindowIcon
   175      Icon flushCachedIcons
   176     "
   177 
   178     <resource: #image>
   179 
   180     ^Icon
   181         constantNamed:'Tools::ViewTreeInspectorApplication class pickWindowIcon'
   182         ifAbsentPut:[(Depth8Image new) width: 22; height: 22; photometric:(#palette); bitsPerSample:(#[8]); samplesPerPixel:(1); bits:(ByteArray fromPackedString:'
   183 ,;N3,;N3,;N3,;N3,;N3,;N3,;N3,3H<P38;M3P,H2@^GA(VEQHQCP0KA D<[&-%XU=WST%BN#D!!GQ$TD@(IBP\BQF)+Z6E_U4-FPCX+G1,WEA@JBP$HAT23
   184 ,;N3,;N3,;N3,;N$():Z&IRR&1!!^,;N3,;N3,;N3,;N$)JJ^&)"T$),0W[N3,;N3,;N3,;N3,:R"'')*X%IJWK523,;N3,;N3,0@@@KN3)JJ^&)"T$"5Z,;N3
   185 ,;N3@@B3-KL@@JJ^&)"T$)D*V[N3,;N3@KN3-KR4)JH@&)"T$)*MJE"3,;N3,0B3)JJ4&*R"@I*X%IJZ#RYV,;N3,0B3@JR"-JR"-I(@%IJV%H %U[N3,;L@
   186 -@B4-KR4-KR4@IRR%IJEIER3,;N3@KL@)JJ4():4&@BO#9RR!!RIS,;N3,;L@,:R"-JJ^& BT#8>O#8H"T+N3,;N3@KN$@@@@'')(@%H>O#(>AH%F3,;N3,;L@
   187 @JR4'' @@%IJO#8>O RIO,;N3,;N3):P@@@BX%IJO#8>O#7<"S*63,;N$():Z&IRR&IRR#8>O#8=>H"&-,;N$():Z&IRR&)"T$(>O#8>O @<)R$!!GQTD?OS$8
   188 MSL.I2H"H"H"H"HO,;N3,;N3,;N3,;N3,;N3,;N3,;N3,0@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@a') ; colorMapFromArray:#[0 0 0 0 50 164 0 50 171 0 137 0 0 206 0 1 50 177 2 56 178 3 64 241 3 67 246 3 73 255 4 74 255 5 63 191 7 66 194 10 71 196 10 79 255 12 59 167 12 82 255 14 77 199 18 83 201 19 88 255 21 91 255 23 89 204 27 95 206 28 97 255 29 72 179 30 100 255 32 101 209 36 106 255 36 107 211 39 109 255 41 113 214 45 115 255 45 119 216 48 118 255 50 87 176 50 125 219 51 88 176 51 88 177 52 89 178 52 90 178 53 90 178 53 127 212 54 91 179 54 123 255 54 131 221 55 92 180 55 95 181 56 93 180 56 94 181 57 127 255 57 149 229 58 99 184 58 137 224 61 104 187 63 132 255 63 143 226 64 108 190 66 113 193 66 135 255 67 149 229 68 157 232 69 117 196 71 155 231 72 122 199 72 141 255 75 126 202 75 144 255 75 160 234 77 163 236 78 131 206 80 149 255 81 136 209 84 140 212 84 153 255 87 145 215 88 157 255 91 168 235 93 161 255 94 154 222 96 157 223 96 165 255 97 159 225 98 160 225 98 162 226 99 163 227 100 165 228 101 166 229 101 170 255 102 167 230 103 169 231 104 170 232 104 173 255 105 172 233 105 174 234 106 175 235 109 178 255 112 180 255 117 186 255 119 187 255 122 154 245 125 160 253 125 193 255 126 161 253 126 194 255 127 162 254 130 165 254 132 200 255 132 201 255 133 60 36 135 170 255 139 207 255 140 175 255 144 179 255 149 184 255 153 188 255 157 192 255 162 196 255 166 200 255 170 204 255 174 208 255 174 218 230 177 212 255 181 215 255 185 219 255 188 222 255 191 225 255 212 211 224 218 217 230 219 219 230 220 220 231 222 221 232 223 223 233 225 224 234 225 225 234 226 226 237 227 226 235 227 227 236 227 227 238 228 228 237 229 229 239 231 230 238 231 231 238 231 231 240 232 232 241 233 232 239 233 233 240 234 234 242 235 234 241 236 236 243 237 236 242 237 237 244 238 237 243 238 238 244 239 238 243 239 239 245 240 239 244 241 240 245 241 241 246 241 241 247 242 242 246 242 242 247 243 243 247 243 243 248 244 244 248 244 244 249 245 244 247 246 246 249 246 246 250 247 246 249 247 247 250 248 248 251 249 249 250 249 249 251 250 250 251 250 250 252 251 251 252 251 251 253 253 253 254 254 254 255 255 255 255 0 0 0]; mask:((Depth1Image new) width: 22; height: 22; photometric:(#blackIs0); bitsPerSample:(#[1]); samplesPerPixel:(1); bits:(ByteArray fromPackedString:'@@@C????????????????????????????????????????????????????????????????????????????????@@@C') ; yourself); yourself]
   189 ! !
   190 
   191 !ViewTreeInspectorApplication class methodsFor:'interface specs'!
   192 
   193 windowSpec
   194     "This resource specification was automatically generated
   195      by the UIPainter of ST/X."
   196 
   197     "Do not manually edit this!! If it is corrupted,
   198      the UIPainter may not be able to read the specification."
   199 
   200     "
   201      UIPainter new openOnClass:Tools::ViewTreeApplication andSelector:#windowSpec
   202      Tools::ViewTreeApplication new openInterface:#windowSpec
   203      Tools::ViewTreeApplication open
   204     "
   205 
   206     <resource: #canvas>
   207 
   208     ^ 
   209      #(FullSpec
   210         name: windowSpec
   211         window: 
   212        (WindowSpec
   213           label: 'View Tree Inspector'
   214           name: 'ViewTreeInspector'
   215           min: (Point 10 10)
   216           max: (Point 1024 9999)
   217           bounds: (Rectangle 0 0 381 654)
   218           menu: menu
   219         )
   220         component: 
   221        (SpecCollection
   222           collection: (
   223            (MenuPanelSpec
   224               name: 'toolbarMenu'
   225               layout: (LayoutFrame 0 0.0 0 0 0 1.0 32 0)
   226               menu: toolbarMenu
   227               textDefault: true
   228             )
   229            (HierarchicalListViewSpec
   230               name: 'List'
   231               layout: (LayoutFrame 0 0.0 32 0.0 0 1.0 0 1.0)
   232               level: 1
   233               model: model
   234               menu: middleButtonMenu
   235               hasHorizontalScrollBar: true
   236               hasVerticalScrollBar: true
   237               miniScrollerHorizontal: true
   238               miniScrollerVertical: false
   239               listModel: listOfItems
   240               multipleSelectOk: true
   241               useIndex: false
   242               highlightMode: label
   243               showLeftIndicators: false
   244               indicatorSelector: indicatorClicked:
   245               useDefaultIcons: false
   246               postBuildCallback: postBuildTree:
   247             )
   248            )
   249          
   250         )
   251       )
   252 ! !
   253 
   254 !ViewTreeInspectorApplication class methodsFor:'menu specs'!
   255 
   256 menu
   257     "This resource specification was automatically generated
   258      by the MenuEditor of ST/X."
   259 
   260     "Do not manually edit this!! If it is corrupted,
   261      the MenuEditor may not be able to read the specification."
   262 
   263     "
   264      MenuEditor new openOnClass:Tools::ViewTreeApplication andSelector:#menu
   265      (Menu new fromLiteralArrayEncoding:(Tools::ViewTreeApplication menu)) startUp
   266     "
   267 
   268     <resource: #menu>
   269 
   270     ^ 
   271      #(Menu
   272         (
   273          (MenuItem
   274             label: 'File'
   275             translateLabel: true
   276             submenu: 
   277            (Menu
   278               (
   279                (MenuItem
   280                   label: 'Pick a View'
   281                   itemValue: doPickViews
   282                   translateLabel: true
   283                 )
   284                (MenuItem
   285                   enabled: hasTargetWidgetChannel
   286                   label: 'Release Picked View'
   287                   itemValue: doUnpick
   288                   translateLabel: true
   289                 )
   290                (MenuItem
   291                   label: '-'
   292                 )
   293                (MenuItem
   294                   label: 'Settings'
   295                   translateLabel: true
   296                   submenu: 
   297                  (Menu
   298                     (
   299                      (MenuItem
   300                         label: 'Test Mode'
   301                         translateLabel: true
   302                         hideMenuOnActivated: false
   303                         indication: testModeChannel
   304                       )
   305                      (MenuItem
   306                         enabled: testModeChannel
   307                         label: 'Follow Focus'
   308                         translateLabel: true
   309                         hideMenuOnActivated: false
   310                         indication: followFocusChannel
   311                       )
   312                      (MenuItem
   313                         label: '-'
   314                       )
   315                      (MenuItem
   316                         label: 'Select on Click'
   317                         translateLabel: true
   318                         hideMenuOnActivated: false
   319                         indication: selectOnClickHolder
   320                       )
   321                      (MenuItem
   322                         label: '-'
   323                       )
   324                      (MenuItem
   325                         label: 'Show Name of Widgets'
   326                         translateLabel: true
   327                         hideMenuOnActivated: false
   328                         indication: showNamesHolder
   329                       )
   330                      )
   331                     nil
   332                     nil
   333                   )
   334                 )
   335                (MenuItem
   336                   label: '-'
   337                 )
   338                (MenuItem
   339                   label: 'Exit'
   340                   itemValue: closeRequest
   341                   translateLabel: true
   342                 )
   343                )
   344               nil
   345               nil
   346             )
   347           )
   348          (MenuItem
   349             enabled: hasSingleSelectionHolder
   350             label: 'Selection'
   351             translateLabel: true
   352             submenuChannel: middleButtonMenu
   353           )
   354          (MenuItem
   355             label: 'Application'
   356             translateLabel: true
   357             submenu: 
   358            (Menu
   359               (
   360                (MenuItem
   361                   enabled: hasSingleSelectionHolder
   362                   label: 'Browse'
   363                   itemValue: doBrowse:
   364                   translateLabel: true
   365                   argument: application
   366                 )
   367                (MenuItem
   368                   enabled: hasSingleSelectionHolder
   369                   label: 'Inspect'
   370                   itemValue: doInspect:
   371                   translateLabel: true
   372                   argument: application
   373                 )
   374                (MenuItem
   375                   label: '-'
   376                 )
   377                (MenuItem
   378                   enabled: hasTargetWidgetChannel
   379                   label: 'All Applications'
   380                   translateLabel: true
   381                   submenuChannel: submenuApplications:
   382                 )
   383                )
   384               nil
   385               nil
   386             )
   387           )
   388          (MenuItem
   389             label: 'Widget'
   390             translateLabel: true
   391             submenu: 
   392            (Menu
   393               (
   394                (MenuItem
   395                   enabled: hasSingleSelectionHolder
   396                   label: 'Browse'
   397                   itemValue: doBrowse:
   398                   translateLabel: true
   399                   argument: view
   400                 )
   401                (MenuItem
   402                   enabled: hasSingleSelectionHolder
   403                   label: 'Inspect'
   404                   itemValue: doInspect:
   405                   translateLabel: true
   406                   argument: view
   407                 )
   408                (MenuItem
   409                   label: '-'
   410                 )
   411                (MenuItem
   412                   enabled: hasTargetWidgetChannel
   413                   label: 'All Components'
   414                   translateLabel: true
   415                   startGroup: right
   416                   submenuChannel: submenuComponents:
   417                 )
   418                )
   419               nil
   420               nil
   421             )
   422           )
   423          (MenuItem
   424             label: 'Help'
   425             translateLabel: true
   426             startGroup: conditionalRight
   427             submenu: 
   428            (Menu
   429               (
   430                (MenuItem
   431                   label: 'Documentation'
   432                   itemValue: openDocumentation
   433                   translateLabel: true
   434                 )
   435                (MenuItem
   436                   label: '-'
   437                 )
   438                (MenuItem
   439                   label: 'About this Application...'
   440                   itemValue: openAboutThisApplication
   441                   translateLabel: true
   442                 )
   443                )
   444               nil
   445               nil
   446             )
   447           )
   448          )
   449         nil
   450         nil
   451       )
   452 !
   453 
   454 middleButtonMenu
   455     "This resource specification was automatically generated
   456      by the MenuEditor of ST/X."
   457 
   458     "Do not manually edit this!! If it is corrupted,
   459      the MenuEditor may not be able to read the specification."
   460 
   461     "
   462      MenuEditor new openOnClass:ViewTreeApplication andSelector:#middleButtonMenu
   463      (Menu new fromLiteralArrayEncoding:(ViewTreeApplication middleButtonMenu)) startUp
   464     "
   465 
   466     <resource: #menu>
   467 
   468     ^ 
   469      #(Menu
   470         (
   471          (MenuItem
   472             label: 'Geometry'
   473             translateLabel: true
   474             submenuChannel: submenuGeometry:
   475             keepLinkedMenu: true
   476           )
   477          (MenuItem
   478             label: 'Interface'
   479             translateLabel: true
   480             submenuChannel: submenuInterface:
   481             keepLinkedMenu: true
   482           )
   483          (MenuItem
   484             label: 'Visibility'
   485             translateLabel: true
   486             submenuChannel: submenuVisibility:
   487             keepLinkedMenu: true
   488           )
   489          (MenuItem
   490             label: '-'
   491           )
   492          (MenuItem
   493             label: 'Browse View Class'
   494             itemValue: doBrowse:
   495             translateLabel: true
   496             argument: view
   497           )
   498          (MenuItem
   499             label: 'Browse Model Class'
   500             itemValue: doBrowse:
   501             translateLabel: true
   502             isVisible: hasModel
   503             argument: model
   504           )
   505          (MenuItem
   506             label: 'Browse Application Class'
   507             itemValue: doBrowse:
   508             translateLabel: true
   509             isVisible: hasApplication
   510             argument: application
   511           )
   512          (MenuItem
   513             label: 'Browse Controller Class'
   514             itemValue: doBrowse:
   515             translateLabel: true
   516             isVisible: hasController
   517             argument: controller
   518           )
   519          (MenuItem
   520             label: '-'
   521           )
   522          (MenuItem
   523             label: 'Inspect View'
   524             itemValue: doInspect:
   525             translateLabel: true
   526             argument: view
   527           )
   528          (MenuItem
   529             label: 'Inspect Window Group'
   530             itemValue: doInspect:
   531             translateLabel: true
   532             argument: group
   533           )
   534          (MenuItem
   535             label: 'Inspect Model'
   536             itemValue: doInspect:
   537             translateLabel: true
   538             isVisible: hasModel
   539             argument: model
   540           )
   541          (MenuItem
   542             label: 'Inspect Application'
   543             itemValue: doInspect:
   544             translateLabel: true
   545             isVisible: hasApplication
   546             argument: application
   547           )
   548          (MenuItem
   549             label: 'Inspect Controller'
   550             itemValue: doInspect:
   551             translateLabel: true
   552             isVisible: hasController
   553             argument: controller
   554           )
   555          (MenuItem
   556             label: '-'
   557           )
   558          (MenuItem
   559             label: 'Flash'
   560             itemValue: doFlash
   561             translateLabel: true
   562           )
   563          (MenuItem
   564             label: '-'
   565           )
   566          (MenuItem
   567             label: 'Destroy'
   568             itemValue: doDestroy
   569             translateLabel: true
   570           )
   571          (MenuItem
   572             label: '-'
   573           )
   574          (MenuItem
   575             label: 'Instance Variables'
   576             translateLabel: true
   577             submenuChannel: submenuInspector:
   578             keepLinkedMenu: true
   579           )
   580          (MenuItem
   581             label: '='
   582           )
   583          (MenuItem
   584             label: ''
   585           )
   586          (MenuItem
   587             enabled: selectedComponentHasChildren
   588             label: 'Applications'
   589             nameKey: single
   590             translateLabel: true
   591             submenuChannel: submenuApplications:
   592             keepLinkedMenu: true
   593           )
   594          (MenuItem
   595             enabled: selectedComponentHasChildren
   596             label: 'Components'
   597             nameKey: single
   598             translateLabel: true
   599             submenuChannel: submenuComponents:
   600             keepLinkedMenu: true
   601           )
   602          )
   603         nil
   604         nil
   605       )
   606 !
   607 
   608 toolbarMenu
   609     "This resource specification was automatically generated
   610      by the MenuEditor of ST/X."
   611 
   612     "Do not manually edit this!! If it is corrupted,
   613      the MenuEditor may not be able to read the specification."
   614 
   615     "
   616      MenuEditor new openOnClass:Tools::ViewTreeApplication andSelector:#toolbarMenu
   617      (Menu new fromLiteralArrayEncoding:(Tools::ViewTreeApplication toolbarMenu)) startUp
   618     "
   619 
   620     <resource: #menu>
   621 
   622     ^ 
   623      #(Menu
   624         (
   625          (MenuItem
   626             label: 'Pick a View'
   627             itemValue: doPickViews
   628             translateLabel: false
   629             isButton: true
   630             hideMenuOnActivated: false
   631             labelImage: (ResourceRetriever #'Tools::ViewTreeInspectorApplication' pickWindowIcon)
   632           )
   633          (MenuItem
   634             enabled: hasSingleSelectionHolder
   635             label: 'Browse Application'
   636             itemValue: doBrowse:
   637             translateLabel: false
   638             isButton: true
   639             hideMenuOnActivated: false
   640             labelImage: (ResourceRetriever ToolbarIconLibrary systemBrowser24x24Icon2)
   641             argument: application
   642           )
   643          (MenuItem
   644             enabled: hasSingleSelectionHolder
   645             label: 'Inspect Application'
   646             itemValue: doInspect:
   647             translateLabel: false
   648             isButton: true
   649             hideMenuOnActivated: false
   650             labelImage: (ResourceRetriever ToolbarIconLibrary inspect22x24Icon)
   651             argument: application
   652           )
   653          )
   654         nil
   655         nil
   656       )
   657 ! !
   658 
   659 !ViewTreeInspectorApplication class methodsFor:'startup'!
   660 
   661 openInPickMode
   662     |app|
   663 
   664     app := self new.
   665     app open.
   666     app doPickViews.
   667 ! !
   668 
   669 !ViewTreeInspectorApplication methodsFor:'actions'!
   670 
   671 indicatorClicked:anIndex
   672     |item sensor|
   673 
   674     item := model listOfItems at:anIndex ifAbsent:nil.
   675 
   676     item notNil ifTrue:[
   677         (     (sensor := self window sensor) notNil
   678          and:[(sensor ctrlDown or:[sensor shiftDown])]
   679         ) ifTrue:[
   680             item recursiveToggleExpand
   681         ] ifFalse:[
   682             item toggleExpand
   683         ]
   684     ].
   685 ! !
   686 
   687 !ViewTreeInspectorApplication methodsFor:'aspects'!
   688 
   689 followFocusChannel
   690     "boolean holder, which indicates whether selection changed dependend on the focus view"
   691 
   692     ^ followFocusChannel
   693 !
   694 
   695 hasSingleSelectionHolder
   696     "boolean holder, true if one item is selected"
   697 
   698     ^ hasSingleSelectionHolder
   699 !
   700 
   701 hasTargetWidgetChannel
   702     "answer the channel which is set to true if a target widget exists"
   703 
   704     ^ model hasTargetWidgetChannel
   705 !
   706 
   707 listOfItems
   708     "returns the hierarchical list of items"
   709 
   710     ^ model listOfItems
   711 !
   712 
   713 model
   714     "returns my selection model, a ViewTreeModel"
   715 
   716     ^ model
   717 !
   718 
   719 selectOnClickHolder
   720     "boolean holder, which indicates whether the selection will change on click"
   721 
   722     ^ model selectOnClickHolder
   723 !
   724 
   725 showNamesHolder
   726     "boolean holder, which indicates whether application names or widget names
   727      as additional text are shown for the items"
   728 
   729     ^ showNamesHolder
   730 !
   731 
   732 testModeChannel
   733     "answer a boolean channel which describes the behaviour how to process
   734      events on the target view.
   735 
   736      false: all input events are eaten and the selection is shown on the target view.
   737      true:  no  input events are eaten and no  selection is shown on the target view."
   738 
   739     ^ model testModeChannel
   740 ! !
   741 
   742 !ViewTreeInspectorApplication methodsFor:'change & update'!
   743 
   744 selectionChanged
   745     "called if the selection changed"
   746 
   747     |info view item|
   748 
   749     item := model selectedItem.
   750 
   751     item notNil ifTrue:[ |state|
   752         view := item widget.
   753 
   754         view id isNil ifTrue:[
   755             state := 'no ID'.
   756         ] ifFalse:[
   757             view shown ifTrue:[
   758                 state := 'visible'.
   759             ] ifFalse:[
   760                 state := 'invisible'
   761             ].
   762         ].
   763         info := '%1 [%2] - %3' bindWith:(view class name)
   764                                    with:(view name ? '') with:state allBold.
   765 
   766     ] ifFalse:[
   767         info := ''
   768     ].
   769     hasSingleSelectionHolder value:(view notNil).
   770 !
   771 
   772 update:something with:someArgument from:aModel
   773     |oldSelection|
   774 
   775     aModel == showNamesHolder ifTrue:[
   776         oldSelection := model selectedItem.
   777         model selectedItem:nil.
   778         self listOfItems showWidgetNames:(aModel value).
   779         model selectedItem:oldSelection.
   780         ^ self
   781     ].
   782 
   783     aModel == model ifTrue:[
   784         self selectionChanged.
   785         ^ self
   786     ].
   787 
   788     super update:something with:someArgument from:aModel.
   789 ! !
   790 
   791 !ViewTreeInspectorApplication methodsFor:'event processing'!
   792 
   793 processButtonMotionEvent:ev
   794     "handle a button motion event"
   795 
   796     |click rootView|
   797 
   798     motionAction isNil ifTrue:[^ self].
   799 
   800     (rootView := model rootView) isNil ifTrue:[
   801         clickedItem := motionAction := nil.
   802         ^ self
   803     ].
   804 
   805     click := rootView device
   806             translatePoint:((ev x)@ (ev y))
   807             fromView:(ev view)
   808             toView:rootView.
   809 
   810     click = clickedPoint ifFalse:[
   811         (clickedItem isNil or:[(click dist:clickedPoint) > 5.0]) ifTrue:[
   812             motionAction value:click
   813         ]
   814     ].
   815 !
   816 
   817 processButtonPressEvent:ev
   818     "handle a buttopn press event"
   819 
   820     |rootView sensor lastRectangle|
   821 
   822     rootView    := model rootView.
   823     sensor      := model rootView sensor.
   824     clickedItem := model listOfItems detectItemRespondsToView:(ev view).
   825 
   826     (sensor ctrlDown or:[sensor shiftDown]) ifTrue:[
   827         clickedItem notNil ifTrue:[
   828             self selectOnClickHolder value ifTrue:[
   829                 model toggleSelectItem:clickedItem
   830             ].
   831         ].
   832         clickedItem := motionAction := nil.
   833         ^ self
   834     ].
   835 
   836     clickedPoint := rootView device translatePoint:((ev x)@ (ev y))  fromView:(ev view) toView:rootView.
   837     lastRectangle := nil.
   838 
   839     motionAction :=[:p|
   840         rootView    := model rootView device rootView.
   841         rootView    := model rootView.
   842         clickedItem := nil.
   843 
   844         rootView xoring:[
   845             lastRectangle notNil ifTrue:[ rootView displayRectangle:lastRectangle ]
   846                                 ifFalse:[ rootView clippedByChildren:false ].
   847 
   848             p isNil ifTrue:[
   849                 rootView clippedByChildren:true.
   850                 motionAction := nil.
   851             ] ifFalse:[
   852                 lastRectangle := Rectangle origin:(clickedPoint min:p) corner:(clickedPoint max:p).
   853                 rootView displayRectangle:lastRectangle.
   854             ].
   855             rootView flush.
   856         ].
   857         lastRectangle
   858     ].
   859 !
   860 
   861 processButtonReleaseEvent:anEvent
   862     "handle a button release event"
   863 
   864     |rootView rectangle newItems widget origin|
   865 
   866     (rootView := model rootView) isNil ifTrue:[
   867         clickedItem := motionAction := nil.
   868         ^ self
   869     ].
   870     motionAction isNil ifTrue:[ ^ self ].
   871     clickedItem notNil ifTrue:[ ^ model selectItem:clickedItem ].
   872 
   873     rectangle := motionAction value:nil.
   874     rectangle isNil ifTrue:[^ self].
   875 
   876     newItems := OrderedCollection new.
   877 
   878     model rootItem recursiveDo:[:anItem|
   879         widget := anItem widget.
   880         origin := widget originRelativeTo:rootView.
   881 
   882         (rectangle containsRect:(Rectangle origin:origin extent:(widget extent))) ifTrue:[
   883             newItems add:anItem.
   884         ]
   885     ].
   886     model value:newItems.
   887 !
   888 
   889 processEvent:anEvent
   890     "process an event"
   891 
   892     |button menu|
   893 
   894     anEvent isKeyPressEvent ifTrue:[ ^ self processKeyPressEvent:anEvent ].
   895     anEvent isButtonEvent  ifFalse:[ ^ self ].
   896 
   897     button := anEvent button.
   898 
   899     (button == 2 or:[button == #menu]) ifTrue:[
   900         motionAction isNil ifTrue:[
   901             anEvent isButtonPressEvent ifTrue:[
   902                 self selectOnClickHolder value ifTrue:[
   903                     menu := self middleButtonMenu value.
   904                     menu notNil ifTrue:[
   905                         menu := MenuPanel menu:(Menu new fromLiteralArrayEncoding:menu)
   906                                       receiver:self.
   907                         menu startUp.
   908                     ]
   909                 ].
   910             ].
   911             clickedItem := nil.
   912         ].
   913         ^ self
   914     ].
   915 
   916     anEvent isButtonPressEvent  ifTrue:[ ^ self processButtonPressEvent:anEvent  ].
   917     anEvent isButtonMotionEvent ifTrue:[ ^ self processButtonMotionEvent:anEvent ].
   918 
   919     anEvent isButtonReleaseEvent ifTrue:[
   920         self selectOnClickHolder value ifTrue:[
   921             self processButtonReleaseEvent:anEvent
   922         ].
   923     ].
   924     clickedItem := motionAction := nil.
   925 
   926     anEvent type == #'buttonMultiPress:x:y:' ifTrue:[
   927         self selectOnClickHolder value ifTrue:[
   928             self doInspect:#view.
   929         ].
   930     ].
   931 !
   932 
   933 processKeyPressEvent:anEvent
   934     "process an key press event"
   935 
   936     |item prnt idx key max next|
   937 
   938     key := anEvent key.
   939     key isSymbol ifFalse:[^ self].
   940 
   941     key == #Delete    ifTrue:[ ^ self doDestroy ].
   942     key == #InspectIt ifTrue:[ ^ self doInspect:#view ].
   943 
   944     (   key == #CursorUp
   945     or:[key == #CursorDown
   946     or:[key == #CursorLeft
   947     or:[key == #CursorRight]]]
   948     ) ifFalse:[
   949         ^ self
   950     ].
   951     item := model selectedItem.
   952 
   953     item isNil ifTrue:[
   954         ^ model selectedItem:(model first ? model rootItem)
   955     ].
   956 
   957     prnt := item parent.
   958     prnt isNil ifTrue:[
   959         "/ is the root item
   960         (key == #CursorUp or:[key == #CursorLeft]) ifTrue:[item := model listOfItems last]
   961                                                   ifFalse:[item := item at:1 ifAbsent:item].
   962 
   963       ^ model selectedItem:item
   964     ].
   965     key == #CursorLeft ifTrue:[ ^ model selectedItem:prnt ].
   966 
   967     key == #CursorRight ifTrue:[
   968         next := item at:1 ifAbsent:nil.
   969         next notNil ifTrue:[ model selectedItem:next ].
   970       ^ self
   971     ].
   972 
   973     max := prnt size.
   974 
   975     key == #CursorUp ifTrue:[
   976         idx := prnt identityIndexOf:item.
   977         idx == 1 ifTrue:[idx := max + 1].
   978         model selectedItem:(prnt at:idx - 1).
   979       ^ self.
   980     ].
   981 
   982     key == #CursorDown ifTrue:[
   983         idx := prnt identityIndexOf:item.
   984         idx == max ifTrue:[idx := 0].
   985         model selectedItem:(prnt at:idx + 1).
   986       ^ self.
   987     ].
   988 !
   989 
   990 processMappedView:aView
   991     "process a mapped event"
   992 
   993     |parent anchor|
   994 
   995     parent := self listOfItems detectItemRespondsToView:aView.
   996     parent isNil ifTrue:[ ^ self ].
   997 
   998     NotFoundSignal handle:[:ex|
   999         "contained subvies used by spec are not yet created;
  1000          thus we have to wait until last used subview is build
  1001         "
  1002         anchor := nil.
  1003     ] do:[
  1004         anchor := parent class buildViewsFrom:(parent widget).
  1005     ].
  1006     anchor notNil ifTrue:[
  1007         parent updateFromChildren:anchor children.
  1008     ].
  1009 ! !
  1010 
  1011 !ViewTreeInspectorApplication methodsFor:'initialization & release'!
  1012 
  1013 closeDownViews
  1014     "release the grapped application"
  1015 
  1016     process := nil.
  1017     super closeDownViews.
  1018     self doUnpick.
  1019 !
  1020 
  1021 initialize
  1022     "setup my model and channels"
  1023 
  1024     super initialize.
  1025 
  1026     hasSingleSelectionHolder := false asValue.
  1027     followFocusChannel       := false asValue.
  1028 
  1029     model := ViewTreeModel new.
  1030     model inputEventAction:[:ev| self processEvent:ev ].
  1031     model mappedViewAction:[:vw| self processMappedView:vw ].
  1032     model application:self.
  1033     model addDependent:self.
  1034 
  1035 
  1036     showNamesHolder := false asValue.
  1037     showNamesHolder addDependent:self.
  1038 !
  1039 
  1040 postBuildTree:aTree
  1041     treeView := aTree scrolledView.
  1042     treeView hasConstantHeight:true.
  1043 ! !
  1044 
  1045 !ViewTreeInspectorApplication methodsFor:'menu queries'!
  1046 
  1047 hasApplication
  1048     "returns true if the current selected view has an application"
  1049 
  1050     |view|
  1051 
  1052     view := self selectedView.
  1053   ^ (view notNil and:[view application notNil])
  1054 !
  1055 
  1056 hasController
  1057     "returns true if the current selected item's view has a controller
  1058      other than nil or the view itself"
  1059 
  1060     |view controller|
  1061 
  1062     view := self selectedView.
  1063 
  1064     view notNil ifTrue:[
  1065         controller := view controller.
  1066       ^ (controller notNil and:[controller ~~ view])
  1067     ].
  1068     ^ false
  1069 !
  1070 
  1071 hasModel
  1072     "returns true if the current selected view has a model"
  1073 
  1074     |view|
  1075 
  1076     view := self selectedView.
  1077   ^ (view notNil and:[view model notNil])
  1078 ! !
  1079 
  1080 !ViewTreeInspectorApplication methodsFor:'menu specs'!
  1081 
  1082 middleButtonMenu
  1083     "returns the middleButton menu for the single selected item or nil"
  1084 
  1085     ^ [ model selectedItem notNil ifTrue:[self class middleButtonMenu]
  1086                                  ifFalse:[nil]
  1087       ]
  1088 !
  1089 
  1090 submenuApplications:aMenu
  1091     |applications menu item list addBlock|
  1092 
  1093     item := aMenu selection nameKey == #single ifTrue:[model selectedItem]
  1094                                               ifFalse:[model rootItem].
  1095     item isNil ifTrue:[^ nil].
  1096 
  1097     applications := IdentityDictionary new.
  1098 
  1099     addBlock := [:el| |cls ctr|
  1100         cls := self resolveApplicationClassFor:el.
  1101 
  1102         cls notNil ifTrue:[
  1103             ctr := applications at:cls ifAbsent:0.
  1104             applications at:cls put:(ctr + 1).
  1105         ].
  1106     ].
  1107     item recursiveDo:addBlock.
  1108     addBlock value:item.
  1109 
  1110     applications isEmpty ifTrue:[^ nil ].
  1111     list := SortedCollection sortBlock:[:a :b| a title < b title ].
  1112 
  1113     applications keysAndValuesDo:[:cls :ctr|
  1114        list add:(MenuDesc title:(cls name)
  1115                           value:(ctr printString)
  1116                          action:[self doSelectNextOfApplicationClass:cls startingIn:item]
  1117                  ).
  1118     ].
  1119 
  1120     menu := MenuDesc buildFromList:list onGC:aMenu.
  1121     menu do:[:el|
  1122         el hideMenuOnActivated:false
  1123     ].
  1124     ^ menu
  1125 !
  1126 
  1127 submenuComponents:aMenu
  1128     |widgets list total menu item|
  1129 
  1130     item := aMenu selection nameKey == #single ifTrue:[model selectedItem]
  1131                                               ifFalse:[model rootItem].
  1132     item isNil ifTrue:[^ nil].
  1133 
  1134     widgets := IdentityDictionary new.
  1135     total   := 0.
  1136 
  1137     item recursiveDo:[:el| |cls ctr|
  1138         cls := el widget.
  1139 
  1140         cls notNil ifTrue:[
  1141             cls := cls class.
  1142             ctr := widgets at:cls ifAbsent:0.
  1143             widgets at:cls put:(ctr + 1).
  1144             total := total + 1.
  1145         ].
  1146     ].
  1147     total == 0 ifTrue:[^ nil].
  1148     list := SortedCollection sortBlock:[:a :b| a title < b title ].
  1149 
  1150     widgets keysAndValuesDo:[:cls :ctr|
  1151         list add:(MenuDesc title:(cls name)
  1152                            value:(ctr printString)
  1153                           action:[self doSelectNextOfClass:cls startingIn:item]
  1154                  ).
  1155     ].
  1156     list := list asOrderedCollection.
  1157     list add:(MenuDesc separator).
  1158     list add:(MenuDesc title:'Total' value:(total printString)).
  1159     menu := MenuDesc buildFromList:list onGC:aMenu.
  1160     menu do:[:el|
  1161         el hideMenuOnActivated:false
  1162     ].
  1163     ^ menu
  1164 !
  1165 
  1166 submenuGeometry:aMenu
  1167     "builds and returns the geometry submenu"
  1168 
  1169     |view point inst list x y|
  1170 
  1171     view := self selectedView.
  1172     view isNil ifTrue:[^ nil].
  1173 
  1174     list := OrderedCollection new.
  1175 
  1176     "/ origin
  1177     point := view relativeOrigin.
  1178     point isNil ifTrue:[ point := view origin ].
  1179 
  1180     x := view left.
  1181     y := view top.
  1182 
  1183     (x == point x and:[y == point y]) ifTrue:[ inst := point ]
  1184                                      ifFalse:[ inst := '%1 --> (%2@%3)' bindWith:point with:x with:y ].
  1185 
  1186     list add:(MenuDesc title:'origin' value:inst).
  1187 
  1188     "/ corner
  1189     point := view relativeCorner.
  1190     point isNil ifTrue:[ point := view corner ].
  1191 
  1192     x := view right.
  1193     y := view bottom.
  1194 
  1195     (x == point x and:[y == point y]) ifTrue:[ inst := point ]
  1196                                      ifFalse:[ inst := '%1 --> (%2@%3)' bindWith:point with:x with:y ].
  1197 
  1198     list add:(MenuDesc title:'corner' value:inst).
  1199 
  1200     "/ extent
  1201     (point := view relativeExtent) isNil ifTrue:[point := view extent].
  1202     list add:(MenuDesc title:'extent' value:point).
  1203 
  1204     "/ preferred extent
  1205     list add:(MenuDesc title:'pref. extent' value:(view preferredExtent)).
  1206     list add:(MenuDesc separator).
  1207 
  1208     "/ view insets
  1209     inst := 'l:%1  r:%2  t:%3  b:%4' bindWith:(view leftInset)
  1210                                          with:(view rightInset)
  1211                                          with:(view topInset)
  1212                                          with:(view bottomInset).
  1213 
  1214     list add:(MenuDesc title:'insets'      value:inst).
  1215     list add:(MenuDesc title:'borderWidth' value:(view borderWidth)).
  1216     list add:(MenuDesc title:'level'       value:(view level)).
  1217     list add:(MenuDesc separator).
  1218 
  1219     (inst := view layout) notNil ifTrue:[ inst := inst displayString ].
  1220     list add:(MenuDesc title:'layout' value:inst).
  1221 
  1222     (inst := view transformation) notNil ifTrue:[ inst := inst displayString ].
  1223     list add:(MenuDesc title:'transformation' value:inst).
  1224 
  1225   ^ MenuDesc buildFromList:list onGC:aMenu
  1226 !
  1227 
  1228 submenuInspector:aMenu
  1229     "builds and returns the inspector submenu"
  1230 
  1231     |view list n names label value|
  1232 
  1233     view := self selectedView.
  1234     view isNil ifTrue:[^ nil].
  1235 
  1236     n := view class instSize.
  1237     n > 0 ifFalse:[^ nil ].
  1238 
  1239     list  := OrderedCollection new:n.
  1240     names := view class allInstVarNames.
  1241 
  1242     1 to:n do:[:i| |action|
  1243         label := (names at:i) printString.
  1244         value := view instVarAt:i.
  1245         value isNil ifTrue:[
  1246             value  := '------'.
  1247             action := nil.
  1248         ] ifFalse:[
  1249             value  := value displayString contractAtEndTo:40.
  1250             action := [(view instVarAt:i) inspect].
  1251         ].
  1252         list add:(MenuDesc title:label value:value action:action).
  1253     ].
  1254 
  1255     ^ MenuDesc buildFromList:list onGC:aMenu
  1256 !
  1257 
  1258 submenuInterface:aMenu
  1259     "builds and returns the interface submenu"
  1260 
  1261     |view label inst value list|
  1262 
  1263     view := self selectedView.
  1264     view isNil ifTrue:[^ nil].
  1265 
  1266     list := OrderedCollection new.
  1267 
  1268     inst  := view controller.
  1269     value := nil.
  1270 
  1271     inst isNil ifTrue:[
  1272         label := nil
  1273     ] ifFalse:[
  1274         inst == view ifTrue:[ label := '== view itself' ]
  1275                     ifFalse:[ label := inst displayString.
  1276                               value := [view controller inspect].
  1277                             ].
  1278     ].
  1279     list add:(MenuDesc title:'controller' value:label action:value).
  1280 
  1281     inst := view delegate.
  1282     inst notNil ifTrue:[
  1283         list add:(MenuDesc title:'delegate' value:(inst displayString) action:[ view delegate inspect ]).
  1284     ].
  1285 
  1286     inst := view application.
  1287 
  1288     inst notNil ifTrue:[ |topAppl|
  1289         list add:(MenuDesc title:'application' value:inst action:[ view application inspect ]).
  1290 
  1291         topAppl := inst topApplication.
  1292 
  1293         (topAppl notNil and:[topAppl ~~ inst]) ifTrue:[
  1294             list add:(MenuDesc title:'topApplication' value:topAppl action:[ inst topApplication inspect ]).
  1295         ].
  1296     ].
  1297     list add:(MenuDesc separator).
  1298 
  1299     (view respondsTo:#'model:') ifTrue:[
  1300         inst := model.
  1301 
  1302         inst isNil ifTrue:[ label := value := nil ]
  1303                   ifFalse:[ label := inst displayString.
  1304                             value := [ view model inspect ].
  1305                           ].
  1306 
  1307         list add:(MenuDesc title:'model' value:label action:value).
  1308 
  1309         (inst notNil and:[view respondsTo:#modelInterface]) ifTrue:[
  1310             view modelInterface keysAndValuesDo:[:key : val|
  1311                 val isNil ifTrue:[ label := nil ]
  1312                          ifFalse:[ label := val displayString ].
  1313 
  1314                 list add:(MenuDesc title:('      - ', key) value:label ).
  1315             ]
  1316         ].
  1317     ].
  1318 
  1319     (view respondsTo:#enableChannel) ifTrue:[
  1320         inst := view enableChannel.
  1321 
  1322         inst isNil ifTrue:[ label := value := nil ]
  1323                   ifFalse:[ label := inst displayString.
  1324                             value := [ view enableChannel inspect ].
  1325                           ].
  1326 
  1327         list add:(MenuDesc title:'enableChannel' value:label action:value).
  1328     ].
  1329 
  1330     list last isSeparator ifFalse:[ list add:(MenuDesc separator) ].
  1331 
  1332     (view respondsTo:#listHolder) ifTrue:[
  1333         inst := view listHolder.
  1334 
  1335         inst isNil ifTrue:[ label := value := nil ]
  1336                   ifFalse:[ label := inst class printString.
  1337                             value := [ view listHolder inspect ].
  1338                           ].
  1339         list add:(MenuDesc title:'listHolder' value:label action:value).
  1340     ].
  1341 
  1342     (view respondsTo:#list) ifTrue:[
  1343         inst := view list.
  1344 
  1345         inst isNil ifTrue:[ label := value := nil ]
  1346                   ifFalse:[ label := '%1 [%2]' bindWith:(inst class printString) with:(inst size).
  1347                             value := [ view list inspect ].
  1348                           ].
  1349 
  1350         list add:(MenuDesc title:'list' value:label action:value).
  1351     ].
  1352 
  1353     list last isSeparator ifTrue:[ list removeLast ].
  1354   ^ MenuDesc buildFromList:list onGC:aMenu
  1355 !
  1356 
  1357 submenuVisibility:aMenu
  1358     "builds and returns the geometry submenu"
  1359 
  1360     |view list value|
  1361 
  1362     view := self selectedView.
  1363     view isNil ifTrue:[^ nil].
  1364 
  1365     list := OrderedCollection new.
  1366 
  1367     list add:(MenuDesc title:'device'     value:(view device printString)).
  1368     list add:(MenuDesc title:'drawableId' value:(view id)).
  1369     list add:(MenuDesc title:'gcId'       value:(view gcId)).
  1370 
  1371     list add:(MenuDesc separator).
  1372 
  1373     list add:(MenuDesc title:'shown'    value:(view shown)).
  1374     list add:(MenuDesc title:'realized' value:(view realized)).
  1375 
  1376     list add:(MenuDesc separator).
  1377 
  1378     list add:(MenuDesc title:'hiddenOnRealize' value:(view isHiddenOnRealize)).
  1379 
  1380     (value := view visibilityChannel) isNil ifTrue:[
  1381         list add:(MenuDesc title:'visibilityChannel' value:'------').
  1382     ] ifFalse:[
  1383         list add:(MenuDesc title:'visibilityChannel'
  1384                            value:(value displayString)
  1385                           action:[view visibilityChannel inspect]).
  1386     ].
  1387 
  1388         
  1389   ^ MenuDesc buildFromList:list onGC:aMenu
  1390 ! !
  1391 
  1392 !ViewTreeInspectorApplication methodsFor:'private'!
  1393 
  1394 selectFocusView
  1395     |rootView focusItem focusView|
  1396 
  1397     rootView := model rootView.
  1398 
  1399     (rootView notNil and:[rootView shown]) ifTrue:[
  1400         focusView := rootView windowGroup focusView.
  1401     ].
  1402     focusView isNil ifTrue:[^ self ].
  1403 
  1404     focusItem := model selectedItem.
  1405 
  1406     (focusItem notNil and:[focusItem widget == focusView]) ifTrue:[
  1407         ^ self
  1408     ].
  1409     focusItem := model listOfItems recursiveDetect:[:el| el widget == focusView ].
  1410 
  1411     focusItem notNil ifTrue:[
  1412         model selectItem:focusItem.
  1413     ].        
  1414 !
  1415 
  1416 setRootItem:aRootItemOrNil
  1417     |theProcess|
  1418 
  1419     aRootItemOrNil isNil ifTrue:[
  1420         process := nil.
  1421     ] ifFalse:[
  1422         "/ expand tree to level 3
  1423         aRootItemOrNil do:[:aRootChild|
  1424             aRootChild do:[:aSubChild| aSubChild expand ].
  1425             aRootChild expand.
  1426         ].
  1427         aRootItemOrNil expand.
  1428 
  1429         process isNil ifTrue:[
  1430             theProcess := process :=
  1431                 Process for:[   |update testModeChannel|
  1432 
  1433                                 update := false.
  1434                                 testModeChannel := model testModeChannel.
  1435 
  1436                                 [process == theProcess] whileTrue:[
  1437                                     Delay waitForSeconds:0.5.
  1438 
  1439                                     (treeView notNil and:[process == theProcess and:[treeView shown]]) ifTrue:[
  1440                                         (testModeChannel value == true and:[followFocusChannel value == true]) ifTrue:[
  1441                                             self selectFocusView.
  1442                                         ].
  1443                                         update ifTrue:[
  1444                                             self updateShownStatus.
  1445                                         ].
  1446                                         update := update not.
  1447                                     ].
  1448                                 ].
  1449 
  1450                              ] priority:8.
  1451             theProcess name:'ViewTreeInspector - Follow Focus'.
  1452             theProcess resume.
  1453         ].
  1454     ].
  1455     model rootItem:aRootItemOrNil.
  1456 !
  1457 
  1458 updateShownStatus
  1459     |rootItem min max visState listIdx visY0 visY1 height damage|
  1460 
  1461     rootItem := model rootItem.
  1462     (rootItem notNil and:[rootItem widget shown]) ifFalse:[^ self].
  1463 
  1464     max := 0.
  1465     min := 9999999.
  1466 
  1467     rootItem recursiveEachVisibleItemDo:[:anItem|
  1468         visState := (anItem widget shown).
  1469 
  1470         visState ~~ anItem isDrawnShown ifTrue:[
  1471             anItem isDrawnShown:visState.
  1472             listIdx := treeView identityIndexOf:anItem.
  1473 
  1474             listIdx > 0 ifTrue:[    
  1475                 max := max max:listIdx.
  1476                 min := min min:listIdx.
  1477             ].
  1478         ].
  1479     ].
  1480     max < min ifTrue:[^ self].
  1481     max := max + 1.
  1482 
  1483     visY0  := (treeView yVisibleOfLine:min) max:0.
  1484     visY1  := (treeView yVisibleOfLine:max) min:(treeView height).
  1485     height := visY1 - visY0.
  1486     
  1487     height > 2 ifTrue:[
  1488         treeView shown ifTrue:[
  1489             damage := Rectangle left:0 top:visY0 width:(treeView width) height:height.
  1490             treeView invalidateDeviceRectangle:damage repairNow:false.
  1491         ].
  1492     ].
  1493 ! !
  1494 
  1495 !ViewTreeInspectorApplication methodsFor:'selection'!
  1496 
  1497 selectedView
  1498     "answer the selected view or nil"
  1499 
  1500     |item|
  1501 
  1502     item := model selectedItem.
  1503     item notNil ifTrue:[ ^ item widget ].
  1504   ^ nil
  1505 ! !
  1506 
  1507 !ViewTreeInspectorApplication methodsFor:'testing'!
  1508 
  1509 resolveApplicationClassFor:aTreeItem
  1510     aTreeItem isApplicationClass ifTrue:[
  1511        ^ aTreeItem applicationClass
  1512     ].
  1513     ^ nil
  1514 !
  1515 
  1516 selectedComponentHasChildren
  1517     |item|
  1518 
  1519     item := model selectedItem.
  1520     ^ (item notNil and:[item hasChildren])
  1521 ! !
  1522 
  1523 !ViewTreeInspectorApplication methodsFor:'user operations'!
  1524 
  1525 doBrowse:what
  1526     "open browser on:
  1527         #view           browse class
  1528         #model          browse model class
  1529         #application    browse application class
  1530         #controller     browse controller class
  1531     "
  1532     |view inst|
  1533 
  1534     view := self selectedView.
  1535     view isNil ifTrue:[^ self].
  1536 
  1537              what == #view        ifTrue:[ inst := view ]
  1538     ifFalse:[what == #model       ifTrue:[ inst := view model ]
  1539     ifFalse:[what == #application ifTrue:[ inst := view application ]
  1540     ifFalse:[what == #controller  ifTrue:[ inst := view controller ]
  1541     ifFalse:[
  1542         ^ self
  1543     ]]]].
  1544 
  1545     inst notNil ifTrue:[
  1546         inst class browserClass openInClass:(inst class) selector:nil
  1547     ].
  1548 !
  1549 
  1550 doDestroy
  1551     "destroy the current selected view"
  1552 
  1553     |item parent|
  1554 
  1555     item := model selectedItem.
  1556     item isNil ifTrue:[ ^ self].
  1557 
  1558     parent := item parent.
  1559 
  1560     parent isNil ifTrue:[
  1561         "/ the root
  1562         model withSelectionHiddenDo:[item deleteAll].
  1563       ^ self
  1564     ].
  1565 
  1566     model withSelectionHiddenDo:[
  1567         |idx nsel|
  1568 
  1569         idx := parent identityIndexOf:item.
  1570 
  1571         idx == parent size ifTrue:[
  1572             nsel := parent at:(idx - 1) ifAbsent:parent
  1573         ] ifFalse:[
  1574             nsel := parent at:(idx + 1)
  1575         ].
  1576         model setValue:nil.
  1577         item delete.
  1578 
  1579         parent isLayoutContainer ifTrue:[
  1580             parent widget sizeChanged:nil
  1581         ].
  1582         model value:nsel.
  1583     ].
  1584 !
  1585 
  1586 doFlash
  1587     "flash the selected view"
  1588 
  1589     |view|
  1590 
  1591     view := self selectedView.
  1592     view isNil ifTrue:[ ^ self].
  1593 
  1594     view shown ifTrue:[
  1595         model withSelectionHiddenDo:[
  1596             view perform:#flash ifNotUnderstood:nil.
  1597         ].
  1598     ].
  1599 !
  1600 
  1601 doInspect:what
  1602     "open inspector on:
  1603         #view           inspect class
  1604         #group          inspect windowGroup
  1605         #model          inspect model
  1606         #application    inspect application
  1607         #controller     inspect controller
  1608     "
  1609     |inst|
  1610 
  1611     inst := self selectedView.
  1612     inst isNil ifTrue:[^ self].
  1613 
  1614              what == #group       ifTrue:[ inst := inst windowGroup ]
  1615     ifFalse:[what == #model       ifTrue:[ inst := inst model ]
  1616     ifFalse:[what == #application ifTrue:[ inst := inst application ]
  1617     ifFalse:[what == #controller  ifTrue:[ inst := inst controller  ]]]].
  1618 
  1619     inst notNil ifTrue:[ inst inspect ].
  1620 !
  1621 
  1622 doPickViews
  1623     "pick a window's topView"
  1624 
  1625     |window|
  1626 
  1627     self doUnpick.
  1628 
  1629     window := Screen current viewFromUser.
  1630     window isNil ifTrue:[^ self].
  1631 
  1632     window := window topView.
  1633 
  1634     (    window == Screen current rootView
  1635      or:[window == self window topView]
  1636     ) ifTrue:[
  1637         ^ self
  1638     ].
  1639     self setRootItem:(ViewTreeItem buildViewsFrom:window).
  1640 !
  1641 
  1642 doSelectNextOfApplicationClass:aClass startingIn:anItem
  1643     |startItem firstFound searchNext|
  1644 
  1645     startItem  := model last.
  1646     searchNext := startItem notNil.        
  1647     firstFound := nil.
  1648 
  1649     anItem recursiveDo:[:el|
  1650         el == startItem ifTrue:[
  1651             searchNext := false
  1652         ] ifFalse:[
  1653             (self resolveApplicationClassFor:el) == aClass ifTrue:[
  1654                 searchNext ifFalse:[^ model selectItem:el].
  1655 
  1656                 firstFound isNil ifTrue:[
  1657                     firstFound := el
  1658                 ]
  1659             ]
  1660         ]
  1661     ].
  1662     firstFound notNil ifTrue:[
  1663         self window beep.
  1664         model selectItem:firstFound
  1665     ].
  1666 !
  1667 
  1668 doSelectNextOfClass:aClass startingIn:anItem
  1669     |startItem firstFound searchNext|
  1670 
  1671     startItem  := model last.
  1672     searchNext := startItem notNil.        
  1673     firstFound := nil.
  1674 
  1675     anItem recursiveDo:[:el|
  1676         el == startItem ifTrue:[
  1677             searchNext := false
  1678         ] ifFalse:[
  1679             el widget class == aClass ifTrue:[
  1680                 searchNext ifFalse:[^ model selectItem:el].
  1681 
  1682                 firstFound isNil ifTrue:[
  1683                     firstFound := el
  1684                 ]
  1685             ]
  1686         ]
  1687     ].
  1688     firstFound notNil ifTrue:[
  1689         self window beep.
  1690         model selectItem:firstFound
  1691     ].
  1692 !
  1693 
  1694 doUnpick
  1695     "release current picked window and contained subwindows"
  1696 
  1697     self setRootItem:nil.
  1698 !
  1699 
  1700 openDocumentation
  1701     HTMLDocumentView openFullOnDocumentationFile:'tools/misc/TOP.html#VIEWTREEINSPECTOR'
  1702 ! !
  1703 
  1704 !ViewTreeInspectorApplication::MenuDesc class methodsFor:'building'!
  1705 
  1706 buildFromList:aList onGC:aMenu
  1707     |tabSpec menu w menuPanel|
  1708 
  1709     w := 0.
  1710     aList do:[:el| w := w max:(el widthOn:aMenu) ].
  1711 
  1712     tabSpec := TabulatorSpecification new.
  1713     tabSpec unit:#pixel.
  1714     tabSpec positions:#(0     1.5 ).
  1715     tabSpec align:#(#left #left).
  1716 
  1717     w := w + 15.
  1718     tabSpec positions:(Array with:0 with:w).
  1719 
  1720     menu := Menu new.
  1721 
  1722     aList do:[:el|
  1723         menu addItem:(el asMenuItemWithTabulatorSpecification:tabSpec).
  1724     ].
  1725     menuPanel := MenuPanel menu:menu.
  1726     ^ menuPanel
  1727 ! !
  1728 
  1729 !ViewTreeInspectorApplication::MenuDesc class methodsFor:'instance creation'!
  1730 
  1731 separator
  1732     ^ self new
  1733 !
  1734 
  1735 title:aTitle value:aValue
  1736     ^ self title:aTitle value:aValue action:nil
  1737 !
  1738 
  1739 title:aTitle value:aValue action:anAction
  1740     ^ self new title:aTitle value:aValue action:anAction
  1741 ! !
  1742 
  1743 !ViewTreeInspectorApplication::MenuDesc methodsFor:'accessing'!
  1744 
  1745 title
  1746     ^ title
  1747 ! !
  1748 
  1749 !ViewTreeInspectorApplication::MenuDesc methodsFor:'building'!
  1750 
  1751 asMenuItemWithTabulatorSpecification:aTabSpec
  1752     |array|
  1753 
  1754     title isNil ifTrue:[ ^ MenuItem label:value ].     "/ separator
  1755 
  1756     array := Array with:(title, ':') with:'------'.
  1757 
  1758     value notNil ifTrue:[
  1759         array at:2 put:(value printString, ' ')
  1760     ].
  1761 
  1762   ^ MenuItem label:(MultiColListEntry fromStrings:array tabulatorSpecification:aTabSpec)
  1763              value:action
  1764 ! !
  1765 
  1766 !ViewTreeInspectorApplication::MenuDesc methodsFor:'instance creation'!
  1767 
  1768 title:aTitle value:aValue action:anAction
  1769     "test for separator
  1770     "
  1771     title  := aTitle withoutSeparators.
  1772     action := anAction.
  1773 
  1774     aValue notNil ifTrue:[
  1775         value := aValue printString.
  1776 
  1777         value size > 70 ifTrue:[
  1778             value := value copyFrom:1 to:70.
  1779             value := value, '...'
  1780         ]
  1781     ].
  1782 ! !
  1783 
  1784 !ViewTreeInspectorApplication::MenuDesc methodsFor:'queries'!
  1785 
  1786 isSeparator
  1787     ^ title isNil
  1788 !
  1789 
  1790 widthOn:aGC
  1791     title isNil ifTrue:[^ 5].  "/ separator
  1792   ^ title widthOn:aGC
  1793 ! !
  1794 
  1795 !ViewTreeInspectorApplication::ViewTreeItem class methodsFor:'building'!
  1796 
  1797 buildViewsFrom:aView
  1798     "build the items starting from a source view;
  1799      returns the anhor.
  1800     "
  1801     |item subViews subItems|
  1802 
  1803     aView isNil ifTrue:[^ nil].
  1804 
  1805     item     := self forView:aView.
  1806     subViews := aView subViews.
  1807 
  1808     subViews notEmptyOrNil ifTrue:[
  1809         subItems := OrderedCollection new.
  1810         subViews do:[:aSubView|
  1811             subItems add:(self buildViewsFrom:aSubView).
  1812         ].
  1813         item children:subItems.
  1814     ].
  1815     ^ item
  1816 ! !
  1817 
  1818 !ViewTreeInspectorApplication::ViewTreeItem class methodsFor:'documentation'!
  1819 
  1820 documentation
  1821 "
  1822     ViewTreeItems represants a pickable object within a ViewTreeModel.
  1823     The class is used to build up the hierarchical tree.
  1824 
  1825     [Instance variables:]
  1826         widget        <View>            the widget represented by the item
  1827         spec          <UISpecification> the UISpecification or nil
  1828 
  1829     [Class variables:]
  1830         HandleExtent  <Point>           keeps the extent of a handle
  1831 
  1832 
  1833     [author:]
  1834         Claus Atzkern
  1835 
  1836     [see also:]
  1837         HierarchicalItem
  1838         ViewTreeModel
  1839 "
  1840 !
  1841 
  1842 version
  1843     ^ '$Header$'
  1844 ! !
  1845 
  1846 !ViewTreeInspectorApplication::ViewTreeItem class methodsFor:'initialization'!
  1847 
  1848 initialize
  1849     "set the extent of the Handle
  1850     "
  1851     HandleExtent := 6@6.
  1852 ! !
  1853 
  1854 !ViewTreeInspectorApplication::ViewTreeItem class methodsFor:'instance creation'!
  1855 
  1856 forView:aView
  1857     |item|
  1858 
  1859     item := self basicNew initialize.
  1860     item forView:aView.
  1861   ^ item
  1862 !
  1863 
  1864 new
  1865     self error:'not allowed'.
  1866   ^ nil
  1867 !
  1868 
  1869 on:aView withSpec:aSpec
  1870     |item|
  1871 
  1872     item := self basicNew initialize.
  1873     item on:aView withSpec:aSpec.
  1874   ^ item
  1875 ! !
  1876 
  1877 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'accessing'!
  1878 
  1879 applicationClass
  1880     |appl|
  1881 
  1882     widget notNil ifTrue:[
  1883         appl := widget application.
  1884         appl notNil ifTrue:[^ appl class ].
  1885     ].
  1886     ^ nil
  1887 !
  1888 
  1889 isDrawnShown
  1890     "returns true if the last display operations was done during the widget was shown
  1891     "
  1892     ^ isDrawnShown
  1893 !
  1894 
  1895 isDrawnShown:aBoolean
  1896     isDrawnShown := aBoolean.
  1897 !
  1898 
  1899 rootView
  1900     "returns the widget assigned to the root or nil
  1901     "
  1902     ^ parent rootView
  1903 !
  1904 
  1905 specClass
  1906     "returns the spec-class assigned to the item
  1907     "
  1908     ^ widget specClass
  1909 !
  1910 
  1911 treeModel
  1912     "returns the assigned treeModel, an instance of ViewTreeModel
  1913     "
  1914     ^ parent treeModel
  1915 !
  1916 
  1917 widget
  1918     "returns the widget assigned to the item
  1919     "
  1920     ^ widget
  1921 ! !
  1922 
  1923 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'accessing layout'!
  1924 
  1925 boundsRelativeToRoot
  1926     "returns the bounds relative to the root widget
  1927     "
  1928     ^ self originRelativeToRoot extent:(widget extent)
  1929 !
  1930 
  1931 cornerRelativeToRoot
  1932     "returns the corner relative to the root widget
  1933     "
  1934     ^ self originRelativeToRoot + (widget extent)
  1935 !
  1936 
  1937 extent
  1938     "returns the extent of the widget
  1939     "
  1940     ^ widget extent
  1941 !
  1942 
  1943 layoutType
  1944     "returns the type of layout assigned to the wiget; nil if the
  1945      superView cannot resize its sub widgets
  1946     "
  1947     |layout specClass superView|
  1948 
  1949     (superView := widget superView) isNil ifTrue:[
  1950         ^ #Extent
  1951     ].
  1952         
  1953     specClass := superView specClass.
  1954 
  1955     (specClass notNil and:[specClass isLayoutContainer]) ifTrue:[
  1956         ^ specClass canResizeSubComponents ifTrue:[#Extent] ifFalse:[nil]
  1957     ].
  1958 
  1959     (layout := widget geometryLayout) isNil ifTrue:[
  1960         ^ #Extent
  1961     ].
  1962 
  1963     layout isLayout ifTrue:[
  1964         layout isLayoutFrame        ifTrue:[ ^ #LayoutFrame ].
  1965         layout isAlignmentOrigin    ifTrue:[ ^ #AlignmentOrigin ].
  1966         layout isLayoutOrigin       ifTrue:[ ^ #LayoutOrigin ].
  1967     ] ifFalse:[
  1968         layout isRectangle          ifTrue:[ ^ #Rectangle ].
  1969         layout isPoint              ifTrue:[ ^ #Point ].
  1970 
  1971     ].
  1972     Transcript showCR:'UNSUPPORTRD LAYOUT: ', layout printString.
  1973   ^ nil
  1974 !
  1975 
  1976 originRelativeToRoot
  1977     "returns the origin relative to the root widget
  1978     "
  1979     ^ widget originRelativeTo:(self rootView)
  1980 ! !
  1981 
  1982 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'accessing optimize'!
  1983 
  1984 children
  1985     "redefined: optimize
  1986     "
  1987     ^ children
  1988 !
  1989 
  1990 hasChildren
  1991     |subViews list item|
  1992 
  1993     children size ~~ 0 ifTrue:[
  1994         ^ true
  1995     ].
  1996     isExpanded := false.
  1997     subViews   := widget subViews.
  1998 
  1999     subViews size == 0 ifTrue:[^ false].
  2000 
  2001     list := OrderedCollection new.
  2002 
  2003     subViews do:[:aSubView|
  2004         item := self class buildViewsFrom:aSubView.
  2005         item parent:self.
  2006         list add:item.
  2007     ].
  2008     children := list.
  2009     ^ true
  2010 !
  2011 
  2012 size
  2013     "redefined: returns list of children
  2014     "
  2015     ^ children size
  2016 ! !
  2017 
  2018 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'displaying'!
  2019 
  2020 additionalLabelForItem:anItem
  2021     "answer an additional item for an Item or nil"
  2022 
  2023     parent notNil ifTrue:[
  2024         ^ parent additionalLabelForItem:anItem
  2025     ].
  2026     ^ nil
  2027 !
  2028 
  2029 displayIcon:anIcon atX:x y:y on:aGC
  2030     |x0 y0 y1 w|
  2031 
  2032     super displayIcon:anIcon atX:x y:y on:aGC.
  2033 
  2034     self exists ifFalse:[
  2035         aGC paint:(Color red).
  2036 
  2037         y0 := y + 1.
  2038         y1 := y + anIcon height - 2.
  2039 
  2040         x0 := x - 1.
  2041         w  := anIcon width.
  2042 
  2043         2 timesRepeat:[
  2044             aGC displayLineFromX:x0 y:y0 toX:(x0 + w) y:y1.
  2045             aGC displayLineFromX:x0 y:y1 toX:(x0 + w) y:y0.
  2046             x0 := x0 + 1.
  2047         ].
  2048     ].
  2049 !
  2050 
  2051 displayOn:aGC x:x y:y h:h
  2052     |labelHeight additionalName label isValidAndShown|
  2053 
  2054     label := self label.
  2055     label isEmptyOrNil ifTrue:[^ self].
  2056 
  2057     widget id isNil ifTrue:[
  2058         isDrawnShown := false.
  2059 
  2060         self exists ifFalse:[
  2061             xOffsetAdditionalName := nil.
  2062         ].
  2063         isValidAndShown := false.
  2064     ] ifFalse:[
  2065         isValidAndShown := widget shown.
  2066     ].
  2067     isValidAndShown ifFalse:[
  2068         label := Text string:label emphasis:#italic
  2069     ].
  2070 
  2071     labelHeight := self heightOn:aGC.
  2072     self displayLabel:label h:labelHeight on:aGC x:x y:y h:h.
  2073 
  2074     xOffsetAdditionalName notNil ifTrue:[
  2075         additionalName := self additionalLabelForItem:self.
  2076 
  2077         additionalName notNil ifTrue:[
  2078             self displayLabel:additionalName
  2079                             h:labelHeight on:aGC
  2080                             x:(x + xOffsetAdditionalName)
  2081                             y:y
  2082                             h:h.
  2083         ] ifFalse:[
  2084             xOffsetAdditionalName := nil.
  2085         ].
  2086     ].
  2087 !
  2088 
  2089 recursiveAdditionalNameBehaviourChanged
  2090     width := xOffsetAdditionalName := nil.
  2091 
  2092     children notNil ifTrue:[
  2093         children do:[:each| each recursiveAdditionalNameBehaviourChanged ]
  2094     ].
  2095 !
  2096 
  2097 widthOn:aGC
  2098     "return the width of the receiver, if it is to be displayed on aGC
  2099     "
  2100     |additionalName|
  2101 
  2102     width isNil ifTrue:[
  2103         width := self widthOf:(self label) on:aGC.
  2104         width := width + 2.
  2105 
  2106         additionalName := self additionalLabelForItem:self.
  2107 
  2108         additionalName notNil ifTrue:[
  2109             xOffsetAdditionalName := width + 10.
  2110             width := xOffsetAdditionalName + (self widthOf:additionalName on:aGC).
  2111             width := width + 2.
  2112         ] ifFalse:[
  2113             xOffsetAdditionalName := nil.
  2114         ].
  2115     ].
  2116     ^ width
  2117 ! !
  2118 
  2119 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'enumerating'!
  2120 
  2121 handlesDo:aTwoArgAction
  2122     "evaluate the two arg block on each handle; the arguments to the block is
  2123      the rectangle relative to the rootView and the handle type which is
  2124      set to nil if not resizeable.
  2125 
  2126      TYPES:     type    position( X - Y )
  2127                 -------------------------        
  2128                 #LT     Left   - Top
  2129                 #LC     Left   - Center
  2130                 #LB     Left   - Bottom
  2131                 #CT     Center - Top
  2132                 #CB     Center - Bottom
  2133                 #RT     Right  - Top
  2134                 #RC     Right  - Center
  2135                 #RB     Right  - Bottom
  2136 
  2137                 nil     ** handle not pickable **
  2138     "
  2139     |type relOrg relCrn maxExt rootView w h
  2140      xL    "{ Class:SmallInteger }"
  2141      xC    "{ Class:SmallInteger }"
  2142      xR    "{ Class:SmallInteger }"
  2143      yT    "{ Class:SmallInteger }"
  2144      yC    "{ Class:SmallInteger }"
  2145      yB    "{ Class:SmallInteger }"
  2146     |
  2147     rootView := self rootView.
  2148     relOrg   := widget originRelativeTo:rootView.
  2149     relOrg isNil ifTrue:[ ^ self ].    "/ widget destroyed
  2150 
  2151     relOrg   := relOrg - (HandleExtent // 2).
  2152     relCrn   := relOrg + widget extent.
  2153     maxExt   := rootView extent - HandleExtent.
  2154 
  2155     xL := relOrg x max:0.
  2156     xR := relCrn x min:(maxExt x).
  2157     xC := xR + xL // 2.
  2158 
  2159     yT := relOrg y max:0.
  2160     yB := relCrn y min:(maxExt y).
  2161     yC := yB + yT // 2.
  2162 
  2163     type := self layoutType.
  2164     w   := HandleExtent x.
  2165     h   := HandleExtent y.
  2166 
  2167     (type == #LayoutFrame or:[type == #Rectangle]) ifTrue:[
  2168         aTwoArgAction value:(Rectangle left:xL top:yT width:w height:h) value:#LT.
  2169         aTwoArgAction value:(Rectangle left:xL top:yC width:w height:h) value:#LC.
  2170         aTwoArgAction value:(Rectangle left:xL top:yB width:w height:h) value:#LB.
  2171         aTwoArgAction value:(Rectangle left:xC top:yT width:w height:h) value:#CT.
  2172         aTwoArgAction value:(Rectangle left:xC top:yB width:w height:h) value:#CB.
  2173         aTwoArgAction value:(Rectangle left:xR top:yT width:w height:h) value:#RT.
  2174         aTwoArgAction value:(Rectangle left:xR top:yC width:w height:h) value:#RC.
  2175         aTwoArgAction value:(Rectangle left:xR top:yB width:w height:h) value:#RB.
  2176       ^ self
  2177     ].
  2178 
  2179     aTwoArgAction value:(Rectangle left:xL top:yT width:w height:h) value:nil.
  2180     aTwoArgAction value:(Rectangle left:xL top:yB width:w height:h) value:nil.
  2181     aTwoArgAction value:(Rectangle left:xR top:yT width:w height:h) value:nil.
  2182 
  2183     type == #Extent ifTrue:[
  2184         aTwoArgAction value:(Rectangle left:xC top:yB width:w height:h) value:#CB.
  2185         aTwoArgAction value:(Rectangle left:xR top:yC width:w height:h) value:#RC.
  2186         aTwoArgAction value:(Rectangle left:xR top:yB width:w height:h) value:#RB.
  2187       ^ self
  2188     ].
  2189     aTwoArgAction value:(Rectangle left:xR top:yB width:w height:h) value:nil.
  2190 !
  2191 
  2192 recursiveEachVisibleItemDo:anOneArgBlock
  2193     "recursive evaluate the block on each child which is visible
  2194     "
  2195     (isExpanded and:[children size > 0]) ifTrue:[
  2196         children do:[:aChild|
  2197             anOneArgBlock value:aChild.
  2198             aChild recursiveEachVisibleItemDo:anOneArgBlock.
  2199         ]
  2200     ].
  2201 !
  2202 
  2203 subViewsDo:aOneArgBlock
  2204     "evaluate aBlock for all subviews other than InputView's   
  2205     "
  2206     |subViews|
  2207 
  2208     subViews := widget subViews.
  2209 
  2210     subViews notNil ifTrue:[
  2211         subViews do:aOneArgBlock
  2212     ].
  2213 ! !
  2214 
  2215 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'initialization'!
  2216 
  2217 forView:aView
  2218     widget := aView.
  2219 !
  2220 
  2221 initialize
  2222     "setup default attributes
  2223     "
  2224     super initialize.
  2225     isDrawnShown := false.
  2226     isExpanded   := false.
  2227     children     := OrderedCollection new.
  2228 ! !
  2229 
  2230 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'operations delete'!
  2231 
  2232 delete
  2233     "delete self and all contained items; the assigned views are destroyed
  2234      in case of rootView, only the children are deleted
  2235     "
  2236     parent isHierarchicalItem ifTrue:[
  2237         self criticalDo:[
  2238             parent remove:self.
  2239             widget destroy.
  2240         ]
  2241     ] ifFalse:[
  2242         self deleteAll
  2243     ].
  2244 !
  2245 
  2246 deleteAll
  2247     "delete all contained items; the assigned views are destroyed
  2248     "
  2249     children size == 0 ifTrue:[^ self].
  2250 
  2251     self criticalDo:[
  2252         self nonCriticalDo:[:el| el widget destroy ].
  2253         self removeAll
  2254     ].
  2255 ! !
  2256 
  2257 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'operations layout'!
  2258 
  2259 asLayoutFrame
  2260     "convert the layout of the widget to a LayoutFrame;
  2261     "
  2262     |extent layout newLyt lftFrc lftOff topFrc topOff|
  2263 
  2264     layout := widget geometryLayout.
  2265 
  2266     layout isNil ifTrue:[
  2267         ^ widget bounds asLayout
  2268     ].
  2269 
  2270     layout isLayout ifFalse:[
  2271         layout isRectangle ifTrue:[
  2272             ^ LayoutFrame leftOffset:(layout left) rightOffset:(layout right)
  2273                            topOffset:(layout top) bottomOffset:(layout bottom)
  2274         ].
  2275         layout isPoint ifTrue:[
  2276             extent := widget extent.
  2277           ^ LayoutFrame leftOffset:(layout x)  rightOffset:(layout x + extent x)
  2278                          topOffset:(layout y) bottomOffset:(layout y + extent y)
  2279         ].
  2280 
  2281         Transcript showCR:'UNSUPPORTRD LAYOUT: ', layout printString.
  2282       ^ nil
  2283     ].
  2284 
  2285     layout isLayoutFrame ifTrue:[ ^ layout copy ].    
  2286 
  2287     lftFrc := layout leftFraction.
  2288     lftOff := layout leftOffset.
  2289     topFrc := layout topFraction.
  2290     topOff := layout topOffset.
  2291     extent := widget extent.
  2292 
  2293     newLyt := LayoutFrame leftFraction:lftFrc offset:lftOff
  2294                          rightFraction:lftFrc offset:(lftOff + extent x)
  2295                            topFraction:topFrc offset:topOff
  2296                         bottomFraction:topFrc offset:(topOff + extent y).
  2297 
  2298     (      layout isAlignmentOrigin
  2299      and:[(layout leftAlignmentFraction ~= 0 or:[layout topAlignmentFraction ~= 0])]
  2300     ) ifTrue:[
  2301         |svRc prBd dlta|
  2302 
  2303         svRc := widget superView viewRectangle.
  2304         prBd := widget preferredBounds.
  2305 
  2306         dlta := (  ((layout rectangleRelativeTo:svRc preferred:prBd) corner)
  2307                  - ((newLyt rectangleRelativeTo:svRc preferred:prBd) corner)
  2308                 ) rounded.
  2309 
  2310         newLyt   leftOffset:(lftOff + dlta x).
  2311         newLyt  rightOffset:(lftOff + extent x + dlta x).
  2312         newLyt    topOffset:(topOff + dlta y).
  2313         newLyt bottomOffset:(topOff + extent y + dlta y).
  2314     ].
  2315     ^ newLyt
  2316 !
  2317 
  2318 moveLeft:l top:t
  2319     "move the widget n pixele left and right
  2320     "
  2321     |layout|
  2322 
  2323     self isMoveable ifFalse:[ ^ self ].
  2324 
  2325     (layout := widget geometryLayout) isNil ifTrue:[
  2326         "Extent"
  2327         widget origin:(widget origin + (l@t)).
  2328       ^ self
  2329     ].
  2330 
  2331     layout := layout copy.
  2332 
  2333     layout isLayout ifTrue:[
  2334         layout leftOffset:(layout leftOffset + l)
  2335                 topOffset:(layout topOffset  + t).
  2336 
  2337         layout isLayoutFrame ifTrue:[
  2338             layout  rightOffset:(layout rightOffset  + l).
  2339             layout bottomOffset:(layout bottomOffset + t).
  2340         ]
  2341 
  2342     ] ifFalse:[
  2343         layout isRectangle ifTrue:[
  2344             layout setLeft:(layout left + l).
  2345             layout  setTop:(layout top  + t).
  2346         ] ifFalse:[
  2347             layout isPoint ifFalse:[^ self].
  2348             layout x:(layout x + l) y:(layout y + t).
  2349         ]
  2350     ].
  2351     widget geometryLayout:layout.
  2352 !
  2353 
  2354 resizeLeft:l top:t right:r bottom:b
  2355     "resize the widget measured in pixels
  2356     "
  2357     |layout|
  2358 
  2359     self isResizeable ifFalse:[
  2360         ^ self
  2361     ].
  2362 
  2363     (layout := widget geometryLayout) isNil ifTrue:[
  2364         "Extent"
  2365         (r == l and:[b == t]) ifFalse:[
  2366             widget extent:(widget computeExtent + ((r-l) @ (b-t))).
  2367         ].
  2368         ^ self
  2369     ].
  2370 
  2371     layout isLayout ifTrue:[
  2372         layout := layout copy.
  2373 
  2374         layout leftOffset:(layout leftOffset + l)
  2375                 topOffset:(layout topOffset  + t).
  2376 
  2377         layout isLayoutFrame ifTrue:[
  2378             layout bottomOffset:(layout bottomOffset + b).
  2379             layout  rightOffset:(layout rightOffset  + r).
  2380         ]
  2381     ] ifFalse:[
  2382         layout isRectangle ifFalse:[^ self].
  2383         layout := layout copy.
  2384 
  2385         layout left:(layout left   + l)
  2386               right:(layout right  + r)
  2387                 top:(layout top    + t)
  2388              bottom:(layout bottom + b).
  2389     ].
  2390     widget geometryLayout:layout.
  2391 ! !
  2392 
  2393 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'operations update'!
  2394 
  2395 updateChildren
  2396     |list|
  2397 
  2398     self do:[:el|
  2399         el exists ifTrue:[
  2400             el updateChildren.
  2401         ] ifFalse:[
  2402             list isNil ifTrue:[list := OrderedCollection new].
  2403             list add:el.
  2404         ]
  2405     ].
  2406     list notNil ifTrue:[
  2407         list do:[:el| self remove:el ].
  2408     ].
  2409 !
  2410 
  2411 updateFromChildren:mergedList
  2412     "update my children against the list of items derived from
  2413      the merged list.
  2414     "
  2415 
  2416     mergedList size == 0 ifTrue:[ ^ self removeAll ].
  2417     children   size == 0 ifTrue:[ ^ self addAll:mergedList ].
  2418 
  2419     self criticalDo:[
  2420         self nonCriticalDo:[:el| |wdg|
  2421             wdg := el widget.
  2422             mergedList detect:[:e2| e2 widget == wdg ] ifNone:[ self remove:el ].
  2423         ].
  2424 
  2425         mergedList keysAndValuesDo:[:i :el| |wdg e2|
  2426             wdg := el widget.
  2427 
  2428             e2  := self at:i ifAbsent:nil.
  2429 
  2430             (e2 isNil or:[e2 widget ~~ wdg]) ifTrue:[
  2431                 self add:el beforeIndex:i
  2432             ]
  2433         ]
  2434     ].
  2435 ! !
  2436 
  2437 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'printing & storing'!
  2438 
  2439 icon
  2440     "get the icon used for presentation
  2441     "
  2442     |specClass model|
  2443 
  2444     specClass := self specClass.
  2445     specClass isNil ifTrue:[^ nil].
  2446 
  2447     model := self treeModel.
  2448 
  2449     model notNil ifTrue:[
  2450         ^ model iconAt:specClass ifNonePut:[specClass icon]
  2451     ].
  2452     ^ specClass icon
  2453 !
  2454 
  2455 label
  2456     "get the label used for presentation
  2457     "
  2458     ^ self string
  2459 !
  2460 
  2461 printOn:aStream
  2462     "append a a printed representation of the item to aStream
  2463     "
  2464     aStream nextPutAll:(self string)
  2465 !
  2466 
  2467 string
  2468     "get the string
  2469     "
  2470     ^ widget class name.
  2471 ! !
  2472 
  2473 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'queries'!
  2474 
  2475 canChangeLayout
  2476     "returns true if the layout of the widget can be changed and the
  2477      layout is not organized by its superView
  2478     "
  2479     ^ self isResizeable
  2480 !
  2481 
  2482 canResizeSubComponents
  2483     "returns true if the widget can resize its sub components
  2484     "
  2485     |specClass|
  2486 
  2487     specClass := self specClass.
  2488 
  2489     specClass notNil ifTrue:[
  2490         ^ specClass canResizeSubComponents
  2491     ].
  2492     ^ false
  2493 !
  2494 
  2495 exists
  2496     widget id notNil ifTrue:[^ true ].
  2497 
  2498     exists ~~ false ifTrue:[
  2499         exists := false.
  2500 
  2501         widget superView notNil ifTrue:[
  2502             (parent isHierarchicalItem and:[parent exists]) ifTrue:[
  2503                 exists := (parent widget subViews includesIdentical:widget).
  2504             ].
  2505         ].
  2506     ].
  2507     ^ exists
  2508 !
  2509 
  2510 isApplicationClass
  2511     |cls|
  2512 
  2513     cls := widget class.
  2514 
  2515     ^ (    cls == ApplicationSubView
  2516         or:[cls == ApplicationWindow
  2517         or:[cls == SubCanvas]]
  2518       ) 
  2519 !
  2520 
  2521 isSelected
  2522     |model|
  2523 
  2524     model := self treeModel.
  2525     model notNil ifTrue:[^ model isSelected:self].
  2526     ^ false
  2527 !
  2528 
  2529 supportsSubComponents
  2530     "returns true if the widget supports sub components
  2531     "
  2532     |specClass|
  2533 
  2534     widget isScrollWrapper ifTrue:[
  2535         ^ false
  2536     ].
  2537     specClass := self specClass.
  2538 
  2539     specClass notNil ifTrue:[
  2540         ^ specClass supportsSubComponents
  2541     ].
  2542     ^ false
  2543 ! !
  2544 
  2545 !ViewTreeInspectorApplication::ViewTreeItem methodsFor:'testing'!
  2546 
  2547 isInLayoutContainer
  2548     "returns true if the widget is in a layout container
  2549     "
  2550     |sv specClass|
  2551 
  2552     sv := widget superView.
  2553 
  2554     sv notNil ifTrue:[
  2555         specClass := sv specClass.
  2556 
  2557         specClass notNil ifTrue:[
  2558             ^ specClass isLayoutContainer
  2559         ].
  2560     ].
  2561     ^ false
  2562 !
  2563 
  2564 isLayoutContainer
  2565     "answer whether corresponding view instances of the spec class can contain
  2566      (and arrange) other view
  2567     "
  2568     |specClass|
  2569 
  2570     specClass := self specClass.
  2571 
  2572     specClass notNil ifTrue:[
  2573         ^ specClass isLayoutContainer
  2574     ].
  2575     ^ false
  2576 !
  2577 
  2578 isMoveable
  2579     "returns true if the widget is not in a layout container
  2580     "
  2581     self isInLayoutContainer ifFalse:[
  2582         ^ widget superView notNil
  2583     ].
  2584     ^ false
  2585 !
  2586 
  2587 isResizeable
  2588     "returns true if the widget is resizeable
  2589     "
  2590     |sv specClass|
  2591 
  2592     sv := widget superView.
  2593 
  2594     sv notNil ifTrue:[
  2595         specClass := sv specClass.
  2596 
  2597         specClass notNil ifTrue:[
  2598             ^ specClass canResizeSubComponents
  2599         ].
  2600     ].
  2601     ^ false
  2602 ! !
  2603 
  2604 !ViewTreeInspectorApplication::ViewTreeModel class methodsFor:'documentation'!
  2605 
  2606 documentation
  2607 "
  2608     Instances of ViewTreeModel can be used as model on a View and all
  2609     it contained subviews for a HierarchicalListView.
  2610     The model keeps two values, the hierarchical representation of the views
  2611     and subviews (ViewTreeItems) and the selection, a list of selected ViewTreeItems's.
  2612     It shows the selected items highlighted.
  2613 
  2614 
  2615     [Instance variables:]
  2616         lockSema            <Semaphore>         lock selection notifications and redraws
  2617 
  2618         testModeChannel     <ValueHolder>       true, than running in test mode.
  2619 
  2620         hasTargetWidgetChannel <ValueHolder>    true, than any target view is grapped
  2621 
  2622         selection           <Sequence or nil>   selected items or nil
  2623 
  2624         hiddenLevel         <Integer>           internal use; redrawing the selection
  2625                                                 only is done if the counter is 0.
  2626 
  2627         listOfItems         <HierarchicalList>  hiearchical list build from existing items.
  2628 
  2629         selectedSuperItems  <Sequence>          list of selected super items; items selected
  2630                                                 but not contained in another selected item.
  2631 
  2632         inputEventAction    <Action>            called for each InputEvent
  2633 
  2634         mappedViewAction    <Action>            called for a new mapped view which
  2635                                                 can not be found in the current item list.
  2636 
  2637         beforeSelectionChangedAction <Action>   called before the selection changed
  2638 
  2639     [author:]
  2640         Claus Atzkern
  2641 
  2642     [see also:]
  2643         ViewTreeItem
  2644 "
  2645 !
  2646 
  2647 examples
  2648 "
  2649     example 1: pick any window and show views and contained views
  2650                                                                                 [exBegin]
  2651     |top sel model panel|
  2652 
  2653     model := ViewTreeModel new.
  2654     top   := StandardSystemView new; extent:440@400.
  2655     sel   := ScrollableView for:HierarchicalListView miniScroller:true origin:0.0@0.0 corner:1.0@1.0 in:top.
  2656     sel bottomInset:24.
  2657 
  2658     panel := HorizontalPanelView origin:0.0@1.0 corner:1.0@1.0 in:top.
  2659     panel topInset:-24.
  2660     panel horizontalLayout:#fitSpace.
  2661 
  2662     Button label:'Exit'       action:[model rootItem:nil. top destroy] in:panel.
  2663     Button label:'Pick Views' action:[  |win|
  2664                                         (     (win := Screen current viewFromUser) notNil
  2665                                          and:[(win := win topView) ~~ Screen current rootView
  2666                                          and:[win ~~ top]]
  2667                                         ) ifTrue:[
  2668                                             model rootItem:(ViewTreeItem buildViewsFrom:win)
  2669                                         ] ifFalse:[
  2670                                             model rootItem:nil
  2671                                         ]
  2672                                      ] in:panel.
  2673 
  2674     sel  multipleSelectOk:true.
  2675     sel              list:model listOfItems.
  2676     sel             model:model.
  2677     sel          useIndex:false.
  2678 
  2679     sel doubleClickAction:[:i| |el|
  2680         el := model listOfItems at:i.
  2681         el spec notNil ifTrue:[ el spec   inspect ] ifFalse:[ el widget inspect ]
  2682     ].
  2683     sel indicatorAction:[:i| (model listOfItems at:i) toggleExpand ].
  2684 
  2685     model inputEventAction:[:anEvent| |item|
  2686         anEvent isButtonEvent ifTrue:[
  2687             anEvent isButtonPressEvent ifTrue:[
  2688                 model selectedItem:(model listOfItems detectItemRespondsToView:(anEvent view)).
  2689             ] ifFalse:[
  2690                 anEvent type == #'buttonMultiPress:x:y:' ifTrue:[
  2691                     (item := model selectedItem) notNil ifTrue:[item widget inspect]
  2692                 ]
  2693             ]
  2694         ]
  2695     ].
  2696 
  2697     top openAndWait.
  2698     [[top shown] whileTrue:[Delay waitForSeconds:0.5]. model rootItem:nil] forkAt:8
  2699 
  2700                                                                                 [exEnd]
  2701 "
  2702 ! !
  2703 
  2704 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'accessing'!
  2705 
  2706 application:anApplication
  2707     listOfItems application:anApplication.
  2708 !
  2709 
  2710 rootItem
  2711     "get the rootItem the event viewer is established on
  2712     "
  2713     ^ listOfItems root
  2714 !
  2715 
  2716 rootItem:anItem
  2717     "set the rootItem the event viewer is established on
  2718     "
  2719     |expanded|
  2720 
  2721     timedUpdateTask := nil.
  2722     self deselect.
  2723 
  2724     lockSema critical:[
  2725         anItem notNil ifTrue:[ expanded := anItem isExpanded ]
  2726                      ifFalse:[ expanded := false ].
  2727 
  2728         self value:nil.
  2729         listOfItems root:anItem.
  2730 
  2731         anItem notNil ifTrue:[
  2732             timedUpdateTask := Process for:[ self timedUpdateTaskCycle ] priority:8.
  2733             timedUpdateTask name:'Update'.
  2734             timedUpdateTask resume.
  2735         ].
  2736     ].
  2737 
  2738     (expanded and:[anItem notNil]) ifTrue:[
  2739         anItem expand
  2740     ].
  2741     ^ anItem
  2742 !
  2743 
  2744 rootView
  2745     "get the top widget the event viewer is established on, a View
  2746     "
  2747     ^ listOfItems rootView
  2748 ! !
  2749 
  2750 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'accessing actions'!
  2751 
  2752 beforeSelectionChangedAction
  2753     "none argument action which is called before
  2754      the selection changed
  2755     "
  2756     ^ beforeSelectionChangedAction
  2757 !
  2758 
  2759 beforeSelectionChangedAction:aNoneArgBlock
  2760     "none argument action which is called before
  2761      the selection changed
  2762     "
  2763     beforeSelectionChangedAction := aNoneArgBlock.
  2764 !
  2765 
  2766 inputEventAction
  2767     "called for each input event; the argument to the action is the WindowEvent
  2768     "
  2769     ^ inputEventAction
  2770 !
  2771 
  2772 inputEventAction:aOneArgActionTheEvent
  2773     "called for each input event; the argument to the action is the WindowEvent
  2774     "
  2775     inputEventAction := aOneArgActionTheEvent.
  2776 !
  2777 
  2778 mappedViewAction
  2779     "called for a new mapped view which can not be found
  2780      in the current item list
  2781     "
  2782     ^ mappedViewAction
  2783 !
  2784 
  2785 mappedViewAction:aOneArgBlockTheMappedView
  2786     "called for a new mapped view which can not be found
  2787      in the current item list
  2788     "
  2789     mappedViewAction := aOneArgBlockTheMappedView
  2790 ! !
  2791 
  2792 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'accessing look'!
  2793 
  2794 iconAt:aKey ifNonePut:aNoneArgBlock
  2795     |icon view|
  2796 
  2797     icon := icons at:aKey ifAbsent:nil.
  2798     icon notNil ifTrue:[^ icon].
  2799 
  2800     icon := aNoneArgBlock value.
  2801     icon isNil ifTrue:[^ nil].
  2802 
  2803     view := self rootView.
  2804     view isNil ifTrue:[^ icon].
  2805 
  2806     icon := icon copy onDevice:(view device).
  2807     icon isImage ifTrue:[
  2808         icon clearMaskedPixels.
  2809     ].
  2810     icons at:aKey put:icon.
  2811     ^ icon
  2812 ! !
  2813 
  2814 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'accessing visibility'!
  2815 
  2816 signalHiddenLevel
  2817     "show the selection if signaled; increments hiddenLevel
  2818      see: #waitHiddenLevel
  2819     "
  2820     (hiddenLevel := hiddenLevel - 1) < 1 ifTrue:[
  2821         hiddenLevel := 0.
  2822         self invalidateSelection.
  2823     ].
  2824 !
  2825 
  2826 waitHiddenLevel
  2827     "hide the selection until signaled; increments hiddenLevel
  2828      see: #signalHiddenLevel
  2829     "
  2830     self redrawUnselected:selection andLock:true
  2831 !
  2832 
  2833 withSelectionHiddenDo:aNoneArgumentBlock
  2834     "apply block with selection hidden
  2835     "
  2836 
  2837     [   self waitHiddenLevel.
  2838 
  2839         aNoneArgumentBlock value
  2840 
  2841     ] valueNowOrOnUnwindDo:[
  2842         self signalHiddenLevel.
  2843     ].
  2844 ! !
  2845 
  2846 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'aspects'!
  2847 
  2848 hasTargetWidgetChannel
  2849     "answer the channel which is set to true if a target widget exists"
  2850 
  2851     ^ hasTargetWidgetChannel
  2852 !
  2853 
  2854 listOfItems
  2855     "hiearchical list build from existing items"
  2856 
  2857     ^ listOfItems
  2858 !
  2859 
  2860 selectOnClickHolder
  2861     "boolean holder, which indicates whether the selection will change on click
  2862     "
  2863     ^ selectOnClickHolder
  2864 !
  2865 
  2866 testModeChannel
  2867     "answer a boolean channel which describes the behaviour how to process
  2868      events on the target view.
  2869 
  2870      false: all input events are eaten and the selection is shown on the target view.
  2871      true:  no  input events are eaten and no  selection is shown on the target view."
  2872 
  2873     ^ testModeChannel
  2874 ! !
  2875 
  2876 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'change & update'!
  2877 
  2878 targetWidgetChanged
  2879     hasTargetWidgetChannel value:(self rootItem notNil).
  2880 !
  2881 
  2882 timedUpdateTaskCycle
  2883     |view myTaskId|
  2884 
  2885     myTaskId := timedUpdateTask.
  2886 
  2887     listOfItems root notNil ifTrue:[
  2888         view := listOfItems root widget.
  2889     ].
  2890 
  2891     [ view notNil ] whileTrue:[
  2892         Delay waitForSeconds:0.5.
  2893         
  2894         (myTaskId == timedUpdateTask and:[view id notNil]) ifFalse:[
  2895             view := nil.
  2896         ] ifTrue:[
  2897             (view sensor hasUserEvent:#updateChildren for:self) ifFalse:[
  2898                 view sensor pushUserEvent:#updateChildren for:self.
  2899             ].
  2900         ].
  2901     ].
  2902     timedUpdateTask == myTaskId ifTrue:[
  2903         timedUpdateTask := nil.
  2904         listOfItems root:nil.
  2905     ].
  2906 !
  2907 
  2908 update:something with:someArgument from:aModel
  2909 
  2910     aModel == testModeChannel ifTrue:[
  2911         (hiddenLevel == 0 and:[selection size > 0]) ifTrue:[
  2912             testModeChannel value ifTrue:[
  2913                 self redrawUnselected:selection andLock:false checkTestMode:false.
  2914             ] ifFalse:[
  2915                 self invalidateSelection.
  2916             ].
  2917         ].
  2918         ^ self
  2919     ].
  2920     super update:something with:someArgument from:aModel.
  2921 !
  2922 
  2923 updateChildren
  2924     |rootItem|
  2925 
  2926     rootItem := listOfItems root.
  2927     rootItem isNil ifTrue:[^ self].
  2928 
  2929     rootItem exists ifFalse:[
  2930         listOfItems root:nil.
  2931     ] ifTrue:[
  2932         rootItem updateChildren.
  2933     ].
  2934 ! !
  2935 
  2936 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'event processing'!
  2937 
  2938 processEvent:anEvent
  2939     "catch and process all WindowEvents for the rootComponent and its contained
  2940      widgets; redraw selection in case of damage ....
  2941     "
  2942     |evView item rootView testMode|
  2943 
  2944     evView := anEvent view.
  2945     evView isNil ifTrue:[
  2946         (anEvent isMessageSendEvent and:[anEvent receiver == self]) ifFalse:[
  2947             ^ false
  2948         ].
  2949         anEvent value.
  2950         ^ true.
  2951     ].
  2952     rootView := listOfItems rootView.
  2953     rootView isNil ifTrue:[ ^ false ].
  2954 
  2955     anEvent isConfigureEvent ifTrue:[
  2956         hiddenLevel == 0 ifTrue:[
  2957             self redrawUnselected:selection andLock:false.
  2958         ].
  2959         ^ false
  2960     ].
  2961 
  2962     "/ check whether view is contained within the rootView
  2963     (evView == rootView or:[evView isComponentOf:rootView]) ifFalse:[
  2964         ^ false
  2965     ].
  2966 
  2967     anEvent isInputEvent ifFalse:[
  2968         anEvent isDamage ifTrue:[
  2969             hiddenLevel == 0 ifTrue:[self invalidateSelection].
  2970             ^ false
  2971         ].
  2972 
  2973         anEvent isMapEvent ifTrue:[
  2974             mappedViewAction notNil ifTrue:[
  2975                 item := listOfItems recursiveDetect:[:el| el widget == evView].
  2976                 item isNil ifTrue:[ mappedViewAction value:evView ]
  2977             ].
  2978             ^ false
  2979         ].
  2980 
  2981         anEvent type == #terminate ifTrue:[
  2982             item := listOfItems recursiveDetect:[:el| el widget == evView].
  2983             item notNil ifTrue:[ self processTerminateForItem:item ].
  2984             ^ false
  2985         ].
  2986         ^ false
  2987     ].
  2988     testMode := testModeChannel value.
  2989 
  2990     anEvent isFocusEvent ifTrue:[
  2991         evView == rootView ifTrue:[
  2992             self invalidateSelection
  2993         ].
  2994         ^ testMode not.
  2995     ].
  2996     anEvent isPointerEnterLeaveEvent ifTrue:[ ^ testMode not ].
  2997 
  2998     testMode ifFalse:[
  2999         inputEventAction notNil ifTrue:[ inputEventAction value:anEvent ].
  3000     ] ifTrue:[
  3001         anEvent isButtonPressEvent ifTrue:[
  3002             selectOnClickHolder value ifTrue:[
  3003                 self selectItem:(listOfItems detectItemRespondsToView:evView).
  3004             ].
  3005         ]
  3006     ].
  3007 
  3008     (hiddenLevel ~~ 0 and:[anEvent isButtonReleaseEvent]) ifTrue:[
  3009         hiddenLevel := 1.
  3010         self signalHiddenLevel.
  3011     ].
  3012 
  3013     ^ testMode not
  3014 !
  3015 
  3016 processTerminateForItem:anItem
  3017     "received terminate for an item
  3018     "
  3019     anItem remove.
  3020 ! !
  3021 
  3022 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'initialization'!
  3023 
  3024 initialize
  3025     "setup the default attributes
  3026     "
  3027     super initialize.
  3028 
  3029     hiddenLevel           := 0.
  3030     lockSema              := RecursionLock new.
  3031     listOfItems           := ItemList new on:self.
  3032     selectedSuperItems    := #().
  3033     icons                 := IdentityDictionary new.
  3034 
  3035     hasTargetWidgetChannel := false asValue.
  3036     selectOnClickHolder    := true asValue.
  3037 
  3038     testModeChannel := false asValue.
  3039     testModeChannel addDependent:self.
  3040 ! !
  3041 
  3042 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'private selection'!
  3043 
  3044 invalidateSelection
  3045     "invalidate the current selection
  3046     "
  3047     |topView|
  3048 
  3049     testModeChannel value ifTrue:[ ^ self ]. "/ test whether running testMode
  3050 
  3051     (     hiddenLevel == 0
  3052      and:[selection notNil
  3053      and:[(topView := listOfItems rootView) notNil
  3054      and:[topView shown]]]
  3055     ) ifTrue:[
  3056         topView sensor pushUserEvent:#redrawSelection for:self withArguments:#()
  3057     ]
  3058 !
  3059 
  3060 recursiveRepair:theDamages startIn:aView relativeTo:aRootView
  3061     "repair all views and contained views, which intersects the damage.
  3062      !!!! all damages repaired are removed from the list of damages !!!!
  3063     "
  3064     |color relOrg damage subViews repaired
  3065      bwWidth    "{ Class:SmallInteger }"
  3066      x          "{ Class:SmallInteger }"
  3067      y          "{ Class:SmallInteger }"
  3068      w          "{ Class:SmallInteger }"
  3069      h          "{ Class:SmallInteger }"
  3070      relOrgX    "{ Class:SmallInteger }"
  3071      relOrgY    "{ Class:SmallInteger }"
  3072      width      "{ Class:SmallInteger }"
  3073      height     "{ Class:SmallInteger }"
  3074      size       "{ Class:SmallInteger }"
  3075     |
  3076     (aView shown and:[theDamages notEmpty]) ifFalse:[ ^ self ].
  3077 
  3078     subViews := aView subViews.
  3079 
  3080     subViews size ~~ 0 ifTrue:[
  3081         subViews reverseDo:[:v| self recursiveRepair:theDamages startIn:v relativeTo:aRootView ].
  3082         theDamages isEmpty ifTrue:[ ^ self ].
  3083     ].
  3084 
  3085     relOrg  := aView originRelativeTo:aRootView.
  3086     bwWidth := aView borderWidth.
  3087     size    := theDamages size.
  3088 
  3089     "/ compute relative origin starting from border left@top
  3090     relOrgX := relOrg x - bwWidth.
  3091     relOrgY := relOrg y - bwWidth.
  3092     width   := aView width  + bwWidth + bwWidth.
  3093     height  := aView height + bwWidth + bwWidth.
  3094 
  3095     size to:1 by:-1 do:[:anIndex|
  3096         repaired := damage := theDamages at:anIndex.
  3097 
  3098         "/ compute the rectangle into the view
  3099         y := damage top  - relOrgY.
  3100         x := damage left - relOrgX.
  3101         w := damage width.
  3102         h := damage height.
  3103 
  3104         x     < 0      ifTrue:[ w := w + x. x := 0. repaired := nil ].
  3105         y     < 0      ifTrue:[ h := h + y. y := 0. repaired := nil ].
  3106         x + w > width  ifTrue:[ w := width  - x.    repaired := nil ].
  3107         y + h > height ifTrue:[ h := height - y.    repaired := nil ].
  3108 
  3109         (w > 0 and:[h > 0]) ifTrue:[
  3110             bwWidth ~~ 0 ifTrue:[
  3111                 color isNil ifTrue:[
  3112                     "/ must force redraw of border
  3113                     color := aView borderColor.
  3114                     aView borderColor:(Color colorId:1).
  3115                     aView borderColor:color.
  3116                 ].
  3117                 w := w - bwWidth.
  3118                 h := h - bwWidth.
  3119 
  3120                 (x := x - bwWidth) < 0 ifTrue:[w := w + x. x := 0].
  3121                 (y := y - bwWidth) < 0 ifTrue:[h := h + y. y := 0].
  3122 
  3123                 h > 0 ifFalse:[w := 0].         "/ later testing on width only
  3124             ].
  3125 
  3126             w > 0 ifTrue:[
  3127                 aView clearRectangleX:x y:y width:w height:h.
  3128                 aView exposeX:x y:y width:w height:h
  3129             ].
  3130             repaired notNil ifTrue:[ theDamages removeFromIndex:anIndex toIndex:anIndex ].
  3131         ]
  3132     ].
  3133 !
  3134 
  3135 redrawSelection
  3136     "redraw all items selected
  3137     "
  3138     |topView size|
  3139 
  3140     testModeChannel value ifTrue:[ ^ self ]. "/ test whether running testMode
  3141 
  3142     (     hiddenLevel == 0
  3143      and:[(size := selection size) > 0
  3144      and:[(topView := listOfItems rootView) notNil
  3145      and:[topView shown
  3146      and:[(topView sensor hasEvent:#redrawSelection for:self) not]]]]
  3147     ) ifFalse:[
  3148         ^ self
  3149     ].
  3150 
  3151     lockSema critical:[
  3152         |list|
  3153 
  3154         list := selection.
  3155 
  3156         list size > 0 ifTrue:[
  3157             topView paint:(Color black).
  3158             topView clippedByChildren:false.
  3159 
  3160             list keysAndValuesReverseDo:[:anIndex :anItem|
  3161                 (anIndex == 1 and:[size > 1]) ifTrue:[ topView paint:(Color red) ].
  3162 
  3163                 anItem handlesDo:[:aRect :what|
  3164                     what isNil ifTrue:[topView displayRectangle:aRect]
  3165                               ifFalse:[topView    fillRectangle:aRect]
  3166                 ]
  3167             ].
  3168             topView clippedByChildren:true.
  3169         ].
  3170     ].
  3171 !
  3172 
  3173 redrawUnselected:aList andLock:doLock
  3174     "redraw all items unselected; if doLock is true, the hiddenLevel
  3175      is incremented and thus the select mechanism is locked.
  3176     "
  3177     self redrawUnselected:aList andLock:doLock checkTestMode:true.
  3178 !
  3179 
  3180 redrawUnselected:aList andLock:doLock checkTestMode:checkTestMode
  3181     "redraw all items unselected; if doLock is true, the hiddenLevel
  3182      is incremented and thus the select mechanism is locked.
  3183     "
  3184     |rootView damages subViews x y w h|
  3185 
  3186     doLock ifTrue:[
  3187         hiddenLevel := hiddenLevel + 1.
  3188         hiddenLevel ~~ 1 ifTrue:[^ self].
  3189     ] ifFalse:[
  3190         hiddenLevel ~~ 0 ifTrue:[^ self].
  3191     ].
  3192     checkTestMode ifTrue:[
  3193         testModeChannel value ifTrue:[ ^ self ]. "/ test whether running testMode
  3194     ].
  3195 
  3196     (     aList size ~~ 0
  3197      and:[(rootView := listOfItems rootView) notNil
  3198      and:[rootView shown]]
  3199     ) ifFalse:[
  3200         ^ self
  3201     ].
  3202 
  3203     lockSema critical:[
  3204         damages := OrderedCollection new:(8 * aList size).
  3205 
  3206         aList do:[:item|
  3207             item handlesDo:[:handle :what|
  3208                 damages reverseDo:[:el|
  3209                     (el intersects:handle) ifTrue:[
  3210                         damages removeIdentical:el.
  3211 
  3212                         handle left:(handle left   min:el left)
  3213                               right:(handle right  max:el right)
  3214                                 top:(handle top    min:el top)
  3215                              bottom:(handle bottom max:el bottom)
  3216                     ]
  3217                 ].                        
  3218                 damages add:handle
  3219             ]
  3220         ].
  3221 
  3222         damages do:[:el|
  3223             x := el left.
  3224             y := el top.
  3225             w := el width.
  3226             h := el height.
  3227 
  3228             rootView clearRectangleX:x y:y width:w height:h.
  3229             rootView         exposeX:x y:y width:w height:h.
  3230         ].
  3231 
  3232         (subViews := rootView subViews) notNil ifTrue:[
  3233             subViews reverseDo:[:v| self recursiveRepair:damages startIn:v relativeTo:rootView ].
  3234         ].
  3235     ].
  3236 ! !
  3237 
  3238 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'queries'!
  3239 
  3240 isInTestMode
  3241     "answer false, all input events are eaten and the selection is shown on the target view.
  3242      answer true,  no  input events are eaten and no  selection is shown on the target view."
  3243 
  3244     ^ testModeChannel value
  3245 ! !
  3246 
  3247 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'selection accessing'!
  3248 
  3249 at:anIndex
  3250     "returns the selected item at an index or nil
  3251     "
  3252     selection notNil ifTrue:[
  3253         ^ selection at:anIndex ifAbsent:nil
  3254     ].
  3255     ^ nil
  3256 !
  3257 
  3258 at:anIndex ifAbsent:aBlock
  3259     "returns the selected item at an index or the result of the block
  3260     "
  3261     selection notNil ifTrue:[
  3262         ^ selection at:anIndex ifAbsent:aBlock
  3263     ].
  3264     ^ aBlock value
  3265 !
  3266 
  3267 first
  3268     "returns the first selected item or nil
  3269     "
  3270     ^ self at:1
  3271 !
  3272 
  3273 last
  3274     "returns the last selected item or nil
  3275     "
  3276     ^ selection notNil ifTrue:[selection last] ifFalse:[nil]
  3277 !
  3278 
  3279 selectedItem
  3280     "returns the single selected item or nil (size ~~ 1 nil is returned)
  3281     "
  3282     ^ selection size == 1 ifTrue:[selection at:1] ifFalse:[nil]
  3283 !
  3284 
  3285 selectedSuperItems
  3286     "returs the list of selected superItems; items selected
  3287      but not contained in another selected item.
  3288     "
  3289     ^ selectedSuperItems
  3290 !
  3291 
  3292 size
  3293     "returns the number of items selected
  3294     "
  3295     ^ selection size
  3296 ! !
  3297 
  3298 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'selection adding & removing'!
  3299 
  3300 add:item
  3301     "add an item to the current selection
  3302     "
  3303     |newSelect|
  3304 
  3305     item isNil ifTrue:[^ item].
  3306 
  3307     lockSema critical:[
  3308         selection isNil ifTrue:[
  3309             newSelect := Array with:item.
  3310         ] ifFalse:[
  3311             (self includes:item) ifFalse:[
  3312                 newSelect := selection copyWith:item
  3313             ]
  3314         ].
  3315 
  3316         newSelect size ~~ selection size ifTrue:[
  3317             item makeVisible.
  3318             self value:newSelect
  3319         ]
  3320     ].
  3321     ^ item
  3322 !
  3323 
  3324 addAll:aCollectionOfItems
  3325     "add a collection of items to the current selection
  3326     "
  3327     |newSelect|
  3328 
  3329     aCollectionOfItems size == 0 ifTrue:[ ^ aCollectionOfItems ].
  3330 
  3331     lockSema critical:[
  3332         selection isNil ifTrue:[
  3333             newSelect := Array withAll:aCollectionOfItems.
  3334         ] ifFalse:[
  3335             newSelect := OrderedCollection withAll:selection.
  3336 
  3337             aCollectionOfItems do:[:el|
  3338                 (selection includesIdentical:el) ifFalse:[newSelect add:el]
  3339             ].
  3340         ].
  3341         self value:newSelect.
  3342     ].
  3343     ^ aCollectionOfItems
  3344 !
  3345 
  3346 deselect
  3347     "clear the selection
  3348     "
  3349     self value:nil.
  3350 !
  3351 
  3352 remove:item
  3353     "remove the item from the current selection
  3354     "
  3355     |newSelect|
  3356 
  3357     item isNil ifTrue:[^ nil].
  3358 
  3359     lockSema critical:[
  3360         (selection notNil and:[selection includesIdentical:item]) ifTrue:[
  3361             selection size == 1 ifTrue:[ newSelect := nil ]
  3362                                ifFalse:[ newSelect := selection copyWithout:item ].
  3363 
  3364             self value:newSelect
  3365         ].
  3366     ].
  3367     ^ item
  3368 !
  3369 
  3370 removeAll
  3371     "clear the selection
  3372     "
  3373     self deselect.
  3374 !
  3375 
  3376 removeAll:loItems
  3377     "remove all items of the collection from the current selection
  3378     "
  3379     |newSelect|
  3380 
  3381     selection   isNil ifTrue:[ ^ loItems ].
  3382     loItems size == 0 ifTrue:[ ^ loItems ].
  3383 
  3384     lockSema critical:[
  3385         selection notNil ifTrue:[
  3386             newSelect := selection select:[:el| (loItems includesIdentical:el) not ].
  3387             self value:newSelect.
  3388         ]
  3389     ].
  3390     ^ loItems
  3391 !
  3392 
  3393 selectAll
  3394     "select all items
  3395     "
  3396     |root newSelection|
  3397 
  3398     root := listOfItems root.
  3399 
  3400     root isNil ifTrue:[
  3401         newSelection := nil
  3402     ] ifFalse:[
  3403         newSelection := OrderedCollection new.
  3404         root recursiveDo:[:el| newSelection add:el ].
  3405     ].
  3406     self value:newSelection.
  3407 !
  3408 
  3409 selectItem:anItem
  3410     "set the current selection to the item
  3411     "
  3412     self value:anItem
  3413 !
  3414 
  3415 selectRootItem
  3416     "set the current selection to the root item
  3417     "
  3418     self value:(self rootItem).
  3419 !
  3420 
  3421 selectedItem:anItem
  3422     "set the current selection to the item
  3423     "
  3424     self selectItem:anItem.
  3425 !
  3426 
  3427 toggleSelectItem:anItem
  3428     "toggle selection-state of the item; add or remove the item from the
  3429      current selection.
  3430     "
  3431     anItem notNil ifTrue:[
  3432         (self includes:anItem) ifTrue:[self remove:anItem]
  3433                               ifFalse:[self add:anItem]
  3434     ].
  3435     ^ anItem
  3436 ! !
  3437 
  3438 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'selection enumerating'!
  3439 
  3440 collect:aBlock
  3441     "for each element in the selection, evaluate the argument, aBlock
  3442      and return a new collection with the results
  3443     "
  3444     |res|
  3445 
  3446     res := OrderedCollection new.
  3447     self do:[:el| res add:(aBlock value:el)].
  3448   ^ res
  3449 !
  3450 
  3451 do:aOneArgBlock
  3452     "evaluate the argument, aBlock for each item in the selection
  3453     "
  3454     |cashedSelection|
  3455 
  3456     cashedSelection := selection.
  3457     cashedSelection isNil ifTrue:[^ nil].
  3458   ^ cashedSelection do:aOneArgBlock
  3459 !
  3460 
  3461 from:start do:aOneArgBlock
  3462     "evaluate the argument, aBlock for the items starting at index start
  3463     "
  3464     |cashedSelection|
  3465 
  3466     cashedSelection := selection.
  3467     cashedSelection isNil ifTrue:[^ nil].
  3468   ^ cashedSelection from:start do:aOneArgBlock
  3469 !
  3470 
  3471 from:start to:stop do:aOneArgBlock
  3472     "evaluate the argument, aBlock for the items with index start to
  3473      stop in the selection.
  3474     "
  3475     |cashedSelection|
  3476 
  3477     cashedSelection := selection.
  3478     cashedSelection isNil ifTrue:[^ nil].
  3479   ^ cashedSelection from:start to:stop do:aOneArgBlock
  3480 !
  3481 
  3482 reverseDo:aOneArgBlock
  3483     "evaluate the argument, aBlock for each item in the selection
  3484     "
  3485     |cashedSelection|
  3486 
  3487     cashedSelection := selection.
  3488     cashedSelection isNil ifTrue:[^ nil].
  3489   ^ cashedSelection reverseDo:aOneArgBlock
  3490 !
  3491 
  3492 select:aBlock
  3493     "return a new collection with all elements from the selection, for which
  3494      the argument aBlock evaluates to true.
  3495     "
  3496     |res|
  3497 
  3498     res := OrderedCollection new.
  3499     self do:[:el| (aBlock value:el) ifTrue:[res add:el] ].
  3500   ^ res
  3501 ! !
  3502 
  3503 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'selection protocol'!
  3504 
  3505 changed:aParameter with:oldSelection
  3506     "update the visibility staus of the current selection
  3507     "
  3508     |unselected rootView rootItem selSize|
  3509 
  3510     selSize := selection size.
  3511 
  3512     selSize == 0 ifTrue:[
  3513         selectedSuperItems := #().
  3514     ] ifFalse:[
  3515         selSize == 1 ifTrue:[
  3516             selectedSuperItems := Array with:(selection at:1).
  3517         ] ifFalse:[
  3518             rootItem := listOfItems root.
  3519 
  3520             (selection includesIdentical:rootItem) ifTrue:[
  3521                 selectedSuperItems := Array with:rootItem.
  3522             ] ifFalse:[
  3523                 selectedSuperItems := OrderedCollection new:selSize.
  3524 
  3525                 selection do:[:anItem|
  3526                     anItem parentsDetect:[:el| selection includesIdentical:el ]
  3527                                   ifNone:[ selectedSuperItems add:anItem ].
  3528                 ].
  3529             ]
  3530         ]
  3531     ].
  3532 
  3533     (     hiddenLevel == 0
  3534      and:[(rootView := listOfItems rootView) notNil
  3535      and:[rootView shown]]
  3536     ) ifTrue:[
  3537         selSize == 0 ifTrue:[
  3538             "/ must redraw the old selection unselected
  3539             self redrawUnselected:oldSelection andLock:false
  3540         ] ifFalse:[
  3541             self invalidateSelection.
  3542 
  3543             oldSelection size ~~ 0 ifTrue:[
  3544                 "/ must redraw all elements no longer in the selection
  3545                 unselected := oldSelection select:[:el| (selection includesIdentical:el) not ].
  3546                 self redrawUnselected:unselected andLock:false.
  3547             ]
  3548         ]
  3549     ].
  3550     super changed:aParameter with:oldSelection.
  3551 !
  3552 
  3553 setValue:aNewSelection 
  3554     "set the selection without notifying
  3555     "
  3556     |newSelect idx|
  3557 
  3558     newSelect := nil.
  3559 
  3560     aNewSelection notNil ifTrue:[
  3561         lockSema critical:[
  3562             aNewSelection isCollection ifFalse:[
  3563                 (selection size == 1 and:[selection first == aNewSelection]) ifTrue:[
  3564                     newSelect := selection
  3565                 ] ifFalse:[
  3566                     newSelect := Array with:aNewSelection.
  3567                 ]
  3568             ] ifTrue:[
  3569                 aNewSelection notEmpty ifTrue:[
  3570                     aNewSelection size ~~ selection size ifTrue:[
  3571                         newSelect := aNewSelection copy.
  3572                     ] ifFalse:[
  3573                         idx := selection findFirst:[:el| (aNewSelection includesIdentical:el) not ].
  3574 
  3575                         idx ~~ 0 ifTrue:[newSelect := aNewSelection copy]
  3576                                 ifFalse:[newSelect := selection ].
  3577                     ]
  3578                 ]
  3579             ]
  3580         ].
  3581     ].
  3582     newSelect ~~ selection ifTrue:[
  3583         beforeSelectionChangedAction value.
  3584         selection := newSelect.
  3585         selection notNil ifTrue:[selection do:[:el| el makeVisible]]
  3586     ].
  3587 !
  3588 
  3589 triggerValue:aValue
  3590     "set my value & send change notifications to my dependents.
  3591      Send the change message even if the value didn't change.
  3592     "
  3593     |oldSelection|
  3594 
  3595     lockSema critical:[
  3596         oldSelection := selection.
  3597         self setValue:aValue.
  3598         self changed:#value with:oldSelection
  3599     ]
  3600 !
  3601 
  3602 value
  3603     "returns the current selection
  3604     "
  3605     ^ selection ? #()
  3606 !
  3607 
  3608 value:aValue
  3609     "change the current selection and send change notifications to my
  3610      dependents if it changed.
  3611     "
  3612     |oldSelection|
  3613 
  3614     lockSema critical:[
  3615         oldSelection := selection.
  3616         self setValue:aValue.
  3617 
  3618         oldSelection == selection ifFalse:[
  3619             self changed:#value with:oldSelection
  3620         ]
  3621     ].
  3622 ! !
  3623 
  3624 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'selection searching'!
  3625 
  3626 detect:aBlock
  3627     "evaluate the argument, aBlock for each item in the selection until
  3628      the block returns true; in this case return the element which caused
  3629      the true evaluation.
  3630      If none of the evaluations returns true, an error is raised
  3631     "
  3632     ^ self detect:aBlock ifNone:[self errorNotFound]
  3633 !
  3634 
  3635 detect:aBlock ifNone:exceptionBlock
  3636     "evaluate the argument, aBlock for each item in the selection until the
  3637      block returns true; in this case return the element which caused the
  3638      true evaluation.
  3639      If none of the evaluations returns true, the result of the evaluation
  3640      of the exceptionBlock is returned
  3641     "
  3642     |cashedSelection|
  3643 
  3644     cashedSelection := selection.
  3645     cashedSelection isNil ifTrue:[ ^ exceptionBlock value ].
  3646   ^ cashedSelection detect:aBlock ifNone:exceptionBlock
  3647 !
  3648 
  3649 detectLast:aBlock
  3650     "evaluate the argument, aBlock for each item in the selection until
  3651      the block returns true; in this case return the element which caused
  3652      the true evaluation. The items are processed in reverse order.
  3653      If none of the evaluations returns true, an error is raised
  3654     "
  3655     ^ self detectLast:aBlock ifNone:[self errorNotFound]
  3656 !
  3657 
  3658 detectLast:aBlock ifNone:exceptionBlock
  3659     "evaluate the argument, aBlock for each item in the selection until
  3660      the block returns true; in this case return the element which caused
  3661      the true evaluation. The items are processed in reverse order.
  3662      If none of the evaluations returns true, the result of the evaluation
  3663      of the exceptionBlock is returned
  3664     "
  3665     |cashedSelection|
  3666 
  3667     cashedSelection := selection.
  3668     cashedSelection isNil ifTrue:[ ^ exceptionBlock value ].
  3669   ^ cashedSelection detectLast:aBlock ifNone:exceptionBlock
  3670 ! !
  3671 
  3672 !ViewTreeInspectorApplication::ViewTreeModel methodsFor:'selection testing'!
  3673 
  3674 includes:anItem
  3675     "returns true if the item is in the current selection
  3676     "
  3677     |cashedSelection|
  3678 
  3679     cashedSelection := selection.
  3680     cashedSelection isNil ifTrue:[^ false].
  3681  ^  cashedSelection includesIdentical:anItem
  3682 !
  3683 
  3684 includesAll:aCollection
  3685     "return true, if all items of the collection are included in the current selection
  3686     "
  3687     |cashedSelection|
  3688 
  3689     aCollection size ~~ 0 ifTrue:[
  3690         cashedSelection := selection.
  3691         cashedSelection isNil ifTrue:[ ^ false ].
  3692 
  3693         aCollection do:[:el|
  3694             (cashedSelection includesIdentical:el) ifFalse:[^ false]
  3695         ]
  3696     ].
  3697     ^ true
  3698 !
  3699 
  3700 includesAny:aCollection
  3701     "return true, if the any item of the collection is in the current selection
  3702     "
  3703     |cashedSelection|
  3704 
  3705     aCollection notNil ifTrue:[
  3706         cashedSelection := selection.
  3707 
  3708         cashedSelection notNil ifTrue:[
  3709             aCollection do:[:el|
  3710                 (cashedSelection includesIdentical:el) ifTrue:[^ true]
  3711             ]
  3712         ]
  3713     ].
  3714     ^ false
  3715 !
  3716 
  3717 includesIdentical:anItem
  3718     "returns true if the item is in the current selection
  3719     "
  3720     ^ self includes:anItem
  3721 !
  3722 
  3723 isEmpty
  3724     "returns true if the current selection is empty
  3725     "
  3726     ^ selection size == 0
  3727 !
  3728 
  3729 isSelected:anItem
  3730     "returns true if the item is in the current selection
  3731     "
  3732     ^ self includes:anItem
  3733 !
  3734 
  3735 notEmpty
  3736     "returns true if the current selection is not empty
  3737     "
  3738     ^ selection size ~~ 0
  3739 ! !
  3740 
  3741 !ViewTreeInspectorApplication::ViewTreeModel::ItemList class methodsFor:'documentation'!
  3742 
  3743 documentation
  3744 "
  3745     Kind of HierarchicalList class which contains all the visible
  3746     ViewTreeItem's and the root, the anchor of the hierarchical list.
  3747 
  3748     [Instance variables:]
  3749         treeModel       <ViewTreeModel>         all events are delegated to
  3750         eventHook       <BlockValue>            save and resore the pre/post -EventHook
  3751 
  3752 
  3753     [author:]
  3754         Claus Atzkern
  3755 
  3756     [see also:]
  3757         HierarchicalList
  3758         ViewTreeModel
  3759         ViewTreeItem
  3760 "
  3761 ! !
  3762 
  3763 !ViewTreeInspectorApplication::ViewTreeModel::ItemList methodsFor:'accessing'!
  3764 
  3765 root:theRoot
  3766     "set the root item; delegate events to my treeModel
  3767     "
  3768     |rootView|
  3769 
  3770     theRoot == root ifTrue:[^ self].
  3771 
  3772     rootView := self rootView.
  3773     super root:theRoot.
  3774 
  3775     rootView notNil ifTrue:[ |wgrp|
  3776         wgrp := rootView windowGroup.
  3777 
  3778         wgrp notNil ifTrue:[
  3779            wgrp removePreEventHook:treeModel.
  3780            wgrp removePostEventHook:self.
  3781         ].
  3782     ].
  3783 
  3784     super root:theRoot.
  3785     rootView := self rootView.
  3786 
  3787     rootView notNil ifTrue:[
  3788         "must setup a task because there might not exist a windowGroup at the moment
  3789         "
  3790         [   |wgrp|
  3791 
  3792             [rootView == self rootView] whileTrue:[
  3793                 wgrp := rootView windowGroup.
  3794                 wgrp notNil ifTrue:[
  3795                     rootView := nil.
  3796                     wgrp addPreEventHook:treeModel.
  3797                     wgrp addPostEventHook:self.
  3798                 ] ifFalse:[
  3799                     Delay waitForMilliseconds:100.
  3800                 ].
  3801             ].
  3802 
  3803         ] forkAt:(Processor userSchedulingPriority + 2).
  3804     ].
  3805     treeModel notNil ifTrue:[
  3806         treeModel targetWidgetChanged.
  3807     ].
  3808     
  3809     ^ root.
  3810 !
  3811 
  3812 rootView
  3813     "returns the widget assigned to the root or nil
  3814     "
  3815     ^ root notNil ifTrue:[root widget] ifFalse:[nil]
  3816 !
  3817 
  3818 treeModel
  3819     "returne the treeModel, a ViewTreeModel
  3820     "
  3821     ^ treeModel
  3822 ! !
  3823 
  3824 !ViewTreeInspectorApplication::ViewTreeModel::ItemList methodsFor:'accessing look'!
  3825 
  3826 additionalLabelForItem:anItem
  3827     "answer the additional lable for an item or nil"
  3828 
  3829     |applClass|
  3830 
  3831     showWidgetNames == true ifTrue:[
  3832         ^ '[', anItem widget name, ']'
  3833     ].
  3834 
  3835     anItem isApplicationClass ifTrue:[
  3836         applClass := anItem applicationClass.
  3837 
  3838         applClass notNil ifTrue:[
  3839             ^ ('[', applClass name, ']')
  3840         ].
  3841     ].
  3842     ^ nil
  3843 !
  3844 
  3845 showWidgetNames
  3846     "answer true if the additional text is the widget name
  3847      otherwise the name of the application"
  3848 
  3849     ^ showWidgetNames ? false
  3850 !
  3851 
  3852 showWidgetNames:aBoolean
  3853     "set true if the additional text is the widget name
  3854      otherwise the name of the application"
  3855 
  3856     self showWidgetNames == aBoolean ifFalse:[
  3857         showWidgetNames := aBoolean.
  3858 
  3859         root notNil ifTrue:[
  3860             root recursiveAdditionalNameBehaviourChanged.
  3861             self changed.
  3862         ].
  3863     ].
  3864 ! !
  3865 
  3866 !ViewTreeInspectorApplication::ViewTreeModel::ItemList methodsFor:'event processing'!
  3867 
  3868 processEvent:anEvent
  3869     "post process event
  3870     "
  3871     ^ treeModel isInTestMode not
  3872 ! !
  3873 
  3874 !ViewTreeInspectorApplication::ViewTreeModel::ItemList methodsFor:'instance creation'!
  3875 
  3876 on:aModel
  3877     "set the model, a ViewTreeModel
  3878     "
  3879     treeModel := aModel.
  3880     showRoot  := true.
  3881     showWidgetNames := false.
  3882 ! !
  3883 
  3884 !ViewTreeInspectorApplication::ViewTreeModel::ItemList methodsFor:'searching'!
  3885 
  3886 detectItemRespondsToView:aView
  3887     "returns the bottom-most item which contains the view
  3888     "
  3889     |view item topView|
  3890 
  3891     root notNil ifTrue:[
  3892         view    := aView.
  3893         topView := root widget.
  3894 
  3895         [ view notNil ] whileTrue:[
  3896             topView == view ifTrue:[^ root].
  3897             item := root recursiveDetect:[:el| el widget == view ].
  3898             item notNil ifTrue:[^ item].
  3899             view := view superView
  3900         ]
  3901     ].
  3902     ^ nil
  3903 !
  3904 
  3905 recursiveDetect:aOneOrgBlock
  3906     "recursive find the first child, for which evaluation 
  3907      of the block returns true; if none nil is returned
  3908     "
  3909     root notNil ifTrue:[
  3910         (aOneOrgBlock value:root) ifTrue:[ ^ root ].
  3911       ^ root recursiveDetect:aOneOrgBlock
  3912     ].
  3913     ^ nil
  3914 ! !
  3915 
  3916 !ViewTreeInspectorApplication class methodsFor:'documentation'!
  3917 
  3918 version
  3919     ^ '$Header$'
  3920 !
  3921 
  3922 version_CVS
  3923     ^ '$Header$'
  3924 ! !
  3925 
  3926 ViewTreeInspectorApplication initialize!
  3927 ViewTreeInspectorApplication::ViewTreeItem initialize!