figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

iconlist.tcl (15978B)


      1 # iconlist.tcl
      2 #
      3 #	Implements the icon-list megawidget used in the "Tk" standard file
      4 #	selection dialog boxes.
      5 #
      6 # Copyright (c) 1994-1998 Sun Microsystems, Inc.
      7 # Copyright (c) 2009 Donal K. Fellows
      8 #
      9 # See the file "license.terms" for information on usage and redistribution of
     10 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
     11 #
     12 # API Summary:
     13 #	tk::IconList <path> ?<option> <value>? ...
     14 #	<path> add <imageName> <itemList>
     15 #	<path> cget <option>
     16 #	<path> configure ?<option>? ?<value>? ...
     17 #	<path> deleteall
     18 #	<path> destroy
     19 #	<path> get <itemIndex>
     20 #	<path> index <index>
     21 #	<path> invoke
     22 #	<path> see <index>
     23 #	<path> selection anchor ?<int>?
     24 #	<path> selection clear <first> ?<last>?
     25 #	<path> selection get
     26 #	<path> selection includes <item>
     27 #	<path> selection set <first> ?<last>?
     28 
     29 package require Tk 8.6
     30 
     31 ::tk::Megawidget create ::tk::IconList ::tk::FocusableWidget {
     32     variable w canvas sbar accel accelCB fill font index \
     33 	itemList itemsPerColumn list maxIH maxIW maxTH maxTW noScroll \
     34 	numItems oldX oldY options rect selected selection textList
     35     constructor args {
     36 	next {*}$args
     37 	set accelCB {}
     38     }
     39     destructor {
     40 	my Reset
     41 	next
     42     }
     43 
     44     method GetSpecs {} {
     45 	concat [next] {
     46 	    {-command "" "" ""}
     47 	    {-font "" "" "TkIconFont"}
     48 	    {-multiple "" "" "0"}
     49 	}
     50     }
     51 
     52     # ----------------------------------------------------------------------
     53 
     54     method index i {
     55 	if {![info exist list]} {
     56 	    set list {}
     57 	}
     58 	switch -regexp -- $i {
     59 	    "^-?[0-9]+$" {
     60 		if {$i < 0} {
     61 		    set i 0
     62 		}
     63 		if {$i >= [llength $list]} {
     64 		    set i [expr {[llength $list] - 1}]
     65 		}
     66 		return $i
     67 	    }
     68 	    "^anchor$" {
     69 		return $index(anchor)
     70 	    }
     71 	    "^end$" {
     72 		return [llength $list]
     73 	    }
     74 	    "@-?[0-9]+,-?[0-9]+" {
     75 		scan $i "@%d,%d" x y
     76 		set item [$canvas find closest \
     77 			[$canvas canvasx $x] [$canvas canvasy $y]]
     78 		return [lindex [$canvas itemcget $item -tags] 1]
     79 	    }
     80 	}
     81     }
     82 
     83     method selection {op args} {
     84 	switch -exact -- $op {
     85 	    anchor {
     86 		if {[llength $args] == 1} {
     87 		    set index(anchor) [$w index [lindex $args 0]]
     88 		} else {
     89 		    return $index(anchor)
     90 		}
     91 	    }
     92 	    clear {
     93 		switch [llength $args] {
     94 		    2 {
     95 			lassign $args first last
     96 		    }
     97 		    1 {
     98 			set first [set last [lindex $args 0]]
     99 		    }
    100 		    default {
    101 			return -code error -errorcode {TCL WRONGARGS} \
    102 			    "wrong # args: should be\
    103 			    \"[lrange [info level 0] 0 1] first ?last?\""
    104 		    }
    105 		}
    106 
    107 		set first [$w index $first]
    108 		set last [$w index $last]
    109 		if {$first > $last} {
    110 		    set tmp $first
    111 		    set first $last
    112 		    set last $tmp
    113 		}
    114 		set ind 0
    115 		foreach item $selection {
    116 		    if {$item >= $first} {
    117 			set first $ind
    118 			break
    119 		    }
    120 		    incr ind
    121 		}
    122 		set ind [expr {[llength $selection] - 1}]
    123 		for {} {$ind >= 0} {incr ind -1} {
    124 		    set item [lindex $selection $ind]
    125 		    if {$item <= $last} {
    126 			set last $ind
    127 			break
    128 		    }
    129 		}
    130 
    131 		if {$first > $last} {
    132 		    return
    133 		}
    134 		set selection [lreplace $selection $first $last]
    135 		event generate $w <<ListboxSelect>>
    136 		my DrawSelection
    137 	    }
    138 	    get {
    139 		return $selection
    140 	    }
    141 	    includes {
    142 		return [expr {[lindex $args 0] in $selection}]
    143 	    }
    144 	    set {
    145 		switch [llength $args] {
    146 		    2 {
    147 			lassign $args first last
    148 		    }
    149 		    1 {
    150 			set first [set last [lindex $args 0]]
    151 		    }
    152 		    default {
    153 			return -code error -errorcode {TCL WRONGARGS} \
    154 			    "wrong # args: should be\
    155 			    \"[lrange [info level 0] 0 1] first ?last?\""
    156 		    }
    157 		}
    158 
    159 		set first [$w index $first]
    160 		set last [$w index $last]
    161 		if {$first > $last} {
    162 		    set tmp $first
    163 		    set first $last
    164 		    set last $tmp
    165 		}
    166 
    167 		for {set i $first} {$i <= $last} {incr i} {
    168 		    lappend selection $i
    169 		}
    170 		set selection [lsort -integer -unique $selection]
    171 		event generate $w <<ListboxSelect>>
    172 		my DrawSelection
    173 	    }
    174 	}
    175     }
    176 
    177     method get item {
    178 	set rTag [lindex $list $item 2]
    179 	lassign $itemList($rTag) iTag tTag text serial
    180 	return $text
    181     }
    182 
    183     #	Deletes all the items inside the canvas subwidget and reset the
    184     #	iconList's state.
    185     #
    186     method deleteall {} {
    187 	$canvas delete all
    188 	unset -nocomplain selected rect list itemList
    189 	set maxIW 1
    190 	set maxIH 1
    191 	set maxTW 1
    192 	set maxTH 1
    193 	set numItems 0
    194 	set noScroll 1
    195 	set selection {}
    196 	set index(anchor) ""
    197 	$sbar set 0.0 1.0
    198 	$canvas xview moveto 0
    199     }
    200 
    201     #	Adds an icon into the IconList with the designated image and text
    202     #
    203     method add {image items} {
    204 	foreach text $items {
    205 	    set iID item$numItems
    206 	    set iTag [$canvas create image 0 0 -image $image -anchor nw \
    207 			  -tags [list icon $numItems $iID]]
    208 	    set tTag [$canvas create text  0 0 -text  $text  -anchor nw \
    209 			  -font $options(-font) -fill $fill \
    210 			  -tags [list text $numItems $iID]]
    211 	    set rTag [$canvas create rect  0 0 0 0 -fill "" -outline "" \
    212 			  -tags [list rect $numItems $iID]]
    213 
    214 	    lassign [$canvas bbox $iTag] x1 y1 x2 y2
    215 	    set iW [expr {$x2 - $x1}]
    216 	    set iH [expr {$y2 - $y1}]
    217 	    if {$maxIW < $iW} {
    218 		set maxIW $iW
    219 	    }
    220 	    if {$maxIH < $iH} {
    221 		set maxIH $iH
    222 	    }
    223 
    224 	    lassign [$canvas bbox $tTag] x1 y1 x2 y2
    225 	    set tW [expr {$x2 - $x1}]
    226 	    set tH [expr {$y2 - $y1}]
    227 	    if {$maxTW < $tW} {
    228 		set maxTW $tW
    229 	    }
    230 	    if {$maxTH < $tH} {
    231 		set maxTH $tH
    232 	    }
    233 
    234 	    lappend list [list $iTag $tTag $rTag $iW $iH $tW $tH $numItems]
    235 	    set itemList($rTag) [list $iTag $tTag $text $numItems]
    236 	    set textList($numItems) [string tolower $text]
    237 	    incr numItems
    238 	}
    239 	my WhenIdle Arrange
    240 	return
    241     }
    242 
    243     #	Gets called when the user invokes the IconList (usually by
    244     #	double-clicking or pressing the Return key).
    245     #
    246     method invoke {} {
    247 	if {$options(-command) ne "" && [llength $selection]} {
    248 	    uplevel #0 $options(-command)
    249 	}
    250     }
    251 
    252     #	If the item is not (completely) visible, scroll the canvas so that it
    253     #	becomes visible.
    254     #
    255     method see rTag {
    256 	if {$noScroll} {
    257 	    return
    258 	}
    259 	set sRegion [$canvas cget -scrollregion]
    260 	if {$sRegion eq ""} {
    261 	    return
    262 	}
    263 
    264 	if {$rTag < 0 || $rTag >= [llength $list]} {
    265 	    return
    266 	}
    267 
    268 	set bbox [$canvas bbox item$rTag]
    269 	set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]
    270 
    271 	set x1 [lindex $bbox 0]
    272 	set x2 [lindex $bbox 2]
    273 	incr x1 [expr {$pad * -2}]
    274 	incr x2 [expr {$pad * -1}]
    275 
    276 	set cW [expr {[winfo width $canvas] - $pad*2}]
    277 
    278 	set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}]
    279 	set dispX [expr {int([lindex [$canvas xview] 0]*$scrollW)}]
    280 	set oldDispX $dispX
    281 
    282 	# check if out of the right edge
    283 	#
    284 	if {($x2 - $dispX) >= $cW} {
    285 	    set dispX [expr {$x2 - $cW}]
    286 	}
    287 	# check if out of the left edge
    288 	#
    289 	if {($x1 - $dispX) < 0} {
    290 	    set dispX $x1
    291 	}
    292 
    293 	if {$oldDispX ne $dispX} {
    294 	    set fraction [expr {double($dispX) / double($scrollW)}]
    295 	    $canvas xview moveto $fraction
    296 	}
    297     }
    298 
    299     # ----------------------------------------------------------------------
    300 
    301     #	Places the icons in a column-major arrangement.
    302     #
    303     method Arrange {} {
    304 	if {![info exists list]} {
    305 	    if {[info exists canvas] && [winfo exists $canvas]} {
    306 		set noScroll 1
    307 		$sbar configure -command ""
    308 	    }
    309 	    return
    310 	}
    311 
    312 	set W [winfo width  $canvas]
    313 	set H [winfo height $canvas]
    314 	set pad [expr {[$canvas cget -highlightthickness]+[$canvas cget -bd]}]
    315 	if {$pad < 2} {
    316 	    set pad 2
    317 	}
    318 
    319 	incr W [expr {$pad*-2}]
    320 	incr H [expr {$pad*-2}]
    321 
    322 	set dx [expr {$maxIW + $maxTW + 8}]
    323 	if {$maxTH > $maxIH} {
    324 	    set dy $maxTH
    325 	} else {
    326 	    set dy $maxIH
    327 	}
    328 	incr dy 2
    329 	set shift [expr {$maxIW + 4}]
    330 
    331 	set x [expr {$pad * 2}]
    332 	set y [expr {$pad * 1}] ; # Why * 1 ?
    333 	set usedColumn 0
    334 	foreach sublist $list {
    335 	    set usedColumn 1
    336 	    lassign $sublist iTag tTag rTag iW iH tW tH
    337 
    338 	    set i_dy [expr {($dy - $iH)/2}]
    339 	    set t_dy [expr {($dy - $tH)/2}]
    340 
    341 	    $canvas coords $iTag $x                    [expr {$y + $i_dy}]
    342 	    $canvas coords $tTag [expr {$x + $shift}]  [expr {$y + $t_dy}]
    343 	    $canvas coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}]
    344 
    345 	    incr y $dy
    346 	    if {($y + $dy) > $H} {
    347 		set y [expr {$pad * 1}] ; # *1 ?
    348 		incr x $dx
    349 		set usedColumn 0
    350 	    }
    351 	}
    352 
    353 	if {$usedColumn} {
    354 	    set sW [expr {$x + $dx}]
    355 	} else {
    356 	    set sW $x
    357 	}
    358 
    359 	if {$sW < $W} {
    360 	    $canvas configure -scrollregion [list $pad $pad $sW $H]
    361 	    $sbar configure -command ""
    362 	    $canvas xview moveto 0
    363 	    set noScroll 1
    364 	} else {
    365 	    $canvas configure -scrollregion [list $pad $pad $sW $H]
    366 	    $sbar configure -command [list $canvas xview]
    367 	    set noScroll 0
    368 	}
    369 
    370 	set itemsPerColumn [expr {($H-$pad) / $dy}]
    371 	if {$itemsPerColumn < 1} {
    372 	    set itemsPerColumn 1
    373 	}
    374 
    375 	my DrawSelection
    376     }
    377 
    378     method DrawSelection {} {
    379 	$canvas delete selection
    380 	$canvas itemconfigure selectionText -fill black
    381 	$canvas dtag selectionText
    382 	set cbg [ttk::style lookup TEntry -selectbackground focus]
    383 	set cfg [ttk::style lookup TEntry -selectforeground focus]
    384 	foreach item $selection {
    385 	    set rTag [lindex $list $item 2]
    386 	    foreach {iTag tTag text serial} $itemList($rTag) {
    387 		break
    388 	    }
    389 
    390 	    set bbox [$canvas bbox $tTag]
    391 	    $canvas create rect $bbox -fill $cbg -outline $cbg \
    392 		-tags selection
    393 	    $canvas itemconfigure $tTag -fill $cfg -tags selectionText
    394 	}
    395 	$canvas lower selection
    396 	return
    397     }
    398 
    399     #	Creates an IconList widget by assembling a canvas widget and a
    400     #	scrollbar widget. Sets all the bindings necessary for the IconList's
    401     #	operations.
    402     #
    403     method Create {} {
    404 	variable hull
    405 	set sbar [ttk::scrollbar $hull.sbar -orient horizontal -takefocus 0]
    406 	catch {$sbar configure -highlightthickness 0}
    407 	set canvas [canvas $hull.canvas -highlightthick 0 -takefocus 1 \
    408 			-width 400 -height 120 -background white]
    409 	pack $sbar -side bottom -fill x -padx 2 -pady {0 2}
    410 	pack $canvas -expand yes -fill both -padx 2 -pady {2 0}
    411 
    412 	$sbar configure -command [list $canvas xview]
    413 	$canvas configure -xscrollcommand [list $sbar set]
    414 
    415 	# Initializes the max icon/text width and height and other variables
    416 	#
    417 	set maxIW 1
    418 	set maxIH 1
    419 	set maxTW 1
    420 	set maxTH 1
    421 	set numItems 0
    422 	set noScroll 1
    423 	set selection {}
    424 	set index(anchor) ""
    425 	set fg [option get $canvas foreground Foreground]
    426 	if {$fg eq ""} {
    427 	    set fill black
    428 	} else {
    429 	    set fill $fg
    430 	}
    431 
    432 	# Creates the event bindings.
    433 	#
    434 	bind $canvas <Configure>	[namespace code {my WhenIdle Arrange}]
    435 
    436 	bind $canvas <1>		[namespace code {my Btn1 %x %y}]
    437 	bind $canvas <B1-Motion>	[namespace code {my Motion1 %x %y}]
    438 	bind $canvas <B1-Leave>		[namespace code {my Leave1 %x %y}]
    439 	bind $canvas <Control-1>	[namespace code {my CtrlBtn1 %x %y}]
    440 	bind $canvas <Shift-1>		[namespace code {my ShiftBtn1 %x %y}]
    441 	bind $canvas <B1-Enter>		[list tk::CancelRepeat]
    442 	bind $canvas <ButtonRelease-1>	[list tk::CancelRepeat]
    443 	bind $canvas <Double-ButtonRelease-1> \
    444 	    [namespace code {my Double1 %x %y}]
    445 
    446 	bind $canvas <Control-B1-Motion> {;}
    447 	bind $canvas <Shift-B1-Motion>	[namespace code {my ShiftMotion1 %x %y}]
    448 
    449 	bind $canvas <<PrevLine>>	[namespace code {my UpDown -1}]
    450 	bind $canvas <<NextLine>>	[namespace code {my UpDown  1}]
    451 	bind $canvas <<PrevChar>>	[namespace code {my LeftRight -1}]
    452 	bind $canvas <<NextChar>>	[namespace code {my LeftRight  1}]
    453 	bind $canvas <Return>		[namespace code {my ReturnKey}]
    454 	bind $canvas <KeyPress>		[namespace code {my KeyPress %A}]
    455 	bind $canvas <Control-KeyPress> ";"
    456 	bind $canvas <Alt-KeyPress>	";"
    457 
    458 	bind $canvas <FocusIn>		[namespace code {my FocusIn}]
    459 	bind $canvas <FocusOut>		[namespace code {my FocusOut}]
    460 
    461 	return $w
    462     }
    463 
    464     #	This procedure is invoked when the mouse leaves an entry window with
    465     #	button 1 down.  It scrolls the window up, down, left, or right,
    466     #	depending on where the mouse left the window, and reschedules itself
    467     #	as an "after" command so that the window continues to scroll until the
    468     #	mouse moves back into the window or the mouse button is released.
    469     #
    470     method AutoScan {} {
    471 	if {![winfo exists $w]} return
    472 	set x $oldX
    473 	set y $oldY
    474 	if {$noScroll} {
    475 	    return
    476 	}
    477 	if {$x >= [winfo width $canvas]} {
    478 	    $canvas xview scroll 1 units
    479 	} elseif {$x < 0} {
    480 	    $canvas xview scroll -1 units
    481 	} elseif {$y >= [winfo height $canvas]} {
    482 	    # do nothing
    483 	} elseif {$y < 0} {
    484 	    # do nothing
    485 	} else {
    486 	    return
    487 	}
    488 	my Motion1 $x $y
    489 	set ::tk::Priv(afterId) [after 50 [namespace code {my AutoScan}]]
    490     }
    491 
    492     # ----------------------------------------------------------------------
    493 
    494     # Event handlers
    495     method Btn1 {x y} {
    496 	focus $canvas
    497 	set i [$w index @$x,$y]
    498 	if {$i eq ""} {
    499 	    return
    500 	}
    501 	$w selection clear 0 end
    502 	$w selection set $i
    503 	$w selection anchor $i
    504     }
    505     method CtrlBtn1 {x y} {
    506 	if {$options(-multiple)} {
    507 	    focus $canvas
    508 	    set i [$w index @$x,$y]
    509 	    if {$i eq ""} {
    510 		return
    511 	    }
    512 	    if {[$w selection includes $i]} {
    513 		$w selection clear $i
    514 	    } else {
    515 		$w selection set $i
    516 		$w selection anchor $i
    517 	    }
    518 	}
    519     }
    520     method ShiftBtn1 {x y} {
    521 	if {$options(-multiple)} {
    522 	    focus $canvas
    523 	    set i [$w index @$x,$y]
    524 	    if {$i eq ""} {
    525 		return
    526 	    }
    527 	    if {[$w index anchor] eq ""} {
    528 		$w selection anchor $i
    529 	    }
    530 	    $w selection clear 0 end
    531 	    $w selection set anchor $i
    532 	}
    533     }
    534 
    535     #	Gets called on button-1 motions
    536     #
    537     method Motion1 {x y} {
    538 	set oldX $x
    539 	set oldY $y
    540 	set i [$w index @$x,$y]
    541 	if {$i eq ""} {
    542 	    return
    543 	}
    544 	$w selection clear 0 end
    545 	$w selection set $i
    546     }
    547     method ShiftMotion1 {x y} {
    548 	set oldX $x
    549 	set oldY $y
    550 	set i [$w index @$x,$y]
    551 	if {$i eq ""} {
    552 	    return
    553 	}
    554 	$w selection clear 0 end
    555 	$w selection set anchor $i
    556     }
    557     method Double1 {x y} {
    558 	if {[llength $selection]} {
    559 	    $w invoke
    560 	}
    561     }
    562     method ReturnKey {} {
    563 	$w invoke
    564     }
    565     method Leave1 {x y} {
    566 	set oldX $x
    567 	set oldY $y
    568 	my AutoScan
    569     }
    570     method FocusIn {} {
    571 	$w state focus
    572 	if {![info exists list]} {
    573 	    return
    574 	}
    575 	if {[llength $selection]} {
    576 	    my DrawSelection
    577 	}
    578     }
    579     method FocusOut {} {
    580 	$w state !focus
    581 	$w selection clear 0 end
    582     }
    583 
    584     #	Moves the active element up or down by one element
    585     #
    586     # Arguments:
    587     #	amount -	+1 to move down one item, -1 to move back one item.
    588     #
    589     method UpDown amount {
    590 	if {![info exists list]} {
    591 	    return
    592 	}
    593 	set curr [$w selection get]
    594 	if {[llength $curr] == 0} {
    595 	    set i 0
    596 	} else {
    597 	    set i [$w index anchor]
    598 	    if {$i eq ""} {
    599 		return
    600 	    }
    601 	    incr i $amount
    602 	}
    603 	$w selection clear 0 end
    604 	$w selection set $i
    605 	$w selection anchor $i
    606 	$w see $i
    607     }
    608 
    609     #	Moves the active element left or right by one column
    610     #
    611     # Arguments:
    612     #	amount -	+1 to move right one column, -1 to move left one
    613     #			column
    614     #
    615     method LeftRight amount {
    616 	if {![info exists list]} {
    617 	    return
    618 	}
    619 	set curr [$w selection get]
    620 	if {[llength $curr] == 0} {
    621 	    set i 0
    622 	} else {
    623 	    set i [$w index anchor]
    624 	    if {$i eq ""} {
    625 		return
    626 	    }
    627 	    incr i [expr {$amount * $itemsPerColumn}]
    628 	}
    629 	$w selection clear 0 end
    630 	$w selection set $i
    631 	$w selection anchor $i
    632 	$w see $i
    633     }
    634 
    635     #	Gets called when user enters an arbitrary key in the listbox.
    636     #
    637     method KeyPress key {
    638 	append accel $key
    639 	my Goto $accel
    640 	after cancel $accelCB
    641 	set accelCB [after 500 [namespace code {my Reset}]]
    642     }
    643 
    644     method Goto text {
    645 	if {![info exists list]} {
    646 	    return
    647 	}
    648 	if {$text eq "" || $numItems == 0} {
    649 	    return
    650 	}
    651 
    652 	if {[llength [$w selection get]]} {
    653 	    set start [$w index anchor]
    654 	} else {
    655 	    set start 0
    656 	}
    657 	set theIndex -1
    658 	set less 0
    659 	set len [string length $text]
    660 	set len0 [expr {$len - 1}]
    661 	set i $start
    662 
    663 	# Search forward until we find a filename whose prefix is a
    664 	# case-insensitive match with $text
    665 	while {1} {
    666 	    if {[string equal -nocase -length $len0 $textList($i) $text]} {
    667 		set theIndex $i
    668 		break
    669 	    }
    670 	    incr i
    671 	    if {$i == $numItems} {
    672 		set i 0
    673 	    }
    674 	    if {$i == $start} {
    675 		break
    676 	    }
    677 	}
    678 
    679 	if {$theIndex > -1} {
    680 	    $w selection clear 0 end
    681 	    $w selection set $theIndex
    682 	    $w selection anchor $theIndex
    683 	    $w see $theIndex
    684 	}
    685     }
    686     method Reset {} {
    687 	unset -nocomplain accel
    688     }
    689 }
    690 
    691 return
    692 
    693 # Local Variables:
    694 # mode: tcl
    695 # fill-column: 78
    696 # End: