Eskil

#                               Added colour options, and Only diffs option
#                               Added 2nd stage line parsing
#                               Improved block parsing
#                               Added print
#     1.4     DA-PS    990210   Bug-fix in "Ignore nothing"
#                               Bug-fix in file handling
#                               Improved RCS handling.
#     1.5     DA-PS    990623   Bug-fix and improvement in block parsing
#                               Added font selection
#                               Added "diff server" functionality
#                               Split text windows in lineno/text
#                               Added "Mark last" option
#
#-----------------------------------------------
# the next line restarts using wish \
exec wish "$0" "$@"

set debug 0
set diffver "Version 1.5  990623"
set tmpcnt 0
set thisscript [file join [pwd] [info script]]

if {$tcl_platform(platform) == "windows"} {
    package require dde
}

proc myform {lineNo text} {
    return [format "%3d: %s\n" $lineNo $text]
}

proc myforml {lineNo} {
    return [format "%3d: \n" $lineNo]
}

proc maxabs {a b} {
    return [expr {abs($a) > abs($b) ? $a : $b}]
}

proc tmpfile {} {

        } else {
            lappend apa $asym
            incr t2
        }
    }
    return $apa
}

#Insert lineno and text
proc insert {n line text {tag {}}} {
    .ft$n.tl insert end [myforml $line] $tag
    .ft$n.tt insert end "$text\n" $tag
}

proc emptyline {n} {
    .ft$n.tl insert end \n
    .ft$n.tt insert end \n
}

#Insert one line in each text widget.
#Mark them as changed, and optionally parse them.
proc insertMatchingLines {line1 line2} {
    global doingLine1 doingLine2 Pref

    if {$Pref(parse) != "none"} {
        comparelines $line1 $line2 res1 res2
        set dotag 0
        set n [maxabs [llength $res1] [llength $res2]]
        .ft1.tl insert end [myforml $doingLine1] change
        .ft2.tl insert end [myforml $doingLine2] change
        set new1 new1
        set new2 new2
        set change change
        foreach i1 $res1 i2 $res2 {
            incr n -1
            if {$dotag} {
                if {$n == 1 && $Pref(marklast)} {
                    lappend new1 last
                    lappend new2 last
                    lappend change last
                }
                if {$i1 == ""} {
                    .ft2.tt insert end $i2 $new2
                } elseif {$i2 == ""} {
                    .ft1.tt insert end $i1 $new1
                } else {
                    .ft1.tt insert end $i1 $change
                    .ft2.tt insert end $i2 $change
                }
                set dotag 0
            } else {
                .ft1.tt insert end $i1
                .ft2.tt insert end $i2
                set dotag 1
            }
        }
        .ft1.tt insert end "\n"
        .ft2.tt insert end "\n"
    } else {
	insert 1 $doingLine1 $line1 change
	insert 2 $doingLine2 $line2 change
    }
    incr doingLine1
    incr doingLine2
}

#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
proc dotext {ch1 ch2 n1 n2 line1 line2} {
    global doingLine1 doingLine2 Pref mapList mapMax

    if {$n1 == 0 && $n2 == 0} {
        #All blocks has been processed. Continue until end of file.
        if {$Pref(onlydiffs) == 1} return
        while {[gets $ch2 apa] != -1} {
	    insert 2 $doingLine2 $apa
            incr doingLine2
            incr mapMax
        }
        while {[gets $ch1 apa] != -1} {
	    insert 1 $doingLine1 $apa
            incr doingLine1
        }
        return
    }

    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
    if {$Pref(onlydiffs) == 1 && $doingLine1 < $line1} {
	emptyline 1
	emptyline 2
        incr mapMax
    }
    while {$doingLine1 < $line1} {
        gets $ch1 apa
        gets $ch2 bepa
        if {$Pref(onlydiffs) == 0} {
	    insert 1 $doingLine1 $apa
	    insert 2 $doingLine2 $bepa
            incr mapMax
        }
        incr doingLine1
        incr doingLine2
    }
    if {$doingLine2 != $line2} {
        .ft1.tt insert end "**Bad alignment here!! $doingLine2 $line2**\n"
        .ft2.tt insert end "**Bad alignment here!! $doingLine2 $line2**\n"
	.ft1.tl insert end \n
	.ft2.tl insert end \n
    }

    #Process the block

    if {$n1 == $n2 && ($n1 == 1 || $Pref(parse) != "block")} {
        for {set t 0} {$t < $n1} {incr t} {
            gets $ch1 line1

                    set line2 [lindex $block2 $t2]
                    insertMatchingLines $line1 $line2
                    incr t1
                    incr t2
                }
                if {$c == "d"} {
                    set bepa [lindex $block1 $t1]
                    .ft1.tl insert end [myforml $doingLine1] change
                    .ft1.tt insert end "$bepa\n" new1
		    emptyline 2
                    incr doingLine1
                    incr t1
                }
                if {$c == "a"} {
                    set bepa [lindex $block2 $t2]
                    .ft2.tl insert end [myforml $doingLine2] change
                    .ft2.tt insert end "$bepa\n" new2
		    emptyline 1
                    incr doingLine2
                    incr t2
                }
            }
            lappend mapList $mapMax
            incr mapMax [llength $apa]
            lappend mapList $mapMax change
        } else {
            for {set t 0} {$t < $n1} {incr t} {
                gets $ch1 apa
		insert 1 $doingLine1 $apa $tag1
                incr doingLine1
            }
            for {set t 0} {$t < $n2} {incr t} {
                gets $ch2 apa
		insert 2 $doingLine2 $apa $tag2
                incr doingLine2
            }
            if {$n1 < $n2} {
                for {set t $n1} {$t < $n2} {incr t} {
		    emptyline 1
                }
                lappend mapList $mapMax
                incr mapMax $n2
                lappend mapList $mapMax $tag2
            } elseif {$n2 < $n1} {
                for {set t $n2} {$t < $n1} {incr t} {
		    emptyline 2
                }
                lappend mapList $mapMax
                incr mapMax $n1
                lappend mapList $mapMax $tag1
            }
        }
    }
}

