
# Bindings to make canvases scroll.  Canvases have no bindings at all
# by default.
proc scrollbindings {cnvs} {
  # Page keys
  bind $cnvs <Next>  [list %W yview scroll  1 pages]
  bind $cnvs <Prior> [list %W yview scroll -1 pages]
  bind $cnvs <Up>    [list %W yview scroll -1 units]
  bind $cnvs <Down>  [list %W yview scroll  1 units]
  bind $cnvs <Left>  [list %W xview scroll -1 pages]
  bind $cnvs <Right> [list %W xview scroll  1 pages]
  # Middle button dragging
  bind $cnvs <B2-Motion> [list dragbind %W %x %y]
  # Wheelmouse
  bind $cnvs <MouseWheel> [list wheelbind %W %D]
  bind $cnvs <ButtonPress-4> [list %W yview scroll -1 pages]
  bind $cnvs <ButtonPress-5> [list %W yview scroll 1 pages]
}

# Generic Copy popup for read-only text widgets
proc copy_paste_popup {win X Y} {
  global colorglb
  #gen_log:log T "ENTER ($win $X $Y)"
  
  if {! [winfo exists $win.copy_paste_pop] } {
    menu $win.copy_paste_pop
    $win.copy_paste_pop add command -label "Copy selection" \
        -command [list event generate $win <<Copy>>]
    $win.copy_paste_pop add command -label "Select all" \
        -command [list $win tag add sel 0.0 end]
  }
  tk_popup $win.copy_paste_pop $X $Y
  $win.copy_paste_pop configure -background $colorglb(menubg) -foreground $colorglb(menufg)
}

# Disable all key sequences for text widget except for navigation
# and copy-to-clipboard
proc ro_textbindings {txtw} {
  
  #gen_log:log T "ENTER ($txtw)"
  bind $txtw <KeyPress>   {break}
  
  bind $txtw <Key-Home>   {catch {%W yview moveto 0};break}
  bind $txtw <Key-Up>     {catch {%W yview scroll -1 units};break}
  bind $txtw <Key-Prior>  {catch {%W yview scroll -1 pages};break}
  bind $txtw <Key-Next>   {catch {%W yview scroll  1 pages};break}
  bind $txtw <Key-Down>   {catch {%W yview scroll  1 units};break}
  bind $txtw <Key-End>    {catch {%W yview moveto 1};break}
  bind $txtw <Key-Left>   {catch {%W xview scroll -1 units};break}
  bind $txtw <Key-Right>  {catch {%W xview scroll  1 units};break}
  
  bind $txtw <Control-Key-c> {tk_textCopy %W;break}
  bind $txtw <Meta-Key-c>    {tk_textCopy %W;break}
  bind $txtw <Control-Key-a> {%W tag add sel 0.0 end;break}
  bind $txtw <Meta-Key-a>    {%W tag add sel 0.0 end;break}
  
  # Disable the cut and paste events.
  bind $txtw <<Paste>> "break"
  bind $txtw <<Cut>> "break"
  bind $txtw <2> "copy_paste_popup $txtw %X %Y"
  bind $txtw <3> "copy_paste_popup $txtw %X %Y"
}

# Save the contents of a text widget to a file
proc save_viewcontents {w} {
  global tcl_version

  set types  { {"Text Files" {*.txt *.log}} {"All Files" *} }
  set savfile [ \
      tk_getSaveFile -title "Save Results Summary" \
      -initialdir "." \
      -filetypes $types \
      -parent $w \
      ]
  if {$savfile == ""} {
    return
  }
  if {[catch {set fo [open $savfile w]}]} {
    puts "Cannot open $savfile for writing"
    return
  }
  if {$tcl_version >= 9.0} {chan configure $fo -profile tcl8}
  puts $fo [$w.text get 1.0 end]
  close $fo
}

