#!/usr/bin/env wish

# Copyright (C) 2005 Paul Mackerras.  All rights reserved.

# This program is free software; it may be used, copied, modified

# and distributed under the terms of the GNU General Public Licence,

# either version 2, or (at your option) any later version.

#

# See hgk.py for extension usage and configuration.

# Modified version of Tip 171:

# http://www.tcl.tk/cgi-bin/tct/tip/171.html

#

# The in_mousewheel global was added to fix strange reentrancy issues.

# The whole snipped is activated only under windows, mouse wheel

# bindings working already under MacOSX and Linux.

if {[tk windowingsystem] eq "win32"} {

set mw_classes [list Text Listbox Table TreeCtrl]

   foreach class $mw_classes { bind $class <MouseWheel> {} }

set in_mousewheel 0

proc ::tk::MouseWheel {wFired X Y D {shifted 0}} {

    global in_mousewheel

    if { $in_mousewheel != 0 } { return }

    # Set event to check based on call

    set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>"

    # do not double-fire in case the class already has a binding

    if {[bind [winfo class $wFired] $evt] ne ""} { return }

    # obtain the window the mouse is over

    set w [winfo containing $X $Y]

    # if we are outside the app, try and scroll the focus widget

    if {![winfo exists $w]} { catch {set w [focus]} }

    if {[winfo exists $w]} {

        if {[bind $w $evt] ne ""} {

            # Awkward ... this widget has a MouseWheel binding, but to

            # trigger successfully in it, we must give it focus.

            catch {focus} old

            if {$w ne $old} { focus $w }

            set in_mousewheel 1

            event generate $w $evt -rootx $X -rooty $Y -delta $D

            set in_mousewheel 0

            if {$w ne $old} { focus $old }

            return

        }

        # aqua and x11/win32 have different delta handling

        if {[tk windowingsystem] ne "aqua"} {

            set delta [expr {- ($D / 30)}]

        } else {

            set delta [expr {- ($D)}]

        }

        # scrollbars have different call conventions

        if {[string match "*Scrollbar" [winfo class $w]]} {

            catch {tk::ScrollByUnits $w \

                       [string index [$w cget -orient] 0] $delta}

        } else {

            set cmd [list $w [expr {$shifted ? "xview" : "yview"}] \

                         scroll $delta units]

            # Walking up to find the proper widget (handles cases like

            # embedded widgets in a canvas)

            while {[catch $cmd] && [winfo toplevel $w] ne $w} {

                set w [winfo parent $w]

            }

        }

    }

}

bind all <MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 0]

# end of win32 section

}

# Unify right mouse button handling.

# See "mouse buttons on macintosh" thread on comp.lang.tcl

if {[tk windowingsystem] eq "aqua"} {

    event add <<B3>> <Control-ButtonPress-1>

    event add <<B3>> <Button-2>

} else {

    event add <<B3>> <Button-3>

}

proc gitdir {} {

    global env

    if {[info exists env(GIT_DIR)]} {

	return $env(GIT_DIR)

    } else {

	return ".hg"

    }

}

proc getcommits {rargs} {

    global commits commfd phase canv mainfont env

    global startmsecs nextupdate ncmupdate

    global ctext maincursor textcursor leftover

    # check that we can find a .git directory somewhere...

    set gitdir [gitdir]

    if {![file isdirectory $gitdir]} {

	error_popup "Cannot find the git directory \"$gitdir\"."

	exit 1

    }

    set commits {}

    set phase getcommits

    set startmsecs [clock clicks -milliseconds]

    set nextupdate [expr $startmsecs + 100]

    set ncmupdate 1

    set limit 0

    set revargs {}

    for {set i 0} {$i < [llength $rargs]} {incr i} {

	set opt [lindex $rargs $i]

	if {$opt == "--limit"} {

	    incr i

	    set limit [lindex $rargs $i]

	} else {

	    lappend revargs $opt

	}

    }

    if [catch {

	set parse_args [concat --default HEAD $revargs]

	set parse_temp [eval exec {$env(HG)} --config ui.report_untrusted=false debug-rev-parse $parse_args]

	regsub -all "\r\n" $parse_temp "\n" parse_temp

	set parsed_args [split $parse_temp "\n"]

    } err] {

	# if git-rev-parse failed for some reason...

	if {$rargs == {}} {

	    set revargs HEAD

	}

	set parsed_args $revargs

    }

    if {$limit > 0} {

	set parsed_args [concat -n $limit $parsed_args]

    }

    if [catch {

	set commfd [open "|{$env(HG)} --config ui.report_untrusted=false debug-rev-list --header --topo-order --parents $parsed_args" r]

    } err] {

	puts stderr "Error executing hg debug-rev-list: $err"

	exit 1

    }

    set leftover {}

    fconfigure $commfd -blocking 0 -translation lf

    fileevent $commfd readable [list getcommitlines $commfd]

    $canv delete all

    $canv create text 3 3 -anchor nw -text "Reading commits..." \

	-font $mainfont -tags textitems

    . config -cursor watch

    settextcursor watch

}

