#
# Code for adding keybindings and menus to remote widgets
#


if {[info procs get_widget] == ""} {
  source "[file dirname [info script]]/../aux/teach.tcl"
}
if {[info exists All_Bindings] == 0} {
  source "$TH_Dir/aux/bindings.$TH_Bindings_Set/bindings.tcl"
}
catch {source "$TH_Dir/aux/bindings.$TH_Bindings_Set/$Bind_Keyword.tcl"}
if {[info procs KeysymBox] == ""} {
  catch {source "$XF_Dir/templates/Procedures/KeysymBox.t"}
}
if {[info procs th_Misc_menus] == ""} {
  catch {source "$TH_Dir/lib/tk.tcl"}
}

if {[info globals Bind_Loaded] == ""} {

set Bind_Loaded 1

# Help text.
if {[info globals TH_Change_Help] == ""} {set TH_Change_Help ""}

set TH_Bind_Help "" ; append TH_Bind_Help {
The Change Menu

  Binding

This option allows you to change the key or menu bindings provided by this
hypertool. After selecting this option, the first key or function to get invoked
is brought up in the Binding Window for you to change.

  Menu

This option allows you to state where the new menus get placed when you elect to
create menubindings for a widget. After selecting this option, click on a
menubar or menubutton in a remote application, and the widget name will be shown
in the "Default Menubar" label. From then on, any widgets that get taught menus
will place them in that menubar, no matter which hypertool teaches them.

Alternatively you can click outside any Tk application, in which case the
"Default Menubar" label will turn blank. In this case, a menubar will be created
above any taught widget and it will hold all that widget's menus.
} $TH_Change_Help {

The Binding Window

This window gets brought up and allows you to change the keys and menus
associated with each binding. You can hit 'OK' to confirm your changes, or
'Cancel' to forget the changes you've made.

The keys entry contains the keys that perform the associated binding function.
More than one key can be bound, and all keys listed will perform the function.
The first key is shown as an 'accelerator' on the corresponding menu entry.
Also, you can leave this entry blank, whence no keys get bound to the function.
The "Keys" button, if active, brings up the Keysyms window from XF (if it is
available), which is helpful for selecting keys on the keyboard.

The menus entry contains the menu hierarchy where the menu entry that performs
this function gets placed. Each element in the menu hierarchy consists of a word
or phrase and a number. The phrase is the text that gets placed in the menu
hierarchy, and the number indicates which character in the phrase gets
underlined, with 0 being the leftmost character, 1 the next one, etc. Leaving
out the number, or using -1 causes no character to be underlined. The first
phrase is the name of the menubutton to store this function on. The last phrase
is the name of the menuentry to bind the function to. Any phrases in the middle
indicate cascade menuentries between the top menubutton and the command
menuentry.

This entry can be left blank, in which case no menu entry gets created for this
function. Otherwise, it must contain at least two items, the menubutton item and
the command item. It can also contain any number of cascade items in between.

Beware that while it is possible to leave blank both the menu entry and the keys
entry, allowing a function to have no menu or key essentially 'locks out' that
function, since there would then be no way to refer to that function. You would
have to restart the tool to reuse that function.


The "Press Keys Here" Entry

This entry demonstrates the keys that can be taught to other applications. When
you press a key here, if that key has a binding, then the program lets you
select a remote widget to perform the binding's function.


Numbered Menus

These menus contains all the functions that this tool provides. Notice that each
menu entry has a key associated with it, as well as an implicit function. When
you teach a remote widget the stuff in this tool, the remote widget gets the
keybindings associated with the functions, and it may also get the same menu
shown here (though the menus will be named, not numbered.)

This menu is mainly to show you what functions are available, and their
associated keys. However, you can use this menu just to execute the function
without teaching bindings or menus. After selecting an option, you may select a
widget in any remote application. Once you select that widget. the menu's
function gets executed in that widget. This may require this tool to teach the
remote tool some code, but it adds no keybindings or menus. This is useful for
performing functions on remote applications without teaching them any keys or
menus.

} $TH_Help {

While much more flexible, Tk 4.0's binding mechanism is considerably more
complicated. Bindings provided by these hypertools only overwrite the Tk
bindings for the appropriate bindtag you specify (either a widget name or its
class). So if a binding has a hypertool-defined function for its widget bindtag,
but a Tk function for its class bindtag, both functions get executed when you
press that key. Sometimes two functions can get executed for slightly different
keys. For example, if you press Meta-Control-t on an Entry widget, the Entry's
<Control-t> binding, which transposes two characters, is executed. The best way
to avoid this problem is use 'Class Keybindings', since most of Tk's bindings
are defined for widget classes.}


# For a binding, returns the code necessary to teach that bindtag the
# keybinding. Prefix is "uplevel #0" or "send $app" for the app that contains
# the bindtag.
proc keybind_code {bindtag binding cmd {prefix "uplevel #0"}} {
# What binding should we really use?
  if {$prefix == "uplevel #0"} {
    set command "execute_or_change_binding $binding \{$cmd\}"
  } else {set command $cmd}

  global All_Bindings
  set bindings [lindex $All_Bindings($binding) 0]
  set needed_bindings ""
  foreach binding $bindings {
    if {[eval "$prefix bind $bindtag $binding"] != $command} {
      lappend needed_bindings $binding
  }}
  switch [llength $needed_bindings] {
    0 {return ""
  } 1 {return "bind $bindtag [lindex $needed_bindings 0] \{$command\}\n"
  } default {return "foreach th_binding \{$needed_bindings\} \{\n\
  bind $bindtag \$th_binding \{$command\}\}\n"
}}}

# Returns code necessary to pack something immdeiately on side $side
# of Widget (in App)
proc pack_side_parms {w {side top} {prefix "uplevel #0"}} {
  if {[eval $prefix winfo manager $w] != "pack"} {return $side}

  set info [eval $prefix pack info $w]
  set i [lsearch $info "-side"] ; incr i
  set w_side [lindex $info $i]
  switch [list $w_side $side] {
    {top bottom} - {left right} - {bottom top} - {right left} {
      set code "-after $w -side $w_side"
    } default {set code "-before $w -side $side"
  }}
  set sides {left right top botto} ; set anchor {w e n s}
  return "$code -anchor [lindex {n e w s} [lsearch {top right left bottom} \
		$w_side]]"
}

set TH(Symname) "symth"
set TH(Symnum) 0

# Returns a new symbol upon each call
proc th_gensym {} {
  global TH
  incr TH(Symnum)
  return $TH(Symname)$TH(Symnum)
}

# Returns App's menubar.
proc app_menubar {widget prefix} {
  global Aux_App Aux_Menu App
# If app already has a menubar assigned to this widget, use that.
  if {![catch {$prefix set TH(Menubar,$widget)} result]} {return $result}
# If we can assign it one, use Aux_Menu
  if {($Aux_App == $App) && ($Aux_Menu != "")} {return $Aux_Menu}
# OK, we'll make one up, then.
  if {[eval $prefix winfo manager $widget] == "pack"} {
# Make it a sibling of the widget, it can be packed next to the widget.
    return "[set widget]_mb"
# Make it a child of the widget's toplevel window, pack it in toplevel.
  } else {return "[underscore_widget $widget $prefix]_mb"}
}

proc underscore_widget {widget prefix} {
  if {([set tl [eval $prefix winfo toplevel $widget]] == ".")} {
    regsub -- {\.} [string range $widget 1 end] {_} rest
    return ".$rest"
  } elseif {$tl == $widget} {
    return "[set widget].w"
  } else {
    regsub -all -- {\.} [string range $widget [expr [string length $tl] + 1] end] {_} rest
    return "$tl.$rest"
}}

# Returns code necessary to generate the menubar.
proc menubar_code {widget {prefix "uplevel #0"}} {
  set menubar [app_menubar $widget $prefix]
  global Aux_Menu Aux_App App
  if {($Aux_App == $App) && ($Aux_Menu != "")} {
    return "set TH(Menubar,$widget) $Aux_Menu"}
  if {![catch {send $App set TH(Menubar,$widget)}]} {return}
  set code ""
  if {[eval $prefix winfo manager $widget] != "pack"} {
    set parent [eval "$prefix winfo toplevel $widget"]
    if {![catch "$prefix pack slaves $parent" result]} {
      if {[lsearch $result $menubar] >= 0} {return $code}}
    set code "pack $menubar -fill x -expand yes -before [lindex $result 0]\n$code\n"
  } else {set parent [eval "$prefix winfo toplevel $widget"]
    if {![catch "$prefix pack slaves $parent" result]} {
      if {[lsearch $result $menubar] >= 0} {return $code}}
    set code "pack $menubar -f x [pack_side_parms $widget top $prefix]\n$code"
  }

  if {[eval "$prefix winfo exists $menubar"]} {return $code}
  return "frame $menubar\nset TH(Menubar,$widget) $menubar\n$code\n"
}

# For a binding, returns the code necessary to teach that widget (or class) the
# menu. Prefix is "uplevel #0" or "send $app" for the app that contains the
# widget.
proc menu_code {widget binding cmd {prefix "uplevel #0"}} {
  global All_Bindings
  set code ""

# Important variables
  set menu_sets [lindex $All_Bindings($binding) 1]
  if {[llength $All_Bindings($binding)] <= 2} {set variable ""
  } else {
    set stuff [regexp_replace [lindex $All_Bindings($binding) 2] %W $widget]
    set variable "TH([lindex $stuff 0])"
    set on [lindex $stuff 1]
    set off [lindex $stuff 2]
    if {$on == ""} {set on 1}
    if {$off == ""} {set off 0}
   }
  if {$menu_sets == ""} {return}
  set ml [expr [llength $menu_sets] - 1]
  set first_menu_set [lindex $menu_sets 0]
  set first_menu_name [lindex $first_menu_set 0]
  set last_menu_set [lindex $menu_sets $ml]
  set last_menu_name [lindex $last_menu_set 0]
  set cascade_menu_sets [lrange $menu_sets 1 [expr $ml - 1]]
  set menubar [app_menubar $widget $prefix]
  set menubutton "$menubar.mb_[string tolower $first_menu_name]"
  set first_menu_widget "$menubutton.m"
  set last_menu_widget $first_menu_widget
  foreach cascade_menu_set $cascade_menu_sets {
    append last_menu_widget ".[string tolower [lindex $cascade_menu_set 0]]"
  }

# What binding should we really use?
  if {$prefix == "uplevel #0"} {
    set command "execute_or_change_binding \{$binding\} \{$cmd\}"
  } else {
    set command "if \{!\[winfo exists $widget\]\} \{destroy $menubar\} else \{\n  $cmd\}"
  }

# Check existance of command menuentry.
  if {[llength $last_menu_set] > 0} {set underline [lindex $last_menu_set 1]
  } else {set underline -1}

  set accel [lindex [lindex $All_Bindings($binding) 0] 0]
  if {$prefix != "uplevel #0"} {
    if {[catch "$prefix bindtags $widget" bindtags]} {return}
    foreach bindtag $bindtags {
      if {[catch "$prefix bind $bindtag $accel" result]} {return}
      if {$result != ""} {break}}
    set result [regexp_replace $result %W $widget]
    if {$result != $cmd} {set accel ""}}

  set configure_code "$last_menu_widget entryconfigure \{$last_menu_name\} -u $underline -acc \{$accel\} -co \{$command\}"
  if {$variable == ""} {
    set create_code "$last_menu_widget add command"
  } else {
    set create_code "$last_menu_widget add checkbutton -variable $variable\\\n  -onvalue $on -offvalue $off"
  }
  append create_code " -l \{$last_menu_name\} -u $underline -acc \{$accel\} -co \{$command\}"
  if {![catch "$prefix $last_menu_widget entrycget \{\{$last_menu_name\}\} -co" result]} {
    if {($result == $command) && ([eval $prefix $last_menu_widget \
       entrycget \{\{$last_menu_name\}\} -acc] == $accel)} {return $code
    } else {set code "$configure_code\n$code"
  }} else {set code "$create_code\n$code"}

# Check existance of cascade menus and menuentries.
  set menu_widget $first_menu_widget
  set cascade_code ""
  for {set i 0} {$i < $ml} {incr i} {
    set name [lindex [lindex $menu_sets $i] 0]

# Check if this menu exists.
    if {$i < $ml} {
      if {![eval "$prefix winfo exists $menu_widget"]} {
        append cascade_code "menu $menu_widget\n"
    }}

# Check to see if this menu has a cascade entry to the next menu.
    if {$i < [expr $ml - 1]} {
      set next_set [lindex $menu_sets [expr $i+1]]
      set next_name [lindex $next_set 0]
      set next_widget "$menu_widget.[string tolower $next_name]"
      if {[llength $next_set] > 0} {set next_underline [lindex $next_set 1]
      } else {set underline -1}
      if {[catch "$prefix $menu_widget entryconfigure $next_name"]} {
        append cascade_code "$menu_widget add cascade -l $next_name -u $next_underline -m $next_widget\n"
      }
      set menu_widget $next_widget
   }}
   set code "$cascade_code$code"

# Check to see if menubutton exists.
  if {![catch "$prefix pack slaves $menubar" result]} {
    if {[lsearch $result $menubutton] >= 0} {return $code}}
  set code "pack $menubutton -in $menubar -side left\n$code"
  if {[eval "$prefix winfo exists $menubutton"]} {return $code}
  if {[llength $first_menu_set] > 0} {set underline [lindex $first_menu_set 1]
  } else {set underline -1}
  set code "menubutton $menubutton -m $first_menu_widget -text $first_menu_name -u $underline\n$code"

  return "[menubar_code $widget $prefix]\n$code"
}

# Teaches keybindings to bindtag in app. (If not given, defaults to local)
proc teach_keybindings {bindtag bindings} {
  global App
  foreach binding $bindings {
    set b [lindex $binding 0]
    if {[llength $binding] < 2} {set cmd [lindex $binding 0]
    } else {set cmd [lindex $binding 1]}
    if {$App != ""} {
      set prefix "send \"$App\""
      do_cmd [keybind_code $bindtag $b $cmd $prefix] 0
    } else {
      uplevel #0 [keybind_code $bindtag $b $cmd]
}}}

proc regexp_replace {string old_exp new_exp} {
  if {[regsub -all $old_exp $string $new_exp new_string]} {
    return $new_string
  } else {return $string
}}

# Teaches menubindings to Widget in App. (If not given, defaults to local)
proc teach_menubindings {bindings} {
  global App Widget
  foreach binding $bindings {
    set b [lindex $binding 0]
    if {[llength $binding] < 2} {set cmd [lindex $binding 0]
    } else {set cmd [lindex $binding 1]}
    if {$App != ""} {
      set cmd [regexp_replace $cmd %W $Widget]
      set prefix "send \"$App\""
      do_cmd [menu_code $Widget $b $cmd $prefix] 0
    } else {
      uplevel #0 [menu_code $Widget $b $cmd]
}}}

# Creates a label to send remote keybindings
proc create_keybind_entry {} {
  if {![winfo exists .buttons.bind]} {
    [entry .buttons.bind -width 0] insert 0 "Press keys here"
    pack .buttons.bind -side left -expand yes -f x
    bindtags .buttons.bind ".buttons.bind . all"
    foreach binding {<Tab> <Shift-Tab> <Button-1>} {
      bind .buttons.bind $binding [bind Entry $binding]}
    bind .buttons.bind <Key> {if {[regexp . %A]} {bell} ; break}
    bind .buttons.bind <Control-Key> {bell ; break}
  }
  global Local_Bindings App ; set App ""
  teach_keybindings .buttons.bind $Local_Bindings
}

# Creates a menu to send remote functions.
proc create_menubind_frame {} {
  global Local_Bindings App Widget
; set App "" ; set Widget .buttons.bind
  teach_menubindings $Local_Bindings
  pack .buttons.bind_mb -side right
  set i 1
  foreach child [winfo children .buttons.bind_mb] {
    $child configure -text "#$i" -u -1
    incr i
}}

# Given a binding, allows the user to change it.
proc change_binding {binding} {
  global All_Bindings
  set result [eval change_binding_dialog $binding]
  if {$result != ""} {
    set All_Bindings($binding) $result
    create_menubind_frame
    create_keybind_entry
}}

# Pops up a window with the binding specs for the user to change.
proc change_binding_dialog {binding} {
  global All_Bindings
  toplevel .cb
  wm title .cb "Change: $binding"
  wm iconname .cb "Change Binding"
  grab .cb
  frame .cb.keys
  pack .cb.keys -side top -f x -expand no
  entry .cb.keys.e
  .cb.keys.e insert 0 [lindex $All_Bindings($binding) 0]
  pack .cb.keys.e -f x -expand yes -side right
  button .cb.keys.l -text "Keys" -co {.cb.keys.e insert insert [KeysymBox $XF_Dir/lib/Keysyms] ; grab .cb}
  if {[info procs KeysymBox] == ""} {.cb.keys.l configure -state disabled}
  pack .cb.keys.l
  frame .cb.menus
  pack .cb.menus -side top -f x -expand no
  entry .cb.menus.e
  .cb.menus.e insert 0 [lindex $All_Bindings($binding) 1]
  label .cb.menus.l -text "Menus:"
  pack .cb.menus.e -f x -expand yes -side right
  pack .cb.menus.l
  button .cb.ok -text "OK" -co "set CB_Done 1"
  pack .cb.ok -side left -expand yes -f x
  button .cb.cancel -text "Cancel" -co "set CB_Done 2"
  pack .cb.cancel -side left -expand yes -f x
  global CB_Done
  set CB_Done 0
  tkwait variable CB_Done
  if {$CB_Done == 2} {set result ""} else {
    set result [list [.cb.keys.e get] [.cb.menus.e get]]
  }
  grab release .cb
  destroy .cb
  return $result
}

# Given a set of bindings, choose the one matching choose, and execute it.
proc execute_chosen_binding {choose bindings} {
  global Widget
  clear_output
  foreach binding $bindings {
    if {[lindex $binding 0] == $choose} {
      teach_code
      do_cmd [regexp_replace [lindex $binding 1] %W $Widget] 0
      return
  }}
  bell
}

# Executed upon invoking a local menuentry or key in the Key label. Either
# change the binding or execute it remotely.
proc execute_or_change_binding {binding cmd} {
  global Change_Binding
  if $Change_Binding {
    set Change_Binding 0
    change_binding $binding
  } else {
    if {![get_widget]} {bell ; return}
    global Widget
    execute_remote_command [regexp_replace [regexp_replace $cmd \
	{.buttons.bind} $Widget] {.buttons} $Widget]
}}

# Execute command remotely.
proc execute_remote_command {cmd} {
  global App Widget
  clear_output
  foreach binding [widget_bindings] {
    if {[lindex $binding 0] == $cmd} {
      teach_code
      do_cmd [regexp_replace [lindex $binding 1] %W $Widget] 0
      return
  }}
  bell
}

proc get_menubar_widget {} {
  get_widget
  global Widget Class App Aux_Menu Aux_App
  set Aux_App $App
  set w $Widget
  if {$App != ""} {
    while {([send $App winfo class $w] != "Frame") &&
  	([send $App winfo toplevel $w] != $w)} {
      set w [send $App winfo parent $w]
    }}
  set Aux_Menu $w
}


if {[info globals Local_Bindings] == ""} {
  set Local_Bindings $Bindings($Local_Bindword)
}
if {![catch "menubutton .buttons.change -text Change -menu .buttons.change.m"]} {
  menu .buttons.change.m
  .buttons.change.m add command -label "Binding" -command {focus -displayof . .buttons.bind ; set Change_Binding 1}
  set Change_Binding 0
  pack .buttons.change -side left -after .buttons.source
}
if {![catch "frame .aux"]} {
  pack .aux -side top -before .o -fill x
  pack [frame .aux.m] -side left -expand yes -fill x
  pack [label .aux.m.l -text "Default Menubar:"] -side left
  pack [label .aux.m.e -textvariable Aux_Menu -width 0 -relief sunken] \
		-side left -expand no
  set Aux_Menu "" ; set Aux_App "" ; set App ""
  .buttons.change.m add command -label "Menu" -command {get_menubar_widget}
}}
create_keybind_entry
create_menubind_frame
clear_output
