git/gitk
Paul Mackerras 9a40c50c1e Make behaviour when git-rev-tree fails nicer
Fix crash benh saw with currentid undefined
Add menu with file/quit and help/about items
Add ^Q for quit
2005-05-12 23:46:16 +00:00

755 lines
20 KiB
Tcl
Executable file
Raw Blame History

#!/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.
# CVS $Revision: 1.7 $
set datemode 0
set boldnames 0
set revtreeargs {}
set diffopts "-U 5 -p"
set mainfont {Helvetica 9}
set namefont $mainfont
set textfont {Courier 9}
if {$boldnames} {
lappend namefont bold
}
set colors {green red blue magenta darkgrey brown orange}
set colorbycommitter false
catch {source ~/.gitk}
foreach arg $argv {
switch -regexp -- $arg {
"^$" { }
"^-b" { set boldnames 1 }
"^-c" { set colorbycommitter 1 }
"^-d" { set datemode 1 }
"^-.*" {
puts stderr "unrecognized option $arg"
exit 1
}
default {
lappend revtreeargs $arg
}
}
}
proc getcommits {rargs} {
global commits parents cdate nparents children nchildren
if {$rargs == {}} {
set rargs HEAD
}
set commits {}
if [catch {set clist [eval exec git-rev-tree $rargs]} err] {
if {[string range $err 0 4] == "usage"} {
puts stderr "Error reading commits: bad arguments to git-rev-tree"
puts stderr "Note: arguments to gitk are passed to git-rev-tree"
puts stderr " to allow selection of commits to be displayed"
} else {
puts stderr "Error reading commits: $err"
}
return 0
}
foreach c [split $clist "\n"] {
set i 0
set cid {}
foreach f $c {
if {$i == 0} {
set d $f
} else {
set id [lindex [split $f :] 0]
if {![info exists nchildren($id)]} {
set children($id) {}
set nchildren($id) 0
}
if {$i == 1} {
set cid $id
lappend commits $id
set parents($id) {}
set cdate($id) $d
set nparents($id) 0
} else {
lappend parents($cid) $id
incr nparents($cid)
incr nchildren($id)
lappend children($id) $cid
}
}
incr i
}
}
return 1
}
proc readcommit {id} {
global commitinfo
set inhdr 1
set comment {}
set headline {}
set auname {}
set audate {}
set comname {}
set comdate {}
foreach line [split [exec git-cat-file commit $id] "\n"] {
if {$inhdr} {
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 [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 $line
} else {
append comment "\n"
}
append comment $line
}
}
if {$audate != {}} {
set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
}
if {$comdate != {}} {
set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
}
set commitinfo($id) [list $headline $auname $audate \
$comname $comdate $comment]
}
proc makewindow {} {
global canv canv2 canv3 linespc charspc ctext cflist textfont
menu .bar
.bar add cascade -label "File" -menu .bar.file
menu .bar.file
.bar.file add command -label "Quit" -command "set stopped 1; destroy ."
menu .bar.help
.bar add cascade -label "Help" -menu .bar.help
.bar.help add command -label "About gitk" -command about
. configure -menu .bar
panedwindow .ctop -orient vertical
panedwindow .ctop.clist -orient horizontal -sashpad 0 -handlesize 4
.ctop add .ctop.clist
set canv .ctop.clist.canv
set cscroll .ctop.clist.dates.csb
set height [expr 25 * $linespc + 4]
canvas $canv -height $height -width [expr 45 * $charspc] \
-bg white -bd 0 \
-yscrollincr $linespc -yscrollcommand "$cscroll set"
.ctop.clist add $canv
set canv2 .ctop.clist.canv2
canvas $canv2 -height $height -width [expr 30 * $charspc] \
-bg white -bd 0 -yscrollincr $linespc
.ctop.clist add $canv2
frame .ctop.clist.dates
.ctop.clist add .ctop.clist.dates
set canv3 .ctop.clist.dates.canv3
canvas $canv3 -height $height -width [expr 15 * $charspc] \
-bg white -bd 0 -yscrollincr $linespc
scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
pack .ctop.clist.dates.csb -side right -fill y
pack $canv3 -side left -fill both -expand 1
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 -height 32 \
-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
frame .ctop.cdet.right
set cflist .ctop.cdet.right.cfiles
listbox $cflist -width 30 -bg white -selectmode extended \
-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
pack .ctop -side top -fill both -expand 1
bindall <1> {selcanvline %x %y}
bindall <B1-Motion> {selcanvline %x %y}
bindall <ButtonRelease-4> "allcanvs yview scroll -5 u"
bindall <ButtonRelease-5> "allcanvs yview scroll 5 u"
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 . p "selnextline -1"
bind . n "selnextline 1"
bind . <Key-Prior> "allcanvs yview scroll -1 p"
bind . <Key-Next> "allcanvs yview scroll 1 p"
bind . <Key-Delete> "$ctext yview scroll -1 p"
bind . <Key-BackSpace> "$ctext yview scroll -1 p"
bind . <Key-space> "$ctext yview scroll 1 p"
bind . b "$ctext yview scroll -1 p"
bind . d "$ctext yview scroll 18 u"
bind . u "$ctext yview scroll -18 u"
bind . Q "set stopped 1; destroy ."
bind . <Control-q> "set stopped 1; destroy ."
bind $cflist <<ListboxSelect>> listboxsel
}
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 0.9
Copyright <EFBFBD> 2005 Paul Mackerras
Use and redistribute under the terms of the GNU General Public License
(CVS $Revision: 1.7 $)} \
-justify center -aspect 400
pack $w.m -side top -fill x -padx 20 -pady 20
button $w.ok -text Close -command "destroy $w"
pack $w.ok -side bottom
}
proc truncatetofit {str width font} {
if {[font measure $font $str] <= $width} {
return $str
}
set best 0
set bad [string length $str]
set tmp $str
while {$best < $bad - 1} {
set try [expr {int(($best + $bad) / 2)}]
set tmp "[string range $str 0 [expr $try-1]]..."
if {[font measure $font $tmp] <= $width} {
set best $try
} else {
set bad $try
}
}
return $tmp
}
proc assigncolor {id} {
global commitinfo colormap commcolors colors nextcolor
global colorbycommitter
global parents nparents children nchildren
if [info exists colormap($id)] return
set ncolors [llength $colors]
if {$colorbycommitter} {
if {![info exists commitinfo($id)]} {
readcommit $id
}
set comm [lindex $commitinfo($id) 3]
if {![info exists commcolors($comm)]} {
set commcolors($comm) [lindex $colors $nextcolor]
if {[incr nextcolor] >= $ncolors} {
set nextcolor 0
}
}
set colormap($id) $commcolors($comm)
} else {
if {$nparents($id) == 1 && $nchildren($id) == 1} {
set child [lindex $children($id) 0]
if {[info exists colormap($child)]
&& $nparents($child) == 1} {
set colormap($id) $colormap($child)
return
}
}
set badcolors {}
foreach child $children($id) {
if {[info exists colormap($child)]
&& [lsearch -exact $badcolors $colormap($child)] < 0} {
lappend badcolors $colormap($child)
}
if {[info exists parents($child)]} {
foreach p $parents($child) {
if {[info exists colormap($p)]
&& [lsearch -exact $badcolors $colormap($p)] < 0} {
lappend badcolors $colormap($p)
}
}
}
}
if {[llength $badcolors] >= $ncolors} {
set badcolors {}
}
for {set i 0} {$i <= $ncolors} {incr i} {
set c [lindex $colors $nextcolor]
if {[incr nextcolor] >= $ncolors} {
set nextcolor 0
}
if {[lsearch -exact $badcolors $c]} break
}
set colormap($id) $c
}
}
proc drawgraph {start} {
global parents children nparents nchildren commits
global canv canv2 canv3 mainfont namefont canvx0 canvy0 canvy linespc
global datemode cdate
global lineid linehtag linentag linedtag commitinfo
global nextcolor colormap
global stopped
set nextcolor 0
assigncolor $start
foreach id $commits {
set ncleft($id) $nchildren($id)
}
set todo [list $start]
set level 0
set y2 $canvy0
set linestarty(0) $canvy0
set nullentry -1
set lineno -1
while 1 {
set canvy $y2
allcanvs conf -scrollregion [list 0 0 0 $canvy]
update
if {$stopped} return
incr lineno
set nlines [llength $todo]
set id [lindex $todo $level]
set lineid($lineno) $id
set actualparents {}
foreach p $parents($id) {
if {[info exists ncleft($p)]} {
incr ncleft($p) -1
lappend actualparents $p
}
}
if {![info exists commitinfo($id)]} {
readcommit $id
}
set x [expr $canvx0 + $level * $linespc]
set y2 [expr $canvy + $linespc]
if {$linestarty($level) < $canvy} {
set t [$canv create line $x $linestarty($level) $x $canvy \
-width 2 -fill $colormap($id)]
$canv lower $t
set linestarty($level) $canvy
}
set t [$canv create oval [expr $x - 4] [expr $canvy - 4] \
[expr $x + 3] [expr $canvy + 3] \
-fill blue -outline black -width 1]
$canv raise $t
set xt [expr $canvx0 + $nlines * $linespc]
set headline [lindex $commitinfo($id) 0]
set name [lindex $commitinfo($id) 1]
set date [lindex $commitinfo($id) 2]
set linehtag($lineno) [$canv create text $xt $canvy -anchor w \
-text $headline -font $mainfont ]
set linentag($lineno) [$canv2 create text 3 $canvy -anchor w \
-text $name -font $namefont]
set linedtag($lineno) [$canv3 create text 3 $canvy -anchor w \
-text $date -font $mainfont]
if {!$datemode && [llength $actualparents] == 1} {
set p [lindex $actualparents 0]
if {$ncleft($p) == 0 && [lsearch -exact $todo $p] < 0} {
assigncolor $p
set todo [lreplace $todo $level $level $p]
continue
}
}
set oldtodo $todo
set oldlevel $level
set lines {}
for {set i 0} {$i < $nlines} {incr i} {
if {[lindex $todo $i] == {}} continue
set oldstarty($i) $linestarty($i)
if {$i != $level} {
lappend lines [list $i [lindex $todo $i]]
}
}
unset linestarty
if {$nullentry >= 0} {
set todo [lreplace $todo $nullentry $nullentry]
if {$nullentry < $level} {
incr level -1
}
}
set todo [lreplace $todo $level $level]
if {$nullentry > $level} {
incr nullentry -1
}
set i $level
foreach p $actualparents {
set k [lsearch -exact $todo $p]
if {$k < 0} {
assigncolor $p
set todo [linsert $todo $i $p]
if {$nullentry >= $i} {
incr nullentry
}
}
lappend lines [list $oldlevel $p]
}
# choose which one to do next time around
set todol [llength $todo]
set level -1
set latest {}
for {set k $todol} {[incr k -1] >= 0} {} {
set p [lindex $todo $k]
if {$p == {}} continue
if {$ncleft($p) == 0} {
if {$datemode} {
if {$latest == {} || $cdate($p) > $latest} {
set level $k
set latest $cdate($p)
}
} else {
set level $k
break
}
}
}
if {$level < 0} {
if {$todo != {}} {
puts "ERROR: none of the pending commits can be done yet:"
foreach p $todo {
puts " $p"
}
}
break
}
# If we are reducing, put in a null entry
if {$todol < $nlines} {
if {$nullentry >= 0} {
set i $nullentry
while {$i < $todol
&& [lindex $oldtodo $i] == [lindex $todo $i]} {
incr i
}
} else {
set i $oldlevel
if {$level >= $i} {
incr i
}
}
if {$i >= $todol} {
set nullentry -1
} else {
set nullentry $i
set todo [linsert $todo $nullentry {}]
if {$level >= $i} {
incr level
}
}
} else {
set nullentry -1
}
foreach l $lines {
set i [lindex $l 0]
set dst [lindex $l 1]
set j [lsearch -exact $todo $dst]
if {$i == $j} {
set linestarty($i) $oldstarty($i)
continue
}
set xi [expr {$canvx0 + $i * $linespc}]
set xj [expr {$canvx0 + $j * $linespc}]
set coords {}
if {$oldstarty($i) < $canvy} {
lappend coords $xi $oldstarty($i)
}
lappend coords $xi $canvy
if {$j < $i - 1} {
lappend coords [expr $xj + $linespc] $canvy
} elseif {$j > $i + 1} {
lappend coords [expr $xj - $linespc] $canvy
}
lappend coords $xj $y2
set t [$canv create line $coords -width 2 -fill $colormap($dst)]
$canv lower $t
if {![info exists linestarty($j)]} {
set linestarty($j) $y2
}
}
}
}
proc selcanvline {x y} {
global canv canvy0 ctext linespc selectedline
global lineid linehtag linentag linedtag
set ymax [lindex [$canv cget -scrollregion] 3]
set yfrac [lindex [$canv yview] 0]
set y [expr {$y + $yfrac * $ymax}]
set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
if {$l < 0} {
set l 0
}
if {[info exists selectedline] && $selectedline == $l} return
selectline $l
}
proc selectline {l} {
global canv canv2 canv3 ctext commitinfo selectedline
global lineid linehtag linentag linedtag
global canvy canvy0 linespc nparents treepending
global cflist treediffs currentid
if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
$canv delete secsel
set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
-tags secsel -fill [$canv cget -selectbackground]]
$canv lower $t
$canv2 delete secsel
set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
-tags secsel -fill [$canv2 cget -selectbackground]]
$canv2 lower $t
$canv3 delete secsel
set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
-tags secsel -fill [$canv3 cget -selectbackground]]
$canv3 lower $t
set y [expr {$canvy0 + $l * $linespc}]
set ytop [expr {($y - $linespc / 2.0) / $canvy}]
set ybot [expr {($y + $linespc / 2.0) / $canvy}]
set wnow [$canv yview]
if {$ytop < [lindex $wnow 0]} {
allcanvs yview moveto $ytop
} elseif {$ybot > [lindex $wnow 1]} {
set wh [expr {[lindex $wnow 1] - [lindex $wnow 0]}]
allcanvs yview moveto [expr {$ybot - $wh}]
}
set selectedline $l
set id $lineid($l)
$ctext conf -state normal
$ctext delete 0.0 end
set info $commitinfo($id)
$ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
$ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
$ctext insert end "\n"
$ctext insert end [lindex $info 5]
$ctext insert end "\n"
$ctext tag delete Comments
$ctext conf -state disabled
$cflist delete 0 end
set currentid $id
if {$nparents($id) == 1} {
if {![info exists treediffs($id)]} {
if {![info exists treepending]} {
gettreediffs $id
}
} else {
addtocflist $id
}
}
}
proc selnextline {dir} {
global selectedline
if {![info exists selectedline]} return
set l [expr $selectedline + $dir]
selectline $l
}
proc addtocflist {id} {
global currentid treediffs cflist treepending
if {$id != $currentid} {
gettreediffs $currentid
return
}
$cflist insert end "All files"
foreach f $treediffs($currentid) {
$cflist insert end $f
}
getblobdiffs $id
}
proc gettreediffs {id} {
global treediffs parents treepending
set treepending $id
set treediffs($id) {}
set p [lindex $parents($id) 0]
if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
fconfigure $gdtf -blocking 0
fileevent $gdtf readable "gettreediffline $gdtf $id"
}
proc gettreediffline {gdtf id} {
global treediffs treepending
set n [gets $gdtf line]
if {$n < 0} {
if {![eof $gdtf]} return
close $gdtf
unset treepending
addtocflist $id
return
}
set type [lindex $line 1]
set file [lindex $line 3]
if {$type == "blob"} {
lappend treediffs($id) $file
}
}
proc getblobdiffs {id} {
global parents diffopts blobdifffd env curdifftag curtagstart
set p [lindex $parents($id) 0]
set env(GIT_DIFF_OPTS) $diffopts
if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
puts "error getting diffs: $err"
return
}
fconfigure $bdf -blocking 0
set blobdifffd($id) $bdf
set curdifftag Comments
set curtagstart 0.0
fileevent $bdf readable "getblobdiffline $bdf $id"
}
proc getblobdiffline {bdf id} {
global currentid blobdifffd ctext curdifftag curtagstart
set n [gets $bdf line]
if {$n < 0} {
if {[eof $bdf]} {
close $bdf
if {$id == $currentid && $bdf == $blobdifffd($id)} {
$ctext tag add $curdifftag $curtagstart end
}
}
return
}
if {$id != $currentid || $bdf != $blobdifffd($id)} {
return
}
$ctext conf -state normal
if {[regexp {^---[ \t]+([^/])+/(.*)} $line match s1 fname]} {
# start of a new file
$ctext insert end "\n"
$ctext tag add $curdifftag $curtagstart end
set curtagstart [$ctext index "end - 1c"]
set curdifftag "f:$fname"
$ctext tag delete $curdifftag
set l [expr {(78 - [string length $fname]) / 2}]
set pad [string range "----------------------------------------" 1 $l]
$ctext insert end "$pad $fname $pad\n" filesep
} elseif {[string range $line 0 2] == "+++"} {
# no need to do anything with this
} elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
$line match f1l f1c f2l f2c rest]} {
$ctext insert end "\t" hunksep
$ctext insert end " $f1l " d0 " $f2l " d1
$ctext insert end " $rest \n" hunksep
} else {
set x [string range $line 0 0]
if {$x == "-" || $x == "+"} {
set tag [expr {$x == "+"}]
set line [string range $line 1 end]
$ctext insert end "$line\n" d$tag
} elseif {$x == " "} {
set line [string range $line 1 end]
$ctext insert end "$line\n"
} else {
# Something else we don't recognize
if {$curdifftag != "Comments"} {
$ctext insert end "\n"
$ctext tag add $curdifftag $curtagstart end
set curtagstart [$ctext index "end - 1c"]
set curdifftag Comments
}
$ctext insert end "$line\n" filesep
}
}
$ctext conf -state disabled
}
proc listboxsel {} {
global ctext cflist currentid treediffs
if {![info exists currentid]} return
set sel [$cflist curselection]
if {$sel == {} || [lsearch -exact $sel 0] >= 0} {
# show everything
$ctext tag conf Comments -elide 0
foreach f $treediffs($currentid) {
$ctext tag conf "f:$f" -elide 0
}
} else {
# just show selected files
$ctext tag conf Comments -elide 1
set i 1
foreach f $treediffs($currentid) {
set elide [expr {[lsearch -exact $sel $i] < 0}]
$ctext tag conf "f:$f" -elide $elide
incr i
}
}
}
if {![getcommits $revtreeargs]} {
exit 1
}
set linespc [font metrics $mainfont -linespace]
set charspc [font measure $mainfont "m"]
set canvy0 [expr 3 + 0.5 * $linespc]
set canvx0 [expr 3 + 0.5 * $linespc]
set namex [expr 45 * $charspc]
set datex [expr 75 * $charspc]
set stopped 0
makewindow
set start {}
foreach id $commits {
if {$nchildren($id) == 0} {
set start $id
break
}
}
if {$start != {}} {
drawgraph $start
}