tkgate-data 1.8.7-4 / usr / share / tkgate-1.8.7 / scripts / dropbox.tcl

#   Copyright (C) 1987-2007 by Jeffery P. Hansen
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# Last edit by hansen on Wed Jan  7 14:37:42 2004
#

set dropbox_debug 0

if { $dropbox_debug } {
  source "misc.tcl"
}

image create bitmap dropbox_arrow -data {
#define dbarrow_width 5
#define dbarrow_height 3
static unsigned char dbarrow_bits[] = {
    0x1f, 0x0e, 0x04};
}


#############################################################################
#
# 
#
namespace eval Dropbox {
  variable contents
  variable did_leave
  variable p_width
  variable p_height
  variable p_command
  variable p_value
  variable p_variable
  variable p_entry

  proc init {w} {
    variable p_width
    variable p_height
    variable p_command
    variable p_value
    variable p_variable
    variable p_entry
    variable contents

    set p_width($w) 15
    set p_height($w) 5
    set p_command($w) ""
    set p_value($w) ""
    set p_variable($w) ""
    set p_entry($w) 0
  }

  proc new {w args} {
    variable contents

    frame $w -bd 2 -relief sunken
    entry $w.e -bd 0 -relief flat -bg white -state disabled -bg white

    #
    # This is supported from tcl/tk 8.4
    #
    catch { $w.e configure -disabledbackground white -disabledforeground black }

    label $w.b -image dropbox_arrow -width 10
    pack $w.e $w.b -side left -fill y
    set contents($w) {}

    init $w
    configurel $w $args

    bind $w <Enter> "Dropbox::enter $w"
    bind $w <Leave> "Dropbox::leave $w"
    bind $w.b <Button-1> "Dropbox::press $w"
    bind $w.e <KeyPress-Return> "Dropbox::return $w"
  }
  proc enter {w} {
    $w.b configure -relief raised
  }
  proc leave {w} {
    $w.b configure -relief flat
  }
  proc press {w} {
    variable did_enter

    $w.b configure -relief sunken
    grab release $w.b
    set did_enter 0
    Dropbox::showlist $w
  }
  proc return {w} {
    catch { destroy .dblist }
    configure $w -value [$w.e get]
    docommand $w
  }
  proc itemadd {w l} {
    variable contents
    foreach item $l {
      lappend contents($w) $item
    }
  }
  proc flush {w} {
    variable contents
    set contents($w) {}
  }
  proc configure {w args} {
    configurel $w $args
  }
  proc configurel {w argv} {
    variable p_width
    variable p_height
    variable p_command
    variable p_value
    variable p_variable
    variable p_entry

    parseargs $argv {-width -height -command -value -variable -entry}
    if {![catch {set width}]} {
      set p_width($w) $width
      $w.e configure -width $width
    }
    if {![catch {set value}]} {
      set p_value($w) $value
      $w.e configure -state normal
      $w.e delete 0 end
      $w.e insert end $value
      if { $p_entry($w) == 0 } { $w.e configure -state disabled -bg white }
      if { $p_variable($w) != "" } {
	global $p_variable($w)
	set $p_variable($w) $value
      }
    }
    if {![catch {set height}]} { set p_height($w) $height }
    if {![catch {set command}]} { set p_command($w) $command }
    if {![catch {set variable}]} { set p_variable($w) $variable }
    if {![catch {set entry}]} { 
      set p_entry($w) $entry
      if { $entry == 0 } {
	$w.e configure -state disabled -bg white
      } else {
	$w.e configure -state normal
      }
    }
  }
  proc docommand {w} {
    variable p_command
    variable p_value
    if { $p_command($w) != "" } {
	$p_command($w) $w $p_value($w)
}
  }
  proc listdnaction {w W} {
    if { $W == ".dblist" } { destroy .dblist }
  }
  proc listupaction {w W} {
    variable did_enter
    variable p_command

    if { $W == ".dblist.lb" } { 
      set i [.dblist.lb curselection]
      if  {$i != ""} {
	set text [.dblist.lb get $i]
	configure $w -value $text
	docommand $w
      }
    }
    if { $did_enter && $W != ".dblist.vb" } { destroy .dblist }
  }
  proc showlist {w} {
    variable contents
    variable p_width
    variable p_height

    catch { destroy .dblist }
    toplevel .dblist -cursor arrow

    set w_top [winfo toplevel $w]

    set X [winfo rootx $w]
    set Y [winfo rooty $w]
    scan [winfo geometry $w] "%dx%d+%d+%d" W H Xw Yw

    wm geometry .dblist +[expr $X]+[expr $Y + $H]
    wm transient .dblist $w
    wm overrideredirect .dblist 1

    listbox .dblist.lb -bg white -yscrollcommand ".dblist.vb set" -height $p_height($w) -width $p_width($w)
    scrollbar .dblist.vb -command ".dblist.lb yview"
    pack .dblist.lb .dblist.vb -side left -fill y

    foreach i $contents($w) {
      .dblist.lb insert end $i
    }

    bind $w_top <Configure> { destroy .dblist }
    bind .dblist <Button-1> "Dropbox::listdnaction $w %W"
    bind .dblist <ButtonRelease-1> "Dropbox::listupaction $w %W"
    bind .dblist <Enter> "set Dropbox::did_enter 1"

    update
    grab set .dblist
    tkwait window .dblist
  }
}

#
# If in debugging mode, throw up a simple dropbox
# for testing.
#
if { $dropbox_debug } {
  proc box_changed {w v} {
    puts "box_changed w=$w v=$v"
    focus .
  }

  Dropbox::new .db1 -width 10 -command box_changed -value Sand
  Dropbox::new .db2 -width 10 -command box_changed -value Oo-Toro -entry 1
  Dropbox::new .db3 -width 10 -command box_changed -value Diplodocus

  button .dismiss -text Dismiss -command { destroy . }
  pack .db1 .db2 .db3 .dismiss -padx 10 -pady 10

  Dropbox::itemadd .db1 Foo
  Dropbox::itemadd .db1 Bar
  Dropbox::itemadd .db1 Bletch
  Dropbox::itemadd .db1 Vomit
  Dropbox::itemadd .db1 Sand
  Dropbox::itemadd .db1 Bile
  Dropbox::itemadd .db1 Smelly
  Dropbox::itemadd .db1 Socks

  Dropbox::itemadd .db2 Hamachi
  Dropbox::itemadd .db2 Maguro
  Dropbox::itemadd .db2 Suzuki
  Dropbox::itemadd .db2 Ikura
  Dropbox::itemadd .db2 Tobiko
  Dropbox::itemadd .db2 Odori
  Dropbox::itemadd .db2 Ika
  Dropbox::itemadd .db2 Oo-Toro


  Dropbox::itemadd .db3 Diplodocus
  Dropbox::itemadd .db3 Apatasaurus
  Dropbox::itemadd .db3 Stegosaurus
  Dropbox::itemadd .db3 Styracasaurus
  Dropbox::itemadd .db3 Tyrannosaurus
}