proc getcommitlines {commfd}  {

    global commits parents cdate children

    global commitlisted phase commitinfo nextupdate

    global stopped redisplaying leftover

    set stuff [read $commfd]

    if {$stuff == {}} {

	if {![eof $commfd]} return

	# set it blocking so we wait for the process to terminate

	fconfigure $commfd -blocking 1

	if {![catch {close $commfd} err]} {

	    after idle finishcommits

	    return

	}

	if {[string range $err 0 4] == "usage"} {

	    set err \

{Gitk: error reading commits: bad arguments to git-rev-list.

(Note: arguments to gitk are passed to git-rev-list

to allow selection of commits to be displayed.)}

	} else {

	    set err "Error reading commits: $err"

	}

	error_popup $err

	exit 1

    }

    set start 0

    while 1 {

	set i [string first "\0" $stuff $start]

	if {$i < 0} {

	    append leftover [string range $stuff $start end]

	    return

	}

	set cmit [string range $stuff $start [expr {$i - 1}]]

	if {$start == 0} {

	    set cmit "$leftover$cmit"

	    set leftover {}

	}

	set start [expr {$i + 1}]

	regsub -all "\r\n" $cmit "\n" cmit

	set j [string first "\n" $cmit]

	set ok 0

	if {$j >= 0} {

	    set ids [string range $cmit 0 [expr {$j - 1}]]

	    set ok 1

	    foreach id $ids {

		if {![regexp {^[0-9a-f]{12}$} $id]} {

		    set ok 0

		    break

		}

	    }

	}

	if {!$ok} {

	    set shortcmit $cmit

	    if {[string length $shortcmit] > 80} {

		set shortcmit "[string range $shortcmit 0 80]..."

	    }

	    error_popup "Can't parse hg debug-rev-list output: {$shortcmit}"

	    exit 1

	}

	set id [lindex $ids 0]

	set olds [lrange $ids 1 end]

	set cmit [string range $cmit [expr {$j + 1}] end]

	lappend commits $id

	set commitlisted($id) 1

	parsecommit $id $cmit 1 [lrange $ids 1 end]

	drawcommit $id

	if {[clock clicks -milliseconds] >= $nextupdate} {

	    doupdate 1

	}

	while {$redisplaying} {

	    set redisplaying 0

	    if {$stopped == 1} {

		set stopped 0

		set phase "getcommits"

		foreach id $commits {

		    drawcommit $id

		    if {$stopped} break

		    if {[clock clicks -milliseconds] >= $nextupdate} {

			doupdate 1

		    }

		}

	    }

	}

    }

}

proc doupdate {reading} {

    global commfd nextupdate numcommits ncmupdate

    if {$reading} {

	fileevent $commfd readable {}

    }

    update

    set nextupdate [expr {[clock clicks -milliseconds] + 100}]

    if {$numcommits < 100} {

	set ncmupdate [expr {$numcommits + 1}]

    } elseif {$numcommits < 10000} {

	set ncmupdate [expr {$numcommits + 10}]

    } else {

	set ncmupdate [expr {$numcommits + 100}]

    }

    if {$reading} {

	fileevent $commfd readable [list getcommitlines $commfd]

    }

}

