From 4f49b16079b27d7ce633619e4cddfdf2bffbc952 Mon Sep 17 00:00:00 2001 From: cashmere Date: Fri, 4 Sep 2026 09:05:24 +0200 Subject: initial commit --- src/diff.tcl | 707 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 707 insertions(+) create mode 100644 src/diff.tcl (limited to 'src/diff.tcl') 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 {& & < < > > ' ' " \"} $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 . exit +bind . {catch searchPrev; break} +bind . {catch searchNext; break} +bind . exit +bind . {after 0 exit} +bind . {cycleDiffs; break} +bind . <> {cycleDiffs 1; break} +bind . {searchOnOff; break} +bind . {catch searchNext; break} +bind . { + event generate .bb.files <1> + event generate .bb.files + 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 . 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 {wm withdraw .wfiles} +bind .wfiles {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 { + %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 {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 -- cgit v1.3.1