#---------------------------------------------------------- -*- tcl -*-
#
# Eskil, a Graphical frontend to diff
#
# Copyright (c) 1998-2015, Peter Spjuth (peter.spjuth@gmail.com)
#
# Usage
# Do 'eskil' for interactive mode
# Do 'eskil --help' for command line usage
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; see the file COPYING. If not, write to
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
#
#----------------------------------------------------------------------
# This function is called when a toplevel is closed.
# If it is the last remaining toplevel, the application quits.
# If top = "all" it means quit.
# If eskil is embedded, this should be used to close an eskil toplevel.
proc cleanupAndExit {top} {
# A security thing to make sure we can exit.
set cont 0
if {[catch {
if {$top != "all"} {
set i [lsearch $::eskil(diffWindows) $top]
if {$i >= 0} {
set ::eskil(diffWindows) [lreplace $::eskil(diffWindows) $i $i]
}
set i [lsearch $::widgets(toolbars) $top.f]
if {$i >= 0} {
set ::widgets(toolbars) [lreplace $::widgets(toolbars) $i $i]
}
destroy $top
array unset ::eskil $top,*
# Any windows remaining?
if {[llength $::eskil(diffWindows)] > 0} {
set cont 1
}
}
} errMsg]} {
tk_messageBox -icon error -title "Eskil Error" -message \
"An error occured in the close process.\n$errMsg\n\
(This is a bug)\nTerminating application." -type ok
}
if {$cont} return
clearTmp
exit
}
# If embedding, tell eskil about any other toplevel, then
# cleanupAndExit can be used to get rid of it.
proc eskilRegisterToplevel {top} {
lappend ::eskil(diffWindows) $top
}
# Format a line number
proc myFormL {lineNo} {
if {![string is integer -strict $lineNo]} {return "$lineNo\n"}
return [format "%3d: \n" $lineNo]
}
# Get a name for a temporary file
# A tail can be given to make the file more recognisable.
proc tmpFile {{tail {}}} {
if {[info exists ::tmpcnt]} {
incr ::tmpcnt
} else {
set ::tmpcnt 0
}
set name "tmpd[pid]a$::tmpcnt"
if {$tail ne ""} {
append name " [file tail $tail]"
}
set name [file join $::eskil(tmpdir) $name]
lappend ::tmpfiles $name
return $name
}
# Delete temporary files
proc clearTmp {args} {
if {![info exists ::tmpfiles]} {
set ::tmpfiles {}
return
}
if {[llength $args] > 0} {
foreach f $args {
set i [lsearch -exact $::tmpfiles $f]
if {$i >= 0} {
catch {file delete $f}
set ::tmpfiles [lreplace $::tmpfiles $i $i]
}
}
} else {
foreach f $::tmpfiles {
catch {file delete $f}
}
set ::tmpfiles {}
}
}
# insertLine, when in table mode
proc insertLineTable {top n line text {tag equal}} {
set RE $::eskil($top,separator)
set words [split $text $RE]
set id [$::widgets($top,wTable) insert end $words]
if {$tag ne "equal"} {
set col 0
foreach w $words {
if {$n == 1} {
# TBD TABLE, r is faked here for now
dict set ::eskil($top,tablechanges) $id,$col w1 $w
dict set ::eskil($top,tablechanges) $id,$col w2 ""
dict set ::eskil($top,tablechanges) $id,$col r "0 0 1 1"
} else {
dict set ::eskil($top,tablechanges) $id,$col w1 ""
dict set ::eskil($top,tablechanges) $id,$col w2 $w
dict set ::eskil($top,tablechanges) $id,$col r "0 0 1 1"
}
incr col
}
}
}
# Insert lineno and text
proc insertLine {top n line text {tag {equal}} {linetag {}}} {
if {$::eskil($top,view) eq "table"} {
insertLineTable $top $n $line $text $tag
return
}
$::widgets($top,wDiff$n) insert end "$text\n" $tag
if {$linetag ne ""} {
append tag " $linetag"
}
if {$tag != "equal"} {
set tag "hl$::HighLightCount $tag"
}
$::widgets($top,wLine$n) insert end [myFormL $line] $tag
}
# Insert an empty line on one side of the diff.
proc emptyLine {top n {highlight 1}} {
if {$::eskil($top,view) eq "table"} {
# This should be ignored for table
return
}
if {$highlight} {
$::widgets($top,wLine$n) insert end "\n" hl$::HighLightCount
} else {
$::widgets($top,wLine$n) insert end "*****\n"
}
$::widgets($top,wDiff$n) insert end "\n" padding
}
# Helper to take care of -sep case
# This can be used when diffing e.g. a CSV file.
# Each column will be handled separately, so differences will never be shown
# crossing a separator
proc diffWithSeparator {RE line1 line2 opts} {
set ixs1 [regexp -all -inline -indices -- $RE $line1]
set ixs2 [regexp -all -inline -indices -- $RE $line2]
# Fake a separator after end of line, makes the loop below simpler
lappend ixs1 [list [string length $line1] [string length $line1]]
lappend ixs2 [list [string length $line2] [string length $line2]]
# Res is at all times starting and ending with an equal pair
# i.e. same format as the result from DiffStrings
set res [list {} {}]
set s1 0
set s2 0
foreach ix1 $ixs1 ix2 $ixs2 {
# Handle if one index list is shorter
if {$ix1 eq ""} {
set str1 ""
set sep1 ""
} else {
lassign $ix1 e1 ns1
incr e1 -1
set str1 [string range $line1 $s1 $e1]
set sep1 [string range $line1 {*}$ix1]
}
if {$ix2 eq ""} {
set str2 ""
set sep2 ""
} else {
lassign $ix2 e2 ns2
incr e2 -1
set str2 [string range $line2 $s2 $e2]
set sep2 [string range $line2 {*}$ix2]
}
if {$str1 eq $str2} {
# Merge this equality with end of res
set resEq1 [lindex $res end-1]
set resEq2 [lindex $res end]
lset res end-1 $resEq1$str1$sep1
lset res end $resEq2$str2$sep2
} else {
set r [DiffUtil::diffStrings {*}$opts $str1 $str2]
# Starting equal pair
set rEq1a [lindex $r 0]
set rEq2a [lindex $r 1]
# Ending equal pair
set rEq1b [lindex $r end-1]
set rEq2b [lindex $r end]
# Mid part
set r [lrange $r 2 end-2]
# Merge starting equalities with end of res
set resEq1 [lindex $res end-1]
set resEq2 [lindex $res end]
lset res end-1 $resEq1$rEq1a
lset res end $resEq2$rEq2a
# Merge equality at end with separator
lappend res {*}$r $rEq1b$sep1 $rEq2b$sep2
}
set s1 [expr {$ns1 + 1}]
set s2 [expr {$ns2 + 1}]
}
#puts "RES '$res'"
return $res
}
# This is called from the table view whenever a cell is drawn.
# Add color as needed.
proc tblModeColorCallback {win w key row col tabIdx1 tabIdx2 inStripe selected} {
set cellX $key,$col
set top [winfo toplevel $win]
if {![dict exists $::eskil($top,tablechanges) $cellX]} {
# No changes, nothing to do here
return
}
set cinfo [dict get $::eskil($top,tablechanges) $cellX]
set w1 [dict get $cinfo w1]
set w2 [dict get $cinfo w2]
#puts "COLOR UPDATE W $win K $key R $row C $col TB1 $tabIdx1 TB2 $tabIdx2"
#puts " [string length $xxx] '$xxx'"
#puts " CHANGEME"
# Currently the displayed string is just $w1$w2
# The table might have cut of display of a cell so make sure to stay
# within the boundaries.
set txIdx1 [$w index $tabIdx1+1c]
set l1 [string length $w1]
set mid "$txIdx1 + $l1 char"
if {[$w compare $mid >= $tabIdx2]} {
set mid $tabIdx2
}
$w tag add new1 $txIdx1 $mid
$w tag add new2 $mid $tabIdx2
# Get the displayed string
set xxx [$w get $txIdx1 $tabIdx2]
if {$xxx ne "$w1$w2"} {
# Make sure dots are coloured
$w tag add change "$tabIdx2 - 3c" $tabIdx2
}
}
# insertMatchingLines, when in table mode
proc insertMatchingLinesTable {top line1 line2} {
global doingLine1 doingLine2
set opts $::Pref(ignore)
if {$::Pref(nocase)} {lappend opts -nocase}
if {$::Pref(lineparsewords)} {lappend opts -words}
set RE $::eskil($top,separator)
set words1 [split $line1 $RE]
set words2 [split $line2 $RE]
# Lap 1, make row data
set rs {}
set row {}
foreach w1 $words1 w2 $words2 {
set r [DiffUtil::diffStrings {*}$opts $w1 $w2]
# Store for next lap
lappend rs $r
if {[llength $r] <= 2} {
# Equal
lappend row $w1
} else {
# TBD TABLE, simple display for now
lappend row $w1$w2
}
}
set id [$::widgets($top,wTable) insert end $row]
# Lap 2, collect cell changes once we have the row id
set col -1
foreach w1 $words1 w2 $words2 r $rs {
incr col
# Equal? Skip
if {[llength $r] <= 2} continue
dict set ::eskil($top,tablechanges) $id,$col "w1" $w1
dict set ::eskil($top,tablechanges) $id,$col "w2" $w2
dict set ::eskil($top,tablechanges) $id,$col "r" $r
}
incr doingLine1
incr doingLine2
}
# Insert one line in each text widget.
# Mark them as changed, and optionally parse them.
proc insertMatchingLines {top line1 line2} {
global doingLine1 doingLine2
if {$::eskil($top,view) eq "table"} {
insertMatchingLinesTable $top $line1 $line2
return
}
# FIXA: fully implement filter
if {$::eskil(filter) != ""} {
if {[regexp $::eskil(filter) $line1]} {
insertLine $top 1 $doingLine1 $line1
insertLine $top 2 $doingLine2 $line2
incr doingLine1
incr doingLine2
set ::eskil(filterflag) 1
return
}
set ::eskil(filterflag) 0
}
if {$::Pref(parse) != 0} {
set opts $::Pref(ignore)
if {$::Pref(nocase)} {lappend opts -nocase}
if {$::Pref(lineparsewords)} {lappend opts -words}
if {$::eskil($top,separator) ne ""} {
set res [diffWithSeparator $::eskil($top,separator) $line1 $line2 \
$opts]
} else {
set res [DiffUtil::diffStrings {*}$opts $line1 $line2]
}
set dotag 0
set n [expr {[llength $res] / 2}]
$::widgets($top,wLine1) insert end [myFormL $doingLine1] \
"hl$::HighLightCount change"
$::widgets($top,wLine2) insert end [myFormL $doingLine2] \
"hl$::HighLightCount change"
set new1 "new1"
set new2 "new2"
set change "change"
foreach {i1 i2} $res {
incr n -1
if {$dotag} {
if {$n == 1 && $::Pref(marklast)} {
lappend new1 last
lappend new2 last
lappend change last
}
if {$i1 eq ""} {
$::widgets($top,wDiff2) insert end $i2 $new2
} elseif {$i2 eq ""} {
$::widgets($top,wDiff1) insert end $i1 $new1
} else {
$::widgets($top,wDiff1) insert end $i1 $change
$::widgets($top,wDiff2) insert end $i2 $change
}
set dotag 0
} else {
$::widgets($top,wDiff1) insert end $i1
$::widgets($top,wDiff2) insert end $i2
set dotag 1
}
}
$::widgets($top,wDiff1) insert end "\n"
$::widgets($top,wDiff2) insert end "\n"
} else {
insertLine $top 1 $doingLine1 $line1 "change"
insertLine $top 2 $doingLine2 $line2 "change"
}
incr doingLine1
incr doingLine2
}
# Detect if only newlines has changed within the block, e.g.
# when rearranging newlines.
# Rearranging newlines in comment blocks usually leads to
# words moving across "*", ignore * too.
# Returns 0 if the block in not handled here, non-zero if the block is done,
# negative if the block is considered not a change.
proc ParseBlocksAcrossNewline {top block1 block2} {
global doingLine1 doingLine2
set map {{ } {} \t {}}
set RE {\n\s*\*?|\s}
set equal 0
set visible [expr {$::eskil(ignorenewline) == 1}]
if 1 {
set block1nospace [regsub -all $RE [join $block1 \n] {}]
set block2nospace [regsub -all $RE [join $block2 \n] {}]
if {$block1nospace eq $block2nospace} {
set equal 1
}
} else {
set block1nospace [string map $map [join $block1 ""]]
set block2nospace [string map $map [join $block2 ""]]
if {$block1nospace eq $block2nospace} {
set equal 1
} else {
# Look for newlines rearranged in a comment block.
set block1nostar [string map {* {}} $block1nospace]
set block2nostar [string map {* {}} $block2nospace]
if {$block1nostar eq $block2nostar} {
set equal 1
}
}
}
if {!$equal} {
return 0
}
if {$visible} {
set tag change
} else {
set tag {}
}
# Just insert the blocks
foreach line $block1 {
insertLine $top 1 $doingLine1 $line {} $tag
incr doingLine1
}
foreach line $block2 {
insertLine $top 2 $doingLine2 $line {} $tag
incr doingLine2
}
set n1 [llength $block1]
set n2 [llength $block2]
if {$n1 <= $n2} {
for {set t $n1} {$t < $n2} {incr t} {
if {$visible} {
$::widgets($top,wDiff1) insert end "\n" "padding change"
$::widgets($top,wLine1) insert end "\n" hl$::HighLightCount
} else {
emptyLine $top 1
}
}
} elseif {$n2 < $n1} {
if {$visible} {
for {set t $n2} {$t < $n1} {incr t} {
$::widgets($top,wDiff2) insert end "\n" "padding change"
$::widgets($top,wLine2) insert end "\n" hl$::HighLightCount
}
} else {
emptyLine $top 2
}
}
if {$visible} {
$::widgets($top,wDiff1) insert end "\n" "padding change"
$::widgets($top,wDiff2) insert end "\n" "padding change"
$::widgets($top,wLine1) insert end "\n" hl$::HighLightCount
$::widgets($top,wLine2) insert end "\n" hl$::HighLightCount
return [expr {($n1 > $n2 ? $n1 : $n2) + 1}]
} else {
return [expr {-($n1 > $n2 ? $n1 : $n2)}]
}
}
# Insert two blocks of lines in the compare windows.
# No extra parsing at all.
proc insertMatchingBlocksNoParse {top block1 block2 line1 line2 details} {
global doingLine1 doingLine2
set n1 [llength $block1]
set n2 [llength $block2]
# Is this a change block, a delete block or an insert block?
if {$n1 == 0} {set tag2 new2} else {set tag2 change}
if {$n2 == 0} {set tag1 new1} else {set tag1 change}
if {$n1 == $n2} {
# This should only happen for equal sized blocks that were deemed
# too large for block parsing.
foreach line1 $block1 line2 $block2 {
insertMatchingLines $top $line1 $line2
}
} else {
foreach line $block1 {
insertLine $top 1 $doingLine1 $line $tag1
incr doingLine1
}
foreach line $block2 {
insertLine $top 2 $doingLine2 $line $tag2
incr doingLine2
}
}
if {$n1 <= $n2} {
for {set t $n1} {$t < $n2} {incr t} {
emptyLine $top 1
}
addChange $top $n2 $tag2 $line1 $n1 $line2 $n2
nextHighlight $top
} elseif {$n2 < $n1} {
for {set t $n2} {$t < $n1} {incr t} {
emptyLine $top 2
}
addChange $top $n1 $tag1 $line1 $n1 $line2 $n2
nextHighlight $top
}
}
# Insert two blocks of lines in the compare windows.
proc insertMatchingBlocks {top block1 block2 line1 line2 details} {
global doingLine1 doingLine2
set n1 [llength $block1]
set n2 [llength $block2]
set large [expr {$n1 * $n2 > 5000}]
if {$n1 == 0 || $n2 == 0 || $::Pref(parse) < 2 || \
($large && $::Pref(parse) < 3)} {
# No extra parsing at all.
insertMatchingBlocksNoParse $top $block1 $block2 $line1 $line2 $details
return
}
# A large block may take time. Give a small warning.
if {$n1 * $n2 > 2000} {
set ::widgets($top,eqLabel) "!"
update idletasks
}
# Detect if only newlines has changed within the block, e.g.
# when rearranging newlines.
if {$::eskil(ignorenewline)} {
set res [ParseBlocksAcrossNewline $top $block1 $block2]
if {$res != 0} {
# FIXA: move this to ParseBlocksAcrossNewline ?
if {$res > 0 && $details} {
addChange $top $res change $line1 $n1 $line2 $n2
nextHighlight $top
} else {
addMapLines $top [expr {abs($res)}]
}
return
}
}
set apa [compareBlocks $block1 $block2]
# Fine grained changes means that each line is considered its own
# chunk. This is used for merging better to avoid the same decision
# for an entire block.
set finegrain [expr {$::Pref(finegrainchunks) && $details}]
if {$finegrain && $::eskil($top,ancestorFile) ne ""} {
# Avoid fine grain depending on relation to ancestor
set leftChange 0
set leftChangeOrAdd 0
for {set t $line1} {$t < $line1 + $n1} {incr t} {
if {[info exists ::eskil($top,ancestorLeft,$t)]} {
set leftChangeOrAdd 1
if {$::eskil($top,ancestorLeft,$t) eq "c"} {
set leftChange 1
break
}
}
}
set rightChange 0
set rightChangeOrAdd 0
for {set t $line2} {$t < $line2 + $n2} {incr t} {
if {[info exists ::eskil($top,ancestorRight,$t)]} {
set rightChangeOrAdd 1
if {$::eskil($top,ancestorRight,$t) eq "c"} {
set rightChange 1
break
}
}
}
# Avoid fine grain if either side has no changes against ancestor
if {!$leftChangeOrAdd || !$rightChangeOrAdd} {
set finegrain 0
}
# Avoid fine grain if both sides have at most additions
if {!$leftChange && !$rightChange} {
set finegrain 0
}
}
set t1 0
set t2 0
foreach c $apa {
if {$c eq "c"} {
set textline1 [lindex $block1 $t1]
set textline2 [lindex $block2 $t2]
insertMatchingLines $top $textline1 $textline2
if {$finegrain} {
addChange $top 1 change [expr {$line1 + $t1}] 1 \
[expr {$line2 + $t2}] 1
nextHighlight $top
}
incr t1
incr t2
} elseif {$c eq "C"} {
# This is two lines that the block matching considered
# too different to use line parsing on them.
# Marked the whole line as deleted/inserted
set textline1 [lindex $block1 $t1]
set textline2 [lindex $block2 $t2]
if {$::eskil($top,view) eq "table"} {
# Fall back to proc that handles table
insertMatchingLinesTable $top $textline1 $textline2
} else {
# insertLine cannot be used here since lineNo and text tags
# are different
$::widgets($top,wLine1) insert end [myFormL $doingLine1] \
"hl$::HighLightCount change"
$::widgets($top,wDiff1) insert end "$textline1\n" new1
$::widgets($top,wLine2) insert end [myFormL $doingLine2] \
"hl$::HighLightCount change"
$::widgets($top,wDiff2) insert end "$textline2\n" new2
incr doingLine1
incr doingLine2
}
if {$finegrain} {
addChange $top 1 change [expr {$line1 + $t1}] 1 \
[expr {$line2 + $t2}] 1
nextHighlight $top
}
incr t1
incr t2
} elseif {$c eq "d"} {
set bepa [lindex $block1 $t1]
if {$::eskil($top,view) eq "table"} {
insertLineTable $top 1 $doingLine1 $bepa new1
} else {
$::widgets($top,wLine1) insert end [myFormL $doingLine1] \
"hl$::HighLightCount change"
$::widgets($top,wDiff1) insert end "$bepa\n" new1
emptyLine $top 2
}
incr doingLine1
if {$finegrain} {
addChange $top 1 new1 [expr {$line1 + $t1}] 1 \
[expr {$line2 + $t2}] 0
nextHighlight $top
}
incr t1
} elseif {$c eq "a"} {
set bepa [lindex $block2 $t2]
if {$::eskil($top,view) eq "table"} {
insertLineTable $top 2 $doingLine2 $bepa new2
} else {
$::widgets($top,wLine2) insert end [myFormL $doingLine2] \
"hl$::HighLightCount change"
$::widgets($top,wDiff2) insert end "$bepa\n" new2
emptyLine $top 1
}
incr doingLine2
if {$finegrain} {
addChange $top 1 new2 [expr {$line1 + $t1}] 0 \
[expr {$line2 + $t2}] 1
nextHighlight $top
}
incr t2
}
}
if {!$finegrain} {
if {$details} {
addChange $top [llength $apa] change $line1 $n1 $line2 $n2
nextHighlight $top
} else {
addMapLines $top [llength $apa]
}
}
}
# Process one of the change/add/delete blocks reported by diff.
# ch1 is a file channel for the left file
# ch2 is a file channel for the right file
# n1/n2 is the number of lines involved
# line1/line2 says on what lines this block starts
# If n1/n2 are both 0, it means that this is the last lines to be displayed.
# In that case line1/line2, if non-zero says the last line to display.
proc doText {top ch1 ch2 n1 n2 line1 line2} {
global doingLine1 doingLine2
if {$n1 == 0 && $n2 == 0} {
# All blocks have been processed. Continue until end of file.
# If "show all" is not on, just display a couple of context lines.
set limit -1
if {$::Pref(context) >= 0} {
set limit $::Pref(context)
}
# Consider any total limit on displayed lines.
if {$::eskil($top,limitlines)} {
set limit [expr {$::eskil($top,limitlines) - $::eskil($top,mapMax)}]
if {$limit < 0} {
set limit 0
}
}
if {$limit >= 0} {disallowEdit $top}
# Unless we are in "only diffs", display remaining lines to the limit
if {$limit != 0} {
set t 0
while {[gets $ch2 apa] != -1} {
if {$line2 > 0 && $doingLine2 > $line2} break
insertLine $top 2 $doingLine2 $apa
incr doingLine2
addMapLines $top 1
incr t
if {$limit >= 0 && $t >= $limit} break
}
if {$::eskil($top,view) ne "table"} {
set t 0
while {[gets $ch1 apa] != -1} {
if {$line1 > 0 && $doingLine1 > $line1} break
insertLine $top 1 $doingLine1 $apa
incr doingLine1
incr t
if {$limit >= 0 && $t >= $limit} break
}
}
}
return
}
# Is this a change block, a delete block or an insert block?
if {$n1 == 0} {set tag2 new2} else {set tag2 change}
if {$n2 == 0} {set tag1 new1} else {set tag1 change}
# Display all equal lines before next diff, or skip if context is set.
# If context is on, only skip a section if the blank
# line replaces at least 3 lines.
set limit -1
if {$::Pref(context) == 0} {
set limit 0
} elseif {$::Pref(context) > 0 && \
($line1 - $doingLine1 > (2 * $::Pref(context) + 2))} {
set limit $::Pref(context)
}
if {$doingLine1 == 1} {
set allowStartFill 0
} else {
set allowStartFill 1
}
set t 0
while {$doingLine1 < $line1} {
gets $ch1 apa
gets $ch2 bepa
if {$limit < 0 || ($t < $limit && $allowStartFill) || \
($line1 - $doingLine1) <= $limit} {
if {$::eskil($top,view) ne "table"} {
insertLine $top 1 $doingLine1 $apa
insertLine $top 2 $doingLine2 $bepa
} else {
insertLineTable $top 1 $doingLine1 $apa
}
addMapLines $top 1
} elseif {$t == $limit && $allowStartFill} {
# If zero context is shown, skip the filler to keep display tight.
if {$limit > 0} {
emptyLine $top 1 0
emptyLine $top 2 0
addMapLines $top 1
}
}
incr doingLine1
incr doingLine2
incr t
if {$::eskil($top,limitlines) && \
($::eskil($top,mapMax) > $::eskil($top,limitlines))} {
return
}
}
# This should not happen unless something is wrong...
if {$doingLine2 != $line2} {
disallowEdit $top
$::widgets($top,wDiff1) insert end \
"**Bad alignment here!! $doingLine2 $line2**\n"
$::widgets($top,wDiff2) insert end \
"**Bad alignment here!! $doingLine2 $line2**\n"
$::widgets($top,wLine1) insert end "\n"
$::widgets($top,wLine2) insert end "\n"
}
# Process the block
if {$n1 == $n2 && ($n1 == 1 || $::Pref(parse) < 2)} {
# Never do block parsing for one line blocks.
# If block parsing is turned off, only do line parsing for
# blocks of equal size.
for {set t 0} {$t < $n1} {incr t} {
gets $ch1 textline1
gets $ch2 textline2
insertMatchingLines $top $textline1 $textline2
}
if {$::eskil(filter) != "" && $::eskil(filterflag)} {
addMapLines $top $n1
} else {
addChange $top $n1 change $line1 $n1 $line2 $n2
nextHighlight $top
}
} else {
# Collect blocks
set block1 {}
for {set t 0} {$t < $n1} {incr t} {
gets $ch1 apa
lappend block1 $apa
}
set block2 {}
for {set t 0} {$t < $n2} {incr t} {
gets $ch2 apa
lappend block2 $apa
}
insertMatchingBlocks $top $block1 $block2 $line1 $line2 1
}
# Empty return value
return
}
proc enableRedo {top} {
$top.m.mf entryconfigure "Redo Diff" -state normal
$top.m.mt entryconfigure "Merge" -state normal
}
proc disableRedo {top} {
$top.m.mf entryconfigure "Redo Diff" -state disabled
$top.m.mt entryconfigure "Merge" -state disabled
}
proc busyCursor {top} {
global oldcursor oldcursor2
if {$::eskil($top,view) eq "table"} {
set items wTable
} else {
set items {wLine1 wDiff1 wLine2 wDiff2}
}
if {![info exists oldcursor]} {
set oldcursor [$top cget -cursor]
set i1 [lindex $items 0]
set oldcursor2 [$::widgets($top,$i1) cget -cursor]
}
$top config -cursor watch
foreach item $items {
if {[info exists ::widgets($top,$item)]} {
set w $::widgets($top,$item)
$w config -cursor watch
}
}
}
proc normalCursor {top} {
global oldcursor oldcursor2
if {$::eskil($top,view) eq "table"} {
set items wTable
} else {
set items {wLine1 wDiff1 wLine2 wDiff2}
}
$top config -cursor $oldcursor
foreach item $items {
if {[info exists ::widgets($top,$item)]} {
set w $::widgets($top,$item)
$w config -cursor $oldcursor2
}
}
}
#####################################
# Special cases. Conflict/patch
#####################################
proc startConflictDiff {top file} {
set ::eskil($top,mode) "conflict"
set ::eskil($top,modetype) ""
set ::eskil($top,view) ""
set ::eskil($top,conflictFile) $file
set ::eskil($top,rightDir) [file dirname $file]
set ::eskil($top,rightOK) 1
set ::eskil($top,rightLabel) $file
set ::eskil($top,leftLabel) $file
set ::eskil($top,leftOK) 0
# Turn off ignore
set ::Pref(ignore) " "
set ::Pref(nocase) 0
set ::Pref(noempty) 0
# Try to autodetect line endings in file
detectLineEnd $top $file mergetranslation lf
}
# Read a conflict file and extract the two versions.
proc prepareConflict {top} {
disallowEdit $top
set ::eskil($top,leftFile) [tmpFile]
set ::eskil($top,rightFile) [tmpFile]
set ch1 [open $::eskil($top,leftFile) w]
set ch2 [open $::eskil($top,rightFile) w]
set ch [open $::eskil($top,conflictFile) r]
set ::eskil($top,conflictDiff) {}
set leftLine 1
set rightLine 1
set state both
set rightName ""
set leftName ""
while {[gets $ch line] != -1} {
if {[string match <<<<<<* $line]} {
set state right
regexp {<*\s*(.*)} $line -> rightName
set start2 $rightLine
} elseif {[string match ======* $line] && $state eq "right"} {
set state left
set end2 [expr {$rightLine - 1}]
set start1 $leftLine
} elseif {[string match >>>>>>* $line] && $state eq "left"} {
set state both
regexp {>*\s*(.*)} $line -> leftName
set end1 [expr {$leftLine - 1}]
lappend ::eskil($top,conflictDiff) [list \
$start1 [expr {$end1 - $start1 + 1}] \
$start2 [expr {$end2 - $start2 + 1}]]
} elseif {$state eq "both"} {
puts $ch1 $line
puts $ch2 $line
incr leftLine
incr rightLine
} elseif {$state eq "left"} {
puts $ch1 $line
incr leftLine
} else {
puts $ch2 $line
incr rightLine
}
}
close $ch
close $ch1
close $ch2
if {$leftName eq "" && $rightName eq ""} {
set leftName "No Conflict: [file tail $::eskil($top,conflictFile)]"
set rightName $leftName
}
set ::eskil($top,leftLabel) $leftName
set ::eskil($top,rightLabel) $rightName
update idletasks
}
# Clean up after a conflict diff.
proc cleanupConflict {top} {
clearTmp $::eskil($top,rightFile) $::eskil($top,leftFile)
set ::eskil($top,rightFile) $::eskil($top,conflictFile)
set ::eskil($top,leftFile) $::eskil($top,conflictFile)
}
# Display one chunk from a patch file
proc displayOnePatch {top leftLines rightLines leftLine rightLine} {
mapNoChange $top 1
emptyLine $top 1
emptyLine $top 2
set leftlen [llength $leftLines]
set rightlen [llength $rightLines]
set leftc 0
set rightc 0
set lblock {}
set lblockl 0
set rblock {}
set rblockl 0
while {$leftc < $leftlen || $rightc < $rightlen} {
lassign [lindex $leftLines $leftc] lline lmode lstr
lassign [lindex $rightLines $rightc] rline rmode rstr
# Fix the case where one side's block is empty.
# That means that each line not marked should show up on both sides.
if {$leftc >= $leftlen} {
set lline $leftLine
incr leftLine
set lmode ""
set lstr $rstr
}
if {$rightc >= $rightlen} {
set rline $rightLine
incr rightLine
set rmode ""
set rstr $lstr
}
# Treat the combination "-" and "+" as a "!"
if {$lmode == "-" && $rmode == "+"} {
set lmode "!"
set rmode "!"
}
if {$lmode == "-" && [llength $lblock] > 0} {
set lmode "!"
}
if {$rmode == "+" && [llength $rblock] > 0} {
set rmode "!"
}
# If we are in a change block, gather up all lines
if {$lmode == "!" || $rmode == "!"} {
if {$lmode == "!"} {
if {[llength $lblock] == 0} {
set lblockl $lline
}
lappend lblock $lstr
incr leftc
}
if {$rmode == "!"} {
if {[llength $rblock] == 0} {
set rblockl $rline
}
lappend rblock $rstr
incr rightc
}
continue
}
# No change block anymore. If one just ended, display it.
if {[llength $lblock] > 0 || [llength $rblock] > 0} {
set ::doingLine1 $lblockl
set ::doingLine2 $rblockl
insertMatchingBlocks $top $lblock $rblock $lblockl $rblockl 0
set lblock {}
set rblock {}
}
if {$lmode == "" && $rmode == ""} {
insertLine $top 1 $lline $lstr
insertLine $top 2 $rline $rstr
incr leftc
incr rightc
addMapLines $top 1
continue
}
if {$lmode == "-"} {
insertLine $top 1 $lline $lstr new1
emptyLine $top 2
incr leftc
addMapLines $top 1
continue
}
if {$rmode == "+"} {
insertLine $top 2 $rline $rstr new2
emptyLine $top 1
incr rightc
addMapLines $top 1
continue
}
}
# If the patch ended with a change block, display it.
if {[llength $lblock] > 0 || [llength $rblock] > 0} {
set ::doingLine1 $lblockl
set ::doingLine2 $rblockl
insertMatchingBlocks $top $lblock $rblock $lblockl $rblockl 0
set lblock {}
set rblock {}
}
mapNoChange $top 0
}
# Read a patch file and display it
proc displayPatch {top} {
set ::eskil($top,leftLabel) "Patch $::eskil($top,patchFile): old"
set ::eskil($top,rightLabel) "Patch $::eskil($top,patchFile): new"
update idletasks
if {$::eskil($top,patchFile) eq ""} {
if {$::eskil($top,patchData) eq ""} {
set data [getFullPatch $top]
} else {
set data $::eskil($top,patchData)
}
} elseif {$::eskil($top,patchFile) eq "-"} {
set data [read stdin]
} else {
set ch [open $::eskil($top,patchFile) r]
set data [read $ch]
close $ch
}
set style ""
set divider "-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-"
set leftLine 1
set rightLine 1
set leftLines {}
set rightLines {}
set state none
set fname ""
foreach line [split $data \n] {
# Detect a new file
if {[string match ======* $line] || [string match "diff *" $line]} {
if {$state != "none"} {
displayOnePatch $top $leftLines $rightLines $leftLine $rightLine
}
set leftLines {}
set rightLines {}
set state none
continue
}
# Detect a file name
if {[string match "Index: *" $line]} {
# If fname is set, a file that had no contents has passed.
# It could be a binary file or some other that the diffing source
# could not handle.
# Display the name to see that it is involved.
if {$fname ne ""} {
foreach side {1 2} {
emptyLine $top $side
insertLine $top $side "" $divider patch
insertLine $top $side "" $fname patch
insertLine $top $side "" $divider patch
}
addChange $top 4 change 0 0 0 0
}
set fname [string range $line 7 end]
}
# Detect the first line in a -c style diff
if {[regexp {^\*\*\* } $line]} {
if {$state eq "right"} {
displayOnePatch $top $leftLines $rightLines $leftLine $rightLine
set leftLines {}
set rightLines {}
set state none
}
if {$state eq "none"} {
set state newfile
set style c
set leftRE {^\*\*\*\s+(.*)$}
set rightRE {^---\s+(.*)$}
}
}
# Detect the first line in a -u style diff
if {[regexp {^--- } $line] && $state eq "none"} {
if {$state eq "right" || $state eq "both"} {
displayOnePatch $top $leftLines $rightLines $leftLine $rightLine
set leftLines {}
set rightLines {}
set state none
}
if {$state eq "none"} {
set state newfile
set style u
set leftRE {^---\s+(.*)$}
set rightRE {^\+\+\+\s+(.*)$}
}
}
if {$state eq "newfile" && [regexp $leftRE $line -> sub]} {
set fname ""
emptyLine $top 1
insertLine $top 1 "" $divider patch
insertLine $top 1 "" $sub patch
insertLine $top 1 "" $divider patch
addChange $top 4 change 0 0 0 0
continue
}
if {$state eq "newfile" && [regexp $rightRE $line -> sub]} {
set fname ""
emptyLine $top 2
insertLine $top 2 "" $divider patch
insertLine $top 2 "" $sub patch
insertLine $top 2 "" $divider patch
continue
}
# A new section in a -u style diff
# Normally the chunk starts with @@
# From some tools the chunk starts with ##
if {[regexp {^(?:@@|\#\#)\s+-(\d+)(?:,\d+)?\s+\+(\d+)} $line ->\
sub1 sub2]} {
if {$state eq "both"} {
displayOnePatch $top $leftLines $rightLines \
$leftLine $rightLine
}
# Look for c function annotation in -u style
if {[regexp {^@@.*@@(.*)$} $line -> cfun]} {
set cfun [string trim $cfun]
if {$cfun ne ""} {
insertLine $top 1 "" $cfun patch
insertLine $top 2 "" $cfun patch
}
}
set state both
set leftLine $sub1
set rightLine $sub2
set leftLines {}
set rightLines {}
continue
}
# A new section in a -c style diff
if {[regexp {^\*\*\*\*\*} $line]} {
if {$state eq "right"} {
displayOnePatch $top $leftLines $rightLines $leftLine $rightLine
}
# Look for c function annotation in -c style
if {[regexp {^\*\*\*\*\*\S*\s+(.*)$} $line -> cfun]} {
set cfun [string trim $cfun]
if {$cfun ne ""} {
insertLine $top 1 "" $cfun patch
insertLine $top 2 "" $cfun patch
}
}
set leftLines {}
set rightLines {}
set state left
continue
}
# We are in the left part of a -c style diff
if {$state eq "left"} {
if {[regexp {^\*\*\*\s*(\d*)} $line -> sub]} {
if {$sub != ""} {
set leftLine $sub
}
continue
}
if {[regexp {^---\s*(\d*)} $line -> sub]} {
if {$sub != ""} {
set rightLine $sub
}
set state right
continue
}
if {![regexp {^[\s!+-]} $line]} continue
lappend leftLines [list $leftLine \
[string trim [string range $line 0 1]] \
[string range $line 2 end]]
incr leftLine
continue
}
# We are in the right part of a -c style diff
if {$state eq "right"} {
if {![regexp {^[\s!+-]} $line]} continue
lappend rightLines [list $rightLine \
[string trim [string range $line 0 1]] \
[string range $line 2 end]]
incr rightLine
continue
}
# We are in a -u style diff
if {$state eq "both"} {
if {![regexp {^[\s+-]} $line]} continue
set sig [string trim [string index $line 0]]
set str [string range $line 1 end]
if {$sig eq ""} {
lappend leftLines [list $leftLine "" $str]
lappend rightLines [list $rightLine "" $str]
incr leftLine
incr rightLine
} elseif {$sig eq "-"} {
lappend leftLines [list $leftLine "-" $str]
incr leftLine
} else {
lappend rightLines [list $rightLine "+" $str]
incr rightLine
}
continue
}
}
if {$state != "none"} {
displayOnePatch $top $leftLines $rightLines $leftLine $rightLine
}
if {$fname ne ""} {
foreach side {1 2} {
emptyLine $top $side
insertLine $top $side "" $divider patch
insertLine $top $side "" $fname patch
insertLine $top $side "" $divider patch
}
addChange $top 4 change 0 0 0 0
}
}
#####################################
# Main diff
#####################################
# Prepare for a diff by creating needed temporary files
proc prepareFiles {top} {
set ::eskil($top,cleanup) {}
if {$::eskil($top,mode) eq "rev"} {
prepareRev $top
lappend ::eskil($top,cleanup) "rev"
} elseif {$::eskil($top,mode) eq "conflict"} {
prepareConflict $top
lappend ::eskil($top,cleanup) "conflict"
}
# Try to autodetect line endings in files
detectLineEnd $top $::eskil($top,rightFile) righttranslation
detectLineEnd $top $::eskil($top,leftFile) lefttranslation
# Prepare Separator
set ::eskil($top,separator) \
[subst -nocommands -novariables $::eskil($top,separatorview)]
# Autodetect separator before any plugin processing
if {$::eskil($top,view) eq "table" && $::eskil($top,separator) eq ""} {
set ch1 [open $::eskil($top,leftFile)]
if {$::eskil($top,gz)} {
zlib push gunzip $ch1
}
gets $ch1 line1
close $ch1
# Any tab, comma or semicolon?
if {[regsub -all "\t" $line1 "\t" _] >= 2} {
set ::eskil($top,separator) "\t"
set ::eskil($top,separatorview) "\\t"
} elseif {[regsub -all "," $line1 "," _] >= 2} {
set ::eskil($top,separator) ","
set ::eskil($top,separatorview) ","
lappend ::eskil(argv) -sep ","
} elseif {[regsub -all ";" $line1 ";" _] >= 2} {
set ::eskil($top,separator) ";"
set ::eskil($top,separatorview) ";"
lappend ::eskil(argv) -sep ";"
}
}
# Make it look like it came from command line
# It could come from the GUI or auto-detect, put it in the command line
# to make it visible for plugins.
set i [lsearch -exact $::eskil(argv) "-sep"]
if {$i >= 0} {
incr i
lset ::eskil(argv) $i $::eskil($top,separatorview)
} else {
lappend ::eskil(argv) -sep $::eskil($top,separatorview)
}
# Prepare plugin
if {$::eskil($top,plugin) ne "" && \
[dict get $::eskil($top,pluginpinfo) file]} {
preparePlugin $top
set ::eskil($top,cleanup) "plugin $::eskil($top,cleanup)"
}
}
# Clean up after a diff
proc cleanupFiles {top} {
foreach keyword $::eskil($top,cleanup) {
switch $keyword {
"rev" {cleanupRev $top}
"conflict" {cleanupConflict $top}
"plugin" {cleanupPlugin $top}
}
}
set ::eskil($top,cleanup) {}
}
# Redo Diff command
proc redoDiff {top} {
if {$::eskil($top,view) eq "table"} {
# TBD TABLE
doDiff $top
# Restore view
return
}
# Note what rows are being displayed
set w $::widgets($top,wDiff1)
set width [winfo width $w]
set height [winfo height $w]
set first [$w index @0,0]
set last [$w index @[- $width 4],[- $height 4]]
set first [lindex [split $first .] 0]
set last [lindex [split $last .] 0]
# Narrow it 5 lines since seeText will try to view 5 lines extra
incr first 5
incr last -5
if {$last < $first} {
set last $first
}
doDiff $top
# Restore view
foreach item {wLine1 wDiff1 wLine2 wDiff2} {
set w $::widgets($top,$item)
seeText $w $first.0 $last.0
}
}
# Make an appropriate tail for a window title, depending on mode and files.
proc TitleTail {top} {
set tail1 [file tail $::eskil($top,rightLabel)]
set tail2 [file tail $::eskil($top,leftLabel)]
if {$::eskil($top,mode) ne "" || $tail1 eq $tail2} {
if {$::eskil($top,mode) eq "rev"} {
set tail1 [file tail $::eskil($top,RevFile)]
} elseif {$::eskil($top,mode) eq "conflict"} {
set tail1 [file tail $::eskil($top,conflictFile)]
}
return $tail1
} else {
return "$tail2 vs $tail1"
}
}
# Main diff function.
proc doDiff {top} {
global doingLine1 doingLine2
if {$::eskil($top,mode) eq "" && ($::eskil($top,leftOK) == 0 || $::eskil($top,rightOK) == 0)} {
disableRedo $top
return
} else {
enableRedo $top
}
busyCursor $top
resetEdit $top
# Clear up everything before starting processing
if {$::eskil($top,view) eq "table"} {
set w $::widgets($top,wTable)
# TBD TABLE
$w configure -state normal
$w delete 0 end
set ::eskil($top,tablechanges) {}
} else {
foreach item {wLine1 wDiff1 wLine2 wDiff2 wTb} {
set w $::widgets($top,$item)
$w configure -state normal
$w delete 1.0 end
}
}
clearMap $top
set ::HighLightCount 0
highLightChange $top -1
# Display a star during diff execution, to know when the internal
# processing starts, and when the label is "valid".
set ::widgets($top,eqLabel) "*"
wm title $top "Eskil:"
update idletasks
if {$::eskil($top,mode) eq "patch"} {
disallowEdit $top
displayPatch $top
drawMap $top -1
#drawEditButtons $top
foreach item {wLine1 wLine2} {
set w $::widgets($top,$item)
$w configure -state disabled
}
update idletasks
wm title $top "Eskil: [file tail $::eskil($top,patchFile)]"
# TBD TABLE
$::widgets($top,wLine2) see 1.0
if {$::eskil($top,printFileCmd) && $::eskil($top,printFile) ne ""} {
after idle "doPrint $top 1 ; cleanupAndExit all"
}
normalCursor $top
return
} else {
prepareFiles $top
}
wm title $top "Eskil: [TitleTail $top]"
# Run diff and parse the result.
set opts $::Pref(ignore)
if {$::Pref(nocase)} {lappend opts -nocase}
if {$::Pref(noempty)} {lappend opts -noempty}
if {$::Pref(pivot) > 0} {lappend opts -pivot $::Pref(pivot)}
if {$::eskil($top,gz)} {lappend opts -gz}
if {[info exists ::eskil($top,aligns)] && \
[llength $::eskil($top,aligns)] > 0} {
lappend opts -align $::eskil($top,aligns)
}
set range {}
if {[info exists ::eskil($top,range)] && \
[llength $::eskil($top,range)] == 4} {
set range $::eskil($top,range)
lappend opts -range $range
}
foreach {RE sub side} [getActivePreprocess $top] {
lappend opts -regsub$side [list $RE $sub]
}
# Apply nodigit after preprocess
if {$::Pref(nodigit)} {lappend opts -nodigit}
# If a special file for diffing is present, use it.
if {[info exists ::eskil($top,leftFileDiff)]} {
set dFile1 $::eskil($top,leftFileDiff)
} else {
set dFile1 $::eskil($top,leftFile)
}
if {[info exists ::eskil($top,rightFileDiff)]} {
set dFile2 $::eskil($top,rightFileDiff)
} else {
set dFile2 $::eskil($top,rightFile)
}
set differr [catch {DiffUtil::diffFiles {*}$opts \
$dFile1 $dFile2} diffres]
# In conflict mode we can use the diff information collected when
# parsing the conflict file. This makes sure the blocks in the conflict
# file become change-blocks during merge.
if {$::eskil($top,mode) eq "conflict" && $::eskil($top,modetype) eq "Pure"} {
set diffres $::eskil($top,conflictDiff)
}
if {$differr != 0} {
if {$::eskil($top,view) eq "table"} {
# TBD TABLE
} else {
$::widgets($top,wDiff1) insert end $diffres
}
normalCursor $top
return
}
if {[llength $diffres] == 0} {
set ::widgets($top,eqLabel) "="
# Automatically close if equal
if {$::eskil(autoclose)} {
after idle cleanupAndExit $top
return
}
} else {
set ::widgets($top,eqLabel) " "
}
# Update the equal label immediately for better feedback
update idletasks
if {$::eskil($top,ancestorFile) ne ""} {
collectAncestorInfo $top $dFile1 $dFile2 $opts
}
set firstview 1
set ch1 [open $::eskil($top,leftFile)]
set ch2 [open $::eskil($top,rightFile)]
if {$::eskil($top,gz)} {
disallowEdit $top
zlib push gunzip $ch1
zlib push gunzip $ch2
}
set doingLine1 1
set doingLine2 1
if {$::eskil($top,view) eq "table"} {
# Look for table header line
set i [lindex $diffres 0]
lassign $i line1 n1 line2 n2
if {$line1 == 1 || $line2 == 1} {
# Hide header line of widget TBD TABLE
#$::widgets($top,wTable) configure
# Set up columns??
$::widgets($top,wTable) configure \
-columns "0 Table 0 without 0 header 0 not 0 implemented 0 yet"
} else {
# First lines are equal, treat them as header
# Consume table header line
gets $ch1 line1
incr doingLine1
gets $ch2 line
incr doingLine2
set headings [split $line1 $::eskil($top,separator)]
set columns {}
foreach heading $headings {
lappend columns 0 $heading
}
$::widgets($top,wTable) configure -columns $columns
if {$::eskil($top,maxwidth) > 0} {
set col -1
foreach {_ _} $columns {
incr col
$::widgets($top,wTable) columnconfigure $col \
-maxwidth $::eskil($top,maxwidth)
}
}
}
}
# If there is a range, skip lines up to the range
if {[llength $range] != 0} {
disallowEdit $top
lassign $range start1 end1 start2 end2
while {$doingLine1 < $start1 && [gets $ch1 line] >= 0} {
incr doingLine1
}
while {$doingLine2 < $start2 && [gets $ch2 line] >= 0} {
incr doingLine2
}
}
set t 0
foreach i $diffres {
lassign $i line1 n1 line2 n2
doText $top $ch1 $ch2 $n1 $n2 $line1 $line2
if {$::eskil($top,limitlines) && \
($::eskil($top,mapMax) > $::eskil($top,limitlines))} {
break
}
# Get one update when the screen has been filled.
# Show the first diff.
if {$firstview && $::eskil($top,mapMax) > 100} {
set firstview 0
showDiff $top 0
update idletasks
}
}
# If there is a range, just display the range
if {[llength $range] != 0} {
lassign $range start1 end1 start2 end2
} else {
set end1 0
set end2 0
}
doText $top $ch1 $ch2 0 0 $end1 $end2
if {$::eskil($top,view) ne "table"} {
# Make sure all text widgets have the same number of lines.
# The common y scroll doesn't work well if not.
set max 0.0
foreach item {wLine1 wDiff1 wLine2 wDiff2} {
set w $::widgets($top,$item)
if {[$w index end] > $max} {
set max [$w index end]
}
}
foreach item {wLine1 wDiff1 wLine2 wDiff2} {
set w $::widgets($top,$item)
set d [expr {int($max) - int([$w index end])}]
for {set t 0} {$t < $d} {incr t} {
$w insert end \n padding
}
}
}
close $ch1
close $ch2
# We can turn off editing in the text windows after everything
# is displayed.
noEdit $top
# Mark aligned lines TBD TABLE
if {[info exists ::eskil($top,aligns)] && \
[llength $::eskil($top,aligns)] > 0} {
foreach {align1 align2} $::eskil($top,aligns) {
set i [$::widgets($top,wLine1) search -regexp "\\m$align1\\M" 1.0]
if {$i != ""} {
$::widgets($top,wLine1) tag add align \
"$i linestart" "$i lineend"
}
set i [$::widgets($top,wLine2) search -regexp "\\m$align2\\M" 1.0]
if {$i != ""} {
$::widgets($top,wLine2) tag add align \
"$i linestart" "$i lineend"
}
}
}
drawMap $top -1
#drawEditButtons $top
if {$::eskil($top,view) ne "table"} {
foreach item {wLine1 wLine2 wTb} {
set w $::widgets($top,$item)
$w configure -state disabled
}
update idletasks
$::widgets($top,wLine2) see 1.0
}
normalCursor $top
showDiff $top 0
if {$::widgets($top,eqLabel) eq "!"} {
set ::widgets($top,eqLabel) " "
}
cleanupFiles $top
if {$::eskil($top,mode) eq "conflict"} {
if {$::widgets($top,eqLabel) != "="} {
makeMergeWin $top
}
} elseif {$::eskil($top,ancestorFile) ne ""} {
if {$::widgets($top,eqLabel) != "="} {
makeMergeWin $top
}
}
if {$::eskil($top,printFileCmd) && $::eskil($top,printFile) ne ""} {
# TBD TABLE
after idle "doPrint $top 1 ; cleanupAndExit all"
}
}
# This is the entrypoint to do a diff via DDE or Send
proc remoteDiff {file1 file2} {
newDiff $file1 $file2
}
#####################################
# Highlight and navigation stuff
#####################################
# Scroll windows to next/previous diff
proc findDiff {top delta} {
showDiff $top [expr {$::eskil($top,currHighLight) + $delta}]
}
# Scroll a text window to view a certain range, and possibly some
# lines before and after.
proc seeText {w si ei} {
$w see $ei
$w see $si
$w see $si-5lines
$w see $ei+5lines
if {[llength [$w bbox $si]] == 0} {
$w yview $si-5lines
}
if {[llength [$w bbox $ei]] == 0} {
$w yview $si
}
}
# Highlight a diff
proc highLightChange {top n} {
if {[info exists ::eskil($top,currHighLight)] && \
$::eskil($top,currHighLight) >= 0} {
$::widgets($top,wLine1) tag configure hl$::eskil($top,currHighLight) \
-background {}
$::widgets($top,wLine2) tag configure hl$::eskil($top,currHighLight) \
-background {}
}
set ::eskil($top,currHighLight) $n
if {$::eskil($top,currHighLight) < 0} {
set ::eskil($top,currHighLight) -1
} elseif {$::eskil($top,currHighLight) >= [llength $::eskil($top,changes)]} {
set ::eskil($top,currHighLight) [llength $::eskil($top,changes)]
} else {
$::widgets($top,wLine1) tag configure hl$::eskil($top,currHighLight) \
-background yellow
$::widgets($top,wLine2) tag configure hl$::eskil($top,currHighLight) \
-background yellow
}
}
# Highlight a diff and scroll windows to it.
proc showDiff {top num} {
# TBD TABLE
if {$::eskil($top,view) eq "table"} return
highLightChange $top $num
set change [lindex $::eskil($top,changes) $::eskil($top,currHighLight)]
set line1 [lindex $change 0]
if {$::eskil($top,currHighLight) < 0} {
set line1 1.0
set line2 1.0
} elseif {$line1 eq ""} {
set line1 end
set line2 end
} else {
set line2 [expr {$line1 + [lindex $change 1]}]
incr line1
set line1 $line1.0
set line2 $line2.0
}
foreach item {wLine1 wDiff1 wLine2 wDiff2} {
set w $::widgets($top,$item)
seeText $w $line1 $line2
}
}
#####################################
# Editing
#####################################
# FIXA: Use snit to adapt text widget instead of using wcb
# include seeText in such a snidget.
# Try to autodetect line endings in file
proc detectLineEnd {top file field {def {}}} {
set ch [open $file rb]
set data [read $ch 1000]
close $ch
if {[string first \r\n $data] >= 0} {
set ::eskil($top,$field) crlf
} elseif {[string first \n $data] >= 0} {
set ::eskil($top,$field) lf
} else {
set ::eskil($top,$field) $def
}
}
# Clear Editing state
proc resetEdit {top} {
set ::eskil($top,leftEdit) 0
set ::eskil($top,rightEdit) 0
$top.m.mt entryconfigure "Edit Mode" -state normal
if {$::eskil($top,view) eq "table"} {
return
}
resetEditW $::widgets($top,wDiff1)
resetEditW $::widgets($top,wDiff2)
}
# Clear Editing state for a Text widget
proc resetEditW {w} {
$w tag configure padding -background {}
$w edit reset
$w configure -undo 0
set ::eskil($w,allowChange) all
wcb::callback $w before insert {}
wcb::callback $w before delete {}
}
# Do not allow any editing
proc noEdit {top} {
if {$::eskil($top,view) eq "table"} {
return
}
noEditW $::widgets($top,wDiff1)
noEditW $::widgets($top,wDiff2)
}
# Do not allow any editing in a Text widget
proc noEditW {w} {
set ::eskil($w,allowChange) none
wcb::callback $w before insert [list TextInterceptInsert $w]
wcb::callback $w before delete [list TextInterceptDelete $w]
}
proc TextInterceptInsert {w ow index str args} {
if {$::eskil($w,allowChange) eq "none"} {
wcb::cancel
return
}
if {$::eskil($w,allowChange) eq "all"} return
#wcb::cancel - Cancel a widget command
#wcb::replace - Replace arguments of a widget command with new ones
# Disallow all new lines
if {[string first "\n" $str] >= 0} {
wcb::cancel
return
}
foreach {tag str2} $args {
if {[string first "\n" $str2] >= 0} {
wcb::cancel
return
}
}
}
proc TextInterceptDelete {w ow from {to {}}} {
if {$::eskil($w,allowChange) eq "none"} {
wcb::cancel
return
}
if {$::eskil($w,allowChange) eq "all"} return
if {$to eq ""} {
set to $from+1char
}
set text [$ow get $from $to]
# Disallow all new lines
if {[string first "\n" $text] >= 0} {
wcb::cancel
return
}
}
# Turn on editing for a Text widget
proc turnOnEdit {w} {
$w tag configure padding -background \#f0f0f0
$w configure -undo 1
set ::eskil($w,allowChange) line
}
# Turn on editing on sides where it has not been disallowed
proc allowEdit {top} {
$top.m.mt entryconfigure "Edit Mode" -state disable
if {$::eskil($top,leftEdit) == 0} {
set ::eskil($top,leftEdit) 1
turnOnEdit $::widgets($top,wDiff1)
}
if {$::eskil($top,rightEdit) == 0} {
set ::eskil($top,rightEdit) 1
turnOnEdit $::widgets($top,wDiff2)
}
}
# Turn off editing on sides that do not correspond to a file
proc disallowEdit {top {side 0}} {
if {$side == 0 || $side == 1} {
set ::eskil($top,leftEdit) -1
}
if {$side == 0 || $side == 2} {
set ::eskil($top,rightEdit) -1
}
if {$::eskil($top,leftEdit) == -1 && $::eskil($top,rightEdit) == -1} {
$top.m.mt entryconfigure "Edit Mode" -state disabled
}
}
# Ask if editing is allowed on a side
proc mayEdit {top side} {
if {$side == 1} {
return [expr {$::eskil($top,leftEdit) == 1}]
} else {
return [expr {$::eskil($top,rightEdit) == 1}]
}
}
# Start an undo block in a bunch of text widgets
proc startUndoBlock {args} {
foreach w $args {
$w configure -autoseparators 0
# Open up editing for copy functions
set ::eskil($w,allowChange) all
}
}
# End an undo block in a bunch of text widgets
proc endUndoBlock {args} {
foreach w $args {
$w configure -autoseparators 1
$w edit separator
set ::eskil($w,allowChange) line
}
}
# Copy a block
proc copyBlock {top from first last} {
set to [expr {3 - $from}]
set wfrom $::widgets($top,wDiff$from)
set wto $::widgets($top,wDiff$to)
set tags ""
set dump [$wfrom dump -all $first.0 $last.end+1c]
startUndoBlock $wfrom $wto
$wfrom delete $first.0 $last.end+1c
$wto delete $first.0 $last.end+1c
foreach {key value index} $dump {
switch -- $key {
text {
$wfrom insert $index $value $tags
$wto insert $index $value $tags
}
tagon {
if {$value eq "padding"} {
set tags "padding"
}
}
tagoff {
if {$value eq "padding"} {
set tags 0
}
}
}
}
endUndoBlock $wfrom $wto
}
# Copy a row between text widgets
proc copyRow {top from row} {
set to [expr {3 - $from}]
set wfrom $::widgets($top,wDiff$from)
set wto $::widgets($top,wDiff$to)
set text [$wfrom get $row.0 $row.end+1c]
startUndoBlock $wfrom $wto
$wto delete $row.0 $row.end+1c
$wto insert $row.0 $text ""
# Rewrite the source row to remove any tags
$wfrom delete $row.0 $row.end+1c
$wfrom insert $row.0 $text ""
endUndoBlock $wfrom $wto
}
# Delete a row filling it with padding
proc deleteBlock {top side from {to {}}} {
set w $::widgets($top,wDiff$side)
if {$to eq ""} {set to $from}
startUndoBlock $w
$w delete $from.0 $to.end+1c
$w insert $from.0 [string repeat \n [expr {$to - $from + 1}]] padding
endUndoBlock $w
}
# Get the lines involved in the display
proc getLinesFromRange {w range} {
set from [lindex $range 0]
set to [lindex $range 1]
lassign [split $from "."] fromr fromi
lassign [split $to "."] tor toi
if {$toi == 0} {incr tor -1}
# Get the corresponding lines in the file
set t [$w get $fromr.0 $tor.end]
set lines [lsort -integer [regexp -all -inline {\d+} $t]]
set froml [lindex $lines 0]
set tol [lindex $lines end]
return [list $fromr $tor $froml $tol]
}
# Called by popup menus over row numbers to add commands for editing.
# Returns 1 if nothing was added.
proc editMenu {m top n hl x y} {
if {![mayEdit $top $n]} {return 1}
# Only copy when in a change block
if {$hl ne ""} {
set o [expr {3 - $n}] ;# switch 1 <-> 2
set editOther [mayEdit $top $o]
set w $::widgets($top,wLine$n)
set wo $::widgets($top,wLine$o)
# Get the row that was clicked
set index [$w index @$x,$y]
set row [lindex [split $index "."] 0]
set line [regexp -inline {\d+} [$w get $row.0 $row.end]]
set lineo [regexp -inline {\d+} [$wo get $row.0 $row.end]]
# Row copy
if {$lineo ne ""} {
$m add command -label "Copy Row from other side" \
-command [list copyRow $top $o $row]
} else {
$m add command -label "Delete Row" \
-command [list deleteBlock $top $n $row]
}
if {$line ne "" && $editOther} {
$m add command -label "Copy Row to other side" \
-command [list copyRow $top $n $row]
}
# Get ranges for the change block
set range [$w tag ranges hl$hl]
set rangeo [$wo tag ranges hl$hl]
# Get the lines involved in the block
lassign [getLinesFromRange $w $range ] from to froml tol
lassign [getLinesFromRange $wo $rangeo] fromo too fromlo tolo
# More than one line in the block?
set thisSize 0
set otherSize 0
if {$froml ne "" && $tol ne ""} {
set thisSize [expr {$tol - $froml + 1}]
}
if {$fromlo ne "" && $tolo ne ""} {
set otherSize [expr {$tolo - $fromlo + 1}]
}
if {$thisSize > 1 || $otherSize > 1} {
if {$otherSize > 0} {
$m add command -label "Copy Block from other side" \
-command [list copyBlock $top $o $fromo $too]
} else {
$m add command -label "Delete Block" \
-command [list deleteBlock $top $n $from $to]
}
if {$editOther && $thisSize > 0} {
$m add command -label "Copy Block to other side" \
-command [list copyBlock $top $n $from $to]
}
}
}
$m add command -label "Save File" -command [list saveFile $top $n]
return 0
}
proc saveFile {top side} {
if {$side == 1} {
if {!$::eskil($top,leftEdit)} return
set fileName $::eskil($top,leftFile)
set trans $::eskil($top,lefttranslation)
} else {
if {!$::eskil($top,rightEdit)} return
set fileName $::eskil($top,rightFile)
set trans $::eskil($top,righttranslation)
}
set w $::widgets($top,wDiff$side)
# Confirm dialog
set apa [tk_messageBox -parent $top -icon question \
-title "Overwrite file" -type yesnocancel -message \
"Overwriting file [file tail $fileName]\nDo you want to\
create a backup copy ?"]
if {$apa eq "yes"} {
set backup [file rootname $fileName].bak
if {[catch {file copy -force $fileName $backup} result]} {
tk_messageBox -parent $top -icon error \
-title "File error" -type ok -message \
"Error creating backup file $backup:\n$result"
return
}
} elseif {$apa ne "no"} {
return
}
set ch [open $fileName "w"]
if {$trans ne ""} {
fconfigure $ch -translation $trans
}
set save 1
foreach {key value index} [$w dump -all 1.0 end-1c] {
switch -- $key {
text {
if {$save} {
puts -nonewline $ch $value
}
}
tagon {
if {$value eq "padding"} {
set save 0
}
}
tagoff {
if {$value eq "padding"} {
set save 1
}
}
}
}
close $ch
}
#####################################
# File dialog stuff
#####################################
# Check if a filename is a directory and handle starkits
proc FileIsDirectory {file {kitcheck 0}} {
# Skip directories
if {[file isdirectory $file]} {return 1}
# This detects .kit but how to detect starpacks?
if {[file extension $file] eq ".kit" || $kitcheck} {
if {![catch {package require vfs::mk4}]} {
if {![catch {vfs::mk4::Mount $file $file -readonly}]} {
# Check for contents to ensure it is a kit
if {[llength [glob -nocomplain $file/*]] == 0} {
vfs::unmount $file
}
}
# Now it is possible that the isdirectory status has changed
return [file isdirectory $file]
}
}
return 0
}
# A wrapper for tk_getOpenFile
proc myOpenFile {args} {
array set opts $args
set isVfs 0
if {[info exists opts(-initialdir)]} {
if {[string match tclvfs* [file system $opts(-initialdir)]]} {
set isVfs 1
}
}
# When in a vfs, make sure the Tcl file dialog is used
# to be able to access the files in a starkit.
if {$isVfs} {
# Only do this if tk_getOpenFile is not a proc.
if {[info procs tk_getOpenFile] eq ""} {
# If there is any problem, call the real one
if {![catch {set res [::tk::dialog::file:: open {*}$args]}]} {
return $res
}
}
}
return [tk_getOpenFile {*}$args]
}
proc doOpenLeft {top {forget 0}} {
if {!$forget && [info exists ::eskil($top,leftDir)]} {
set initDir $::eskil($top,leftDir)
} elseif {[info exists ::eskil($top,rightDir)]} {
set initDir $::eskil($top,rightDir)
} else {
set initDir [pwd]
}
set apa [myOpenFile -title "Select left file" -initialdir $initDir \
-parent $top]
if {$apa != ""} {
set ::eskil($top,leftDir) [file dirname $apa]
set ::eskil($top,leftFile) $apa
set ::eskil($top,leftLabel) $apa
set ::eskil($top,leftOK) 1
return 1
}
return 0
}
proc doOpenRight {top {forget 0}} {
if {!$forget && [info exists ::eskil($top,rightDir)]} {
set initDir $::eskil($top,rightDir)
} elseif {[info exists ::eskil($top,leftDir)]} {
set initDir $::eskil($top,leftDir)
} else {
set initDir [pwd]
}
set apa [myOpenFile -title "Select right file" -initialdir $initDir \
-parent $top]
if {$apa != ""} {
set ::eskil($top,rightDir) [file dirname $apa]
set ::eskil($top,rightFile) $apa
set ::eskil($top,rightLabel) $apa
set ::eskil($top,rightOK) 1
return 1
}
return 0
}
proc doOpenAncestor {top} {
if {$::eskil($top,ancestorFile) ne ""} {
set initDir [file dirname $::eskil($top,ancestorFile)]
} elseif {[info exists ::eskil($top,leftDir)]} {
set initDir $::eskil($top,leftDir)
} elseif {[info exists ::eskil($top,rightDir)]} {
set initDir $::eskil($top,rightDir)
} else {
set initDir [pwd]
}
set apa [myOpenFile -title "Select ancestor file" -initialdir $initDir \
-parent $top]
if {$apa != ""} {
set ::eskil($top,ancestorFile) $apa
return 1
}
return 0
}
proc openLeft {top} {
if {[doOpenLeft $top]} {
set ::eskil($top,mode) ""
set ::eskil($top,mergeFile) ""
doDiff $top
}
}
proc openRight {top} {
if {[doOpenRight $top]} {
set ::eskil($top,mode) ""
set ::eskil($top,mergeFile) ""
doDiff $top
}
}
proc openAncestor {top} {
if {[doOpenAncestor $top]} {
# Redo diff with ancestor
doDiff $top
}
}
proc openConflict {top} {
if {[doOpenRight $top]} {
startConflictDiff $top $::eskil($top,rightFile)
set ::eskil($top,mergeFile) ""
doDiff $top
}
}
proc openPatch {top} {
if {[doOpenLeft $top]} {
set ::eskil($top,mode) "patch"
set ::Pref(ignore) " "
set ::Pref(nocase) 0
set ::Pref(noempty) 0
set ::eskil($top,patchFile) $::eskil($top,leftFile)
set ::eskil($top,patchData) ""
doDiff $top
}
}
# Get data from clipboard and display as a patch.
proc doPastePatch {top} {
if {[catch {::tk::GetSelection $top CLIPBOARD} sel]} {
tk_messageBox -icon error -title "Eskil Error" -parent $top \
-message "Could not retreive clipboard" -type ok
return
}
set ::eskil($top,mode) "patch"
set ::Pref(ignore) " "
set ::Pref(nocase) 0
set ::Pref(noempty) 0
set ::eskil($top,patchFile) ""
set ::eskil($top,patchData) $sel
doDiff $top
}
proc openRev {top} {
if {[doOpenRight $top]} {
set rev [detectRevSystem $::eskil($top,rightFile)]
if {$rev eq ""} {
tk_messageBox -icon error -title "Eskil Error" -message \
"Could not figure out which revison control system\
\"$::eskil($top,rightFile)\" is under." -type ok
return
}
startRevMode $top $rev $::eskil($top,rightFile)
set ::eskil($top,mergeFile) ""
doDiff $top
}
}
proc openBoth {top forget} {
if {[doOpenLeft $top]} {
if {[doOpenRight $top $forget]} {
set ::eskil($top,mode) ""
set ::eskil($top,mergeFile) ""
doDiff $top
}
}
}
# File drop using TkDnd
proc fileDrop {top side files} {
# FIXA: Maybe single drop during rev mode should stay in rev mode?
# Dropping two files mean set both
if {[llength $files] >= 2} {
set leftFile [lindex $files 0]
set rightFile [lindex $files 1]
} else {
if {$side eq "any"} {
# Dropped outside the text widgets. Try to be clever.
if {![info exists ::eskil($top,lastDrop)]} {
set side left
} elseif {$::eskil($top,lastDrop) eq "left"} {
set side right
} else {
set side left
}
}
if {$side eq "left"} {
set leftFile [lindex $files 0]
set rightFile ""
} else {
set leftFile ""
set rightFile [lindex $files 0]
}
set ::eskil($top,lastDrop) $side
}
if {$leftFile ne ""} {
set ::eskil($top,leftDir) [file dirname $leftFile]
set ::eskil($top,leftFile) $leftFile
set ::eskil($top,leftLabel) $leftFile
set ::eskil($top,leftOK) 1
set ::eskil($top,mode) ""
set ::eskil($top,mergeFile) ""
}
if {$rightFile ne ""} {
set ::eskil($top,rightDir) [file dirname $rightFile]
set ::eskil($top,rightFile) $rightFile
set ::eskil($top,rightLabel) $rightFile
set ::eskil($top,rightOK) 1
set ::eskil($top,mode) ""
set ::eskil($top,mergeFile) ""
}
if {$::eskil($top,leftOK) && $::eskil($top,rightOK)} {
doDiff $top
}
}
#####################################
# GUI stuff
#####################################
# A little helper to make a scrolled window
# It returns the name of the scrolled window
proc Scroll {dir class w args} {
switch -- $dir {
both {
set scrollx 1
set scrolly 1
}
x {
set scrollx 1
set scrolly 0
}
y {
set scrollx 0
set scrolly 1
}
default {
return -code error "Bad scrolldirection \"$dir\""
}
}
ttk::frame $w
$class $w.s {*}$args
# Move border properties to frame
set bw [$w.s cget -borderwidth]
set relief [$w.s cget -relief]
$w configure -relief $relief -borderwidth $bw
$w.s configure -borderwidth 0
grid $w.s -sticky news
if {$scrollx} {
$w.s configure -xscrollcommand [list $w.sbx set]
ttk::scrollbar $w.sbx -orient horizontal -command [list $w.s xview]
grid $w.sbx -row 1 -sticky we
}
if {$scrolly} {
$w.s configure -yscrollcommand [list $w.sby set]
ttk::scrollbar $w.sby -orient vertical -command [list $w.s yview]
grid $w.sby -row 0 -column 1 -sticky ns
}
grid columnconfigure $w 0 -weight 1
grid rowconfigure $w 0 -weight 1
return $w.s
}
################
# Align function
################
proc enableAlign {top} {
eval $::widgets($top,enableAlignCmd)
}
proc disableAlign {top} {
eval $::widgets($top,disableAlignCmd)
}
# Remove one or all alignment pairs
proc clearAlign {top {leftline {}}} {
if {$leftline == ""} {
set ::eskil($top,aligns) {}
} else {
set i 0
while 1 {
set i [lsearch -integer -start $i $::eskil($top,aligns) $leftline]
if {$i < 0} break
if {($i % 2) == 0} {
set ::eskil($top,aligns) [lreplace $::eskil($top,aligns) \
$i [+ $i 1]]
break
}
incr i
}
}
if {[llength $::eskil($top,aligns)] == 0} {
disableAlign $top
}
}
proc NoMarkAlign {top} {
unset -nocomplain ::eskil($top,align1)
unset -nocomplain ::eskil($top,align2)
unset -nocomplain ::eskil($top,aligntext1)
unset -nocomplain ::eskil($top,aligntext2)
}
# Mark a line as aligned.
proc markAlign {top n line text} {
set ::eskil($top,align$n) $line
set ::eskil($top,aligntext$n) $text
if {[info exists ::eskil($top,align1)] && [info exists ::eskil($top,align2)]} {
if {![string equal $::eskil($top,aligntext1) $::eskil($top,aligntext2)]} {
set apa [tk_messageBox -icon question -title "Align" -type yesno \
-message "Those lines are not equal.\nReally align them?"]
if {$apa != "yes"} {
return 0
}
}
lappend ::eskil($top,aligns) $::eskil($top,align1) $::eskil($top,align2)
enableAlign $top
NoMarkAlign $top
return 1
}
return 0
}
# Called by popup menus over row numbers to add command for alignment.
# Returns 1 if nothing was added.
proc alignMenu {m top n x y} {
# Get the row that was clicked
set w $::widgets($top,wLine$n)
set index [$w index @$x,$y]
set row [lindex [split $index "."] 0]
set data [$w get $row.0 $row.end]
# Must be a line number
if {![regexp {\d+} $data line]} {
return 1
}
set text [$::widgets($top,wDiff$n) get $row.0 $row.end]
set other [expr {$n == 1 ? 2 : 1}]
set cmd [list markAlign $top $n $line $text]
if {![info exists ::eskil($top,align$other)]} {
set label "Mark line for alignment"
} else {
set label "Align with line $::eskil($top,align$other) on other side"
}
if {[info exists ::eskil($top,aligns)]} {
foreach {align1 align2} $::eskil($top,aligns) {
if {$n == 1 && $line == $align1} {
set label "Remove alignment with line $align2"
set cmd [list clearAlign $top $align1]
} elseif {$n == 2 && $line == $align2} {
set label "Remove alignment with line $align1"
set cmd [list clearAlign $top $align1]
}
}
}
$m add command -label $label -command $cmd
return 0
}
# Set up bindings to allow setting alignment using drag
proc SetupAlignDrag {top left right} {
bind $left <ButtonPress-1> [list startAlignDrag $top 1 %x %y %X %Y]\;break
bind $left <B1-Motion> [list motionAlignDrag $top 1 0 %x %y %X %Y]\;break
bind $left <Shift-B1-Motion> [list motionAlignDrag $top 1 1 %x %y %X %Y]\;break
bind $left <ButtonRelease-1> [list endAlignDrag $top 1 %x %y %X %Y]\;break
bind $left <B1-Leave> break
bind $right <ButtonPress-1> [list startAlignDrag $top 2 %x %y %X %Y]\;break
bind $right <B1-Motion> [list motionAlignDrag $top 2 0 %x %y %X %Y]\;break
bind $right <Shift-B1-Motion> [list motionAlignDrag $top 2 1 %x %y %X %Y]\;break
bind $right <ButtonRelease-1> [list endAlignDrag $top 2 %x %y %X %Y]\;break
bind $right <B1-Leave> break
}
# Button has been pressed over line window
proc startAlignDrag {top n x y X Y} {
# Get the row that was clicked
set w $::widgets($top,wLine$n)
set index [$w index @$x,$y]
set row [lindex [split $index "."] 0]
set data [$w get $row.0 $row.end]
set ::eskil($top,alignDrag,state) none
# Must be a line number
if {![regexp {\d+} $data line]} {
return 1
}
# Set up information about start of drag
set text [$::widgets($top,wDiff$n) get $row.0 $row.end]
set other [expr {$n == 1 ? 2 : 1}]
set ::eskil($top,alignDrag,X) $X
set ::eskil($top,alignDrag,Y) $Y
set ::eskil($top,alignDrag,from) $n
set ::eskil($top,alignDrag,line$n) $line
set ::eskil($top,alignDrag,text$n) $text
set ::eskil($top,alignDrag,line$other) "?"
set ::eskil($top,alignDrag,state) press
}
# Mouse moves with button down
proc motionAlignDrag {top n shift x y X Y} {
if {$::eskil($top,alignDrag,state) eq "press"} {
# Have we moved enough to call it dragging?
set dX [expr {abs($X - $::eskil($top,alignDrag,X))}]
set dY [expr {abs($Y - $::eskil($top,alignDrag,Y))}]
if {$dX + $dY > 3} {
# Start a drag action
set w $top.alignDrag
destroy $w
toplevel $w
wm overrideredirect $w 1
label $w.l -borderwidth 1 -relief solid -justify left
pack $w.l
set ::eskil($top,alignDrag,W) $w
set ::eskil($top,alignDrag,state) "drag"
}
}
if {$::eskil($top,alignDrag,state) eq "drag"} {
set w $::eskil($top,alignDrag,W)
# Move drag label with cursor
wm geometry $w +[expr {$X + 1}]+[expr {$Y + 1}]
set n $::eskil($top,alignDrag,from)
set other [expr {$n == 1 ? 2 : 1}]
set w2 $::widgets($top,wLine$other)
# Are we over the other line window?
if {[winfo containing $X $Y] eq $w2} {
set x [expr {$X - [winfo rootx $w2]}]
set y [expr {$Y - [winfo rooty $w2]}]
set index [$w2 index @$x,$y]
set row [lindex [split $index "."] 0]
set data [$w2 get $row.0 $row.end]
if {![regexp {\d+} $data line]} {
set ::eskil($top,alignDrag,line$other) "?"
} else {
set ::eskil($top,alignDrag,line$other) $line
set text [$::widgets($top,wDiff$other) get $row.0 $row.end]
set ::eskil($top,alignDrag,text$other) $text
}
} else {
set ::eskil($top,alignDrag,line$other) "?"
}
set txt "Align Left $::eskil($top,alignDrag,line1)"
append txt "\nwith Right $::eskil($top,alignDrag,line2)"
set ::eskil($top,alignDrag,shift) $shift
if {$shift} {
append txt "\nAnd Redo Diff"
}
$w.l configure -text $txt
}
}
# Button has been released
proc endAlignDrag {top n x y X Y} {
if {$::eskil($top,alignDrag,state) eq "drag"} {
destroy $::eskil($top,alignDrag,W)
# Are both line numbers valid? I.e. is this a full align operation?
if {$::eskil($top,alignDrag,line1) ne "?" && \
$::eskil($top,alignDrag,line2) ne "?"} {
NoMarkAlign $top
markAlign $top 1 $::eskil($top,alignDrag,line1) \
$::eskil($top,alignDrag,text1)
set marked [markAlign $top 2 $::eskil($top,alignDrag,line2) \
$::eskil($top,alignDrag,text2)]
if {$::eskil($top,alignDrag,shift) && $marked} {
redoDiff $top
}
}
}
set ::eskil($top,alignDrag,state) none
}
###################
# Diff highlighting
###################
proc hlSelect {top hl} {
highLightChange $top $hl
}
proc hlSeparate {top n hl} {
set ::eskil($top,separate$n) $hl
set wd $::widgets($top,wDiff$n)
set wl $::widgets($top,wLine$n)
if {$hl eq ""} {
set range [$wd tag ranges sel]
} else {
set range [$wl tag ranges hl$::eskil($top,separate$n)]
}
set text [$wd get {*}$range]
set ::eskil($top,separatetext$n) $text
# Get the lines involved in the display
set from [lindex $range 0]
set to [lindex $range 1]
lassign [split $from "."] froml fromi
lassign [split $to "."] tol toi
if {$toi == 0} {incr tol -1}
# Get the corresponding lines in the file
set t [$wl get $froml.0 $tol.end]
set lines [lsort -integer [regexp -all -inline {\d+} $t]]
set froml [lindex $lines 0]
set tol [lindex $lines end]
set ::eskil($top,separatelines$n) [list $froml $tol]
if {[info exists ::eskil($top,separate1)] && \
[info exists ::eskil($top,separate2)]} {
cloneDiff $top [concat $::eskil($top,separatelines1) \
$::eskil($top,separatelines2)]
unset ::eskil($top,separate1)
unset ::eskil($top,separate2)
}
}
proc hlPopup {top n hl X Y x y} {
if {[info exists ::eskil($top,nopopup)] && $::eskil($top,nopopup)} return
destroy .lpm
menu .lpm
if {![editMenu .lpm $top $n $hl $x $y]} {
.lpm add separator
}
if {$hl != ""} {
.lpm add command -label "Select" \
-command [list hlSelect $top $hl]
}
set other [expr {$n == 1 ? 2 : 1}]
if {![info exists ::eskil($top,separate$other)]} {
set label "Mark for Separate Diff"
} else {
set label "Separate Diff"
}
.lpm add command -label $label -command [list hlSeparate $top $n $hl]
alignMenu .lpm $top $n $x $y
set ::eskil($top,nopopup) 1
tk_popup .lpm $X $Y
after idle [list after 1 [list set "::eskil($top,nopopup)" 0]]
return
}
# This is called when right clicking over the line numbers which are not
# marked for changes
proc rowPopup {w X Y x y} {
set top [winfo toplevel $w]
if {[info exists ::eskil($top,nopopup)] && $::eskil($top,nopopup)} return
destroy .lpm
menu .lpm
regexp {(\d+)\D*$} $w -> n
set tmp1 [editMenu .lpm $top $n "" $x $y]
if {!$tmp1} {.lpm add separator}
set tmp2 [alignMenu .lpm $top $n $x $y]
if {$tmp1 && $tmp2} {
# Nothing in the menu
return
}
if {!$tmp1 && $tmp2} {.lpm delete last}
set ::eskil($top,nopopup) 1
tk_popup .lpm $X $Y
after idle [list after 1 [list set "::eskil($top,nopopup)" 0]]
}
proc nextHighlight {top} {
# TBD TABLE, stop for now?
if {$::eskil($top,view) eq "table"} {
return
}
set tag hl$::HighLightCount
foreach n {1 2} {
$::widgets($top,wLine$n) tag bind $tag <ButtonPress-3> \
"hlPopup $top $n $::HighLightCount %X %Y %x %y ; break"
$::widgets($top,wLine$n) tag bind $tag <ButtonPress-1> \
"hlSelect $top $::HighLightCount"
}
incr ::HighLightCount
}
#########
# Zooming
#########
proc zoomRow {w X Y x y} {
set top [winfo toplevel $w]
# Get the row that was clicked
set index [$w index @$x,$y]
set row [lindex [split $index "."] 0]
# Check if it is selected
if {[lsearch [$w tag names $index] sel] >= 0} {
regexp {(\d+)\D*$} $w -> n
hlPopup $top $n "" $X $Y $x $y
return
}
# Extract the data
set data(1) [$::widgets($top,wDiff1) dump -tag -text $row.0 $row.end]
set data(2) [$::widgets($top,wDiff2) dump -tag -text $row.0 $row.end]
if {[llength $data(1)] == 0 && [llength $data(2)] == 0} return
set font [$::widgets($top,wDiff1) cget -font]
set wx $X
set wy [expr {$Y + 4}]
destroy $top.balloon
toplevel $top.balloon -background black
wm withdraw $top.balloon
wm overrideredirect $top.balloon 1
foreach x {1 2} {
text $top.balloon.t$x -relief flat -font $font -background \#ffffcc \
-foreground black -padx 2 -pady 0 -height 1
$top.balloon.t$x tag configure new1 -foreground $::Pref(colornew1) \
-background $::Pref(bgnew1)
$top.balloon.t$x tag configure change -foreground $::Pref(colorchange) \
-background $::Pref(bgchange)
$top.balloon.t$x tag configure new2 -foreground $::Pref(colornew2) \
-background $::Pref(bgnew2)
$top.balloon.t$x tag configure equal -foreground $::Pref(colorequal) \
-background $::Pref(bgequal)
pack $top.balloon.t$x -side "top" -padx 1 -pady 1 -fill both -expand 1
set tags {}
foreach {key value index} $data($x) {
if {$key eq "tagon"} {
lappend tags $value
set tags [lsort -unique $tags]
} elseif {$key eq "tagoff"} {
set i [lsearch $tags $value]
if {$i >= 0} {
set tags [lreplace $tags $i $i]
}
} else {
$top.balloon.t$x insert end $value $tags
}
}
set text [$top.balloon.t$x get 1.0 1.end]
regsub -all "\t" $text " " text
$top.balloon.t$x configure -width [string length $text]
}
# Let geometry requests propagate
update idletasks
# Is the balloon within the diff window?
set rWidth [winfo reqwidth $top.balloon]
if {$rWidth + $wx > [winfo rootx $top] + [winfo width $top]} {
# No.
# Center on diff window
set wx [expr {([winfo width $top] - $rWidth) / 2 + [winfo rootx $top]}]
if {$wx < 0} {set wx 0}
# Is the balloon not within the screen?
if {$wx + $rWidth > [winfo screenwidth $top]} {
# Center in screen
set wx [expr {([winfo screenwidth $top] - $rWidth) / 2}]
if {$wx < 0} {set wx 0}
}
}
# Does the balloon fit within the screen?
if {$rWidth > [winfo screenwidth $top]} {
# How many rows does it take?
set rows [expr {ceil(double($rWidth) / [winfo screenwidth $top])}]
# Add rows and fill screen width
$top.balloon.t1 configure -height $rows
$top.balloon.t2 configure -height $rows
# Let geometry requests propagate
update idletasks
wm geometry $top.balloon \
[winfo screenwidth $top]x[winfo reqheight $top.balloon]
set wx 0
}
wm geometry $top.balloon +$wx+$wy
wm deiconify $top.balloon
}
proc unzoomRow {w} {
set top [winfo toplevel $w]
destroy $top.balloon
}
# Reconfigure font
proc chFont {} {
font configure myfont -size $::Pref(fontsize) -family $::Pref(fontfamily)
}
# Change color settings
proc applyColor {} {
global dirdiff
foreach top $::eskil(diffWindows) {
if {$top eq ".clipdiff"} continue
if {$top != ".dirdiff"} {
foreach item {wLine1 wDiff1 wLine2 wDiff2} {
if {![info exists ::widgets($top,$item)]} continue
set w $::widgets($top,$item)
$w tag configure equal -foreground $::Pref(colorequal) \
-background $::Pref(bgequal)
$w tag configure new1 -foreground $::Pref(colornew1) \
-background $::Pref(bgnew1)
$w tag configure change -foreground $::Pref(colorchange) \
-background $::Pref(bgchange)
$w tag configure new2 -foreground $::Pref(colornew2) \
-background $::Pref(bgnew2)
}
continue
}
}
}
# Scroll text windows
proc scrollText {top args} {
# Do not scroll if focus is in a text window.
# This is for scroll bindings in the toplevel.
set class [winfo class [focus]]
if {$class in "Text TEntry"} {
return
}
$::widgets($top,wDiff1) {*}$args
if {[string index [lindex $args 0] 0] eq "x"} {
# x commands go to both since that is not synched
$::widgets($top,wDiff2) {*}$args
}
}
# Emulate a label that:
# 1 : Displays the right part of the text if there isn't enough room
# 2 : Justfify text to the left if there is enough room.
# 3 : Does not try to allocate space according to its contents
proc fileLabel {w args} {
ttk::entryX $w -style TLabel
$w configure {*}$args
$w configure -takefocus 0 -state readonly ;#-readonlybackground $bg
set i [lsearch $args -textvariable]
if {$i >= 0} {
set var [lindex $args [+ $i 1]]
uplevel \#0 "trace variable $var w \
{after idle {$w xview end} ;#}"
}
}
# Fill in default data for a diff window
proc initDiffData {top} {
set ::eskil($top,leftOK) 0
set ::eskil($top,rightOK) 0
set ::eskil($top,mode) ""
set ::eskil($top,view) ""
set ::eskil($top,printFileCmd) 0
set ::eskil($top,printFile) ""
set ::eskil($top,mergeFile) ""
set ::eskil($top,ancestorFile) ""
set ::eskil($top,separator) ""
set ::eskil($top,separatorview) ""
set ::eskil($top,conflictFile) ""
set ::eskil($top,limitlines) 0
set ::eskil($top,gz) 0
set ::eskil($top,maxwidth) 0
set ::eskil($top,plugin) ""
# Copy the collected options from command line
foreach {item val} $::eskil(defaultopts) {
set ::eskil($top,$item) $val
}
}
# Create a new diff window and diff two files
proc newDiff {file1 file2 {range {}}} {
set top [makeDiffWin]
update
set ::eskil($top,leftDir) [file dirname $file1]
set ::eskil($top,leftFile) $file1
set ::eskil($top,leftLabel) $file1
set ::eskil($top,leftOK) 1
set ::eskil($top,rightDir) [file dirname $file2]
set ::eskil($top,rightFile) $file2
set ::eskil($top,rightLabel) $file2
set ::eskil($top,rightOK) 1
set ::eskil($top,mode) ""
set ::eskil($top,view) ""
set ::eskil($top,range) $range
wm deiconify $top
raise $top
update
doDiff $top
return $top
}
# Create a new diff window equal to another, except for possibly a range
proc cloneDiff {other {range {}}} {
set top [makeDiffWin $other]
update
foreach item [array names ::eskil $other,*] {
regsub {^[^,]*,} $item {} item
set ::eskil($top,$item) $::eskil($other,$item)
}
if {[llength $range] != 0} {
set ::eskil($top,range) $range
}
wm deiconify $top
raise $top
update
doDiff $top
}
# A thing to easily get to debug mode
proc backDoor {top a} {
append ::eskil(backdoor) $a
set ::eskil(backdoor) [string range $::eskil(backdoor) end-9 end]
if {$::eskil(backdoor) eq "EskilDebug"} {
set ::eskil(debug) 1
catch {console show}
set ::eskil(backdoor) ""
AddDebugMenu $top
}
}
# Runtime disable of C version of DiffUtil
proc DisableDiffUtilC {} {
uplevel \#0 [list source $::eskil(thisDir)/../lib/diffutil/tcl/diffutil.tcl]
}
# Add a debug menu to a toplevel window
proc AddDebugMenu {top} {
set dMenu [DebugMenu $top.m]
$dMenu add checkbutton -label "Wrap" -variable wrapstate \
-onvalue char -offvalue none -command \
"$top.ft1.tt configure -wrap \$wrapstate ;\
$top.ft2.tt configure -wrap \$wrapstate"
$dMenu add command -label "Date Filter" \
-command {set ::eskil(filter) {^Date}}
$dMenu add separator
$dMenu add command -label "Reread Source" -underline 0 \
-command {EskilRereadSource}
$dMenu add separator
$dMenu add command -label "Normal Cursor" \
-command [list normalCursor $top]
$dMenu add separator
# Runtime disable of C version of DiffUtil
$dMenu add command -label "Tcl DiffUtil" -command DisableDiffUtilC
$dMenu add command -label "Evalstats" -command {evalstats}
$dMenu add command -label "_stats" -command {parray _stats}
}
# Build the main window
# "other" is related window. Currently unused
proc makeDiffWin {{other {}} args} {
global tcl_platform
# Locate a free toplevel name
if {[info exists ::eskil(topDiffCnt)]} {
set t $::eskil(topDiffCnt)
} else {
set t 0
}
while {[winfo exists .diff$t]} {
incr t
}
set top .diff$t
toplevel $top
eskilRegisterToplevel $top
initDiffData $top
if {"-table" in $args} {
set ::eskil($top,view) "table"
}
wm title $top "Eskil:"
wm protocol $top WM_DELETE_WINDOW [list cleanupAndExit $top]
ttk::frame $top.f
grid $top.f -row 0 -columnspan 5 -sticky nws
lappend ::widgets(toolbars) $top.f
if {!$::Pref(toolbar)} {
grid remove $top.f
}
menu $top.m
$top configure -menu $top.m
$top.m add cascade -label "File" -underline 0 -menu $top.m.mf
menu $top.m.mf
$top.m.mf add command -label "Redo Diff" -underline 5 \
-command [list redoDiff $top] -state disabled
if {$::eskil(debug) == 1} {
$top.m.mf entryconfigure "Redo Diff" -state normal
}
$top.m.mf add separator
$top.m.mf add command -label "Open Both..." -underline 0 \
-command [list openBoth $top 0]
$top.m.mf add command -label "Open Both (forget)..." \
-command [list openBoth $top 1]
$top.m.mf add command -label "Open Left File..." \
-command [list openLeft $top]
$top.m.mf add command -label "Open Right File..." \
-command [list openRight $top]
$top.m.mf add separator
$top.m.mf add command -label "Open Ancestor File..." \
-command [list openAncestor $top]
$top.m.mf add command -label "Open Conflict File..." \
-command [list openConflict $top]
$top.m.mf add command -label "Open Patch File..." \
-command [list openPatch $top]
$top.m.mf add command -label "Revision Diff..." -underline 0 \
-command [list openRev $top]
$top.m.mf add separator
$top.m.mf add command -label "Print Pdf..." -underline 0 \
-command [list doPrint $top]
$top.m.mf add separator
$top.m.mf add command -label "Close" -underline 0 \
-command [list cleanupAndExit $top]
$top.m.mf add separator
$top.m.mf add command -label "Quit" -underline 0 \
-command {cleanupAndExit all}
$top.m add cascade -label "Options" -underline 0 -menu $top.m.mo
menu $top.m.mo
$top.m.mo add cascade -label "Font" -underline 0 -menu $top.m.mo.f
$top.m.mo add cascade -label "Ignore" -underline 0 -menu $top.m.mo.i
$top.m.mo add command -label "Preprocess..." -underline 0 \
-command [list EditPrefPreprocess $top]
$top.m.mo add command -label "Plugins..." -underline 1 \
-command [list EditPrefPlugins $top]
$top.m.mo add cascade -label "Parse" -underline 1 -menu $top.m.mo.p
$top.m.mo add command -label "Colours..." -underline 0 -command makePrefWin
$top.m.mo add cascade -label "Context" -underline 1 -menu $top.m.mo.c
$top.m.mo add cascade -label "Pivot" -underline 2 -menu $top.m.mo.piv
$top.m.mo add separator
$top.m.mo add checkbutton -label "Toolbar" -variable ::Pref(toolbar)
$top.m.mo add separator
$top.m.mo add command -label "Save default" \
-command [list saveOptions $top]
menu $top.m.mo.f
$top.m.mo.f add command -label "Select..." -command makeFontWin \
-underline 0
$top.m.mo.f add radiobutton -label 6 -variable ::Pref(fontsize) -value 6 \
-command chFont
$top.m.mo.f add radiobutton -label 7 -variable ::Pref(fontsize) -value 7 \
-command chFont
$top.m.mo.f add radiobutton -label 8 -variable ::Pref(fontsize) -value 8 \
-command chFont
$top.m.mo.f add radiobutton -label 9 -variable ::Pref(fontsize) -value 9 \
-command chFont
$top.m.mo.f add radiobutton -label 10 -variable ::Pref(fontsize) -value 10 \
-command chFont
menu $top.m.mo.i
$top.m.mo.i add radiobutton -label "No spaces" \
-variable ::Pref(ignore) -value " "
$top.m.mo.i add radiobutton -label "Space changes (-b)" \
-variable ::Pref(ignore) -value "-b"
$top.m.mo.i add radiobutton -label "All spaces (-w)" \
-variable ::Pref(ignore) -value "-w"
$top.m.mo.i add separator
$top.m.mo.i add checkbutton -label "Case (-i)" \
-variable ::Pref(nocase)
$top.m.mo.i add checkbutton -label "Empty" \
-variable ::Pref(noempty)
$top.m.mo.i add checkbutton -label "Digits" \
-variable ::Pref(nodigit)
menu $top.m.mo.p
$top.m.mo.p add radiobutton -label "Nothing" -variable ::Pref(parse) -value 0
$top.m.mo.p add radiobutton -label "Lines" -variable ::Pref(parse) -value 1
$top.m.mo.p add radiobutton -label "Blocks (small)" -variable ::Pref(parse) \
-value 2
$top.m.mo.p add radiobutton -label "Blocks" -variable ::Pref(parse) -value 3
$top.m.mo.p add separator
$top.m.mo.p add radiobutton -label "Characters" \
-variable ::Pref(lineparsewords) -value "0"
$top.m.mo.p add radiobutton -label "Words" \
-variable ::Pref(lineparsewords) -value "1"
$top.m.mo.p add separator
$top.m.mo.p add checkbutton -label "Fine chunks" -variable ::Pref(finegrainchunks)
$top.m.mo.p add separator
$top.m.mo.p add checkbutton -label "Mark last" -variable ::Pref(marklast)
menu $top.m.mo.c
$top.m.mo.c add radiobutton -label "Show all lines" \
-variable ::Pref(context) -value -1
$top.m.mo.c add radiobutton -label "Show only diffs" \
-variable ::Pref(context) -value 0
$top.m.mo.c add separator
$top.m.mo.c add radiobutton -label "Context 2 lines" \
-variable ::Pref(context) -value 2
$top.m.mo.c add radiobutton -label "Context 5 lines" \
-variable ::Pref(context) -value 5
$top.m.mo.c add radiobutton -label "Context 10 lines" \
-variable ::Pref(context) -value 10
$top.m.mo.c add radiobutton -label "Context 20 lines" \
-variable ::Pref(context) -value 20
menu $top.m.mo.piv
$top.m.mo.piv add radiobutton -label "10" \
-variable ::Pref(pivot) -value 10
$top.m.mo.piv add radiobutton -label "100" \
-variable ::Pref(pivot) -value 100
$top.m.mo.piv add radiobutton -label "1000" \
-variable ::Pref(pivot) -value 1000
$top.m.mo.piv add radiobutton -label "Max" \
-variable ::Pref(pivot) -value 2000000000
$top.m add cascade -label "Search" -underline 0 -menu $top.m.ms
menu $top.m.ms
if {[info procs textSearch::searchMenu] != ""} {
textSearch::searchMenu $top.m.ms
} else {
$top.m.ms add command -label "Text search not available" \
-state disabled
}
$top.m add cascade -label "Tools" -underline 0 -menu $top.m.mt
menu $top.m.mt
$top.m.mt add command -label "New Diff Window" -underline 0 \
-command [list makeDiffWin $top]
$top.m.mt add command -label "Directory Diff" -underline 0 \
-command makeDirDiffWin
$top.m.mt add command -label "Clip Diff" -underline 0 \
-command makeClipDiffWin
$top.m.mt add command -label "Table Diff" -underline 0 \
-command [list makeDiffWin $top -table]
$top.m.mt add command -label "Merge" -underline 0 \
-command [list makeMergeWin $top] -state disabled
$top.m.mt add command -label "Edit Mode" -underline 0 \
-command [list allowEdit $top] -state disabled
$top.m.mt add command -label "Paste Patch" -underline 0 \
-command [list doPastePatch $top]
$top.m.mt add command -label "Clear Align" \
-command [list clearAlign $top] -state disabled
set ::widgets($top,enableAlignCmd) [list \
$top.m.mt entryconfigure "Clear Align" -state normal]
set ::widgets($top,disableAlignCmd) [list \
$top.m.mt entryconfigure "Clear Align" -state disabled]
if {$::tcl_platform(platform) eq "windows"} {
if {![catch {package require registry}]} {
$top.m.mt add separator
$top.m.mt add command -label "Setup Registry" -underline 6 \
-command makeRegistryWin
}
}
$top.m add cascade -label "Help" -underline 0 -menu $top.m.help
menu $top.m.help
$top.m.help add command -label "General" -command makeHelpWin -underline 0
$top.m.help add command -label "Tutorial" -command makeTutorialWin \
-underline 0
foreach label {{Revision Control} {Edit Mode} {Plugins}} \
file {revision.txt editmode.txt plugins.txt} {
$top.m.help add command -label $label \
-command [list makeDocWin $file] -underline 0
}
$top.m.help add separator
$top.m.help add command -label "About" -command makeAboutWin -underline 0
# Toolbar
ttk::label $top.lr1 -text "Rev 1"
addBalloon $top.lr1 "Revision number for version diff."
ttk::entryX $top.er1 -width 12 -textvariable ::eskil($top,doptrev1)
set ::widgets($top,rev1) $top.er1
bind $top.er1 <Key-Return> [list redoDiff $top]
ttk::label $top.lr2 -text "Rev 2"
addBalloon $top.lr2 "Revision number for version diff."
ttk::entryX $top.er2 -width 12 -textvariable ::eskil($top,doptrev2)
set ::widgets($top,rev2) $top.er2
bind $top.er2 <Key-Return> [list redoDiff $top]
ttk::button $top.bcm -text Commit -command [list revCommit $top] \
-state disabled -underline 0
set ::widgets($top,commit) $top.bcm
ttk::button $top.brv -text Revert -command [list revRevert $top] \
-state disabled
set ::widgets($top,revert) $top.brv
ttk::button $top.blg -text Log -command [list revLog $top] \
-state disabled -underline 0
set ::widgets($top,log) $top.blg
ttk::button $top.bfp -text "Prev Diff" \
-command [list findDiff $top -1] \
-underline 0
ttk::button $top.bfn -text "Next Diff" \
-command [list findDiff $top 1] \
-underline 0
bind $top <Alt-n> [list findDiff $top 1]
bind $top <Alt-p> [list findDiff $top -1]
bind $top <Alt-c> [list revCommit $top]
bind $top <Alt-l> [list revLog $top]
pack $top.bfn -in $top.f -side right -padx {3 6}
pack $top.bfp $top.bcm $top.brv $top.blg \
$top.er2 $top.lr2 $top.er1 $top.lr1 \
-in $top.f -side right -padx 3
# Adjust
pack $top.bfn $top.bfp $top.bcm -ipadx 15
# Add a separator entry in toolbar if table mode is on
if {$::eskil($top,view) eq "table"} {
ttk::label $top.lsep -text "Sep"
addBalloon $top.lsep "Separator for interpreting file as table"
ttk::entryX $top.esep -width 2 -textvariable ::eskil($top,separatorview)
set ::widgets($top,sep) $top.esep
bind $top.esep <Key-Return> [list redoDiff $top]
pack $top.esep $top.lsep \
-in $top.f -side right -padx 3
}
# File and progress indicators
catch {font delete myfont}
font create myfont -family $::Pref(fontfamily) -size $::Pref(fontsize)
fileLabel $top.l1 -textvariable ::eskil($top,leftLabel)
fileLabel $top.l2 -textvariable ::eskil($top,rightLabel)
ttk::label $top.le -textvariable ::widgets($top,eqLabel) -width 1
addBalloon $top.le "* means external diff is running.\n= means files do\
not differ.\n! means a large block is being processed.\nBlank\
means files differ."
# Main window
if {$::eskil($top,view) eq "table"} {
# Single frame for contents
ttk::frame $top.ft -borderwidth 2 -relief sunken
grid $top.l1 $top.le $top.l2 -row 1 -sticky news
grid $top.ft - - -row 2 -sticky news
grid columnconfigure $top "0 2" -weight 1
grid rowconfigure $top $top.ft -weight 1
# TBD TABLE
tablelist::tablelist $top.ft.tab -height 25 -width 100 \
-font myfont -labelfont myfont \
-movablecolumns no -setgrid no -showseparators no \
-fullseparators yes -selectmode none \
-colorizecommand tblModeColorCallback
ttk::scrollbar $top.ft.vsb -orient vertical \
-command "$top.ft.tab yview"
ttk::scrollbar $top.ft.hsb -orient horizontal \
-command "$top.ft.tab xview"
$top.ft.tab configure -yscrollcommand "$top.ft.vsb set" \
-xscrollcommand "$top.ft.hsb set"
set body [$top.ft.tab bodypath]
$body tag configure new1 -foreground $::Pref(colornew1) \
-background $::Pref(bgnew1)
$body tag configure new2 -foreground $::Pref(colornew2) \
-background $::Pref(bgnew2)
$body tag configure change -foreground $::Pref(colorchange) \
-background $::Pref(bgchange)
set bg [ttk::style configure . -background]
set map [createMap $top $bg]
grid $top.ft.tab $top.ft.vsb $map -sticky news
grid $top.ft.hsb x x -sticky news
grid columnconfigure $top.ft 0 -weight 1
grid rowconfigure $top.ft 0 -weight 1
grid $map -pady [expr {[winfo reqwidth $top.ft.vsb] - 2}]
set ::widgets($top,wTable) $top.ft.tab
} else {
ttk::frame $top.ft1 -borderwidth 2 -relief sunken
text $top.ft1.tl -height $::Pref(lines) -width 5 -wrap none \
-font myfont -borderwidth 0 -padx 0 -highlightthickness 0 \
-takefocus 0
text $top.ft1.tt -height $::Pref(lines) -width $::Pref(linewidth) \
-wrap none \
-xscrollcommand [list $top.sbx1 set] \
-font myfont -borderwidth 0 -padx 1 \
-highlightthickness 0
$top.ft1.tt configure -tabstyle wordprocessor
tk::frame $top.ft1.f -width 2 -height 2 -background lightgray
pack $top.ft1.tl -side left -fill y
pack $top.ft1.f -side left -fill y
pack $top.ft1.tt -side right -fill both -expand 1
ttk::scrollbar $top.sby -orient vertical
ttk::scrollbar $top.sbx1 -orient horizontal \
-command [list $top.ft1.tt xview]
set ::widgets($top,wLine1) $top.ft1.tl
set ::widgets($top,wDiff1) $top.ft1.tt
ttk::frame $top.ft2 -borderwidth 2 -relief sunken
text $top.ft2.tl -height $::Pref(lines) -width 5 -wrap none \
-font myfont -borderwidth 0 -padx 0 -highlightthickness 0 \
-takefocus 0
text $top.ft2.tt -height $::Pref(lines) -width $::Pref(linewidth) \
-wrap none \
-xscrollcommand [list $top.sbx2 set] \
-font myfont -borderwidth 0 -padx 1 \
-highlightthickness 0
$top.ft2.tt configure -tabstyle wordprocessor
tk::frame $top.ft2.f -width 2 -height 2 -background lightgray
pack $top.ft2.tl -side left -fill y
pack $top.ft2.f -side left -fill y
pack $top.ft2.tt -side right -fill both -expand 1
ttk::scrollbar $top.sbx2 -orient horizontal \
-command [list $top.ft2.tt xview]
set ::widgets($top,wLine2) $top.ft2.tl
set ::widgets($top,wDiff2) $top.ft2.tt
# Set up a tag for incremental search bindings
if {[info procs textSearch::enableSearch] != ""} {
textSearch::enableSearch $top.ft1.tt -label ::widgets($top,isearchLabel)
textSearch::enableSearch $top.ft2.tt -label ::widgets($top,isearchLabel)
}
# Set up file dropping in text windows if TkDnd is available
if {![catch {package require tkdnd}]} {
dnd bindtarget $top text/uri-list <Drop> "fileDrop $top any %D"
dnd bindtarget $top.ft1.tl text/uri-list <Drop> "fileDrop $top left %D"
dnd bindtarget $top.ft1.tt text/uri-list <Drop> "fileDrop $top left %D"
dnd bindtarget $top.ft2.tl text/uri-list <Drop> "fileDrop $top right %D"
dnd bindtarget $top.ft2.tt text/uri-list <Drop> "fileDrop $top right %D"
}
# FIXA: verify that this label is ok after Tile migration
ttk::label $top.ls -width 1 \
-textvariable ::widgets($top,isearchLabel)
addBalloon $top.ls "Incremental search indicator"
set bg [ttk::style configure . -background]
set map [createMap $top $bg]
# Edit buttons widget
set ::widgets($top,wTb) $top.tb
text $top.tb -width 4 -wrap none -background $bg \
-font myfont -borderwidth 0 -padx 0 -highlightthickness 0 \
-takefocus 0
commonYScroll $top.sby $top.ft1.tl $top.ft1.tt $top.ft2.tl $top.ft2.tt \
;#$top.tb
applyColor
foreach w [list $top.ft1.tt $top.ft2.tt] {
# The last change in a row is underlined
$w tag configure last -underline 1
# Each file in a patch view starts with a block of this type
$w tag configure patch -background gray
# Make sure selection is visible
$w tag raise sel
bind $w <ButtonPress-3> "zoomRow %W %X %Y %x %y"
bind $w <ButtonRelease-3> "unzoomRow %W"
}
foreach w [list $top.ft1.tl $top.ft2.tl] {
$w tag configure align -underline 1
bind $w <ButtonPress-3> "rowPopup %W %X %Y %x %y"
}
SetupAlignDrag $top $top.ft1.tl $top.ft2.tl
grid $top.l1 $top.le - - $top.l2 -row 1 -sticky news
grid $top.ft1 $top.tb $map $top.sby $top.ft2 -row 2 -sticky news
grid $top.sbx1 $top.ls - - $top.sbx2 -row 3 -sticky news
grid columnconfigure $top "$top.ft1 $top.ft2" -weight 1
grid rowconfigure $top $top.ft1 -weight 1
grid $top.tb -pady 2
grid $map -pady [expr {[winfo reqwidth $top.sby] - 2}]
grid $top.ls -sticky ""
grid remove $top.tb ;# Hide until done
# Allow scrolling from keys at toplevel
bind $top <Key-Up> [list scrollText $top yview scroll -1 u]
bind $top <Key-k> [list scrollText $top yview scroll -1 u]
bind $top <Key-Down> [list scrollText $top yview scroll 1 u]
bind $top <Key-j> [list scrollText $top yview scroll 1 u]
bind $top <Key-Prior> [list scrollText $top yview scroll -1 pa]
bind $top <Key-b> [list scrollText $top yview scroll -1 pa]
bind $top <Key-Next> [list scrollText $top yview scroll 1 pa]
bind $top <Key-space> [list scrollText $top yview scroll 1 pa]
bind $top <Key-Left> [list scrollText $top xview scroll -5 u]
bind $top <Key-h> [list scrollText $top xview scroll -5 u]
bind $top <Key-Right> [list scrollText $top xview scroll 5 u]
bind $top <Key-l> [list scrollText $top xview scroll 5 u]
bind $top <Key-Home> [list scrollText $top yview moveto 0]
bind $top <Key-g> [list scrollText $top yview moveto 0]
bind $top <Key-End> [list scrollText $top yview moveto 1]
}
# Go out to toplevel with escape, whereever you are
bind $top <Key-Escape> [list focus $top]
if {$::eskil(debug) == 0} {
set val [bindtags $top]
lappend val backDoor$top
bindtags $top $val
# Keep this binding on a separate tag, so that other key
# bindings on the top does not steal the keys
bind backDoor$top <Key> "backDoor $top %A"
}
if {$::eskil(debug) == 1} {
AddDebugMenu $top
}
resetEdit $top
return $top
}
proc ValidateNewColors {} {
foreach item {colorchange bgchange colornew1 bgnew1
colornew2 bgnew2 colorequal bgequal} {
if {![info exists ::TmpPref($item)]} continue
set col $::TmpPref($item)
if {$col eq ""} continue
if {[catch {winfo rgb . $col}]} {
# FIXA: Error message
# Just restore for now
set ::TmpPref($item) $::Pref($item)
}
}
}
# Set new preferences.
proc applyPref {} {
ValidateNewColors
array set ::Pref [array get ::TmpPref]
applyColor
}
# Update test color fields.
proc testColor {} {
ValidateNewColors
.pr.fc.t1 tag configure change -foreground $::TmpPref(colorchange) \
-background $::TmpPref(bgchange)
.pr.fc.t2 tag configure new1 -foreground $::TmpPref(colornew1) \
-background $::TmpPref(bgnew1)
.pr.fc.t3 tag configure new2 -foreground $::TmpPref(colornew2) \
-background $::TmpPref(bgnew2)
.pr.fc.t4 tag configure equal -foreground $::TmpPref(colorequal) \
-background $::TmpPref(bgequal)
}
# Color dialog.
proc selColor {name} {
set old $::TmpPref($name)
if {$old eq ""} {
set t [tk_chooseColor -parent .pr]
} else {
set t [tk_chooseColor -parent .pr -initialcolor $old]
}
if {$t != ""} {
set ::TmpPref($name) $t
}
}
# Create a window for changing preferences.
# Currently only colors are changed in this dialog.
proc makePrefWin {} {
array set ::TmpPref [array get ::Pref]
destroy .pr
toplevel .pr
wm title .pr "Eskil Preferences"
ttk::frame .pr.fc -borderwidth 1 -relief solid
ttk::label .pr.fc.l1 -text "Colours" -anchor w
ttk::label .pr.fc.l2 -text "Text" -anchor w
ttk::label .pr.fc.l3 -text "Background" -anchor w
ttk::entryX .pr.fc.e1 -textvariable "::TmpPref(colorchange)" -width 10
ttk::entryX .pr.fc.e2 -textvariable "::TmpPref(colornew1)" -width 10
ttk::entryX .pr.fc.e3 -textvariable "::TmpPref(colornew2)" -width 10
ttk::entryX .pr.fc.e4 -textvariable "::TmpPref(colorequal)" -width 10
ttk::button .pr.fc.b1 -text "Sel" -command "selColor colorchange"
ttk::button .pr.fc.b2 -text "Sel" -command "selColor colornew1"
ttk::button .pr.fc.b3 -text "Sel" -command "selColor colornew2"
ttk::button .pr.fc.b4 -text "Sel" -command "selColor colorequal"
ttk::entryX .pr.fc.e5 -textvariable "::TmpPref(bgchange)" -width 10
ttk::entryX .pr.fc.e6 -textvariable "::TmpPref(bgnew1)" -width 10
ttk::entryX .pr.fc.e7 -textvariable "::TmpPref(bgnew2)" -width 10
ttk::entryX .pr.fc.e8 -textvariable "::TmpPref(bgequal)" -width 10
ttk::button .pr.fc.b5 -text "Sel" -command "selColor bgchange"
ttk::button .pr.fc.b6 -text "Sel" -command "selColor bgnew1"
ttk::button .pr.fc.b7 -text "Sel" -command "selColor bgnew2"
ttk::button .pr.fc.b8 -text "Sel" -command "selColor bgequal"
text .pr.fc.t1 -width 12 -height 1 -font myfont -takefocus 0
text .pr.fc.t2 -width 12 -height 1 -font myfont -takefocus 0
text .pr.fc.t3 -width 12 -height 1 -font myfont -takefocus 0
text .pr.fc.t4 -width 12 -height 1 -font myfont -takefocus 0
.pr.fc.t1 tag configure change -foreground $::TmpPref(colorchange) \
-background $::TmpPref(bgchange)
.pr.fc.t2 tag configure new1 -foreground $::TmpPref(colornew1) \
-background $::TmpPref(bgnew1)
.pr.fc.t3 tag configure new2 -foreground $::TmpPref(colornew2) \
-background $::TmpPref(bgnew2)
.pr.fc.t4 tag configure equal -foreground $::TmpPref(colorequal) \
-background $::TmpPref(bgequal)
.pr.fc.t1 insert end "Changed text" change
.pr.fc.t2 insert end "Deleted text" new1
.pr.fc.t3 insert end "Added text" new2
.pr.fc.t4 insert end "Equal text" equal
.pr.fc.t1 configure -state disabled
.pr.fc.t2 configure -state disabled
.pr.fc.t3 configure -state disabled
.pr.fc.t4 configure -state disabled
ttk::button .pr.b1 -text "Apply" -command applyPref
ttk::button .pr.b2 -text "Test" -command testColor
ttk::button .pr.b3 -text "Close" -command {destroy .pr}
grid .pr.fc.l1 .pr.fc.l2 x .pr.fc.l3 x -row 0 -sticky ew -padx 1 -pady 1
grid .pr.fc.t1 .pr.fc.e1 .pr.fc.b1 .pr.fc.e5 .pr.fc.b5 -row 1 \
-sticky nsew -padx 1 -pady 1
grid .pr.fc.t2 .pr.fc.e2 .pr.fc.b2 .pr.fc.e6 .pr.fc.b6 -row 2 \
-sticky nsew -padx 1 -pady 1
grid .pr.fc.t3 .pr.fc.e3 .pr.fc.b3 .pr.fc.e7 .pr.fc.b7 -row 3 \
-sticky nsew -padx 1 -pady 1
grid .pr.fc.t4 .pr.fc.e4 .pr.fc.b4 .pr.fc.e8 .pr.fc.b8 -row 4 \
-sticky nsew -padx 1 -pady 1
grid columnconfigure .pr.fc {1 3} -weight 1
pack .pr.fc -side top -fill x
pack .pr.b1 .pr.b2 .pr.b3 -side left -expand 1 -fill x -anchor s \
-padx 2 -pady 2
}
# Change font preference
proc applyFont {lb} {
set ::Pref(fontsize) $::TmpPref(fontsize)
set i [lindex [$lb curselection] 0]
set ::Pref(fontfamily) [$lb get $i]
chFont
}
# Update example font
proc exampleFont {lb} {
set i [lindex [$lb curselection] 0]
if {$i eq ""} return
set ::TmpPref(fontfamily) [$lb get $i]
font configure tmpfont -family $::TmpPref(fontfamily)
if {[string is integer -strict $::TmpPref(fontsize)]} {
font configure tmpfont -size $::TmpPref(fontsize)
}
}
proc UpdateFontBox {lb} {
$lb delete 0 end
foreach {f fixed} $::FontCache {
if {$fixed || !$::eskil(fixedfont)} {
$lb insert end $f
if {[string equal -nocase $f $::Pref(fontfamily)]} {
$lb selection set end
$lb see end
}
}
}
}
# Font dialog
proc makeFontWin {} {
global FontCache
destroy .fo
toplevel .fo -padx 3 -pady 3
wm title .fo "Select Font"
ttk::label .fo.ltmp -text "Searching for fonts..."
pack .fo.ltmp -padx {10 50} -pady {10 50}
update
catch {font delete tmpfont}
font create tmpfont
array set ::TmpPref [array get ::Pref]
ttk::labelframe .fo.lf -text "Family" -padding 3
set lb [Scroll y listbox .fo.lf.lb -width 15 -height 10 \
-exportselection no -selectmode single]
bind $lb <<ListboxSelect>> [list exampleFont $lb]
pack .fo.lf.lb -fill both -expand 1
ttk::labelframe .fo.ls -text "Size" -padding 3
spinbox .fo.ls.sp -from 1 -to 30 -increment 1 -width 3 -state readonly \
-textvariable ::TmpPref(fontsize) -command [list exampleFont $lb]
pack .fo.ls.sp -fill both -expand 1
ttk::label .fo.le -text "Example\n0Ooi1Il" -anchor w -font tmpfont \
-width 1 -justify left
if {![info exists ::eskil(fixedfont)]} {set ::eskil(fixedfont) 1}
ttk::checkbutton .fo.cb -text "Fixed" -variable ::eskil(fixedfont) \
-command [list UpdateFontBox $lb]
ttk::button .fo.bo -text "Ok" -command "applyFont $lb ; destroy .fo"
ttk::button .fo.ba -text "Apply" -command "applyFont $lb"
ttk::button .fo.bc -text "Close" -command "destroy .fo"
if {![info exists FontCache]} {
set fam [lsort -dictionary [font families]]
font create testfont
foreach f $fam {
if {![string equal $f ""]} {
font configure testfont -family $f
lappend FontCache $f [font metrics testfont -fixed]
}
}
font delete testfont
}
UpdateFontBox $lb
destroy .fo.ltmp
grid .fo.lf .fo.ls -sticky news -padx 3 -pady 3
grid x .fo.cb -sticky nwe -padx 3 -pady 3
grid x .fo.bo -sticky we -padx 3 -pady 3 -ipadx 10
grid x .fo.ba -sticky we -padx 3 -pady 3 -ipadx 10
grid x .fo.bc -sticky we -padx 3 -pady 3 -ipadx 10
grid .fo.le - -sticky nwe -padx 3 -pady 3
grid .fo.lf -sticky news -rowspan 5
grid columnconfigure .fo 0 -weight 1
grid rowconfigure .fo 1 -weight 1
exampleFont $lb
}