[thirdparty/git.git] / gitk

#!/bin/sh
# Tcl ignores the next line -*- tcl -*- \
exec wish "$0" -- "${1+$@}"

# 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.

proc gitdir {} {
    global env
    if {[info exists env(GIT_DIR)]} {
	return $env(GIT_DIR)
    } else {
	return ".git"
    }
}

proc getcommits {rargs} {
    global commits commfd phase canv mainfont env
    global startmsecs nextupdate
    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]
    if [catch {
	set parse_args [concat --default HEAD $rargs]
	set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
    }] {
	# if git-rev-parse failed for some reason...
	if {$rargs == {}} {
	    set rargs HEAD
	}
	set parsed_args $rargs
    }
    if [catch {
	set commfd [open "|git-rev-list --header --topo-order $parsed_args" r]
    } err] {
	puts stderr "Error executing git-rev-list: $err"
	exit 1
    }
    set leftover {}
    fconfigure $commfd -blocking 0 -translation binary
    fileevent $commfd readable "getcommitlines $commfd"
    $canv delete all
    $canv create text 3 3 -anchor nw -text "Reading commits..." \
	-font $mainfont -tags textitems
    . config -cursor watch
    $ctext config -cursor watch
}

proc getcommitlines {commfd}  {
    global commits parents cdate children nchildren
    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}]
	if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
	    set shortcmit $cmit
	    if {[string length $shortcmit] > 80} {
		set shortcmit "[string range $shortcmit 0 80]..."
	    }
	    error_popup "Can't parse git-rev-list output: {$shortcmit}"
	    exit 1
	}
	set cmit [string range $cmit 41 end]
	lappend commits $id
	set commitlisted($id) 1
	parsecommit $id $cmit 1
	drawcommit $id
	if {[clock clicks -milliseconds] >= $nextupdate} {
	    doupdate
	}
	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
		    }
		}
	    }
	}
    }
}

proc doupdate {} {
    global commfd nextupdate

    incr nextupdate 100
    fileevent $commfd readable {}
    update
    fileevent $commfd readable "getcommitlines $commfd"
}

proc readcommit {id} {
    if [catch {set contents [exec git-cat-file commit $id]}] return
    parsecommit $id $contents 0
}