#Scroll windows to next diff
proc findNext {} {
    set i [.ft1.tt index @0,0+1line]
    set n1 [.ft1.tt tag nextrange new1 $i]
    set c1 [.ft1.tt tag nextrange change $i]
    set i [.ft2.tt index @0,0+1line]
    set n2 [.ft2.tt tag nextrange new2 $i]
    set c2 [.ft2.tt tag nextrange change $i]

    set apa [lsort -dictionary "$n1 $c1 $n2 $c2"]

    if {[llength $apa] != 0} {
	set apa [lindex $apa 0]

    } else {
	set apa end
    }

    foreach w {.ft1.tl .ft1.tt .ft2.tl .ft2.tt} {
	$w yview $apa
    }
}

#Scroll windows to previous diff
proc findPrev {} {
    set i [.ft1.tt index @0,0]
    set n1 [.ft1.tt tag prevrange new1 $i]
    set c1 [.ft1.tt tag prevrange change $i]
    set i [.ft2.tt index @0,0]
    set n2 [.ft2.tt tag prevrange new2 $i]
    set c2 [.ft2.tt tag prevrange change $i]

    set apa [lsort -decreasing -dictionary "$n1 $c1 $n2 $c2"]
    if {[llength $apa] != 0} {
	set apa [lindex $apa 1]

    } else {
	set apa 1.0
    }
    
    foreach w {.ft1.tl .ft1.tt .ft2.tl .ft2.tt} {
	$w yview $apa
    }
}

proc enableRedo {} {
    .mf.m entryconfigure 1 -state normal
}

proc disableRedo {} {
    .mf.m entryconfigure 1 -state disabled
}

proc busyCursor {} {
    global oldcursor oldcursor2
    if {![info exists oldcursor]} {
        set oldcursor [. cget -cursor]
        set oldcursor2 [.ft1.tt cget -cursor]
    }
    . config -cursor watch
    foreach w {.ft1.tl .ft1.tt .ft2.tl .ft2.tt} {
	$w config -cursor watch
    }
}

proc normalCursor {} {
    global oldcursor oldcursor2
    . config -cursor $oldcursor
    foreach w {.ft1.tl .ft1.tt .ft2.tl .ft2.tt} {
	$w config -cursor $oldcursor2
    }
}

