Merge master.kernel.org:/pub/scm/linux/kernel/git/chrisw/git

[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 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...
    if {[info exists env(GIT_DIR)]} {
	set gitdir $env(GIT_DIR)
    } else {
	set gitdir ".git"
    }
    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
	# this works around what is apparently a bug in Tcl...
	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 .git/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 .git/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 findloc findstring fstring geometry
    global entries sha1entry sha1string sha1but
    global maincursor textcursor
    global rowctxmenu

    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
    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
    pack .ctop.top.bar.findloc -side right
    pack .ctop.top.bar.findtype -side right

    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]
    $ctext tag conf hunksep -back blue -fore white
    $ctext tag conf d0 -back "#ff8080"
    $ctext tag conf d1 -back green
    $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
    bindkey ? findprev
    bindkey f nextfile
    bind . <Control-q> doquit
    bind . <Control-f> dofind
    bind . <Control-g> findnext
    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
    if {$stuffsaved} return
    if {![winfo viewable .]} return
    catch {
	set f [open "~/.gitk-new" w]
	puts $f "set mainfont {$mainfont}"
	puts $f "set textfont {$textfont}"
	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