Eskil

#----------------------------------------------------------------------
# $Revision$
#----------------------------------------------------------------------
# the next line restarts using wish \
exec wish "$0" "$@"

package provide app-diff 1.0
package require Tcl 8.3
package require Tk
catch {package require textSearch}

if {[catch {package require psballoon}]} {
    # Add a dummy if it does not exists.
    proc addBalloon {args} {}
} else {
    namespace import -force psballoon::addBalloon
}

set debug 1
set diffver "Version 1.9.8+  2003-09-01"
set thisScript [file join [pwd] [info script]]
set thisDir [file dirname $thisScript]

# Follow any link
set tmplink $thisScript
while {[file type $tmplink] == "link"} {
    set tmplink [file readlink $tmplink]
    # Change to this when this app starts to require 8.4
    #set tmplink [file normalize [file join $thisDir $tmplink]]
    set tmplink [file join $thisDir $tmplink]
    set thisDir [file dirname $tmplink]
}
unset tmplink

set ::util(cvsExists) [expr {![string equal [auto_execok cvs] ""]}]
set ::util(diffexe) diff
set ::util(diffWrapped) 0

    if {$::tcl_platform(platform) == "unix"} {
        set util(editor) emacs
    } else {
        set util(editor) wordpad
        foreach dir [lsort -decreasing -dictionary \
                             [glob -nocomplain c:/apps/emacs*]] {
            set em [file join $dir bin runemacs.exe]
            # Remove catch when this app starts to require 8.4
            catch {set em [file normalize $em]}
            if {[file exists $em]} {
                set util(editor) $em
                break
            }
        }
    }
}

proc rowPopup {w X Y x y} {
    set top [winfo toplevel $w]
    if {[info exists ::diff($top,nopopup)] && $::diff($top,nopopup)} return
    destroy .lpm
    menu .lpm

    regexp {\d+} $w n
    if {[alignMenu .lpm $top $n $x $y]} {
        return
    }

    set ::diff($top,nopopup) 1
    tk_popup .lpm $X $Y
    after idle [list after 1 [list set ::diff($top,nopopup) 0]]

    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+} $w n
        hlPopup $top $n "" $X $Y $x $y
        return
    }

    # Extract the data
    set data(1) [$::diff($top,wDiff1) dump -tag -text $row.0 $row.end]
    set data(2) [$::diff($top,wDiff2) dump -tag -text $row.0 $row.end]

    }

    # Let geometry requests propagate
    update idletasks

    # Is the balloon within the diff window?
    set wid [winfo reqwidth $top.balloon]
    if {$wid + $wx > [winfo rootx .] + [winfo width .]} {
        # No.
        # Center on diff window
        set wx [expr {([winfo width .] - $wid) / 2 + [winfo rootx .]}]
        if {$wx < 0} {set wx 0}
        # Is the balloon not within the screen?
        if {$wx + $wid > [winfo screenwidth .]} {
            # Center in screen
            set wx [expr {([winfo screenwidth .] - $wid) / 2}]
            if {$wx < 0} {set wx 0}
        }
    }

    # Does the balloon fit within the screen?
    if {$wid > [winfo screenwidth .]} {
        # How many rows does it take?
        set rows [expr {ceil(double($wid) / [winfo screenwidth .])}]
        # 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 .]x[winfo reqheight $top.balloon]
        set wx 0
    }
    wm geometry $top.balloon +$wx+$wy
    wm deiconify $top.balloon
}

proc unzoomRow {w} {

    set font [$w cget -font]
    destroy $w

    entry $w -relief flat -bd 0 -highlightthickness 0 \
            -foreground $fg -background $bg -font $font
    eval $w configure $args

    $w configure -takefocus 0 -state disabled
    if {[info tclversion] >= 8.4} {
        $w configure -state readonly -readonlybackground $bg
    }

    set i [lsearch $args -textvariable]
    if {$i >= 0} {
	set var [lindex $args [expr {$i + 1}]]
	uplevel \#0 "trace variable $var w \
		{after idle {$w xview end} ;#}"
    }

                -command [list makeDiffWin $top]
        $top.md.m add separator
        $top.md.m add command -label "Normal Cursor" \
                -command [list normalCursor $top]
        $top.md.m add separator
        $top.md.m add command -label "Evalstats" -command {evalstats}
        $top.md.m add command -label "_stats" -command {parray _stats}
        $top.md.m add command -label "Nuisance" -command {makeNuisance \
                "It looks like you are trying out the debug menu."}
        pack $top.md -in $top.f -side left -padx 20 -anchor n
    }

    initDiffData $top
}

