initial commitHEADmaster

1 files changed, 707 insertions, 0 deletions

diff --git a/src/diff.tcl b/src/diff.tcl
new file mode 100644
index 0000000..f93d2b2
--- /dev/null
+++ b/src/diff.tcl
@@ -0,0 +1,707 @@
+# Various diff commands ("fossil diff", "fossil stash diff", "fossil fdiff",
+# "fossil patch diff", and others) that include the --tk option, or that use "gdiff"
+# instead of diff, work by running a Tcl/Tk script which is just this script prepended
+# with some variable initializations. The key variable is fossilcmd which is
+# usually set something like this:
+#
+#     set fossilcmd {| "./fossil" diff --tcl -i -v}
+#
+# If there are additional command-line options or arguments, those will be appended
+# as well.  This variable becomes the argument to "open" to gather the diff
+# information that is to be displayed.
+#
+# Other variables initializations that might be prepended to this script include:
+#
+#     set debug 1
+#     set darkmode 1
+#     set remotehost hostname
+#     set remotedir  directory-on-hostname
+#
+# After prepending those "set" commands, the resulting script is run using "tclsh".
+#
+# This header comment is stripped off by the "mkbuiltin.c" program.
+#
+set prog {
+package require Tk
+
+array set CFG_light {
+  TITLE      {Fossil Diff}
+  LN_COL_BG  #dddddd
+  LN_COL_FG  #444444
+  TXT_COL_BG #ffffff
+  TXT_COL_FG #000000
+  MKR_COL_BG #444444
+  MKR_COL_FG #dddddd
+  CHNG_BG    #d0d0ff
+  ADD_BG     #c0ffc0
+  RM_BG      #ffc0c0
+  HR_FG      #444444
+  HR_PAD_TOP 4
+  HR_PAD_BTM 8
+  FN_BG      #444444
+  FN_FG      #ffffff
+  FN_PAD     5
+  ERR_FG     #ee0000
+  PADX       5
+  WIDTH      80
+  HEIGHT     45
+  LB_HEIGHT  25
+}
+
+array set CFG_dark {
+  TITLE      {Fossil Diff}
+  LN_COL_BG  #dddddd
+  LN_COL_FG  #444444
+  TXT_COL_BG #3f3f3f
+  TXT_COL_FG #dcdccc
+  MKR_COL_BG #444444
+  MKR_COL_FG #dddddd
+  CHNG_BG    #6a6afc
+  ADD_BG     #57934c
+  RM_BG      #ef6767
+  HR_FG      #444444
+  HR_PAD_TOP 4
+  HR_PAD_BTM 8
+  FN_BG      #5e5e5e
+  FN_FG      #ffffff
+  FN_PAD     5
+  ERR_FG     #ee0000
+  PADX       5
+  WIDTH      80
+  HEIGHT     45
+  LB_HEIGHT  25
+}
+
+array set CFG_arr {
+  0          CFG_light
+  1          CFG_dark
+}
+
+array set CFG [array get $CFG_arr($darkmode)]
+
+if {![namespace exists ttk]} {
+  interp alias {} ::ttk::scrollbar {} ::scrollbar
+  interp alias {} ::ttk::menubutton {} ::menubutton
+}
+
+proc dehtml {x} {
+  set x [regsub -all {<[^>]*>} $x {}]
+  return [string map {&amp; & &lt; < &gt; > &#39; ' &quot; \"} $x]
+}
+
+proc cols {} {
+  return [list .lnA .txtA .mkr .lnB .txtB]
+}
+
+proc colType {c} {
+  regexp {[a-z]+} $c type
+  return $type
+}
+
+proc getLine {difftxt N iivar} {
+  upvar $iivar ii
+  if {$ii>=$N} {return -1}
+  set x [lindex $difftxt $ii]
+  incr ii
+  return $x
+}
+
+proc reloadDiff {} {
+  global fossilcmd difftxt
+  unset -nocomplain difftxt
+  set idx [.txtA index @0,0]
+  readDiffs 1
+  update
+  viewDiff $idx
+}
+
+# Populate the difftxt global variable by running the fossilcmd command
+# and capturing the output.  This is a reload if $redo is 1 and the initial
+# load if $redo is 0.
+#
+proc fetchRawDiff {redo} {
+  global fossilcmd remotehost remotedir debug difftxt
+  if {![info exists remotehost] || $remotehost eq ""} {
+    if {$debug} {
+      puts "# [lrange $fossilcmd 1 end]"
+      flush stdout
+    }
+    if {[catch {
+      set in [open $fossilcmd r]
+      fconfigure $in -encoding utf-8
+      set difftxt [split [read $in] \n]
+      close $in
+    } msg]} {
+      if {$redo} {
+        tk_messageBox -type ok -title Error -message "Unable to refresh:\n$msg"
+        return 0
+      } else {
+        puts $msg
+        exit 1
+      }
+    }
+    return 0
+  } else {
+    set suffix [lrange $fossilcmd 2 end]
+    set cmd "| ssh $remotehost {cd $remotedir && fossil $suffix}"
+    if {$debug} {
+      puts "# [lrange $cmd 1 end]"
+      flush stdout
+    }
+    if {![catch {
+      set in [open $cmd r]
+      fconfigure $in -encoding utf-8
+      set difftxt [split [read $in] \n]
+      close $in
+    }]} {
+      return 1
+    }
+    set cmd "| ssh $remotehost {cd $remotedir && \
+         PATH=\$HOME/bin:/usr/local/bin:/opt/homebrew/bin:\$PATH fossil $suffix}"
+    if {$debug} {
+      puts "# [lrange $cmd 1 end]"
+      flush stdout
+    }
+    if {![catch {
+      set in [open $cmd r]
+      fconfigure $in -encoding utf-8
+      set difftxt [split [read $in] \n]
+      close $in
+    } msg]} {
+      return 1
+    }
+    if {$redo} {
+      tk_messageBox -type ok -title Error -message "Unable to refresh:\n$msg"
+      return 0
+    } else {
+      puts $msg
+      exit 1
+    }
+  }
+}
+
+proc readDiffs {redo} {
+  global fossilcmd difftxt debug
+  if {![info exists difftxt]} {
+    fetchRawDiff $redo
+  }
+  set N [llength $difftxt]
+  set ii 0
+  set nDiffs 0
+  set n1 0
+  set n2 0
+  array set widths {txt 3 ln 3 mkr 1}
+  if {$redo} {
+    foreach c [cols] {$c config -state normal}
+    .lnA delete 1.0 end
+    .txtA delete 1.0 end
+    .lnB delete 1.0 end
+    .txtB delete 1.0 end
+    .mkr delete 1.0 end
+    .wfiles.lb delete 0 end
+  }
+
+
+  set fromIndex [lsearch -glob $fossilcmd *-from]
+  set toIndex [lsearch -glob $fossilcmd *-to]
+  set branchIndex [lsearch -glob $fossilcmd *-branch]
+  set checkinIndex [lsearch -glob $fossilcmd *-checkin]
+  if {[lsearch -glob $fossilcmd *-label]>=0
+    || [lsearch {xdiff fdiff merge-info} [lindex $fossilcmd 2]]>=0
+  } {
+    set fA {}
+    set fB {}
+  } else {
+    if {[string match *?--external-baseline* $fossilcmd]} {
+      set fA {external baseline}
+    } else {
+      set fA {base check-in}
+    }
+    set fB {current check-out}
+    if {$fromIndex > -1} {
+      set fA [lindex $fossilcmd $fromIndex+1]
+    }
+    if {$toIndex > -1} {
+      set fB [lindex $fossilcmd $toIndex+1]
+    }
+    if {$branchIndex > -1} {
+      set fA "branch point"; set fB "leaf of branch '[lindex $fossilcmd $branchIndex+1]'"
+    }
+    if {$checkinIndex > -1} {
+      set fA "primary parent"; set fB [lindex $fossilcmd $checkinIndex+1]
+    }
+  }
+
+  while {[set line [getLine $difftxt $N ii]] != -1} {
+    switch -- [lindex $line 0] {
+      FILE {
+        incr nDiffs
+        foreach wx [list [string length $n1] [string length $n2]] {
+          if {$wx>$widths(ln)} {set widths(ln) $wx}
+        }
+        .lnA insert end \n fn \n -
+        if {$fA==""} {
+          .txtA insert end "[lindex $line 1]\n" fn \n -
+        } else {
+          .txtA insert end "[lindex $line 1] ($fA)\n" fn \n -
+        }
+        .mkr insert end \n fn \n -
+        .lnB insert end \n fn \n -
+        if {$fB==""} {
+          .txtB insert end "[lindex $line 2]\n" fn \n -
+        } else {
+          .txtB insert end "[lindex $line 2] ($fB)\n" fn \n -
+        }
+        .wfiles.lb insert end [lindex $line 2]
+        set n1 0
+        set n2 0
+      }
+      SKIP {
+        set n [lindex $line 1]
+        incr n1 $n
+        incr n2 $n
+        .lnA insert end ...\n hrln
+        .txtA insert end [string repeat . 30]\n hrtxt
+        .mkr insert end \n hrln
+        .lnB insert end ...\n hrln
+        .txtB insert end [string repeat . 30]\n hrtxt
+      }
+      COM {
+        set x [lindex $line 1]
+        incr n1
+        incr n2
+        .lnA insert end $n1\n -
+        .txtA insert end $x\n -
+        .mkr insert end \n -
+        .lnB insert end $n2\n -
+        .txtB insert end $x\n -
+      }
+      INS {
+        set x [lindex $line 1]
+        incr n2
+        .lnA insert end \n -
+        .txtA insert end \n -
+        .mkr insert end >\n -
+        .lnB insert end $n2\n -
+        .txtB insert end $x add \n -
+      }
+      DEL {
+        set x [lindex $line 1]
+        incr n1
+        .lnA insert end $n1\n -
+        .txtA insert end $x rm \n -
+        .mkr insert end <\n -
+        .lnB insert end \n -
+        .txtB insert end \n -
+      }
+      EDIT {
+        incr n1
+        incr n2
+        .lnA insert end $n1\n -
+        .lnB insert end $n2\n -
+        .mkr insert end |\n -
+        set nn [llength $line]
+        for {set i 1} {$i<$nn} {incr i 3} {
+          set x [lindex $line $i]
+          if {$x ne ""} {
+            .txtA insert end $x -
+            .txtB insert end $x -
+          }
+          if {$i+2<$nn} {
+            set x1 [lindex $line [expr {$i+1}]]
+            set x2 [lindex $line [expr {$i+2}]]
+            if {"$x1" eq ""} {
+              .txtB insert end $x2 add
+            } elseif {"$x2" eq ""} {
+              .txtA insert end $x1 rm
+            } else {
+              .txtA insert end $x1 chng
+              .txtB insert end $x2 chng
+            }
+          }
+        }
+        .txtA insert end \n -
+        .txtB insert end \n -
+      }
+      "" {
+        foreach wx [list [string length $n1] [string length $n2]] {
+          if {$wx>$widths(ln)} {set widths(ln) $wx}
+        }
+      }
+      default {
+        .lnA insert end \n -
+        .txtA insert end $line\n err
+        .mkr insert end \n -
+        .lnB insert end \n -
+        .txtB insert end $line\n err
+      }
+    }
+  }
+
+  foreach c [cols] {
+    set type [colType $c]
+    if {$type ne "txt"} {
+      $c config -width $widths($type)
+    }
+    $c config -state disabled
+  }
+  .wfiles.lb config -height $nDiffs
+  if {$nDiffs <= [.wfiles.lb cget -height]} {
+    grid remove .wfiles.sb
+  }
+
+  return $nDiffs
+}
+
+proc viewDiff {idx} {
+  .txtA yview $idx
+  .txtA xview moveto 0
+}
+
+proc cycleDiffs {{reverse 0}} {
+  if {$reverse} {
+    set range [.txtA tag prevrange fn @0,0 1.0]
+    if {$range eq ""} {
+      viewDiff {fn.last -1c}
+    } else {
+      viewDiff [lindex $range 0]
+    }
+  } else {
+    set range [.txtA tag nextrange fn {@0,0 +1c} end]
+    if {$range eq "" || [lindex [.txtA yview] 1] == 1} {
+      viewDiff fn.first
+    } else {
+      viewDiff [lindex $range 0]
+    }
+  }
+}
+
+proc xvis {col} {
+  set view [$col xview]
+  return [expr {[lindex $view 1]-[lindex $view 0]}]
+}
+
+proc scroll-x {args} {
+  set c .txt[expr {[xvis .txtA] < [xvis .txtB] ? "A" : "B"}]
+  eval $c xview $args
+}
+
+interp alias {} scroll-y {} .txtA yview
+
+proc noop {args} {}
+
+proc enableSync {axis} {
+  update idletasks
+  interp alias {} sync-$axis {}
+  rename _sync-$axis sync-$axis
+}
+
+proc disableSync {axis} {
+  rename sync-$axis _sync-$axis
+  interp alias {} sync-$axis {} noop
+}
+
+proc sync-x {col first last} {
+  disableSync x
+  $col xview moveto [expr {$first*[xvis $col]/($last-$first)}]
+  foreach side {A B} {
+    set sb .sbx$side
+    set xview [.txt$side xview]
+    if {[lindex $xview 0] > 0 || [lindex $xview 1] < 1} {
+      grid $sb
+      eval $sb set $xview
+    } else {
+      grid remove $sb
+    }
+  }
+  enableSync x
+}
+
+proc sync-y {first last} {
+  disableSync y
+  foreach c [cols] {
+    $c yview moveto $first
+  }
+  if {$first > 0 || $last < 1} {
+    grid .sby
+    .sby set $first $last
+  } else {
+    grid remove .sby
+  }
+  enableSync y
+}
+
+wm withdraw .
+wm title . $CFG(TITLE)
+wm iconname . $CFG(TITLE)
+# Keystroke bindings for on the top-level window for navigation and
+# control also fire when those same keystrokes are pressed in the
+# Search entry box.  Disable them, to prevent the diff screen from
+# disappearing abruptly and unexpectedly when searching for "q".
+#
+bind . <Control-q> exit
+bind . <Control-p> {catch searchPrev; break}
+bind . <Control-n> {catch searchNext; break}
+bind . <Escape><Escape> exit
+bind . <Destroy> {after 0 exit}
+bind . <Tab> {cycleDiffs; break}
+bind . <<PrevWindow>> {cycleDiffs 1; break}
+bind . <Control-f> {searchOnOff; break}
+bind . <Control-g> {catch searchNext; break}
+bind . <Return> {
+  event generate .bb.files <1>
+  event generate .bb.files <ButtonRelease-1>
+  break
+}
+foreach {key axis args} {
+  Up    y {scroll -5 units}
+  k     y {scroll -5 units}
+  Down  y {scroll 5 units}
+  j     y {scroll 5 units}
+  Left  x {scroll -5 units}
+  h     x {scroll -5 units}
+  Right x {scroll 5 units}
+  l     x {scroll 5 units}
+  Prior y {scroll -1 page}
+  b     y {scroll -1 page}
+  Next  y {scroll 1 page}
+  space y {scroll 1 page}
+  Home  y {moveto 0}
+  g     y {moveto 0}
+  End   y {moveto 1}
+} {
+  bind . <$key> "scroll-$axis $args; break"
+  bind . <Shift-$key> continue
+}
+
+frame .bb
+::ttk::menubutton .bb.files -text "Files"
+if {[tk windowingsystem] eq "win32"} {
+  ::ttk::style theme use winnative
+  .bb.files configure -padding {20 1 10 2}
+}
+toplevel .wfiles
+wm withdraw .wfiles
+update idletasks
+wm transient .wfiles .
+wm overrideredirect .wfiles 1
+listbox .wfiles.lb -width 0 -height $CFG(LB_HEIGHT) -activestyle none \
+  -yscroll {.wfiles.sb set}
+::ttk::scrollbar .wfiles.sb -command {.wfiles.lb yview}
+grid .wfiles.lb .wfiles.sb -sticky ns
+bind .bb.files <1> {
+  set x [winfo rootx %W]
+  set y [expr {[winfo rooty %W]+[winfo height %W]}]
+  wm geometry .wfiles +$x+$y
+  wm deiconify .wfiles
+  focus .wfiles.lb
+}
+bind .wfiles <FocusOut> {wm withdraw .wfiles}
+bind .wfiles <Escape> {focus .}
+foreach evt {1 Return} {
+  bind .wfiles.lb <$evt> {
+    catch {
+      set idx [lindex [.txtA tag ranges fn] [expr {[%W curselection]*2}]]
+      viewDiff $idx
+    }
+    focus .
+    break
+  }
+}
+bind .wfiles.lb <Motion> {
+  %W selection clear 0 end
+  %W selection set @%x,%y
+}
+
+foreach {side syncCol} {A .txtB B .txtA} {
+  set ln .ln$side
+  text $ln
+  $ln tag config - -justify right
+
+  set txt .txt$side
+  text $txt -width $CFG(WIDTH) -height $CFG(HEIGHT) -wrap none \
+    -xscroll "sync-x $syncCol"
+  catch {$txt config -tabstyle wordprocessor} ;# Required for Tk>=8.5
+  foreach tag {add rm chng} {
+    $txt tag config $tag -background $CFG([string toupper $tag]_BG)
+    $txt tag lower $tag
+  }
+  $txt tag config fn -background $CFG(FN_BG) -foreground $CFG(FN_FG) \
+    -justify center
+  $txt tag config err -foreground $CFG(ERR_FG)
+}
+text .mkr
+
+foreach c [cols] {
+  set keyPrefix [string toupper [colType $c]]_COL_
+  if {[tk windowingsystem] eq "win32"} {$c config -font {courier 9}}
+  $c config -bg $CFG(${keyPrefix}BG) -fg $CFG(${keyPrefix}FG) -borderwidth 0 \
+    -padx $CFG(PADX) -yscroll sync-y
+  $c tag config hrln -spacing1 $CFG(HR_PAD_TOP) -spacing3 $CFG(HR_PAD_BTM) \
+     -foreground $CFG(HR_FG) -justify right
+  $c tag config hrtxt  -spacing1 $CFG(HR_PAD_TOP) -spacing3 $CFG(HR_PAD_BTM) \
+     -foreground $CFG(HR_FG) -justify center
+  $c tag config fn -spacing1 $CFG(FN_PAD) -spacing3 $CFG(FN_PAD)
+  bindtags $c ". $c Text all"
+  bind $c <1> {focus %W}
+}
+
+::ttk::scrollbar .sby -command {.txtA yview} -orient vertical
+::ttk::scrollbar .sbxA -command {.txtA xview} -orient horizontal
+::ttk::scrollbar .sbxB -command {.txtB xview} -orient horizontal
+frame .spacer
+
+if {[readDiffs 0] == 0} {
+  tk_messageBox -type ok -title $CFG(TITLE) -message "No changes"
+  exit
+}
+update idletasks
+
+proc saveDiff {} {
+  set fn [tk_getSaveFile]
+  if {$fn==""} return
+  set out [open $fn wb]
+  puts $out "#!/usr/bin/tclsh\n#\n# Run this script using 'tclsh' or 'wish'"
+  puts $out "# to see the graphical diff.\n#"
+  puts $out "set fossilcmd {}"
+  puts $out "set darkmode $::darkmode"
+  puts $out "set debug $::debug"
+  puts $out "set prog [list $::prog]"
+  puts $out "set difftxt \173"
+  foreach e $::difftxt {puts $out [list $e]}
+  puts $out "\175"
+  puts $out "eval \$prog"
+  close $out
+}
+proc invertDiff {} {
+  global CFG
+  array set x [grid info .txtA]
+  if {$x(-column)==1} {
+    grid config .lnB -column 0
+    grid config .txtB -column 1
+    .txtB tag config add -background $CFG(RM_BG)
+    grid config .lnA -column 3
+    grid config .txtA -column 4
+    .txtA tag config rm -background $CFG(ADD_BG)
+    .bb.invert config -text Uninvert
+  } else {
+    grid config .lnA -column 0
+    grid config .txtA -column 1
+    .txtA tag config rm -background $CFG(RM_BG)
+    grid config .lnB -column 3
+    grid config .txtB -column 4
+    .txtB tag config add -background $CFG(ADD_BG)
+    .bb.invert config -text Invert
+  }
+  .mkr config -state normal
+  set clt [.mkr search -all < 1.0 end]
+  set cgt [.mkr search -all > 1.0 end]
+  foreach c $clt {.mkr replace $c "$c +1 chars" >}
+  foreach c $cgt {.mkr replace $c "$c +1 chars" <}
+  .mkr config -state disabled
+}
+proc searchOnOff {} {
+  if {[info exists ::search]} {
+    unset ::search
+    .txtA tag remove search 1.0 end
+    .txtB tag remove search 1.0 end
+    pack forget .bb.sframe
+    focus .
+  } else {
+    set ::search .txtA
+    if {![winfo exists .bb.sframe]} {
+      frame .bb.sframe
+      ::ttk::entry .bb.sframe.e -width 10
+      pack .bb.sframe.e -side left -fill y -expand 1
+      bind .bb.sframe.e <Return> {searchNext; break}
+      ::ttk::button .bb.sframe.nx -text \u2193 -width 1 -command searchNext
+      ::ttk::button .bb.sframe.pv -text \u2191 -width 1 -command searchPrev
+      tk_optionMenu .bb.sframe.typ ::search_type \
+           Exact {No Case} {RegExp} {Whole Word}
+      .bb.sframe.typ config -width 10
+      set ::search_type Exact
+      pack .bb.sframe.nx .bb.sframe.pv .bb.sframe.typ -side left
+    }
+    pack .bb.sframe -side left
+    after idle {focus .bb.sframe.e}
+  }
+}
+proc searchNext {} {searchStep -forwards +1 1.0 end}
+proc searchPrev {} {searchStep -backwards -1 end 1.0}
+proc searchStep {direction incr start stop} {
+  set pattern [.bb.sframe.e get]
+  if {$pattern==""} return
+  set count 0
+  set w $::search
+  if {"$w"==".txtA"} {set other .txtB} {set other .txtA}
+  if {[lsearch [$w mark names] search]<0} {
+    $w mark set search $start
+  }
+  switch $::search_type {
+    Exact        {set st -exact}
+    {No Case}    {set st -nocase}
+    {RegExp}     {set st -regexp}
+    {Whole Word} {set st -regexp; set pattern \\y$pattern\\y}
+  }
+  set idx [$w search -count count $direction $st -- \
+              $pattern "search $incr chars" $stop]
+  if {"$idx"==""} {
+    set idx [$other search -count count $direction $st -- $pattern $start $stop]
+    if {"$idx"!=""} {
+      set this $w
+      set w $other
+      set other $this
+    } else {
+      set idx [$w search -count count $direction $st -- $pattern $start $stop]
+    }
+  }
+  $w tag remove search 1.0 end
+  $w mark unset search
+  $other tag remove search 1.0 end
+  $other mark unset search
+  if {"$idx"!=""} {
+    $w mark set search $idx
+    $w yview -pickplace $idx
+    $w tag add search search "$idx +$count chars"
+    $w tag config search -background {#fcc000}
+  }
+  set ::search $w
+}
+::ttk::button .bb.quit -text {Quit} -command exit
+::ttk::button .bb.reload -text {Reload} -command reloadDiff
+::ttk::button .bb.invert -text {Invert} -command invertDiff
+::ttk::button .bb.save -text {Save As...} -command saveDiff
+::ttk::button .bb.search -text {Search} -command searchOnOff
+pack .bb.quit -side left
+if {$fossilcmd ne ""} {
+  pack .bb.reload -side left
+}
+pack .bb.invert -side left
+if {$fossilcmd!=""} {pack .bb.save -side left}
+pack .bb.files .bb.search -side left
+grid rowconfigure . 1 -weight 1
+grid columnconfigure . 1 -weight 1
+grid columnconfigure . 4 -weight 1
+grid .bb -row 0 -columnspan 6
+eval grid [cols] -row 1 -sticky nsew
+grid .sby -row 1 -column 5 -sticky ns
+grid .sbxA -row 2 -columnspan 2 -sticky ew
+grid .spacer -row 2 -column 2
+grid .sbxB -row 2 -column 3 -columnspan 2 -sticky ew
+
+.spacer config -height [winfo height .sbxA]
+
+set h [winfo screenheight .]
+if {$h > 1280} {
+  set w [winfo screenwidth .]; # [winfo width] == 32
+  if {$w > 2048} {
+    set w 2048
+  }
+  set g [expr {$w / 3 * 2}]x[expr {$h / 4 * 3}]
+  wm geometry . $g
+}
+
+wm deiconify .
+
+}
+eval $prog