proc prepareRCS {} {
    global leftFile rightFile RCSFile leftLabel rightLabel Pref

    set revs {}
    set opts {}

        return
    } else {
        enableRedo
    }

    busyCursor

    foreach w {.ft1.tl .ft1.tt .ft2.tl .ft2.tt} {
	$w configure -state normal
	$w delete 1.0 end
    }
    set mapList {}
    set mapMax 0

    update idletasks

    if {$RCS} {
        prepareRCS

        if {[string match {[0-9]*} $i]} {
            lappend result $i
        }
    }

    if {[llength $result] == 0} {
        if {$differr == 1} {
            .ft1.tt insert end $diffres
            normalCursor
            return
        } else {
            set eqLabel "="
        }
    } else {
        set eqLabel " "
    }

    set ch1 [open $leftFile]
    set ch2 [open $rightFile]
    set doingLine1 1
    set doingLine2 1

    foreach i $result {
        if {![regexp {(.*)([acd])(.*)} $i apa l c r]} {
            .ft1.tt insert 1.0 "No regexp match for $i\n"
        } else {
            if {[regexp {([0-9]+),([0-9]+)} $l apa start stop]} {
                set n1 [expr {$stop - $start + 1}]
                set line1 $start
            } else {
                set n1 1
                set line1 $l

    close $ch2

    if {$RCS} {
        cleanupRCS
    }

    drawMap -1
    foreach w {.ft1.tl .ft2.tl} {
	$w configure -state disabled
    }
    normalCursor
}

proc remoteDiff {file1 file2} {
    global leftFile rightFile leftOK rightOK
    global leftDir rightDir leftLabel rightLabel

    set tmpFile2 [file nativename ~/tcldifftmp.ps]
    set tmpFile3 [file nativename ~/tcldiff.ps]
    set ch [open $tmpFile "w"]

    set lines1 {}
    set lines2 {}

    set tdump1 [.ft1.tt dump -tag -text 1.0 end]
    set tdump2 [.ft2.tt dump -tag -text 1.0 end]

    foreach tdump [list $tdump1 $tdump2] \
            lineName {lines1 lines2} wrapName {wrap1 wrap2} {
        set lines {}
        set wraps {}
        set line ""
        set newline 0

                    append line $value
                    incr chars $len
                }
                tagon {
                    if {$value == "change"} {
                        append line "\0bggray\{.6\}"
                        set gray 0.6
                    } elseif {$value != "last"} {
                        append line "\0bggray\{.8\}"
                        set gray 0.8
                    }
                }
                tagoff {
                    if {$value != "last"} {
                        append line "\0bggray\{1.0\}"
                        set gray 1.0
                    }
                }
            }
        }
        set $lineName $lines
        set $wrapName $wraps
    }

            $tmpFile'\n$tmpFile3\nCreated with 'mpage -aA2P $tmpFile2 >\
            $tmpFile3'"
    pack .dp.b -side bottom
    pack .dp.l -side top
}

proc my_yview args {
    foreach w {.ft1.tl .ft1.tt .ft2.tl .ft2.tt} {
	eval $w yview $args
    }
}

proc my_yscroll args {
    eval .sby set $args
    my_yview moveto [lindex $args 0]
}

proc chFont {} {
    global Pref

    font configure myfont -size $Pref(fontsize) -family $Pref(fontfamily)
}

proc applyColor {} {
    global Pref

    foreach w {.tl .tt} {
	.ft1$w tag configure new1 -foreground $Pref(colornew1) -background $Pref(bgnew1)
	.ft1$w tag configure change -foreground $Pref(colorchange) -background $Pref(bgchange)
	.ft2$w tag configure new2 -foreground $Pref(colornew2) -background $Pref(bgnew2)
	.ft2$w tag configure change -foreground $Pref(colorchange) -background $Pref(bgchange)
    }
}