# Set new preferences.

    exampleFont $lb
}

#####################################
# Registry section
#####################################

# A little labelframe thingy for pre 8.4
proc myLabelFrame {w args} {
    if {[info tclversion] >= 8.4} {
        return [eval [list labelframe $w] $args]
    }
    if {([llength $args] % 2) != 0} {
        error "wrong # args: should be \"myLabelFrame pathName ?options?\""
    }

    set allopts {}
    set fopts {}
    set lopts {}
    set labelanchor nw
    set padx 0
    set pady 0
    set bd 2
    set relief groove
    set labelwindow ""
    set text ""

    foreach {opt val} $args {
        switch -- $opt {
            -bd - -borderwidth {
                set bd $val
            }
            -relief {
                set relief $val
            }
            -text {
                lappend lopts $opt $val
                set text $val
            }
            -font - -fg - -foreground {
                lappend lopts $opt $val
            }
            -labelanchor {
                set labelanchor $val
            }
            -labelwindow {
                set labelwindow $val
            }
            -padx {
                set padx $val
            }
            -pady {
                set pady $val
            }
            -bg - -background - -cursor {
                lappend allopts $opt $val
            }
            default {
                error "Unknown or unsupported option: $opt"
            }
        }
    }
    lappend fopts -relief $relief -bd $bd

    eval [list frame $w] $allopts
    eval [list frame $w.bd] $fopts $allopts 
    if {$labelwindow != ""} {
        set lw $labelwindow
        raise $labelwindow $w
    } elseif {$text != ""} {
        set lw $w.l
        eval [list label $lw] $lopts $allopts -highlightthickness 0 -bd 0
    } else {
        set lw ""
    }
    eval [list frame $w.f] $allopts

    grid columnconfigure $w {2 4} -minsize $padx
    grid rowconfigure $w {2 4} -minsize $pady
    grid columnconfigure $w 3 -weight 1
    grid rowconfigure $w 3 -weight 1
    grid columnconfigure $w {1 5} -minsize $bd
    grid rowconfigure $w {1 5} -minsize $bd

    grid $w.bd -row 1 -col 1 -rowspan 5 -columnspan 5 -sticky news
    grid $w.f -row 3 -col 3 -sticky news

    if {$lw != ""} {
        switch -glob $labelanchor {
            n* {
                grid $lw -in $w -row 0 -col 2 -rowspan 2 -columnspan 3 -padx 4
            }
            s* {
                grid $lw -in $w -row 5 -col 2 -rowspan 2 -columnspan 3 -padx 4
            }
            w* {
                grid $lw -in $w -row 2 -col 0 -rowspan 3 -columnspan 2 -pady 4
            }
            e* {
                grid $lw -in $w -row 2 -col 5 -rowspan 3 -columnspan 2 -pady 4
            }
        }
        grid $lw -sticky [string index $labelanchor 1]
    }
    return $w.f
}

proc makeRegistryFrame {w label key newvalue} {
    set old {}
    catch {set old [registry get $key {}]}

    set l [myLabelFrame $w -text $label -padx 4 -pady 4]

    label $l.key1 -text "Key:"
    label $l.key2 -text $key
    label $l.old1 -text "Old value:"
    label $l.old2 -text $old
    label $l.new1 -text "New value:"
    label $l.new2 -text $newvalue

    grid $l.new1 $l.new2 -sticky w -padx 4 -pady 4
    grid $l.change -     -sticky e -padx 4 -pady 4
    grid columnconfigure $l 1 -weight 1
}