proc readcommit {id} {

    global env

    if [catch {set contents [exec $env(HG) --config ui.report_untrusted=false debug-cat-file commit $id]}] return

    parsecommit $id $contents 0 {}

}

proc parsecommit {id contents listed olds} {

    global commitinfo children nchildren parents nparents cdate ncleft

    set inhdr 1

    set comment {}

    set headline {}

    set auname {}

    set audate {}

    set comname {}

    set comdate {}

    set rev {}

    if {![info exists nchildren($id)]} {

	set children($id) {}

	set nchildren($id) 0

	set ncleft($id) 0

    }

    set parents($id) $olds

    set nparents($id) [llength $olds]

    foreach p $olds {

	if {![info exists nchildren($p)]} {

	    set children($p) [list $id]

	    set nchildren($p) 1

	    set ncleft($p) 1

	} elseif {[lsearch -exact $children($p) $id] < 0} {

	    lappend children($p) $id

	    incr nchildren($p)

	    incr ncleft($p)

	}

    }

    regsub -all "\r\n" $contents "\n" contents

    foreach line [split $contents "\n"] {

	if {$inhdr} {

	    set line [split $line]

	    if {$line == {}} {

		set inhdr 0

	    } else {

		set tag [lindex $line 0]

		if {$tag == "author"} {

		    set x [expr {[llength $line] - 2}]

		    set audate [lindex $line $x]

		    set auname [join [lrange $line 1 [expr {$x - 1}]]]

		} elseif {$tag == "committer"} {

		    set x [expr {[llength $line] - 2}]

		    set comdate [lindex $line $x]

		    set comname [join [lrange $line 1 [expr {$x - 1}]]]

		} elseif {$tag == "revision"} {

		    set rev [lindex $line 1]

		}

	    }

	} else {

	    if {$comment == {}} {

		set headline [string trim $line]

	    } else {

		append comment "\n"

	    }

	    if {!$listed} {

		# git-rev-list indents the comment by 4 spaces;

		# if we got this via git-cat-file, add the indentation

		append comment "    "

	    }

	    append comment $line

	}

    }

    if {$audate != {}} {

	set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]

    }

    if {$comdate != {}} {

	set cdate($id) $comdate

	set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]

    }

    set commitinfo($id) [list $headline $auname $audate \

			     $comname $comdate $comment $rev]

}

proc readrefs {} {

    global tagids idtags headids idheads tagcontents env

    set tags [exec $env(HG) --config ui.report_untrusted=false tags]

    regsub -all "\r\n" $tags "\n" tags

    set lines [split $tags "\n"]

    foreach f $lines {

	regexp {(\S+)$} $f full

	regsub {\s+(\S+)$} $f "" direct

	set sha [split $full ':']

	set tag [lindex $sha 1]

	lappend tagids($direct) $tag

	lappend idtags($tag) $direct

    }

}

proc readotherrefs {base dname excl} {

    global otherrefids idotherrefs

    set git [gitdir]

    set files [glob -nocomplain -types f [file join $git $base *]]

    foreach f $files {

	catch {

	    set fd [open $f r]

	    set line [read $fd 40]

	    if {[regexp {^[0-9a-f]{12}} $line id]} {

		set name "$dname[file tail $f]"

		set otherrefids($name) $id

		lappend idotherrefs($id) $name

	    }

	    close $fd

	}

    }

    set dirs [glob -nocomplain -types d [file join $git $base *]]

    foreach d $dirs {

	set dir [file tail $d]

	if {[lsearch -exact $excl $dir] >= 0} continue

	readotherrefs [file join $base $dir] "$dname$dir/" {}

    }

}

proc allcansmousewheel {delta} {

    set delta [expr -5*(int($delta)/abs($delta))]

    allcanvs yview scroll $delta units

}

proc error_popup msg {

    set w .error

    toplevel $w

    wm transient $w .

    message $w.m -text $msg -justify center -aspect 400

    pack $w.m -side top -fill x -padx 20 -pady 20

    button $w.ok -text OK -command "destroy $w"

    pack $w.ok -side bottom -fill x

    bind $w <Visibility> "grab $w; focus $w"

    tkwait window $w

}

