source: tol/tolbase/lib/mkWidgets1.3/Iconbox.tcl @ 32535cc

1941-docker-image-to-testdevel
Last change on this file since 32535cc was 32535cc, checked in by Jorge Pérez <josp.jorge@…>, 18 years ago

adding more types to config, added mkWidget1.3

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@16 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 37.2 KB
Line 
1package require Metawidget
2
3# name: Iconbox
4# args: args: option-value pairs
5# tries to find a font as column separator, creates all widgets,
6# preconfigures tags, sets all bindings for the selection and inits
7# private variables.
8metawidget create Iconbox {
9  if { ! [ourinfo exists bInit] } {
10    # bindings for selection, here for the icon widgets (-view large/small)
11    foreach { sBind sStep iDir sAction sMode } {
12      <Button-1>            m  0 n s   <Control-1>           m  0 t s
13      <Shift-1>             m  0 n r   <Shift-Control-1>     m  0 a r
14    } {
15      bind Iconboxicon $sBind "catch {\[winfo parent \[winfo parent %W\]\] _select2 $sStep $iDir $sAction $sMode %W}"
16    }
17
18    # bindings for selection for the text window itself
19    foreach { sBind sStep iDir sAction sMode } {
20      <Button-1>            m  0 n s   <Control-1>           m  0 t s
21      <Shift-1>             m  0 n r   <Shift-Control-1>     m  0 a r
22
23      <Left>                i -1 n s   <Right>               i  1 n s
24      <Shift-Left>          i -1 n r   <Shift-Right>         i  1 n r
25      <Control-Left>        i -1 c c   <Control-Right>       i  1 c c
26      <Shift-Control-Left>  i -1 a r   <Shift-Control-Right> i  1 a r
27
28      <Up>                  r -1 n s   <Down>                r  1 n s
29      <Shift-Up>            r -1 n r   <Shift-Down>          r  1 n r
30      <Control-Up>          r -1 c c   <Control-Down>        r  1 c c
31      <Shift-Control-Up>    r -1 a r   <Shift-Control-Down>  r  1 a r
32
33      <Prior>               p -1 n s   <Next>                p  1 n s
34      <Shift-Prior>         p -1 n r   <Shift-Next>          p  1 n r
35      <Control-Prior>       p -1 c c   <Control-Next>        p  1 c c
36      <Shift-Control-Prior> p -1 a r   <Shift-Control-Next>  p  1 a r
37
38      <Control-space>       r  0 t s
39    } {
40      bind Iconboxtext $sBind "catch {\[winfo parent %W\] _select $sStep $iDir $sAction $sMode}"
41    }
42
43    # jump to start or end, should be improved one day
44    bind Iconboxtext <Home>        "%W see 1.0"
45    bind Iconboxtext <End>         "%W see end"
46
47    # take over some useful Text class bindings
48    foreach sBind {<MouseWheel> <B2-Motion> <Button-2>} {
49      bind Iconboxtext $sBind [bind Text $sBind]
50    }
51
52    # find a font with one pixel width for column separation
53    _findColFonts
54
55    our bInit 1
56  }
57
58  # internal widgets, gridded later
59  scrollbar $this.scrh -command "$this _dragX" -orient horiz
60  scrollbar $this.scrv -command "$this.text yview"
61
62  text $this.cols -wrap none -cursor arrow -height 1 -spacing1 1 -spacing3 1 \
63                   -border 0 -bg gray -padx 1 -pady 0
64
65  text $this.text -wrap none -cursor arrow -spacing1 0 -spacing3 0 \
66                   -border 0 -bg white -padx 1 -pady 1 -insertofftime 0 -insertwidth 0 \
67                   -xscroll "$this _moveX" -yscroll "$this.scrv set"
68
69  grid $this.text -column 0 -row 1 -sticky news
70  grid $this.scrv -column 1 -row 0 -sticky ns -rowspan 3
71  grid columnconf $this 0 -weight 1
72  grid rowconf    $this 1 -weight 1
73
74  # tags for column header and column separator
75  $this.cols tag config tCols -border 1 -relief raised
76  $this.cols tag config tCsep -back gray -font [our sColFont]
77  $this.text tag config cursor -border 1 -relief solid
78
79  # take Text class bindings out, no insertion cursor etc.
80  bindtags $this.cols [mkw.lshrink [bindtags $this.cols] Text]
81  bindtags $this.text [mkw.lchange [bindtags $this.text] Text Iconboxtext]
82
83  # bindings to resize a column
84  $this.cols tag bind tDrag <Button-1>        "$this _grab"
85  $this.cols tag bind tDrag <B1-Motion>       "$this _drag"
86  $this.cols tag bind tDrag <ButtonRelease-1> "$this _drop"
87  $this.cols tag bind tText <1>               "$this _sort"
88
89  my lSel {}          ;# list of selected icons
90  my lCols {}         ;# column names
91  my lIcons {}        ;# list of all icons
92
93  my iAnchor {}       ;# selection anchor row (for -view list)
94  my iCursor {}       ;# cursor row (for -view list)
95  my sAnchor {}       ;# selection anchor icon
96  my sCursor {}       ;# cursor icon
97
98  my -view large
99  my -columns {}
100  my -onselect {}
101  my -update full
102  my -selectmode multiple
103  my -grid 70
104
105  -font [$this.text cget -font]
106} {} -default text
107
108# name: _findColFonts
109# args: -
110# columns are separated by a 1 pixel line, which is in fact a space character
111# with a special font. the loops search for a font on that system, where the
112# space char is 1 pixel wide.
113metawidget proc Iconbox _findColFonts {} {
114  for { set iBest 1 } { $iBest <= 4 } { incr iBest } {
115    for { set iSize 1 } { $iSize <= 4 } { incr iSize } {
116      foreach sFamily [font families] {
117        set sDescr [list $sFamily $iSize]
118        if { [font measure $sDescr " "] == $iBest } {
119          our sColFont $sDescr
120          return
121        }
122      }
123    }
124  }
125}
126
127# name: _sort
128# args: -
129# sorts the column that has been clicked.
130metawidget proc Iconbox _sort {} {
131  set sColumn [lindex [$this.cols tag names current] 0]
132  set iDecr [lindex [my aCols($sColumn)] 3]
133  sort [mkw.decode $iDecr {0 -incr 1 -decr}] -dict -column $sColumn
134  my aCols($sColumn) [lreplace [my aCols($sColumn)] 3 3 [mkw.decode $iDecr {1 0 0 1}]]
135}
136
137# name: _dragX
138# args: args: from "scrollbar -command"
139# called on horizontal scrollbar dragging. sets the view for column and
140# main text widget simultaneously.
141metawidget proc Iconbox _dragX { args } {
142  eval $this.cols xview $args
143  eval $this.text xview $args
144}
145
146# name: _moveX
147# args: args: from "text -scrollx"
148# called when main text widgets scrolls horizontally. adjusts the column
149# text widget and the scrollbar.
150metawidget proc Iconbox _moveX { args } {
151  eval $this.scrh set $args
152  eval $this.cols xview moveto [lindex $args 0]
153}
154
155# name: _setTabs
156# args: bAll: if false, only tabs in column widget are set
157# called when a column is resized. calculates the tabs for column and main
158# widget. each column is separated by a tab. the text position inside a column
159# is also based on a tab.
160metawidget proc Iconbox _setTabs { {bAll 1} } {
161  set lTabs {}
162  set iX 0
163
164  foreach sColumn [my lCols] {
165    mkw.lassign [my aCols($sColumn)] iWidth sAlign
166
167    # create a tab based on column alignment. For right align, the tab must
168    # be 1 space left of the column separating tab (it's the text widget!)
169    switch $sAlign {
170      l { lappend lTabs [expr $iX]         }
171      r { lappend lTabs [expr $iX+$iWidth] }
172      c { lappend lTabs [expr $iX+$iWidth/2-[my iOneSpace]] }
173      n { lappend lTabs [expr $iX+$iWidth/2] }
174    }
175
176    # create tab for column separation
177    lappend lTabs $sAlign [expr $iX+$iWidth] c
178    incr iX $iWidth
179  }
180
181  $this.cols config -tabs $lTabs
182
183  # set for main window, if indicated (depends on -update)
184  if { $bAll } {
185    $this.text config -tabs $lTabs
186  }
187}
188
189# name: _getValues
190# args: sColumn: valid column name
191# called before dragging a column. extracts the values of the given column
192# out of the lData table and returns them as a list. speeds up text clipping!
193metawidget proc Iconbox _getValues { sColumn } {
194  set iPos [_findColumn $sColumn]
195  set lValues {}
196  foreach sIcon [my lIcons] {
197    lappend lValues [lindex [lindex [my aIcons($sIcon)] 2] $iPos]
198  }
199
200  return $lValues
201}
202
203# name: _clipText
204# args: sText: text to clip
205#       sColumn: column to make sText fit into
206# returns a portion of sText that is not wider then the width of sColumn.
207metawidget proc Iconbox _clipText { sText sColumn {iExtra 0} } {
208  # get column width and substract the width of two tab chars.
209  # strange, but the text widget allocates pixels for a tab.
210  set iColWidth [expr [lindex [my aCols($sColumn)] 0]-[my iTwoTabs]-$iExtra-1]
211
212  # for each cycle, cut off one character at the end and see
213  # if required space is less then available one. if so, get out.
214  for { set i [expr [string length $sText]-2] } { $i >= -1 } { incr i -1 } {
215    if { [font measure [my -font] $sText] <= $iColWidth } break;
216    set sText [string range $sText 0 $i]
217  }
218
219  return $sText
220}
221
222# name: _clipHeader
223# args: sColumn: valid column name
224# called when a column is dragged. clips the column header by replacing it.
225# therefore the tCsel tag needs to be added again. tCsel is the left portion
226# of a column, its bindings cause the column to be selected. (the right side
227# is tDrag, to drag a column).
228metawidget proc Iconbox _clipHeader { sColumn } {
229  mkw.lassign [$this.cols tag ranges $sColumn] sI1 sI2
230  $this.cols delete $sI1+1ch $sI2-2ch
231  $this.cols insert $sI1+1ch [_clipText $sColumn $sColumn]
232
233  mkw.lassign [$this.cols tag ranges $sColumn] sI1 sI2
234  $this.cols tag add tText $sI1 $sI2-2ch
235}
236
237# name: _clipColumn
238# args: sColumn: valid column name
239#       vValues: name of private variable that holds column values
240# called when a column is dragged. clips the values in the main widget.
241# vValues must contain the values, or they are retrieved. clips each
242# cell by replacing the current value with the clipped value.
243metawidget proc Iconbox _clipColumn { sColumn {vValues {}} } {
244  if { $vValues == {} } {
245    set lValues [_getValues $sColumn]
246  } else {
247    set lValues [my $vValues]
248  }
249
250  set iRow 0
251  foreach { sI1 sI2 } [$this.text tag ranges $sColumn] {
252    set sValue [lindex $lValues $iRow]
253
254    if { [catch {
255      set iExtra [image width [$this.text image cget $sI1+1ch -image]]
256      set sI1 $sI1+2ch
257    }] } {
258      set iExtra 0
259      set sI1 $sI1+1ch
260    }
261
262    $this.text delete $sI1 $sI2-1ch
263    $this.text insert $sI1 [_clipText $sValue $sColumn $iExtra]
264    incr iRow
265  }
266}
267
268# name: _clipIcon
269# args: sIcon: icon name
270# clips the icon's caption so that it will take up no more than 2 lines
271# when displayed as a large icon.
272metawidget proc Iconbox _clipIcon { sIcon {bDoit 1} } {
273  set sText [lindex [lindex [my aIcons($sIcon)] 2] 0]
274
275  if { $bDoit } {
276    set iWidth [expr 2*[my -grid]-5]
277
278    for { set i [expr [string length $sText]-2] } { $i >= -1 } { incr i -1 } {
279      if { [font measure [my -font] $sText] <= $iWidth } break;
280      set sText [string range $sText 0 $i]
281    }
282  }
283
284  [lindex [my aIcons($sIcon)] 3].l configure -text $sText
285}
286
287# name: _grab
288# args: {}
289# called before column resize. stores some values in private variables for
290# quicker access during actual dragging: column name into sCol, update mode
291# in numeric form in iUpd, mouse x coord in iX0, column values in lValues.
292metawidget proc Iconbox _grab {} {
293  my sCol [lindex [$this.cols tag names current] 0]
294  my iMin [lindex [my aCols([my sCol])] 2]
295  my iUpd [mkw.decode [my -update] {none 0 partial 1 full 2}]
296  my iX0 [expr [lindex [my aCols([my sCol])] 0]-[winfo pointerx .]]
297  my lValues [_getValues [my sCol]]
298}
299
300# name: _drag
301# args: -
302# called during dragging. calculates new width and udpates column data
303# with it. sets tabs and clips column and, if -update == full, text.
304metawidget proc Iconbox _drag {} {
305  set iX [expr [my iX0]+[winfo pointerx .]]
306  if { $iX < [my iMin] } {
307    set iX [my iMin]
308  }
309
310  my aCols([my sCol]) [lreplace [my aCols([my sCol])] 0 0 $iX]
311
312  _setTabs [my iUpd]
313  _clipHeader [my sCol]
314
315  if { [my iUpd] == 2 } {
316    _clipColumn [my sCol] lValues
317  }
318}
319
320# name: _drop
321# args: -
322# called after column resize. sets tabs and clips one last time.
323metawidget proc Iconbox _drop {} {
324  _setTabs
325  _clipHeader [my sCol]
326  _clipColumn [my sCol] lValues
327
328  if { [my -view] == "list" && [my sCol] == [lindex [my lCols] 0] } {
329    _setListmodeTags
330  }
331}
332
333# name: _findIcon
334# args: sIcon: icon name
335# checks if given icon exists.
336metawidget proc Iconbox _findIcon { sIcon } {
337  set iPos [lsearch [my lIcons] $sIcon]
338
339  if { $iPos == -1 } {
340    error "Iconbox $this: Icon $sIcon does not exist."
341  }
342
343  return $iPos
344}
345
346# name: _findColumn
347# args: sColumn: column name
348# checks if given column is valid and returns its position.
349metawidget proc Iconbox _findColumn { sColumn } {
350  set iPos [lsearch [my lCols] $sColumn]
351
352  if { $iPos == -1 } {
353    error "Iconbox $this: Unknown column '$sColumn'."
354  }
355
356  return $iPos
357}
358
359# name: _selIcon
360# args: sIcon: icon to set or remove selection for
361#       bSelected: 0: remove, 1: set selection
362# sets or removes the selection for an item (or all items, if sIcon == *).
363# changes the look of the item as well as the selection list lSel.
364metawidget proc Iconbox _selIcon { sIcon {bSelected 0} } {
365  if { $sIcon == "*" } {
366    foreach sIcon [my lIcons] {
367      set wIcon [lindex [my aIcons($sIcon)] 3]
368      $wIcon.l config -bg [$this.text cget -back] -fg [$this.text cget -fore]
369    }
370    my lSel {}
371  } elseif { $bSelected } {
372    set wIcon [lindex [my aIcons($sIcon)] 3]
373    $wIcon.l config -bg [$this.text cget -selectback] -fg [$this.text cget -selectfore]
374    my lSel [mkw.lextend [my lSel] $sIcon]
375  } else {
376    set wIcon [lindex [my aIcons($sIcon)] 3]
377    $wIcon.l config -bg [$this.text cget -back] -fg [$this.text cget -fore]
378    my lSel [mkw.lshrink [my lSel] $sIcon]
379  }
380}
381
382# name: _select
383# args: sStep  : m: mouse, i: icon, r: row, p: page
384#       iDir   : 0 for mouse, 1 or -1 otherwise
385#       sAction: n: new selection, a: append, c: cursor only, t: toggle
386#       sMode  : s: single cell, r: range of cells, c: cursor only
387# calls one of the two members that really set the selection.
388metawidget proc Iconbox _select { sStep iDir sAction sMode } {
389  if { [my -view] == "list" } {
390    _select1 $sStep $iDir $sAction $sMode
391  } else {
392    _select2 $sStep $iDir $sAction $sMode
393  }
394}
395
396# name: _select1
397# args: see _select
398# called when view mode is "list". uses the standard sel tag for selection.
399metawidget proc Iconbox _select1 { sStep iDir sAction sMode } {
400  focus $this.text
401
402  # step 1: determine the new cursor position
403  switch $sStep {
404    m {
405      set iY [expr [winfo pointery $this.text]-[winfo rooty $this.text]]
406      set iRow [lindex [split [$this.text index @0,$iY] .] 0]
407      if { $iRow > [llength [my lIcons]] } return
408    }
409    r {
410      set iRows [llength [my lIcons]]
411      set iRow [expr [my iCursor]+$iDir]
412      if { $iRow < 1 } { set iRow 1 }
413      if { $iRow > $iRows } { set iRow $iRows }
414    }
415    p {
416      set iRows [llength [my lIcons]]
417      set iRowH [expr [font metrics [my -font] -linespace]+1]
418      set iStep [expr [winfo height $this.text]/$iRowH]
419      set iRow [expr [my iCursor]+$iDir*$iStep]
420      if { $iRow < 1 } { set iRow 1 }
421      if { $iRow > $iRows } { set iRow $iRows }
422    }
423    i {
424      return
425    }
426  }
427
428  # step 2: get indexes of new cursor cell and set cursor tag there
429  $this.text tag remove cursor 1.0 end
430  mkw.lassign [$this.text tag nextrange tIcon $iRow.0] sI1 sI2
431  $this.text tag add cursor $sI1 $sI2
432  my iCursor $iRow
433
434  # step 3: determine if sel tag will be removed or added to cells
435  switch $sAction {
436    n - a {
437      set sMethod add
438    }
439    t {
440      if { [lsearch [$this.text tag names $iRow.2] sel] != -1 } {
441        set sMethod remove
442      } else {
443        set sMethod add
444      }
445    }
446  }
447
448  # step 4: remove existing sel tags, if a new selection is set
449  if { $sAction == "n" || [my -selectmode] == "single" } {
450    $this.text tag remove sel 1.0 end
451  }
452
453  # step 5: actually set the sel tag
454  if { [info exists sMethod] } {
455    if { ! ( $sMode == "r" && [my -selectmode] == "multiple" ) } {
456      my iAnchor [my iCursor]
457    }
458
459    set iR1 [expr ([my iCursor]<[my iAnchor])?[my iCursor]:[my iAnchor]]
460    set iR2 [expr ([my iCursor]>[my iAnchor])?[my iCursor]:[my iAnchor]]
461
462    for { set i $iR1 } { $i <= $iR2 } { incr i } {
463      mkw.lassign [$this.text tag nextrange tIcon $i.0] sI1 sI2
464      $this.text tag $sMethod sel $sI1 $sI2
465    }
466  }
467
468  $this.text tag raise sel
469  $this.text tag raise cursor
470  $this.text see $iRow.0
471
472  my lSel {}
473  foreach { sI1 sI2 } [$this.text tag ranges sel] {
474    my lSel [linsert [my lSel] end [lindex [$this.text tag names $sI1] 0]]
475  }
476
477  eval [my -onselect]
478}
479
480# name: _select2
481# args: see _select
482#       wWindow: icon that was clicked
483# called when view mode is "large" or "list". can't use sel tag, because the
484# icons are real widgets. rather modifies there background color etc.
485metawidget proc Iconbox _select2 { sStep iDir sAction sMode {wWindow {}} } {
486  focus $this.text
487
488  # try to unset cursor icon
489  catch {
490    set wIcon [lindex [my aIcons([my sCursor])] 3]
491    $wIcon.l config -relief flat
492  }
493
494  # step 1: determine icon to set cursor for
495  if { $sStep == "m" } {
496    if { $wWindow == {} } return
497
498    # search icon name. something to improve!
499    set wParent [winfo parent $wWindow]
500    foreach sIcon [my lIcons] {
501      if { ! [string compare [lindex [my aIcons($sIcon)] 3] $wParent] } break
502    }
503
504    my sCursor $sIcon
505  } else {
506    set iPos [lsearch [my lIcons] [my sCursor]]
507
508    if { $sStep == "i" } {
509      set iStep 1
510    } else {
511      mkw.lassign [$this.text bbox 1.$iPos] iX iY iW iH
512      set iStep [expr [winfo width $this.text]/$iW]
513
514      if { $sStep == "p" } {
515        set iStep [expr $iStep * [winfo height $this.text]/$iH]
516      }
517    }
518
519    #set sIcon [myindex lIcons [expr $iPos+$iDir*$iStep]]
520    set sIcon [lindex [my lIcons] [expr $iPos+$iDir*$iStep]]
521    if { $sIcon != {} } {
522      my sCursor $sIcon
523    }
524  }
525
526  # step 2: determine if selection is set or removed
527  switch $sAction {
528    n - a {
529      set iSetsel 1
530    }
531    t {
532      if { [lsearch [my lSel] [my sCursor]] == -1 } {
533        set iSetsel 1
534      } else {
535        set iSetsel 0
536      }
537    }
538  }
539
540  # step 3: remove existing selection, if new selection will be set
541  if { $sAction == "n" || [my -selectmode] == "single" } {
542    _selIcon * 0
543  }
544
545  # step 4: actually set selection
546  if { [info exists iSetsel] } {
547    if { $sMode != "r" || [my -selectmode] == "single" } {
548      my sAnchor [my sCursor]
549    }
550
551    set iPos1 [lsearch [my lIcons] [my sAnchor]]
552    set iPos2 [lsearch [my lIcons] [my sCursor]]
553    set iP1 [expr ($iPos1<$iPos2)?$iPos1:$iPos2]
554    set iP2 [expr ($iPos1>$iPos2)?$iPos1:$iPos2]
555    set lIcons [lrange [my lIcons] $iP1 $iP2]
556    foreach sIcon $lIcons {
557      _selIcon $sIcon $iSetsel
558    }
559  }
560
561  # set cursor icon
562  catch {
563    set wIcon [lindex [my aIcons([my sCursor])] 3]
564    $wIcon.l config -relief solid
565  }
566
567  $this.text see 1.[lsearch [my lIcons] [my sCursor]]
568}
569
570# name: _setListmodeTags
571# args: -
572# for -view == list, the frame widgets are removed and plain text is used,
573# plus the small image on the left side. in order for selection and column
574# dragging to work, each line needs some tags.
575metawidget proc Iconbox _setListmodeTags {} {
576  # set special tags for the icon itself (left column). tIcon is needed to
577  # set the selection. each icon gets a tag with the icon's name for
578  # identification, e.g. to attach bindings or get the selection.
579  foreach { sI1 sI2 } [$this.text tag ranges [lindex [my lCols] 0]] sIcon [my lIcons] {
580    $this.text tag add tIcon $sI1+2ch $sI2-1ch
581    $this.text tag add $sIcon $sI1+1ch $sI2-1ch
582    $this.text tag lower $sIcon
583  }
584
585  # take over selection from lSel list.
586  foreach sIcon [my lSel] {
587    mkw.lassign [$this.text tag ranges $sIcon] sI1 sI2
588    $this.text tag add sel $sI1+1ch $sI2
589  }
590
591  # add all the individual bindings to the icons.
592  foreach lBinds [myinfo vars lBind.*] {
593    mkw.lassign [split $lBinds .] x sIcon sBind
594    foreach sScript [my $lBinds] {
595      $this.text tag bind $sIcon $sBind $sScript
596    }
597  }
598
599  # set cursor tag
600  my iCursor [expr [lsearch [my lIcons] [my sCursor]]+1]
601  if { [my iCursor] } {
602    mkw.lassign [$this.text tag nextrange tIcon [my iCursor].0] sI1 sI2
603    $this.text tag add cursor $sI1 $sI2
604  }
605}
606
607# name: _redraw
608# args: -
609# draws the metawidget, depending on -view. for -view == large or small,
610# the icon frames are inserted into the text widget with "text window create".
611# for -view == list, the frames are not used. instead, the small image is
612# inserted at the beginning of each line, followed by the icon's -values.
613metawidget proc Iconbox _redraw {} {
614  # get the widgets out the text widget and unpack them.
615  foreach wWindow [$this.text window names] {
616    pack $wWindow
617    pack forget $wWindow
618  }
619
620  if { [my -view] == "list" } {
621    # clear contents and show column row and scrollbar
622    $this.text delete 1.0 end
623    grid $this.cols -column 0 -row 0 -sticky news
624    grid $this.scrh -column 0 -row 2 -sticky we
625
626    $this.text config -wrap none
627
628    # create rows
629    set iRow 0
630    foreach sIcon [my lIcons] {
631      incr iRow
632      $this.text insert $iRow.end "\n"
633
634      # first tab is the text anchor, second is the column separator tab.
635      # each field gets a tag with its column's name.
636      foreach sValue [lindex [my aIcons($sIcon)] 2] sColumn [my lCols] {
637        $this.text insert $iRow.end "\t\t"
638        $this.text tag add $sColumn $iRow.end-2ch $iRow.end
639        $this.text insert $iRow.end-1ch $sValue
640      }
641
642      $this.text image create $iRow.1 -image [lindex [my aIcons($sIcon)] 1] -align center -padx 2
643    }
644
645    # clip all columns and create tags
646    foreach sCol [my lCols] {
647      _clipColumn $sCol
648    }
649
650    _setListmodeTags
651  } else {
652    # if we just had -view list, then clean up first
653    if { [winfo ismapped $this.cols] } {
654      # discard column widget and scrollbar
655      grid forget $this.cols $this.scrh
656
657      # remove selection from all icons...
658      _selIcon * 0
659
660      # ...and take over what has been selected in the list view.
661      foreach { sI1 sI2 } [$this.text tag ranges sel] {
662        set sIcon [lindex [$this.text tag names $sI1] 0]
663        _selIcon $sIcon 1
664      }
665
666      # set the cursor icon
667      catch { [lindex [my aIcons([my sCursor])] 3].l config -relief flat }
668      my sCursor [lindex [my lIcons] [expr [my iCursor]-1]]
669      catch { [lindex [my aIcons([my sCursor])] 3].l config -relief solid }
670    }
671
672    $this.text delete 1.0 end
673    $this.text config -wrap word
674
675    # set some variables depending on the view
676    set iIcon [mkw.decode [my -view] {small 1  large 0 }]
677    set iWrap [mkw.decode [my -view] "small 0  large [my -grid]"]
678    set iGapx [mkw.decode [my -view] {small 15 large 5}]
679    set iGapy [mkw.decode [my -view] {small 0  large 10}]
680    set iMaxw 0
681    set iMaxh 0
682
683    foreach sIcon [my lIcons] {
684      set wIcon [lindex [my aIcons($sIcon)] 3]
685      $wIcon.i config -image [lindex [my aIcons($sIcon)] $iIcon]
686      $wIcon.l config -wrap $iWrap
687      set iIWidth  [winfo reqwidth  $wIcon.i]
688      set iIHeight [winfo reqheight $wIcon.i]
689      set iLWidth  [winfo reqwidth  $wIcon.l]
690      set iLHeight [winfo reqheight $wIcon.l]
691
692      # depending on the view, we must track the largest icon
693      if { $iIcon == 0 } { ;# large icons
694        # width is constant, height is sum of icon and text
695        set iMaxw [my -grid]
696        set iReqh [expr $iIHeight+$iLHeight]
697        if { $iReqh > $iMaxh } {
698          set iMaxh $iReqh
699        }
700
701        place $wIcon.i -relx .5 -rely 0 -anchor n
702        place $wIcon.l -x 0 -y $iIHeight -relx .5 -rely 0 -anchor n
703      } else {             ;# small icons
704        # height is the greater of image and text, width is their sum
705        set iReqw [expr $iIWidth+$iLWidth]
706        if { $iReqw > $iMaxw } {
707          set iMaxw $iReqw
708        }
709
710        set iReqh [expr ($iIHeight>$iLHeight)?$iIHeight:$iLHeight]
711        if { $iReqh > $iMaxh } {
712          set iMaxh $iReqh
713        }
714
715        place $wIcon.i -relx 0 -rely .5 -anchor w
716        place $wIcon.l -x $iIWidth -y 0 -relx 0 -rely .5 -anchor w
717      }
718
719      $this.text window create end -align bottom -window $wIcon
720    }
721
722    # set all icons to the size of the largest icon, so they get oriented.
723    incr iMaxw $iGapx
724    incr iMaxh $iGapy
725    foreach sIcon [my lIcons] {
726      set wIcon [lindex [my aIcons($sIcon)] 3]
727      $wIcon config -width $iMaxw -height $iMaxh
728    }
729  }
730
731  catch { see [my sCursor] }
732}
733
734# name: -columns
735# args: lColumns: list of column specifications
736# sets new columns. a column spec must have the format {text alignment
737# width minwidth}. text is mandatory and must be unique, the rest is optional.
738metawidget proc Iconbox -columns { lColumns } {
739  my lCols {}
740  eval unmy aCols
741  $this.cols delete 1.0 end
742
743  foreach lColumn $lColumns {
744    set sAlign l
745    set iWidth 100
746    set iMinwidth 10
747    mkw.lassign $lColumn sText sAlign iWidth iMinwidth
748
749    my aCols($sText) [list $iWidth $sAlign $iMinwidth 0]
750    my lCols [linsert [my lCols] end $sText]
751
752    # first tab is the text anchor, second is the column separator tab. tags:
753    # tCols for the 3d look, tCsep for the gap, tDrag for resizing.
754    $this.cols insert 1.end "\t\t "
755    $this.cols tag add tCols 1.end-3ch 1.end-1ch
756    $this.cols tag add tCsep 1.end-1ch
757    $this.cols tag add tDrag 1.end-2ch 1.end
758    $this.cols tag add $sText 1.end-3ch 1.end
759
760    $this.cols tag lower $sText
761    _clipHeader $sText
762  }
763
764  my -columns $lColumns
765  _setTabs
766}
767
768# name: -view
769# args: sView: new view to set
770# sets a new view mode: small icons, large icons, or list.
771metawidget proc Iconbox -view { sView } {
772  my -view [mkw.complete $sView {small large list}]
773  _redraw
774}
775
776# name: -update
777# args: sMode: update mode for column resizing
778# none resizes the column only, not the text. partial resizes the text but
779# does not do clipping. full does everything.
780metawidget proc Iconbox -update { sMode } {
781  my -update [mkw.complete $sMode {full partial none}]
782}
783
784# name: -selectmode
785# args: sMode: single, multiple
786# if single, only one cell can be selected.
787metawidget proc Iconbox -selectmode { sMode } {
788  my -selectmode [mkw.complete $sMode {single multiple}]
789}
790
791# name: -font
792# args: sFont: font specification
793# sets the fonts for all two text widgets. separate fonts would have made
794# geometry management too complicated.
795metawidget proc Iconbox -font { sFont } {
796  $this.text config -font $sFont
797  $this.cols config -font $sFont
798
799  my -font $sFont
800
801  # calculate new width of those strange placeholders
802  my iOneSpace [font measure $sFont " "]
803  my iTwoTabs  [font measure $sFont "\t\t"]
804
805  # clip everything, in case font is larger then old one
806  foreach sCol [my lCols] {
807    _clipHeader $sCol
808    _clipColumn $sCol
809  }
810
811  # update icons
812  foreach sIcon [my lIcons] {
813    [lindex [my aIcons($sIcon)] 3].l config -font $sFont
814    _clipIcon $sIcon
815  }
816}
817
818# name: insert
819# args: iRow: position to insert icon
820#       sIcon: icon name
821#       args: option-value pairs
822# inserts a new icon. an icon is a frame with two labels inside, one for
823# the image, one for the text. packing order depends on -view and is done in
824# _redraw.
825metawidget proc Iconbox insert { iPos sIcon args } {
826  if { [myinfo exists aIcons($sIcon)] } {
827    error "Iconbox $this: Icon $sIcon already exists."
828  }
829
830  # eliminate dots and blanks, then get a unique widget name. ("read-me"
831  # is ok, but "read.me" also maps to read-me. sequence will add "#1" etc.).
832  regsub -all {[. ]} $sIcon {-} sNodots
833  set wIcon $this._i$sNodots
834  while { [winfo exists $wIcon] } {
835    if { [catch { incr iSeq }] } { set iSeq 1 }
836    set wIcon $this._i$sNodots#$iSeq
837  }
838
839  # create widgets. two labels for image and caption.
840  frame $wIcon -border 0 -bg white
841  label $wIcon.i -padx 0 -pady 0 -bg white -border 0
842  label $wIcon.l -padx 0 -pady 0 -bg white -border 0 -font [my -font]
843
844  # replace Label class bindings with selection bindings
845  bindtags $wIcon.i [mkw.lchange [bindtags $wIcon.i] Label Iconboxicon]
846  bindtags $wIcon.l [mkw.lchange [bindtags $wIcon.l] Label Iconboxicon]
847
848  # make sure packing order is right (icon above text widget)
849  raise $wIcon $this.text
850
851  # icon properties: large image, small image, values for -view == list, widget, userdata
852  my aIcons($sIcon) [list {} {} {} $wIcon {}]
853  my lIcons [linsert [my lIcons] $iPos $sIcon]
854
855  eval iconconfigure {$sIcon} -text {$sIcon} $args
856
857  # queue an event for _redraw when idle. delete any old events
858  # so that there will be exactly one redraw after several inserts.
859  catch { after cancel [my jRedraw] }
860  my jRedraw [after idle $this _redraw]
861}
862
863# name: delete
864# args: args: list of icon names, nothing for all icons
865# deletes the icons specified by $args. destroys the frame widget and, if
866# -view == list (where the frames are not packed), deletes the associated
867# rows. finally updates internal data.
868metawidget proc Iconbox delete { args } {
869  if { ! [llength $args] } {
870    foreach sIcon [my lIcons] {
871      destroy [lindex [my aIcons($sIcon)] 3]
872    }
873
874    $this.text delete 1.0 end
875
876    my lSel {}
877    my lIcons {}
878    eval unmy aIcons
879  } else {
880    foreach sIcon $args {
881      _findIcon $sIcon
882      destroy [lindex [my aIcons($sIcon)] 3]
883
884      if { [my -view] == "list" } {
885        mkw.lassign [$this.text tag ranges $sIcon] sI1 sI2
886        $this.text delete "$sI1 linestart" "$sI1 linestart+1line"
887      }
888
889      my lSel [mkw.lshrink [my lSel] $sIcon]
890      my lIcons [mkw.lshrink [my lIcons] $sIcon]
891      unmy aIcons($sIcon)
892    }
893  }
894}
895
896# name: iconconfigure
897# args: sIcon: icon name
898#       args: option-value pairs
899# configures an icon. the three special options are stored in the icon's
900# record, all others (like -text for the icon's caption) are applied
901# to the icon's text label.
902metawidget proc Iconbox iconconfigure { sIcon args } {
903  set iRow  [expr [_findIcon $sIcon] + 1]
904  set wIcon [lindex [my aIcons($sIcon)] 3]
905  set args  [mkw.options $args * {-text *} {-image *} {-smallimage *} {-values *} {-user *}]
906
907  if { $args != {} } {
908    eval $wIcon.l configure $args
909  }
910
911  if { [info exists -text] } {
912    my aIcons($sIcon) [lreplace [my aIcons($sIcon)] 2 2 [lreplace [lindex [my aIcons($sIcon)] 2] 0 0 ${-text}]]
913    _clipIcon $sIcon
914
915    if { ! [catch {$this.text index $sIcon.first}] } {
916      mkw.lassign [$this.text tag ranges $sIcon] sI1 sI2
917      $this.text delete $sI1 $sI2
918      $this.text insert $sI1 ${-text}
919      _setListmodeTags
920    }
921  }
922
923  if { [info exists -image] } {
924    my aIcons($sIcon) [lreplace [my aIcons($sIcon)] 0 0 ${-image}]
925    if { [my -view] == "large" } {
926      $wIcon.i config -image ${-image}
927    }
928  }
929
930  if { [info exists -smallimage] } {
931    my aIcons($sIcon) [lreplace [my aIcons($sIcon)] 1 1 ${-smallimage}]
932    if { [my -view] == "small" } {
933      $wIcon.i config -image ${-smallimage}
934    }
935  }
936
937  if { [info exists -values] } {
938    if { [llength ${-values}] >= [llength [my lCols]] } {
939      error "Iconbox $this: Too many values for option -values."
940    }
941
942    set lValues [lindex [my aIcons($sIcon)] 2]
943    set lValues [concat [list [lindex $lValues 0]] ${-values}]
944    my aIcons($sIcon) [lreplace [my aIcons($sIcon)] 2 2 $lValues]
945
946    if { ! [catch {$this.text index $sIcon.first}] } {
947      foreach sValue ${-values} sColumn [lrange [my lCols] 1 end] {
948        mkw.lassign [$this.text tag nextrange $sColumn $iRow.0] sI1 sI2
949        $this.text delete $sI1+1ch $sI2-1ch
950        $this.text insert $sI1+1ch $sValue
951      }
952    }
953  }
954
955  if { [info exists -user] } {
956    my aIcons($sIcon) [lreplace [my aIcons($sIcon)] 4 4 ${-user}]
957  }
958}
959
960# name: iconcget
961# args: sIcon: icon name
962#       args: option-value pairs
963# retrieves an icon's option. the values of the three special options are
964# taken from the icon's record, all others from the icon's text label.
965metawidget proc Iconbox iconcget { sIcon args } {
966  _findIcon $sIcon
967
968  switch -- $sOption {
969    -icon      { return [lindex [my aIcons($sItem)] 0] }
970    -smallicon { return [lindex [my aIcons($sItem)] 1] }
971    -values    { return [lindex [my aIcons($sItem)] 2] }
972    -user      { return [lindex [my aIcons($sItem)] 4] }
973    default    {
974      set wIcon [lindex [my aIcons($sIcon)] 3]
975      eval $wIcon.l cget $args
976    }
977  }
978}
979
980# name: iconbind
981# args: sIcon: icon name
982#       args: as accepted by the bind command
983# defines bindings for an icon. all bindings must be stored because for
984# -view == list, the icons are displayed differently (plain text, not
985# the frame and the labels).
986metawidget proc Iconbox iconbind { sIcon args } {
987  _findIcon $sIcon
988
989  # for each icon, maintain a variable containing sequence-script
990  # pairs. if $sScript is empy, remove it. if $sScript start with +,
991  # append it. otherwise reset list with given binding.
992  if { [llength $args] == 2 } {
993    mkw.lassign $args sBind sScript
994    if { $sScript == {} } {
995      unmy lBind.$sIcon.$sBind
996    } elseif { [string index $sScript 0] == "+" } {
997      my lBind.$sIcon.$sBind [linsert [my lBind.$sIcon.$sBind] end $sScript]
998    } else {
999      my lBind.$sIcon.$sBind [list $sScript]
1000    }
1001  }
1002
1003  # apply binding to image and text label
1004  set wIcon [lindex [my aIcons($sIcon)] 3]
1005  eval bind $wIcon.i $args
1006  eval bind $wIcon.l $args
1007}
1008
1009# name: selection
1010# args: sAction: set, get or clear
1011#       args: depends on sAction
1012# modifies the selection. because icons are made with widgets and inserted
1013# into the text, the text's sel tag cannot be used. rather the background of
1014# the text label is changed.
1015metawidget proc Iconbox selection { sAction args } {
1016  switch [mkw.complete $sAction {clear get set}] {
1017    clear {
1018      $this.text tag remove sel 1.0 end
1019      _selIcon * 0
1020    }
1021
1022    get {
1023      return [my lSel]
1024    }
1025
1026    set {
1027      $this.text tag remove sel 1.0 end
1028      _selIcon * 0
1029
1030      foreach sIcon [lindex $args 0] {
1031        _findIcon $sIcon
1032        _selIcon $sIcon 1
1033
1034        if { [my -view] == "list" } {
1035          mkw.lassign [$this.text tag ranges $sIcon] sI1 sI2
1036          $this.text tag add sel $sI1 $sI2
1037        }
1038      }
1039    }
1040  }
1041}
1042
1043# name: sort
1044# args: args: as accepted by lsort, plus -column
1045# sorts the icons, either by their name or by one of the columns.
1046metawidget proc Iconbox sort { args } {
1047  set args [mkw.options $args * {-column *}]
1048
1049  # build table with two columns: one is icon name, second is sort criteria
1050  set lData {}
1051  if { ! [info exists -column] } {
1052    # if no column is specified, just take the icon's caption
1053    foreach sIcon [my lIcons] {
1054      set wIcon [lindex [my aIcons($sIcon)] 3]
1055      lappend lData [list $sIcon [$wIcon.l cget -text]]
1056    }
1057  } else {
1058    set iPos [lsearch [my lCols] ${-column}]
1059    if { $iPos == -1 } {
1060      error "Iconbox $this: Invalid column ${-column}"
1061    }
1062
1063    # otherwise, extract the value specified by -column
1064    foreach sIcon [my lIcons] {
1065      lappend lData [list $sIcon [lindex [lindex [my aIcons($sIcon)] 2] $iPos]]
1066    }
1067  }
1068
1069  # sort it. the first column now contains the icons in sorted order
1070  set lData [eval lsort $args -index 1 \$lData]
1071
1072  # extract first column, rebuilt icon list, and redraw
1073  my lIcons {}
1074  foreach lRow $lData {
1075    my lIcons [linsert [my lIcons] end [lindex $lRow 0]]
1076  }
1077
1078  _redraw
1079}
1080
1081# name: see
1082# args: sIcon: icon names
1083# makes an icon visible. simply transforms the cell speci into a
1084# real text index and calls the "see" command.
1085metawidget proc Iconbox see { sIcon } {
1086  set iPos [_checkItem $sIcon]
1087
1088  if { [my -view] == "list" } {
1089    $this.cols see 1.0
1090    $this.text see [expr $iPos+1].0
1091  } else {
1092    $this.text see 1.$iPos
1093  }
1094}
1095
1096# name: bind
1097# args: args: as accepted by the bind command.
1098# applies bindings to the text widget itself.
1099metawidget proc Iconbox bind_ { args } {
1100  eval bind $this.text $args
1101}
1102
1103# name: size
1104# args: -
1105# returns the number of rows.
1106metawidget proc Iconbox size {} {
1107  return [llength [my lIcons]]
1108}
1109
1110# name: names
1111# args: -
1112# returns the icon names.
1113metawidget proc Iconbox names {} {
1114  return [my lIcons]
1115}
1116
1117metawidget command Iconbox _sort       _sort
1118metawidget command Iconbox _dragX      _dragX
1119metawidget command Iconbox _moveX      _moveX
1120metawidget command Iconbox _grab       _grab
1121metawidget command Iconbox _drag       _drag
1122metawidget command Iconbox _drop       _drop
1123metawidget command Iconbox _select     _select
1124metawidget command Iconbox _select2    _select2
1125metawidget command Iconbox _redraw     _redraw
1126
1127metawidget command Iconbox insert      insert
1128metawidget command Iconbox delete      delete
1129metawidget command Iconbox iconconfigure iconconfigure
1130metawidget command Iconbox iconcget    iconcget
1131metawidget command Iconbox iconbind    iconbind
1132metawidget command Iconbox selection   selection
1133metawidget command Iconbox sort        sort
1134metawidget command Iconbox see         see
1135metawidget command Iconbox bind        bind_
1136metawidget command Iconbox size        size
1137metawidget command Iconbox names       names
1138
1139metawidget option  Iconbox -columns    -columns
1140metawidget option  Iconbox -view       -view
1141metawidget option  Iconbox -update     -update
1142metawidget option  Iconbox -selectmode -selectmode
1143metawidget option  Iconbox -font       -font
1144metawidget option  Iconbox -onselect
1145
1146proc testGetFiles {} {
1147  global sPath
1148  if { $sPath == "/" } { set sPath "" }
1149
1150  .ibox delete
1151
1152  foreach sFile [glob -nocomplain $sPath/*] {
1153    set sTail [file tail $sFile]
1154    set iSize [file size $sFile]
1155    set sMod [clock format [file mtime $sFile] -format {%D %H:%M}]
1156
1157    set sIcon $sFile
1158
1159    if { [file isfile $sFile] } {
1160      .ibox insert end $sIcon -text $sTail -image pFI -smallimage pFi -values [list $iSize $sMod]
1161    } else {
1162      .ibox insert end $sIcon -text $sTail -image pFO -smallimage pFo -values [list {} $sMod]
1163      .ibox iconbind $sIcon <Double-1> "set sPath {$sIcon}; testGetFiles"
1164    }
1165  }
1166
1167  .ibox bind <Key-Return> {
1168     set sPath [lindex [.ibox selection get] 0]
1169     testGetFiles
1170  }
1171}
1172
1173proc test {} {
1174  image create photo pFo -file ./demos/images/Folder.gif
1175  image create photo pFi -file ./demos/images/File.gif
1176  image create photo pFO -file ./demos/images/Folder32.gif
1177  image create photo pFI -file ./demos/images/File32.gif
1178
1179  pack [label .head -text "Enter a path below and press Browse"] -side top -anchor w
1180  pack [frame .ctrl] -side top -fill x
1181  pack [button .ctrl.list -text "List"  -command {.ibox config -view list}] -side right
1182  pack [button .ctrl.smll -text "Small" -command {.ibox config -view small}] -side right
1183  pack [button .ctrl.lrge -text "Large" -command {.ibox config -view large}] -side right
1184  pack [button .ctrl.back -text "Back"  -command {set sPath [file dirname $sPath]; testGetFiles}] -side right
1185  pack [button .ctrl.brws -text "Browse" -command testGetFiles] -side right
1186  pack [entry  .ctrl.path -textvariable sPath] -side left -fill x -expand 1
1187  pack [iconbox .ibox -columns {{Name l 100} {Size r} {Modified}}] -side bottom -fill both -expand 1
1188}
1189
1190#test
Note: See TracBrowser for help on using the repository browser.