# Get the selected text lines, to pass to git annotate
# Works with what's already selected
proc get_textlines {w} {
  lassign [$w.text tag ranges sel] firstsel lastsel
  set firstline [lindex [split $firstsel "."] 0]
  set lastline [lindex [split $lastsel "."] 0]
  
  return [list $firstline $lastline]
}

#
# Search functionality for text widgets
#
proc search_textwidget_init {} {
  # Initialize the globals for general text searches
  global cvsglb
  
  if {! [info exists cvsglb(searchstr)] } {
    set cvsglb(searchstr) ""
  }
  if {! [info exists cvsglb(last_searchstr)] } {
    set cvsglb(last_searchstr) ""
  }
  set cvsglb(searchidx) "1.0"
}

proc search_textwidget { wtx } {
  # Search the text widget
  global cvsglb
  
  #gen_log:log T "ENTER ($wtx)"
  
  if {$cvsglb(searchstr) != $cvsglb(last_searchstr)} {
    $wtx tag delete match
    set cvsglb(searchidx) "1.0"
  }
  
  $wtx tag configure sel -background gray -foreground #000000
  $wtx tag raise sel
  $wtx tag configure match -background gray -foreground #000000 \
      -relief groove -borderwidth 2
  $wtx tag raise match
  set searchstr $cvsglb(searchstr)
  
  set match [$wtx search -- $searchstr $cvsglb(searchidx)]
  if {[string length $match] > 0} {
    set length [string length $searchstr]
    $wtx mark set insert $match
    $wtx tag add match $match "$match + ${length}c"
    $wtx see $match
    set cvsglb(searchidx) "$match + ${length}c"
  }
  set cvsglb(last_searchstr) $cvsglb(searchstr)
}

proc search_listbox_init {} {
  # Initialize the globals for searches
  global cvsglb
  
  if {! [info exists cvsglb(searchstr)] } {
    set cvsglb(searchstr) ""
  }
  if {! [info exists cvsglb(last_searchstr)] } {
    set cvsglb(last_searchstr) ""
  }
  set cvsglb(lsearchidx) 0
}

proc search_listbox { lbx } {
  # Search a listbox
  global cvsglb
  global colorglb
  
  gen_log:log T "ENTER ($lbx)"
  
  #gen_log:log D "search string = \"$cvsglb(searchstr)\""
  #gen_log:log D "search index = \"$cvsglb(lsearchidx)\""
  
  set ndx [$lbx index end]
  if {$cvsglb(searchstr) != $cvsglb(last_searchstr)} {
    set cvsglb(lsearchidx) 0
    for {set i 0} {$i < $ndx} {incr i} {
      $lbx itemconfigure $i -background $colorglb(bg)
    }
  }
  if {$cvsglb(lsearchidx) > $ndx} {
    gen_log:log D "No more matches"
    return
  }
  for {set i $cvsglb(lsearchidx)} {$i < $ndx} {incr i} {
    set str [$lbx get $i]
    if {[string match "*$cvsglb(searchstr)*" $str]} {
      gen_log:log D "MATCH $str $cvsglb(searchstr)"
      set cvsglb(lsearchidx) $i
      $lbx itemconfigure $i -background $colorglb(hlbg)
      $lbx see $i
      break
    } else {
      $lbx itemconfigure $i -background $colorglb(bg)
    }
  }
  set cvsglb(last_searchstr) $cvsglb(searchstr)
  incr cvsglb(lsearchidx)
}

proc dragbind {W x y} {
  set height [$W cget -height]
  if {$y < 0} {set y 0}
  if {$y > $height} {set y $height}
  set yfrac [expr {double($y) / $height}]
  
  set width [$W cget -width]
  if {$x < 0} {set x 0}
  if {$x > $height} {set x $height}
  set xfrac [expr {double($x) / $width}]
  
  eval $W yview moveto $yfrac
  eval $W xview moveto $xfrac
}

proc wheelbind {W D} {
  eval $W yview scroll [expr {-($D/120)*4}] units
}