proc parsecommit {id contents listed} {
    global commitinfo children nchildren parents nparents cdate ncleft

    set inhdr 1
    set comment {}
    set headline {}
    set auname {}
    set audate {}
    set comname {}
    set comdate {}
    if {![info exists nchildren($id)]} {
	set children($id) {}
	set nchildren($id) 0
	set ncleft($id) 0
    }
    set parents($id) {}
    set nparents($id) 0
    foreach line [split $contents "\n"] {
	if {$inhdr} {
	    if {$line == {}} {
		set inhdr 0
	    } else {
		set tag [lindex $line 0]
		if {$tag == "parent"} {
		    set p [lindex $line 1]
		    if {![info exists nchildren($p)]} {
			set children($p) {}
			set nchildren($p) 0
			set ncleft($p) 0
		    }
		    lappend parents($id) $p
		    incr nparents($id)
		    # sometimes we get a commit that lists a parent twice...
		    if {$listed && [lsearch -exact $children($p) $id] < 0} {
			lappend children($p) $id
			incr nchildren($p)
			incr ncleft($p)
		    }
		} elseif {$tag == "author"} {
		    set x [expr {[llength $line] - 2}]
		    set audate [lindex $line $x]
		    set auname [lrange $line 1 [expr {$x - 1}]]
		} elseif {$tag == "committer"} {
		    set x [expr {[llength $line] - 2}]
		    set comdate [lindex $line $x]
		    set comname [lrange $line 1 [expr {$x - 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]
}

proc readrefs {} {
    global tagids idtags headids idheads
    set tags [glob -nocomplain -types f [gitdir]/refs/tags/*]
    foreach f $tags {
	catch {
	    set fd [open $f r]
	    set line [read $fd]
	    if {[regexp {^[0-9a-f]{40}} $line id]} {
		set direct [file tail $f]
		set tagids($direct) $id
		lappend idtags($id) $direct
		set contents [split [exec git-cat-file tag $id] "\n"]
		set obj {}
		set type {}
		set tag {}
		foreach l $contents {
		    if {$l == {}} break
		    switch -- [lindex $l 0] {
			"object" {set obj [lindex $l 1]}
			"type" {set type [lindex $l 1]}
			"tag" {set tag [string range $l 4 end]}
		    }
		}
		if {$obj != {} && $type == "commit" && $tag != {}} {
		    set tagids($tag) $obj
		    lappend idtags($obj) $tag
		}
	    }
	    close $fd
	}
    }
    set heads [glob -nocomplain -types f [gitdir]/refs/heads/*]
    foreach f $heads {
	catch {
	    set fd [open $f r]
	    set line [read $fd 40]
	    if {[regexp {^[0-9a-f]{40}} $line id]} {
		set head [file tail $f]
		set headids($head) $line
		lappend idheads($line) $head
	    }
	    close $fd
	}
    }
}

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
    global rowctxmenu gaudydiff mergemax

    menu .bar
    .bar add cascade -label "File" -menu .bar.file
    menu .bar.file
    .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"
    .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
    .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
    .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
    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 \
			  findtype Exact IgnCase Regexp]
    set findloc "All fields"
    tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
	Comments Author Committer Files Pickaxe
    pack .ctop.top.bar.findloc -side right
    pack .ctop.top.bar.findtype -side right
    # for making sure type==Exact whenever loc==Pickaxe
    trace add variable findloc write findlocchange

    panedwindow .ctop.cdet -orient horizontal
    .ctop add .ctop.cdet
    frame .ctop.cdet.left
    set ctext .ctop.cdet.left.ctext
    text $ctext -bg white -state disabled -font $textfont \
	-width $geometry(ctextw) -height $geometry(ctexth) \
	-yscrollcommand ".ctop.cdet.left.sb set"
    scrollbar .ctop.cdet.left.sb -command "$ctext yview"
    pack .ctop.cdet.left.sb -side right -fill y
    pack $ctext -side left -fill both -expand 1
    .ctop.cdet add .ctop.cdet.left

    $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
    if {$gaudydiff} {
	$ctext tag conf hunksep -back blue -fore white
	$ctext tag conf d0 -back "#ff8080"
	$ctext tag conf d1 -back green
    } else {
	$ctext tag conf hunksep -fore blue
	$ctext tag conf d0 -fore red
	$ctext tag conf d1 -fore "#00a000"
	$ctext tag conf m0 -fore red
	$ctext tag conf m1 -fore blue
	$ctext tag conf m2 -fore green
	$ctext tag conf m3 -fore purple
	$ctext tag conf m4 -fore brown
	$ctext tag conf mmax -fore darkgrey
	set mergemax 5
	$ctext tag conf mresult -font [concat $textfont bold]
	$ctext tag conf msep -font [concat $textfont bold]
	$ctext tag conf found -back yellow
    }

    frame .ctop.cdet.right
    set cflist .ctop.cdet.right.cfiles
    listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
	-yscrollcommand ".ctop.cdet.right.sb set"
    scrollbar .ctop.cdet.right.sb -command "$cflist yview"
    pack .ctop.cdet.right.sb -side right -fill y
    pack $cflist -side left -fill both -expand 1
    .ctop.cdet add .ctop.cdet.right
    bind .ctop.cdet <Configure> {resizecdetpanes %W %w}

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

    bindall <1> {selcanvline %W %x %y}
    #bindall <B1-Motion> {selcanvline %W %x %y}
    bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
    bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
    bindall <2> "allcanvs scan mark 0 %y"
    bindall <B2-Motion> "allcanvs scan dragto 0 %y"
    bind . <Key-Up> "selnextline -1"
    bind . <Key-Down> "selnextline 1"
    bind . <Key-Prior> "allcanvs yview scroll -1 pages"
    bind . <Key-Next> "allcanvs yview scroll 1 pages"
    bindkey <Key-Delete> "$ctext yview scroll -1 pages"
    bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
    bindkey <Key-space> "$ctext yview scroll 1 pages"
    bindkey p "selnextline -1"
    bindkey n "selnextline 1"
    bindkey b "$ctext yview scroll -1 pages"
    bindkey d "$ctext yview scroll 18 units"
    bindkey u "$ctext yview scroll -18 units"
    bindkey / {findnext 1}
    bindkey <Key-Return> {findnext 0}
    bindkey ? findprev
    bindkey f nextfile
    bind . <Control-q> doquit
    bind . <Control-f> dofind
    bind . <Control-g> {findnext 0}
    bind . <Control-r> findprev
    bind . <Control-equal> {incrfont 1}
    bind . <Control-KP_Add> {incrfont 1}
    bind . <Control-minus> {incrfont -1}
    bind . <Control-KP_Subtract> {incrfont -1}
    bind $cflist <<ListboxSelect>> listboxsel
    bind . <Destroy> {savestuff %W}
    bind . <Button-1> "click %W"
    bind $fstring <Key-Return> dofind
    bind $sha1entry <Key-Return> gotocommit
    bind $sha1entry <<PasteSelection>> clearsha1

    set maincursor [. cget -cursor]
    set textcursor [$ctext cget -cursor]

    set rowctxmenu .rowctxmenu
    menu $rowctxmenu -tearoff 0
    $rowctxmenu add command -label "Diff this -> selected" \
	-command {diffvssel 0}
    $rowctxmenu add command -label "Diff selected -> this" \
	-command {diffvssel 1}
    $rowctxmenu add command -label "Make patch" -command mkpatch
    $rowctxmenu add command -label "Create tag" -command mktag
    $rowctxmenu add command -label "Write commit to file" -command writecommit
}

# when we make a key binding for the toplevel, make sure
# it doesn't get triggered when that key is pressed in the
# find string entry widget.
proc bindkey {ev script} {
    global entries
    bind . $ev $script
    set escript [bind Entry $ev]
    if {$escript == {}} {
	set escript [bind Entry <Key>]
    }
    foreach e $entries {
	bind $e $ev "$escript; break"
    }
}

# set the focus back to the toplevel for any click outside
# the entry widgets
proc click {w} {
    global entries
    foreach e $entries {
	if {$w == $e} return
    }
    focus .
}

proc savestuff {w} {
    global canv canv2 canv3 ctext cflist mainfont textfont
    global stuffsaved findmergefiles gaudydiff

    if {$stuffsaved} return
    if {![winfo viewable .]} return
    catch {
	set f [open "~/.gitk-new" w]
	puts $f [list set mainfont $mainfont]
	puts $f [list set textfont $textfont]
	puts $f [list set findmergefiles $findmergefiles]
	puts $f [list set gaudydiff $gaudydiff]
	puts $f "set geometry(width) [winfo width .ctop]"
	puts $f "set geometry(height) [winfo height .ctop]"
	puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
	puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
	puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
	puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
	set wid [expr {([winfo width $ctext] - 8) \
			   / [font measure $textfont "0"]}]
	puts $f "set geometry(ctextw) $wid"
	set wid [expr {([winfo width $cflist] - 11) \
			   / [font measure [$cflist cget -font] "0"]}]
	puts $f "set geometry(cflistw) $wid"
	close $f
	file rename -force "~/.gitk-new" "~/.gitk"
    }
    set stuffsaved 1
}

proc resizeclistpanes {win w} {
    global oldwidth
    if [info exists oldwidth($win)] {
	set s0 [$win sash coord 0]
	set s1 [$win sash coord 1]
	if {$w < 60} {
	    set sash0 [expr {int($w/2 - 2)}]
	    set sash1 [expr {int($w*5/6 - 2)}]
	} else {
	    set factor [expr {1.0 * $w / $oldwidth($win)}]
	    set sash0 [expr {int($factor * [lindex $s0 0])}]
	    set sash1 [expr {int($factor * [lindex $s1 0])}]
	    if {$sash0 < 30} {
		set sash0 30
	    }
	    if {$sash1 < $sash0 + 20} {
		set sash1 [expr $sash0 + 20]
	    }
	    if {$sash1 > $w - 10} {
		set sash1 [expr $w - 10]
		if {$sash0 > $sash1 - 20} {
		    set sash0 [expr $sash1 - 20]
		}
	    }
	}
	$win sash place 0 $sash0 [lindex $s0 1]
	$win sash place 1 $sash1 [lindex $s1 1]
    }
    set oldwidth($win) $w
}

proc resizecdetpanes {win w} {
    global oldwidth
    if [info exists oldwidth($win)] {
	set s0 [$win sash coord 0]
	if {$w < 60} {
	    set sash0 [expr {int($w*3/4 - 2)}]
	} else {
	    set factor [expr {1.0 * $w / $oldwidth($win)}]
	    set sash0 [expr {int($factor * [lindex $s0 0])}]
	    if {$sash0 < 45} {
		set sash0 45
	    }
	    if {$sash0 > $w - 15} {
		set sash0 [expr $w - 15]
	    }
	}
	$win sash place 0 $sash0 [lindex $s0 1]
    }
    set oldwidth($win) $w
}

proc allcanvs args {
    global canv canv2 canv3
    eval $canv $args
    eval $canv2 $args
    eval $canv3 $args
}

proc bindall {event action} {
    global canv canv2 canv3
    bind $canv $event $action
    bind $canv2 $event $action
    bind $canv3 $event $action
}

proc about {} {
    set w .about
    if {[winfo exists $w]} {
	raise $w
	return
    }
    toplevel $w
    wm title $w "About gitk"
    message $w.m -text {
Gitk version 1.2
Commit	Line	Data
	1	#!/bin/sh
	2	# Tcl ignores the next line -- tcl -- \
	3	exec wish "$0" -- "${1+$@}"
	4
	5	# Copyright (C) 2005 Paul Mackerras. All rights reserved.
	6	# This program is free software; it may be used, copied, modified
	7	# and distributed under the terms of the GNU General Public Licence,
	8	# either version 2, or (at your option) any later version.
	9
	10	proc gitdir {} {
	11	global env
	12	if {[info exists env(GIT_DIR)]} {
	13	return $env(GIT_DIR)
	14	} else {
	15	return ".git"
	16	}
	17	}
	18
	19	proc getcommits {rargs} {
	20	global commits commfd phase canv mainfont env
	21	global startmsecs nextupdate
	22	global ctext maincursor textcursor leftover
	23
	24	# check that we can find a .git directory somewhere...
	25	set gitdir [gitdir]
	26	if {![file isdirectory $gitdir]} {
	27	error_popup "Cannot find the git directory \"$gitdir\"."
	28	exit 1
	29	}
	30	set commits {}
	31	set phase getcommits
	32	set startmsecs [clock clicks -milliseconds]
	33	set nextupdate [expr $startmsecs + 100]
	34	if [catch {
	35	set parse_args [concat --default HEAD $rargs]
	36	set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
	37	}] {
	38	# if git-rev-parse failed for some reason...
	39	if {$rargs == {}} {
	40	set rargs HEAD
	41	}
	42	set parsed_args $rargs
	43	}
	44	if [catch {
	45	set commfd [open "\|git-rev-list --header --topo-order $parsed_args" r]
	46	} err] {
	47	puts stderr "Error executing git-rev-list: $err"
	48	exit 1
	49	}
	50	set leftover {}
	51	fconfigure $commfd -blocking 0 -translation binary
	52	fileevent $commfd readable "getcommitlines $commfd"
	53	$canv delete all
	54	$canv create text 3 3 -anchor nw -text "Reading commits..." \
	55	-font $mainfont -tags textitems
	56	. config -cursor watch
	57	$ctext config -cursor watch
	58	}
	59
	60	proc getcommitlines {commfd} {
	61	global commits parents cdate children nchildren
	62	global commitlisted phase commitinfo nextupdate
	63	global stopped redisplaying leftover
	64
	65	set stuff [read $commfd]
	66	if {$stuff == {}} {
	67	if {![eof $commfd]} return
	68	# set it blocking so we wait for the process to terminate
	69	fconfigure $commfd -blocking 1
	70	if {![catch {close $commfd} err]} {
	71	after idle finishcommits
	72	return
	73	}
	74	if {[string range $err 0 4] == "usage"} {
	75	set err \
	76	{Gitk: error reading commits: bad arguments to git-rev-list.
	77	(Note: arguments to gitk are passed to git-rev-list
	78	to allow selection of commits to be displayed.)}
	79	} else {
	80	set err "Error reading commits: $err"
	81	}
	82	error_popup $err
	83	exit 1
	84	}
	85	set start 0
	86	while 1 {
	87	set i [string first "\0" $stuff $start]
	88	if {$i < 0} {
	89	append leftover [string range $stuff $start end]
	90	return
	91	}
	92	set cmit [string range $stuff $start [expr {$i - 1}]]
	93	if {$start == 0} {
	94	set cmit "$leftover$cmit"
	95	set leftover {}
	96	}
	97	set start [expr {$i + 1}]
	98	if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
	99	set shortcmit $cmit
	100	if {[string length $shortcmit] > 80} {
	101	set shortcmit "[string range $shortcmit 0 80]..."
	102	}
	103	error_popup "Can't parse git-rev-list output: {$shortcmit}"
	104	exit 1
	105	}
	106	set cmit [string range $cmit 41 end]
	107	lappend commits $id
	108	set commitlisted($id) 1
	109	parsecommit $id $cmit 1
	110	drawcommit $id
	111	if {[clock clicks -milliseconds] >= $nextupdate} {
	112	doupdate
	113	}
	114	while {$redisplaying} {
	115	set redisplaying 0
	116	if {$stopped == 1} {
	117	set stopped 0
	118	set phase "getcommits"
	119	foreach id $commits {
	120	drawcommit $id
	121	if {$stopped} break
	122	if {[clock clicks -milliseconds] >= $nextupdate} {
	123	doupdate
	124	}
	125	}
	126	}
	127	}
	128	}
	129	}
	130
	131	proc doupdate {} {
	132	global commfd nextupdate
	133
	134	incr nextupdate 100
	135	fileevent $commfd readable {}
	136	update
	137	fileevent $commfd readable "getcommitlines $commfd"
	138	}
	139
	140	proc readcommit {id} {
	141	if [catch {set contents [exec git-cat-file commit $id]}] return
	142	parsecommit $id $contents 0
	143	}
	144
	145	proc parsecommit {id contents listed} {
	146	global commitinfo children nchildren parents nparents cdate ncleft
	147
	148	set inhdr 1
	149	set comment {}
	150	set headline {}
	151	set auname {}
	152	set audate {}
	153	set comname {}
	154	set comdate {}
	155	if {![info exists nchildren($id)]} {
	156	set children($id) {}
	157	set nchildren($id) 0
	158	set ncleft($id) 0
	159	}
	160	set parents($id) {}
	161	set nparents($id) 0
	162	foreach line [split $contents "\n"] {
	163	if {$inhdr} {
	164	if {$line == {}} {
	165	set inhdr 0
	166	} else {
	167	set tag [lindex $line 0]
	168	if {$tag == "parent"} {
	169	set p [lindex $line 1]
	170	if {![info exists nchildren($p)]} {
	171	set children($p) {}
	172	set nchildren($p) 0
	173	set ncleft($p) 0
	174	}
	175	lappend parents($id) $p
	176	incr nparents($id)
	177	# sometimes we get a commit that lists a parent twice...
	178	if {$listed && [lsearch -exact $children($p) $id] < 0} {
	179	lappend children($p) $id
	180	incr nchildren($p)
	181	incr ncleft($p)
	182	}
	183	} elseif {$tag == "author"} {
	184	set x [expr {[llength $line] - 2}]
	185	set audate [lindex $line $x]
	186	set auname [lrange $line 1 [expr {$x - 1}]]
	187	} elseif {$tag == "committer"} {
	188	set x [expr {[llength $line] - 2}]
	189	set comdate [lindex $line $x]
	190	set comname [lrange $line 1 [expr {$x - 1}]]
	191	}
	192	}
	193	} else {
	194	if {$comment == {}} {
	195	set headline [string trim $line]
	196	} else {
	197	append comment "\n"
	198	}
	199	if {!$listed} {
	200	# git-rev-list indents the comment by 4 spaces;
	201	# if we got this via git-cat-file, add the indentation
	202	append comment " "
	203	}
	204	append comment $line
	205	}
	206	}
	207	if {$audate != {}} {
	208	set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
	209	}
	210	if {$comdate != {}} {
	211	set cdate($id) $comdate
	212	set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
	213	}
	214	set commitinfo($id) [list $headline $auname $audate \
	215	$comname $comdate $comment]
	216	}
	217
	218	proc readrefs {} {
	219	global tagids idtags headids idheads
	220	set tags [glob -nocomplain -types f [gitdir]/refs/tags/*]
	221	foreach f $tags {
	222	catch {
	223	set fd [open $f r]
	224	set line [read $fd]
	225	if {[regexp {^[0-9a-f]{40}} $line id]} {
	226	set direct [file tail $f]
	227	set tagids($direct) $id
	228	lappend idtags($id) $direct
	229	set contents [split [exec git-cat-file tag $id] "\n"]
	230	set obj {}
	231	set type {}
	232	set tag {}
	233	foreach l $contents {
	234	if {$l == {}} break
	235	switch -- [lindex $l 0] {
	236	"object" {set obj [lindex $l 1]}
	237	"type" {set type [lindex $l 1]}
	238	"tag" {set tag [string range $l 4 end]}
	239	}
	240	}
	241	if {$obj != {} && $type == "commit" && $tag != {}} {
	242	set tagids($tag) $obj
	243	lappend idtags($obj) $tag
	244	}
	245	}
	246	close $fd
	247	}
	248	}
	249	set heads [glob -nocomplain -types f [gitdir]/refs/heads/*]
	250	foreach f $heads {
	251	catch {
	252	set fd [open $f r]
	253	set line [read $fd 40]
	254	if {[regexp {^[0-9a-f]{40}} $line id]} {
	255	set head [file tail $f]
	256	set headids($head) $line
	257	lappend idheads($line) $head
	258	}
	259	close $fd
	260	}
	261	}
	262	}
	263
	264	proc error_popup msg {
	265	set w .error
	266	toplevel $w
	267	wm transient $w .
	268	message $w.m -text $msg -justify center -aspect 400
	269	pack $w.m -side top -fill x -padx 20 -pady 20
	270	button $w.ok -text OK -command "destroy $w"
	271	pack $w.ok -side bottom -fill x
	272	bind $w <Visibility> "grab $w; focus $w"
	273	tkwait window $w
	274	}
	275
	276	proc makewindow {} {
	277	global canv canv2 canv3 linespc charspc ctext cflist textfont
	278	global findtype findtypemenu findloc findstring fstring geometry
	279	global entries sha1entry sha1string sha1but
	280	global maincursor textcursor
	281	global rowctxmenu gaudydiff mergemax
	282
	283	menu .bar
	284	.bar add cascade -label "File" -menu .bar.file
	285	menu .bar.file
	286	.bar.file add command -label "Quit" -command doquit
	287	menu .bar.help
	288	.bar add cascade -label "Help" -menu .bar.help
	289	.bar.help add command -label "About gitk" -command about
	290	. configure -menu .bar
	291
	292	if {![info exists geometry(canv1)]} {
	293	set geometry(canv1) [expr 45 * $charspc]
	294	set geometry(canv2) [expr 30 * $charspc]
	295	set geometry(canv3) [expr 15 * $charspc]
	296	set geometry(canvh) [expr 25 * $linespc + 4]
	297	set geometry(ctextw) 80
	298	set geometry(ctexth) 30
	299	set geometry(cflistw) 30
	300	}
	301	panedwindow .ctop -orient vertical
	302	if {[info exists geometry(width)]} {
	303	.ctop conf -width $geometry(width) -height $geometry(height)
	304	set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
	305	set geometry(ctexth) [expr {($texth - 8) /
	306	[font metrics $textfont -linespace]}]
	307	}
	308	frame .ctop.top
	309	frame .ctop.top.bar
	310	pack .ctop.top.bar -side bottom -fill x
	311	set cscroll .ctop.top.csb
	312	scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
	313	pack $cscroll -side right -fill y
	314	panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
	315	pack .ctop.top.clist -side top -fill both -expand 1
	316	.ctop add .ctop.top
	317	set canv .ctop.top.clist.canv
	318	canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
	319	-bg white -bd 0 \
	320	-yscrollincr $linespc -yscrollcommand "$cscroll set"
	321	.ctop.top.clist add $canv
	322	set canv2 .ctop.top.clist.canv2
	323	canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
	324	-bg white -bd 0 -yscrollincr $linespc
	325	.ctop.top.clist add $canv2
	326	set canv3 .ctop.top.clist.canv3
	327	canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
	328	-bg white -bd 0 -yscrollincr $linespc
	329	.ctop.top.clist add $canv3
	330	bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
	331
	332	set sha1entry .ctop.top.bar.sha1
	333	set entries $sha1entry
	334	set sha1but .ctop.top.bar.sha1label
	335	button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
	336	-command gotocommit -width 8
	337	$sha1but conf -disabledforeground [$sha1but cget -foreground]
	338	pack .ctop.top.bar.sha1label -side left
	339	entry $sha1entry -width 40 -font $textfont -textvariable sha1string
	340	trace add variable sha1string write sha1change
	341	pack $sha1entry -side left -pady 2
	342	button .ctop.top.bar.findbut -text "Find" -command dofind
	343	pack .ctop.top.bar.findbut -side left
	344	set findstring {}
	345	set fstring .ctop.top.bar.findstring
	346	lappend entries $fstring
	347	entry $fstring -width 30 -font $textfont -textvariable findstring
	348	pack $fstring -side left -expand 1 -fill x
	349	set findtype Exact
	350	set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
	351	findtype Exact IgnCase Regexp]
	352	set findloc "All fields"
	353	tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
	354	Comments Author Committer Files Pickaxe
	355	pack .ctop.top.bar.findloc -side right
	356	pack .ctop.top.bar.findtype -side right
	357	# for making sure type==Exact whenever loc==Pickaxe
	358	trace add variable findloc write findlocchange
	359
	360	panedwindow .ctop.cdet -orient horizontal
	361	.ctop add .ctop.cdet
	362	frame .ctop.cdet.left
	363	set ctext .ctop.cdet.left.ctext
	364	text $ctext -bg white -state disabled -font $textfont \
	365	-width $geometry(ctextw) -height $geometry(ctexth) \
	366	-yscrollcommand ".ctop.cdet.left.sb set"
	367	scrollbar .ctop.cdet.left.sb -command "$ctext yview"
	368	pack .ctop.cdet.left.sb -side right -fill y
	369	pack $ctext -side left -fill both -expand 1
	370	.ctop.cdet add .ctop.cdet.left
	371
	372	$ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
	373	if {$gaudydiff} {
	374	$ctext tag conf hunksep -back blue -fore white
	375	$ctext tag conf d0 -back "#ff8080"
	376	$ctext tag conf d1 -back green
	377	} else {
	378	$ctext tag conf hunksep -fore blue
	379	$ctext tag conf d0 -fore red
	380	$ctext tag conf d1 -fore "#00a000"
	381	$ctext tag conf m0 -fore red
	382	$ctext tag conf m1 -fore blue
	383	$ctext tag conf m2 -fore green
	384	$ctext tag conf m3 -fore purple
	385	$ctext tag conf m4 -fore brown
	386	$ctext tag conf mmax -fore darkgrey
	387	set mergemax 5
	388	$ctext tag conf mresult -font [concat $textfont bold]
	389	$ctext tag conf msep -font [concat $textfont bold]
	390	$ctext tag conf found -back yellow
	391	}
	392
	393	frame .ctop.cdet.right
	394	set cflist .ctop.cdet.right.cfiles
	395	listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
	396	-yscrollcommand ".ctop.cdet.right.sb set"
	397	scrollbar .ctop.cdet.right.sb -command "$cflist yview"
	398	pack .ctop.cdet.right.sb -side right -fill y
	399	pack $cflist -side left -fill both -expand 1
	400	.ctop.cdet add .ctop.cdet.right
	401	bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
	402
	403	pack .ctop -side top -fill both -expand 1
	404
	405	bindall <1> {selcanvline %W %x %y}
	406	#bindall <B1-Motion> {selcanvline %W %x %y}
	407	bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
	408	bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
	409	bindall <2> "allcanvs scan mark 0 %y"
	410	bindall <B2-Motion> "allcanvs scan dragto 0 %y"
	411	bind . <Key-Up> "selnextline -1"
	412	bind . <Key-Down> "selnextline 1"
	413	bind . <Key-Prior> "allcanvs yview scroll -1 pages"
	414	bind . <Key-Next> "allcanvs yview scroll 1 pages"
	415	bindkey <Key-Delete> "$ctext yview scroll -1 pages"
	416	bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
	417	bindkey <Key-space> "$ctext yview scroll 1 pages"
	418	bindkey p "selnextline -1"
	419	bindkey n "selnextline 1"
	420	bindkey b "$ctext yview scroll -1 pages"
	421	bindkey d "$ctext yview scroll 18 units"
	422	bindkey u "$ctext yview scroll -18 units"
	423	bindkey / {findnext 1}
	424	bindkey <Key-Return> {findnext 0}
	425	bindkey ? findprev
	426	bindkey f nextfile
	427	bind . <Control-q> doquit
	428	bind . <Control-f> dofind
	429	bind . <Control-g> {findnext 0}
	430	bind . <Control-r> findprev
	431	bind . <Control-equal> {incrfont 1}
	432	bind . <Control-KP_Add> {incrfont 1}
	433	bind . <Control-minus> {incrfont -1}
	434	bind . <Control-KP_Subtract> {incrfont -1}
	435	bind $cflist <<ListboxSelect>> listboxsel
	436	bind . <Destroy> {savestuff %W}
	437	bind . <Button-1> "click %W"
	438	bind $fstring <Key-Return> dofind
	439	bind $sha1entry <Key-Return> gotocommit
	440	bind $sha1entry <<PasteSelection>> clearsha1
	441
	442	set maincursor [. cget -cursor]
	443	set textcursor [$ctext cget -cursor]
	444
	445	set rowctxmenu .rowctxmenu
	446	menu $rowctxmenu -tearoff 0
	447	$rowctxmenu add command -label "Diff this -> selected" \
	448	-command {diffvssel 0}
	449	$rowctxmenu add command -label "Diff selected -> this" \
	450	-command {diffvssel 1}
	451	$rowctxmenu add command -label "Make patch" -command mkpatch
	452	$rowctxmenu add command -label "Create tag" -command mktag
	453	$rowctxmenu add command -label "Write commit to file" -command writecommit
	454	}
	455
	456	# when we make a key binding for the toplevel, make sure
	457	# it doesn't get triggered when that key is pressed in the
	458	# find string entry widget.
	459	proc bindkey {ev script} {
	460	global entries
	461	bind . $ev $script
	462	set escript [bind Entry $ev]
	463	if {$escript == {}} {
	464	set escript [bind Entry <Key>]
	465	}
	466	foreach e $entries {
	467	bind $e $ev "$escript; break"
	468	}
	469	}
	470
	471	# set the focus back to the toplevel for any click outside
	472	# the entry widgets
	473	proc click {w} {
	474	global entries
	475	foreach e $entries {
	476	if {$w == $e} return
	477	}
	478	focus .
	479	}
	480
	481	proc savestuff {w} {
	482	global canv canv2 canv3 ctext cflist mainfont textfont
	483	global stuffsaved findmergefiles gaudydiff
	484
	485	if {$stuffsaved} return
	486	if {![winfo viewable .]} return
	487	catch {
	488	set f [open "~/.gitk-new" w]
	489	puts $f [list set mainfont $mainfont]
	490	puts $f [list set textfont $textfont]
	491	puts $f [list set findmergefiles $findmergefiles]
	492	puts $f [list set gaudydiff $gaudydiff]
	493	puts $f "set geometry(width) [winfo width .ctop]"
	494	puts $f "set geometry(height) [winfo height .ctop]"
	495	puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
	496	puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
	497	puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
	498	puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
	499	set wid [expr {([winfo width $ctext] - 8) \
	500	/ [font measure $textfont "0"]}]
	501	puts $f "set geometry(ctextw) $wid"
	502	set wid [expr {([winfo width $cflist] - 11) \
	503	/ [font measure [$cflist cget -font] "0"]}]
	504	puts $f "set geometry(cflistw) $wid"
	505	close $f
	506	file rename -force "~/.gitk-new" "~/.gitk"
	507	}
	508	set stuffsaved 1
	509	}
	510
	511	proc resizeclistpanes {win w} {
	512	global oldwidth
	513	if [info exists oldwidth($win)] {
	514	set s0 [$win sash coord 0]
	515	set s1 [$win sash coord 1]
	516	if {$w < 60} {
	517	set sash0 [expr {int($w/2 - 2)}]
	518	set sash1 [expr {int($w*5/6 - 2)}]
	519	} else {
	520	set factor [expr {1.0 * $w / $oldwidth($win)}]
	521	set sash0 [expr {int($factor * [lindex $s0 0])}]
	522	set sash1 [expr {int($factor * [lindex $s1 0])}]
	523	if {$sash0 < 30} {
	524	set sash0 30
	525	}
	526	if {$sash1 < $sash0 + 20} {
	527	set sash1 [expr $sash0 + 20]
	528	}
	529	if {$sash1 > $w - 10} {
	530	set sash1 [expr $w - 10]
	531	if {$sash0 > $sash1 - 20} {
	532	set sash0 [expr $sash1 - 20]
	533	}
	534	}
	535	}
	536	$win sash place 0 $sash0 [lindex $s0 1]
	537	$win sash place 1 $sash1 [lindex $s1 1]
	538	}
	539	set oldwidth($win) $w
	540	}
	541
	542	proc resizecdetpanes {win w} {
	543	global oldwidth
	544	if [info exists oldwidth($win)] {
	545	set s0 [$win sash coord 0]
	546	if {$w < 60} {
	547	set sash0 [expr {int($w*3/4 - 2)}]
	548	} else {
	549	set factor [expr {1.0 * $w / $oldwidth($win)}]
	550	set sash0 [expr {int($factor * [lindex $s0 0])}]
	551	if {$sash0 < 45} {
	552	set sash0 45
	553	}
	554	if {$sash0 > $w - 15} {
	555	set sash0 [expr $w - 15]
	556	}
	557	}
	558	$win sash place 0 $sash0 [lindex $s0 1]
	559	}
	560	set oldwidth($win) $w
	561	}
	562
	563	proc allcanvs args {
	564	global canv canv2 canv3
	565	eval $canv $args
	566	eval $canv2 $args
	567	eval $canv3 $args
	568	}
	569
	570	proc bindall {event action} {
	571	global canv canv2 canv3
	572	bind $canv $event $action
	573	bind $canv2 $event $action
	574	bind $canv3 $event $action
	575	}
	576
	577	proc about {} {
	578	set w .about
	579	if {[winfo exists $w]} {
	580	raise $w
	581	return
	582	}
	583	toplevel $w
	584	wm title $w "About gitk"
	585	message $w.m -text {
	586	Gitk version 1.2
	587
	588