proc makeRegistryWin {} {
    global thisDir thisScript util
















    set top .reg
    destroy $top
    toplevel $top
    wm title $top "Register Diff"

    # Registry keys

    #set keyg {HKEY_CLASSES_ROOT\Folder\shell\Grep\command}
    set keydd {HKEY_CLASSES_ROOT\Folder\shell\Diff\command}
    set keyd {HKEY_CLASSES_ROOT\*\shell\Diff\command}
    set keyc {HKEY_CLASSES_ROOT\*\shell\DiffC\command}
    set keye {HKEY_CLASSES_ROOT\*\shell\Emacs\command}
    
    # Locate executable for this program
    set exe [info nameofexecutable]

    # Are we in a starkit?
    if {[info exists ::starkit::topdir]} {
        # In a starpack ?
        set exe [file normalize $exe]
        if {[string equal [file normalize $::starkit::topdir] $exe]} {
            set myexe [list $exe]
        } else {

                    -onvalue show -offvalue hide -command {console $consolestate}
            $top.md.m add separator
        }
        $top.md.m add command -label "Reread Source" -underline 0 \
                -command {source $thisScript}
        $top.md.m add separator
        $top.md.m add command -label "Redraw Window" -command {makeDirDiffWin 1}
        pack $top.md -in $top.fm -side left -padx 20
    }

    button $top.bu -text "Up Both" -command upDir -underline 0
    bind $top <Alt-u> "$top.bu invoke"
    button $top.bc -text "Compare" -command doCompare -underline 0
    bind $top <Alt-c> "$top.bc invoke"
    pack $top.bc $top.bu -in $top.fm -side right


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

    entry $top.e1 -textvariable dirdiff(leftDir)
    button $top.bu1 -text "Up" -command {upDir 1}
    button $top.bb1 -text "Browse" -command {browseDir dirdiff(leftDir)}

    entry $top.e2 -textvariable dirdiff(rightDir)
    button $top.bu2 -text "Up" -command {upDir 2}
    button $top.bb2 -text "Browse" -command {browseDir dirdiff(rightDir)}

    bind $top.e1 <Return> doCompare
    bind $top.e2 <Return> doCompare

    pack $top.bb1 $top.bu1 -in $top.fe1 -side right

    pack $top.e1 -in $top.fe1 -side left -fill x -expand 1
    pack $top.bb2 $top.bu2 -in $top.fe2 -side right

    pack $top.e2 -in $top.fe2 -side left -fill x -expand 1

    text $top.t1 -height 40 -width 60 -wrap none -font myfont \
	    -xscrollcommand "$top.sbx1 set" -takefocus 0
    scrollbar $top.sby -orient vertical
    scrollbar $top.sbx1 -orient horizontal -command "$top.t1 xview"
    text $top.t2 -height 40 -width 60 -wrap none -font myfont \

    grid columnconfigure $top {0 1} -weight 1
}

#####################################
# Help and startup functions
#####################################

proc makeNuisance {{str {Hi there!}}} {
    global thisDir

    if {[lsearch [image names] nuisance] < 0} {
        set file [file join $thisDir Nuisance.gif]
        if {![file exists $file]} return
        image create photo nuisance -file $file
    }

    destroy .nui
    toplevel .nui
    wm transient .nui .
    wm geometry .nui +400+400
    wm title .nui ""
    label .nui.l -image nuisance
    pack .nui.l
    wm protocol .nui WM_DELETE_WINDOW {destroy .nui2 .nui}
    update

    destroy .nui2
    toplevel .nui2 -bg yellow
    wm transient .nui2 .nui
    wm overrideredirect .nui2 1
    wm title .nui2 ""
    label .nui2.l -text "$str\nDo you want help?" -justify left -bg yellow
    button .nui2.b -text "No, get out of my face!" -command {destroy .nui2 .nui} -bg yellow

    pack .nui2.l .nui2.b -side top -fill x
    wm geometry .nui2 +[expr {405 + [winfo width .nui]}]+400
}

proc helpWin {w title} {
    destroy $w

    toplevel $w
    wm title $w $title

            set nextArg revision
        } elseif {[string range $arg 0 1] == "-r"} {
            set opts(doptrev$revNo) [string range $arg 2 end]
            incr revNo
        } elseif {[string range $arg 0 0] == "-"} {
            append opts(dopt) " $arg"
        } else {
            set apa [glob -nocomplain [file join [pwd] $arg]]
            if {$apa == ""} {
                puts "Ignoring argument: $arg"
            } else {
                lappend files [lindex $apa 0]
            }
        }
    }

    # Do we start in clip diff mode?
    if {$doclip} {
        makeClipDiffWin