# start and stop busy cursor
proc busy_start {w} {
  foreach widget [winfo children $w] {
    catch {$widget config -cursor watch}
  }
  update idletasks
}

proc busy_done {w} {
  foreach widget [winfo children $w] {
    catch {$widget config -cursor ""}
  }
}

# Position the dialogs relative to the workdir or module browser
proc dialog_position {dialog parent} {
  set x [winfo x $parent]
  set x [winfo x $parent]
  set X [expr {$x + 60}]
  set y [winfo y $parent]
  set Y [expr {$y + 40}]
  wm geometry $dialog +$X+$Y
}

# Read a file containing user's saved picklist variables and values
proc picklist_load {} {
  global cvscfg
  global cvsglb
  
  if {! [catch {set file [open [file join $cvscfg(home) {.tkrev-picklists}] r]}]} {
    while {[gets $file var_name] > 0} {
      lappend vars $var_name
      while {[gets $file item] > 0} {
        lappend cvsglb($var_name) "$item"
      }
    }
    close $file
  }
}

# See if current value is in the saved list. If not, add it.
# If so, promote it to the beginning (last used)
proc picklist_used {var_name value} {
  global cvsglb
  
  gen_log:log T "ENTER ($var_name $value)"
  if {$value == {} } {
    return
  }
  if {[info exists cvsglb($var_name)]} {
    if {[set i [lsearch -exact $cvsglb($var_name) "$value"]] >= 0} {
      gen_log:log D "$value is already in cvsglb($var_name). Removing to change position"
      set cvsglb($var_name) [lreplace $cvsglb($var_name) $i $i]
    }
    # The value might have spaces. That's what the concat list is about.
    set cvsglb($var_name) [lrange [concat [list "$value"] $cvsglb($var_name)] 0 50]
    gen_log:log D "appending $value to cvsglb($var_name)"
    #lappend cvsglb($var_name) "$value"
  } else {
    gen_log:log D "Initializing variable cvsglb($var_name)!"
    set cvsglb($var_name) [concat [list "$value"]]
  }
}

# Save user's picklist variables and values to a file
proc picklist_save {} {
  global cvscfg
  global cvsglb
  
  if {! [catch {set file [open [file join $cvscfg(home) {.tkrev-picklists}] w]}]} {
    foreach var_name {cvsroot directory} {
      puts $file $var_name
      set c 0
      if {! [info exists cvsglb($var_name)]} {
         puts $file ""
         continue 
      }
      foreach item $cvsglb($var_name) {
        # number of items saved is a preference
        if {$c >= $cvscfg(picklist_items)} {break}
        puts $file "$item"
        incr c
      }
      puts $file ""
    }
    close $file
  }
}

proc validate_dirpath {W path} {
  # Returning path instead of canonpath preserves tcl8.x
  # behavior when using that version
  global colorglb

  if {$path == ""} {
    return $path
  }
  set ret [tildChk $path checkresult canonpath]
  if {$ret} {
    $W configure -foreground red
    set checkresult 0
    return $path
  }
  if {$checkresult == 1} {
    $W configure -foreground green
    $W icursor end
    return $path
  }
  if {![file isdirectory $path]} {
    $W configure -foreground red
    return $path
  }
  $W configure -foreground $colorglb(textfg)
  return $path
}

proc change_dir {new_dir} {
  global cwd
  
  set new_dir [tildecheck "$new_dir"]
  if {![file isdirectory "$new_dir"]} {
    set cwd [pwd]
    cvsfail "Directory $new_dir doesn\'t exist or isn't a directory" .workdir
    return 1
  }
  cd "$new_dir"
  set cwd $new_dir
  gen_log:log F "CD $new_dir"

  # Deleting the tree discards the saved scroll position
  # so we start with yview 0 in a new directory
  if {[winfo exists .workdir]} {
    DirCanvas:deltree .workdir.main.tree
    setup_dir
  }
  if {[winfo exists .modbrowse]} {
    vcs_detect $cwd
    modbrowse_run
  }
  return 0
}