#Build the main window
proc makeDiffWin {} {
    global Pref tcl_platform debug
    eval destroy [winfo children .]

        .mf.m add command -label "Print" -underline 0 -command printDiffs
    }
    .mf.m add separator
    .mf.m add command -label "Quit" -command exit

    menubutton .mo -text Options -underline 0 -menu .mo.m
    menu .mo.m
    .mo.m add cascade -label Font -underline 0 -menu .mo.mf
    .mo.m add cascade -label Ignore -underline 0 -menu .mo.mi
    .mo.m add cascade -label Parse -underline 0 -menu .mo.mp
    .mo.m add command -label Colours -underline 0 -command makePrefWin
    .mo.m add checkbutton -label "Diffs only" -variable Pref(onlydiffs)
    .mo.m add separator
    .mo.m add command -label "Save default" -command saveOptions

    .mo.mp add radiobutton -label "Lines" -variable Pref(parse) -value "line"
    .mo.mp add radiobutton -label "Blocks" -variable Pref(parse) -value "block"
    .mo.mp add separator
    .mo.mp add radiobutton -label "Characters" -variable Pref(lineparsewords) -value "0"
    .mo.mp add radiobutton -label "Words" -variable Pref(lineparsewords) -value "1"
    .mo.mp add separator
    .mo.mp add checkbutton -label "Use 2nd stage" -variable Pref(extralineparse)
    .mo.mp add checkbutton -label "Mark last" -variable Pref(marklast)

    menubutton .mh -text Help -underline 0 -menu .mh.m
    menu .mh.m
    .mh.m add command -label "Help" -command makeHelpWin
    .mh.m add command -label "About" -command makeAboutWin

    button .bfn -text "Next Diff" -relief raised -command findNext
    button .bfp -text "Prev Diff" -relief raised -command findPrev
    entry .eo -width 10 -textvariable Pref(dopt)
    label .lo -text "Diff Options"

    catch {font delete myfont}
    font create myfont -family $Pref(fontfamily) -size $Pref(fontsize)

    label .l1 -textvariable leftLabel -anchor e -width 10
    label .l2 -textvariable rightLabel -anchor e -width 10

    frame .ft1 -borderwidth 2 -relief sunken
    text .ft1.tl -height 40 -width 5 -wrap none -yscrollcommand my_yscroll \
	    -font myfont -borderwidth 0 -padx 0 -highlightthickness 0
    text .ft1.tt -height 40 -width 60 -wrap none -yscrollcommand my_yscroll \
	    -xscrollcommand ".sbx1 set" -font myfont -borderwidth 0 -padx 0 \
            -highlightthickness 0
    pack .ft1.tl -side left -fill y
    pack .ft1.tt -side right -fill both -expand 1
    scrollbar .sby -orient vertical -command "my_yview"
    scrollbar .sbx1 -orient horizontal -command ".ft1.tt xview"

    frame .ft2 -borderwidth 2 -relief sunken
    text .ft2.tl -height 40 -width 5 -wrap none -yscrollcommand my_yscroll \
	    -font myfont -borderwidth 0 -padx 0 -highlightthickness 0
    text .ft2.tt -height 40 -width 60 -wrap none -yscrollcommand my_yscroll \
	    -xscrollcommand ".sbx2 set" -font myfont -borderwidth 0 -padx 0 \
            -highlightthickness 0
    pack .ft2.tl -side left -fill y
    pack .ft2.tt -side right -fill both -expand 1
    scrollbar .sbx2 -orient horizontal -command ".ft2.tt xview"
    label .le -textvariable eqLabel -width 1
    canvas .c -width 4

    applyColor
    .ft1.tt tag configure last -underline 1
    .ft2.tt tag configure last -underline 1

    grid .l1 .le - .l2 -row 1 -sticky news
    grid .ft1 .c .sby .ft2 -row 2 -sticky news
    grid .sbx1 x x .sbx2 -row 3 -sticky news
    grid columnconfigure . {0 3} -weight 1
    grid rowconfigure . 2 -weight 1
    grid .c -pady [expr {[.sby cget -width] + 2}]

    image create photo map
    .c create image 0 0 -anchor nw -image map
    bind .c <Configure> {drawMap %h}

    if {$debug == 1} {
        menubutton .md -text Debug -menu .md.m -relief ridge
        menu .md.m
        if {$tcl_platform(platform) == "windows"} {
            .md.m add checkbutton -label Console -variable consolestate \
                    -onvalue show -offvalue hide -command {console $consolestate}
            .md.m add separator
        }
        .md.m add command -label "Stack trace" -command {bgerror Debug}
        .md.m add separator
        .md.m add command -label "Reread Source" -command {source $thisscript}
        .md.m add separator
        .md.m add command -label "Redraw Window" -command {makeDiffWin}
        .md.m add separator
        .md.m add command -label "Normal Cursor" -command {normalCursor}
        
        pack .mf .mo .mh .md -in .f -side left
    } else {

  Open Right File: Select a file for right window, run diff
  RCSDiff        : (UNIX only) Select one file and diff like rcsdiff.
  Print          : (UNIX only) Experimental print function.
                   It currently creates a postscript file ~/tcldiff.ps
  Quit           : Guess

Options Menu
  Font     : Select font ant fontsize for the two main text windows
  Ignore   : Diff options for handling whitespace
  Parse    : Additional parsing made by diff.tcl to improve the display.
             See examples below.
             Nothing: No parsing made.
             Lines  : When there is a changed block with the same number
                      of lines in both right and left files, diff.tcl
                      compares corresponding lines and tries to highlight
                      only the part that has been changed.
             Blocks : When the number of lines in a changed block is not
                      the same in both files, diff.tcl tries to find lines
                      that look the same and place them abreast.
             The Char and Word options selects if the line parsing should
             highlight full words only, or check single characters.
             2nd stage  : More thorough parsing of a line.
             Mark last  : Last change of a line is underlined
  Diffs only : Only differing lines will be displayed.
  Colours  : Choose highlight colours.
  Save default: Save current option settings in ~/.diffrc

Diff Options Field: Any text written here will be passed to diff.
                    In RCS mode, any -r options will be used to select versions.

    set Pref(colorchange) red
    set Pref(colornew1) darkgreen
    set Pref(colornew2) blue
    set Pref(bgchange) gray
    set Pref(bgnew1) gray
    set Pref(bgnew2) gray
    set Pref(onlydiffs) 0
    set Pref(marklast) 1

    if {[file exists "~/.diffrc"]} {
        source "~/.diffrc"
    }
}

if {![winfo exists .f]} {
    getOptions
    makeDiffWin
    update idletasks
    parseCommandLine
}