#!/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 {[catch {package require Ttk}]} {

    # use a shim

    namespace eval ttk {

        proc style args {}

        proc entry args {

            eval [linsert $args 0 ::entry] -relief flat

        }

    }

    interp alias {} ttk::button {} button

    interp alias {} ttk::frame {} frame

    interp alias {} ttk::label {} label

    interp alias {} ttk::scrollbar {} scrollbar

    interp alias {} ttk::optionMenu {} tk_optionMenu

    proc updatepalette {} {}

} else {

    proc ::ttk::optionMenu {w varName firstValue args} {

        upvar #0 $varName var

        if {![info exists var]} {

            set var $firstValue

        }

        ttk::menubutton $w -textvariable $varName -menu $w.menu \

                -direction flush

        menu $w.menu -tearoff 0

        $w.menu add radiobutton -label $firstValue -variable $varName

        foreach i $args {

            $w.menu add radiobutton -label $i -variable $varName

        }

        return $w.menu

    }

    proc updatepalette {} {

        catch {

            tk_setPalette background [ttk::style lookup client -background]

        }

    }

}

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

ttk::style theme use xpnative

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

} else {

if {[catch {

    set theme [ttk::style theme use]

}]} {

    set theme $::ttk::currentTheme

}

if {$theme eq "default"} {

    ttk::style theme use clam

}

}

updatepalette

# 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 popupify {w} {

    wm resizable $w 0 0

    wm withdraw $w

    update

    set x [expr {([winfo screenwidth .]-[winfo reqwidth $w])/2}]

    set y [expr {([winfo screenheight .]-[winfo reqheight $w])/2}]

    wm geometry  $w +$x+$y

    wm transient $w .

    wm deiconify $w

    wm resizable $w 1 1

}

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 -eofchar {}

    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

    global firstparents

    set inhdr 1

    set comment {}

    set headline {}

    set auname {}

    set audate {}

    set comname {}

    set comdate {}

    set rev {}

    set branch {}

    set bookmark {}

    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)