# tcl/tk 9.0 won't allow tilde in filenames
proc tildecheck {path} {
  global tcl_version

  if {$tcl_version < 9.0} {
    return $path
  } else {
    if {[catch {file tildeexpand $path} exp]} {
      gen_log:log E "$exp"
      return $exp
    } else {
      set fullpath $exp
      #gen_log:log F "expand: $path -> $fullpath"
      return $fullpath
    }
  }
}

# By vampm, borrowed from tkdiff
proc tildChk {fnam result canon} {
  global  tcl_version
  # point OUR locals AT callers Vars
  upvar $result resptr
  upvar $canon canptr

  # CALLER is responsible for which returned values (RetCode/result/canon)
  # are of logical importance within ITS specific CALLING situation
  #   Original V8 check produced 3 possible 'result' value sets (w/o errs):
  #       0       - fnam doesnt exist                         w/RetCod=0
  #       1       - fnam  does  exist                         w/RetCod=0
  #       FailedMsg - tilde conversion failed (no such user)  w/Retcod=1
  #   V9 adds an ADDITIONAL output datum (canon) to those sets:
  #       0       - defaulted as fnam CLONE                   w/Retcod=1
  #       1       - canonical form of converted fnam          w/Retcod=0
  #       FailedMsg - tilde conversion failed (no user/home)  w/Retcod=1
  #
  # User EXPECTED to prefix initial fnam with './' to PREVENT tildeexpand,
  # although code ATTEMPTS such evaluation if tildeexpand was IMPOSSIBLE

  if {$tcl_version >= 9.0 && [string index $fnam 0] == "~"} {
    # isolate first fragment from ANY subsequent GLOB syntax
    # THEN perform tilde expansion on JUST 1st frag, OR (if that fails)
    #   a DIRECT CWD filename search, again on only that 1st fragment
    set f1 [lindex [set frags [file split $fnam]] 0]
    if {![set Err [catch {file tildeexpand $f1} newf1]] || \
         [llength [set nms [glob -n $f1]]]} {
      # If Err non-zero HERE, there IS a CWD-relative LITERAL tilde name
      #   (of which there MUST be only a SINGLE name via the V9 GLOB)
      # TWO possible ways to success:
      if {$Err && [llength $nms] == 1} {
        # reassemble fnam w/FOUND literal tilde as 1st frag, THEN ...
        set fnam [file join $nms [lrange $frags 1 end]]
      } elseif {!$Err} {
        # reassemble fnam using tilde EXPANDED 1st fragment, THEN ...
        set fnam [file join $newf1 [lrange $frags 1 end]]
      } else {
        # failed: expansion was IMPOSSIBLE (w/no SINGLE LITERAL tilde)
        set resptr $newf1;  # shove msg where it belongs
        set canptr $fnam;   # has NO canonical form; return unaltered
        return $Err;        # and tell caller theres a DEFINITE problem
      }
      # ...EXIT via V8 GLOB code secure it'll GLOB from PROPER (HOME/CWD)
      # (N.B> catch is superfluous as V9 GLOB has no reason to fault)
    } else {
      # failed: expansion was IMPOSSIBLE (AND found no LITERAL tilde)
      set resptr $newf1;  # shove msg where it belongs
      set canptr $fnam;   # has NO canonical form; return unaltered
      return $Err;        # and tell caller theres a definite problem
    }
    # replicate default V9 semantic tildeexpand behavior as preparartion for V8
  } else {
    set canptr $fnam
  }
  # (N.B> V8/V9 BOTH rely on GLOB to provide filesystem EXISTENCE of result)
  if {![set Err [catch {llength [set nms [glob -n $fnam]]} resptr]]} {
    # success, but given the V9 semantic, must overwrite canon now ...
    if {$resptr == 1} {
      set canptr $nms ; # rewrite using expanded name
      # ... Yet multiple names NOT permitted; TREAT the same as NONE found
    } else { set resptr 0 }
  }
  return $Err
}

