set prog { package require Tk array set CFG { 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 } 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 readDiffs {fossilcmd} { global difftxt if {![info exists difftxt]} { set in [open $fossilcmd r] fconfigure $in -encoding utf-8 set difftxt [split [read $in] \n] close $in } 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} set fromIndex [lsearch -glob $fossilcmd *-from] set toIndex [lsearch -glob $fossilcmd *-to] set branchIndex [lsearch -glob $fossilcmd *-branch] set checkinIndex [lsearch -glob $fossilcmd *-checkin] 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 - .txtA insert end "[lindex $line 1] ($fA)\n" fn \n - .mkr insert end \n fn \n - .lnB insert end \n fn \n - .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 } if {$nDiffs <= [.wfiles.lb cget -height]} { .wfiles.lb config -height $nDiffs 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 $fossilcmd] == 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 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.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 .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] wm deiconify . } eval $prog