proc makewindow {} {

    global canv canv2 canv3 linespc charspc ctext cflist textfont

    global findtype findtypemenu findloc findstring fstring geometry

    global entries sha1entry sha1string sha1but

    global maincursor textcursor curtextcursor

    global rowctxmenu gaudydiff mergemax

    global hgvdiff

    menu .bar

    .bar add cascade -label "File" -menu .bar.file

    menu .bar.file

    .bar.file add command -label "Reread references" -command rereadrefs

    .bar.file add command -label "Quit" -command doquit

    menu .bar.help

    .bar add cascade -label "Help" -menu .bar.help

    .bar.help add command -label "About gitk" -command about

    . configure -menu .bar

    if {![info exists geometry(canv1)]} {

	set geometry(canv1) [expr 45 * $charspc]

	set geometry(canv2) [expr 30 * $charspc]

	set geometry(canv3) [expr 15 * $charspc]

	set geometry(canvh) [expr 25 * $linespc + 4]

	set geometry(ctextw) 80

	set geometry(ctexth) 30

	set geometry(cflistw) 30

    }

    panedwindow .ctop -orient vertical

    if {[info exists geometry(width)]} {

	.ctop conf -width $geometry(width) -height $geometry(height)

	set texth [expr {$geometry(height) - $geometry(canvh) - 56}]

	set geometry(ctexth) [expr {($texth - 8) /

				    [font metrics $textfont -linespace]}]

    }

    frame .ctop.top

    frame .ctop.top.bar

    pack .ctop.top.bar -side bottom -fill x

    set cscroll .ctop.top.csb

    scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0

    pack $cscroll -side right -fill y

    panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4

    pack .ctop.top.clist -side top -fill both -expand 1

    .ctop add .ctop.top

    set canv .ctop.top.clist.canv

    canvas $canv -height $geometry(canvh) -width $geometry(canv1) \

	-bg white -bd 0 \

	-yscrollincr $linespc -yscrollcommand "$cscroll set" -selectbackground grey

    .ctop.top.clist add $canv

    set canv2 .ctop.top.clist.canv2

    canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \

	-bg white -bd 0 -yscrollincr $linespc -selectbackground grey

    .ctop.top.clist add $canv2

    set canv3 .ctop.top.clist.canv3

    canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \

	-bg white -bd 0 -yscrollincr $linespc -selectbackground grey

    .ctop.top.clist add $canv3

    bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}

    set sha1entry .ctop.top.bar.sha1

    set entries $sha1entry

    set sha1but .ctop.top.bar.sha1label

    button $sha1but -text "SHA1 ID: " -state disabled -relief flat \

	-command gotocommit -width 8

    $sha1but conf -disabledforeground [$sha1but cget -foreground]

    pack .ctop.top.bar.sha1label -side left

    entry $sha1entry -width 40 -font $textfont -textvariable sha1string

    trace add variable sha1string write sha1change

    pack $sha1entry -side left -pady 2

    image create bitmap bm-left -data {

	#define left_width 16

	#define left_height 16

	static unsigned char left_bits[] = {

	0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,

	0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,

	0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};

    }

    image create bitmap bm-right -data {

	#define right_width 16

	#define right_height 16

	static unsigned char right_bits[] = {

	0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,

	0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,

	0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};

    }

    button .ctop.top.bar.leftbut -image bm-left -command goback \

	-state disabled -width 26

    pack .ctop.top.bar.leftbut -side left -fill y

    button .ctop.top.bar.rightbut -image bm-right -command goforw \

	-state disabled -width 26

    pack .ctop.top.bar.rightbut -side left -fill y

    button .ctop.top.bar.findbut -text "Find" -command dofind

    pack .ctop.top.bar.findbut -side left

    set findstring {}

    set fstring .ctop.top.bar.findstring

    lappend entries $fstring

    entry $fstring -width 30 -font $textfont -textvariable findstring

    pack $fstring -side left -expand 1 -fill x

    set findtype Exact

    set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \