# $Header: /home/cvsroot/tcldb/ucodb/Tlib/pickList,v 1.4 1998/03/22 21:44:01 de Exp $
# tcl procs saved on Sun Sep 03 16:18:52 PDT 1995

proc pickList {win heading geom plist callproc} {

	global  bitmapdir


#  puts stderr "Entering pickList window name $win callproc $callproc..."

# make sure we do NOT create windows whose names start with upcase
# letters (illegal in Tk 3.2)
  set win_title $win
  regsub -all {_} $win_title " " win_title
  set win [translit A-Z a-z $win]

  catch {destroy $win}
  toplevel $win
  wm title $win [string range $win_title 1 end]
  wm iconbitmap $win @$bitmapdir/picklist.xbm

# try to use appropriate string processing when selected text is pasted
  selection handle $win "handleList $win 0 end"

# catch-22 ! the proc is not in info commands until it is
# loaded and it isn't loaded until it is called.  HACK
# try catching a call with no args, in the hope that it will
# error out and do nothing (DANGER Will Robinson, DANGER)
  set err [catch $callproc]
  set doproc [string length [info commands $callproc]]
#  puts stderr "pickList doproc is $doproc for callproc $callproc"
#  puts stderr "info commands $callproc is [info commands $callproc]"
 
  # FIX THIS  -- this is a mistake
  # try to place window away from the main toplevel
  set tg [winfo geom .]
  set temp ""
  set ptr 0
  while {$ptr < [clength $tg]} {
	set curchar [crange $tg $ptr $ptr]
	case $curchar in {
	{1 2 3 4 5 6 7 8 9 0} {
		append temp $curchar
	}
	{x} {
		set xsiz $temp
		set temp ""
		set lookingfor ysiz
	}
	{+ -} {
		case $lookingfor in {
		{ysiz} {
			set ysiz $temp
			set temp ""
			set xpsign $curchar
			set lookingfor "xpos"
			continue
		}		
		{xpos} {
			set xpos $temp
			set temp ""
			set ypsign $curchar
		}
		}
	}
	}
	incr ptr
   }
   set ypos $temp
	
#  set topgeom [split [split [winfo geom .] x] +]
   if {$xpsign == "+"} {
	set newx [lindex [split [expr {$xpos + $xsiz * .80}] .] 0]
   } else {
	set newx [expr {$xpos - 10}]
   }

   if {$ypsign == "+"} {
	set newy [lindex [split [expr {$ypos + $ysiz * .25}] .] 0]
   } else {
	set newy [expr {$ypos - 10}]
   }
#  set newx [expr {[lindex $topgeom 1] + [lindex [lindex $topgeom 0] 0]} ]
#  set newy [expr {[lindex $topgeom 2] + 10}]
#  set newy [expr {[lindex $topgeom 2] + [lindex [lindex $topgeom 0] 1]} ]

  wm geom $win ${geom}+${newx}+$newy
  set w [lindex [split $geom x] 0]
  set h [lindex [split $geom x] 1]
  wm minsize $win $w $h

  frame $win.l -background antiquewhite
  frame $win.f -background antiquewhite
  frame $win.b -relief sunken -borderwidth 1 -bg bisque

  set font [getFont $win mediumcou]
  label $win.l.l -text $heading -anchor w -font $font -background antiquewhite
  scrollbar $win.f.vert -orient vertical -command "$win.f.box yview" 	-relief sunken -background ivory -activebackground mistyrose -troughcolor bisque
  listbox $win.f.box -yscroll "$win.f.vert set"  -relief sunken 	 -font $font -background ivory
  
  if $doproc {
    bind $win.f.box <Double-1> "$win.b.ok invoke"
  }

  foreach lem $plist {
    $win.f.box insert end $lem
  }

 
  if $doproc {
    if {[crange $callproc 0 0] == "."} {
	button $win.b.ok  -text "Transfer" -relief raised -borderwidth 2  -command "catch \{dumpLB $win.f.box $callproc\}" -padx 0 -pady 0 -background lemonchiffon -activebackground lemonchiffon -activeforeground magenta2
    } else {
    button $win.b.ok  -text "OK"     -relief raised -borderwidth 2  -command "catch \{ $callproc \[selection get\]  \} " -padx 0 -pady 0 -background lemonchiffon -activebackground lemonchiffon -activeforeground magenta2
		# -command "$callproc \[selection get\] "
		# -command "$callproc \[selection get\] ; destroy $win;break "
    } 
  }

  button $win.b.can -text "Cancel" -relief raised -borderwidth 2 -command "destroy $win" -padx 0 -pady 0 -background white -foreground red -activebackground black -activeforeground yellow

  pack $win.l -side top -fill x 		   
  pack $win.f -side top -fill both -expand true 		   
  pack $win.b -side bottom -fill x

  pack $win.l.l    -side top -fill x -anchor nw
  pack $win.f.vert -side right -fill both 		     
  pack $win.f.box  -side left -fill both -expand true

  if $doproc {
    pack $win.b.ok -side left -fill x -expand true 
  }
  pack $win.b.can -side right -fill x -expand true

  #$win.f.box select from 0

  bind $win.f.box <Any-Button1-Motion> "$win.f.box size"
  bind $win.f.box <Any-Button2-Motion> "$win.f.box size"
}

