gitk

   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 getcommits {rargs} {
  11     global commits commfd phase canv mainfont
  12     global startmsecs nextupdate
  13     global ctext maincursor textcursor leftover
  14
  15     set commits {}
  16     set phase getcommits
  17     set startmsecs [clock clicks -milliseconds]
  18     set nextupdate [expr $startmsecs + 100]
  19     if [catch {
  20         set parse_args [concat --default HEAD $rargs]
  21         set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
  22     }] {
  23         # if git-rev-parse failed for some reason...
  24         if {$rargs == {}} {
  25             set rargs HEAD
  26         }
  27         set parsed_args $rargs
  28     }
  29     if [catch {
  30         set commfd [open "|git-rev-list --header --merge-order $parsed_args" r]
  31     } err] {
  32         puts stderr "Error executing git-rev-list: $err"
  33         exit 1
  34     }
  35     set leftover {}
  36     fconfigure $commfd -blocking 0 -translation binary
  37     fileevent $commfd readable "getcommitlines $commfd"
  38     $canv delete all
  39     $canv create text 3 3 -anchor nw -text "Reading commits..." \
  40         -font $mainfont -tags textitems
  41     . config -cursor watch
  42     $ctext config -cursor watch
  43 }
  44
  45 proc getcommitlines {commfd}  {
  46     global commits parents cdate children nchildren
  47     global commitlisted phase commitinfo nextupdate
  48     global stopped redisplaying leftover
  49
  50     set stuff [read $commfd]
  51     if {$stuff == {}} {
  52         if {![eof $commfd]} return
  53         # this works around what is apparently a bug in Tcl...
  54         fconfigure $commfd -blocking 1
  55         if {![catch {close $commfd} err]} {
  56             after idle finishcommits
  57             return
  58         }
  59         if {[string range $err 0 4] == "usage"} {
  60             set err \
  61 {Gitk: error reading commits: bad arguments to git-rev-list.
  62 (Note: arguments to gitk are passed to git-rev-list
  63 to allow selection of commits to be displayed.)}
  64         } else {
  65             set err "Error reading commits: $err"
  66         }
  67         error_popup $err
  68         exit 1
  69     }
  70     set start 0
  71     while 1 {
  72         set i [string first "\0" $stuff $start]
  73         if {$i < 0} {
  74             set leftover [string range $stuff $start end]
  75             return
  76         }
  77         set cmit [string range $stuff $start [expr {$i - 1}]]
  78         if {$start == 0} {
  79             set cmit "$leftover$cmit"
  80         }
  81         set start [expr {$i + 1}]
  82         if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
  83             error_popup "Can't parse git-rev-list output: {$cmit}"
  84             exit 1
  85         }
  86         set cmit [string range $cmit 41 end]
  87         lappend commits $id
  88         set commitlisted($id) 1
  89         parsecommit $id $cmit 1
  90         drawcommit $id
  91         if {[clock clicks -milliseconds] >= $nextupdate} {
  92             doupdate
  93         }
  94         while {$redisplaying} {
  95             set redisplaying 0
  96             if {$stopped == 1} {
  97                 set stopped 0
  98                 set phase "getcommits"
  99                 foreach id $commits {
 100                     drawcommit $id
 101                     if {$stopped} break
 102                     if {[clock clicks -milliseconds] >= $nextupdate} {
 103                         doupdate
 104                     }
 105                 }
 106             }
 107         }
 108     }
 109 }
 110
 111 proc doupdate {} {
 112     global commfd nextupdate
 113
 114     incr nextupdate 100
 115     fileevent $commfd readable {}
 116     update
 117     fileevent $commfd readable "getcommitlines $commfd"
 118 }
 119
 120 proc readcommit {id} {
 121     if [catch {set contents [exec git-cat-file commit $id]}] return
 122     parsecommit $id $contents 0
 123 }
 124
 125 proc parsecommit {id contents listed} {
 126     global commitinfo children nchildren parents nparents cdate ncleft
 127
 128     set inhdr 1
 129     set comment {}
 130     set headline {}
 131     set auname {}
 132     set audate {}
 133     set comname {}
 134     set comdate {}
 135     if {![info exists nchildren($id)]} {
 136         set children($id) {}
 137         set nchildren($id) 0
 138         set ncleft($id) 0
 139     }
 140     set parents($id) {}
 141     set nparents($id) 0
 142     foreach line [split $contents "\n"] {
 143         if {$inhdr} {
 144             if {$line == {}} {
 145                 set inhdr 0
 146             } else {
 147                 set tag [lindex $line 0]
 148                 if {$tag == "parent"} {
 149                     set p [lindex $line 1]
 150                     if {![info exists nchildren($p)]} {
 151                         set children($p) {}
 152                         set nchildren($p) 0
 153                         set ncleft($p) 0
 154                     }
 155                     lappend parents($id) $p
 156                     incr nparents($id)
 157                     # sometimes we get a commit that lists a parent twice...
 158                     if {$listed && [lsearch -exact $children($p) $id] < 0} {
 159                         lappend children($p) $id
 160                         incr nchildren($p)
 161                         incr ncleft($p)
 162                     }
 163                 } elseif {$tag == "author"} {
 164                     set x [expr {[llength $line] - 2}]
 165                     set audate [lindex $line $x]
 166                     set auname [lrange $line 1 [expr {$x - 1}]]
 167                 } elseif {$tag == "committer"} {
 168                     set x [expr {[llength $line] - 2}]
 169                     set comdate [lindex $line $x]
 170                     set comname [lrange $line 1 [expr {$x - 1}]]
 171                 }
 172             }
 173         } else {
 174             if {$comment == {}} {
 175                 set headline [string trim $line]
 176             } else {
 177                 append comment "\n"
 178             }
 179             if {!$listed} {
 180                 # git-rev-list indents the comment by 4 spaces;
 181                 # if we got this via git-cat-file, add the indentation
 182                 append comment "    "
 183             }
 184             append comment $line
 185         }
 186     }
 187     if {$audate != {}} {
 188         set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
 189     }
 190     if {$comdate != {}} {
 191         set cdate($id) $comdate
 192         set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
 193     }
 194     set commitinfo($id) [list $headline $auname $audate \
 195                              $comname $comdate $comment]
 196 }
 197
 198 proc readrefs {} {
 199     global tagids idtags headids idheads
 200     set tags [glob -nocomplain -types f .git/refs/tags/*]
 201     foreach f $tags {
 202         catch {
 203             set fd [open $f r]
 204             set line [read $fd]
 205             if {[regexp {^[0-9a-f]{40}} $line id]} {
 206                 set direct [file tail $f]
 207                 set tagids($direct) $id
 208                 lappend idtags($id) $direct
 209                 set contents [split [exec git-cat-file tag $id] "\n"]
 210                 set obj {}
 211                 set type {}
 212                 set tag {}
 213                 foreach l $contents {
 214                     if {$l == {}} break
 215                     switch -- [lindex $l 0] {
 216                         "object" {set obj [lindex $l 1]}
 217                         "type" {set type [lindex $l 1]}
 218                         "tag" {set tag [string range $l 4 end]}
 219                     }
 220                 }
 221                 if {$obj != {} && $type == "commit" && $tag != {}} {
 222                     set tagids($tag) $obj
 223                     lappend idtags($obj) $tag
 224                 }
 225             }
 226             close $fd
 227         }
 228     }
 229     set heads [glob -nocomplain -types f .git/refs/heads/*]
 230     foreach f $heads {
 231         catch {
 232             set fd [open $f r]
 233             set line [read $fd 40]
 234             if {[regexp {^[0-9a-f]{40}} $line id]} {
 235                 set head [file tail $f]
 236                 set headids($head) $line
 237                 lappend idheads($line) $head
 238             }
 239             close $fd
 240         }
 241     }
 242 }
 243
 244 proc error_popup msg {
 245     set w .error
 246     toplevel $w
 247     wm transient $w .
 248     message $w.m -text $msg -justify center -aspect 400
 249     pack $w.m -side top -fill x -padx 20 -pady 20
 250     button $w.ok -text OK -command "destroy $w"
 251     pack $w.ok -side bottom -fill x
 252     bind $w <Visibility> "grab $w; focus $w"
 253     tkwait window $w
 254 }
 255
 256 proc makewindow {} {
 257     global canv canv2 canv3 linespc charspc ctext cflist textfont
 258     global findtype findloc findstring fstring geometry
 259     global entries sha1entry sha1string sha1but
 260     global maincursor textcursor
 261     global rowctxmenu
 262
 263     menu .bar
 264     .bar add cascade -label "File" -menu .bar.file
 265     menu .bar.file
 266     .bar.file add command -label "Quit" -command doquit
 267     menu .bar.help
 268     .bar add cascade -label "Help" -menu .bar.help
 269     .bar.help add command -label "About gitk" -command about
 270     . configure -menu .bar
 271
 272     if {![info exists geometry(canv1)]} {
 273         set geometry(canv1) [expr 45 * $charspc]
 274         set geometry(canv2) [expr 30 * $charspc]
 275         set geometry(canv3) [expr 15 * $charspc]
 276         set geometry(canvh) [expr 25 * $linespc + 4]
 277         set geometry(ctextw) 80
 278         set geometry(ctexth) 30
 279         set geometry(cflistw) 30
 280     }
 281     panedwindow .ctop -orient vertical
 282     if {[info exists geometry(width)]} {
 283         .ctop conf -width $geometry(width) -height $geometry(height)
 284         set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
 285         set geometry(ctexth) [expr {($texth - 8) /
 286                                     [font metrics $textfont -linespace]}]
 287     }
 288     frame .ctop.top
 289     frame .ctop.top.bar
 290     pack .ctop.top.bar -side bottom -fill x
 291     set cscroll .ctop.top.csb
 292     scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
 293     pack $cscroll -side right -fill y
 294     panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
 295     pack .ctop.top.clist -side top -fill both -expand 1
 296     .ctop add .ctop.top
 297     set canv .ctop.top.clist.canv
 298     canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
 299         -bg white -bd 0 \
 300         -yscrollincr $linespc -yscrollcommand "$cscroll set"
 301     .ctop.top.clist add $canv
 302     set canv2 .ctop.top.clist.canv2
 303     canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
 304         -bg white -bd 0 -yscrollincr $linespc
 305     .ctop.top.clist add $canv2
 306     set canv3 .ctop.top.clist.canv3
 307     canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
 308         -bg white -bd 0 -yscrollincr $linespc
 309     .ctop.top.clist add $canv3
 310     bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
 311
 312     set sha1entry .ctop.top.bar.sha1
 313     set entries $sha1entry
 314     set sha1but .ctop.top.bar.sha1label
 315     button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
 316         -command gotocommit -width 8
 317     $sha1but conf -disabledforeground [$sha1but cget -foreground]
 318     pack .ctop.top.bar.sha1label -side left
 319     entry $sha1entry -width 40 -font $textfont -textvariable sha1string
 320     trace add variable sha1string write sha1change
 321     pack $sha1entry -side left -pady 2
 322     button .ctop.top.bar.findbut -text "Find" -command dofind
 323     pack .ctop.top.bar.findbut -side left
 324     set findstring {}
 325     set fstring .ctop.top.bar.findstring
 326     lappend entries $fstring
 327     entry $fstring -width 30 -font $textfont -textvariable findstring
 328     pack $fstring -side left -expand 1 -fill x
 329     set findtype Exact
 330     tk_optionMenu .ctop.top.bar.findtype findtype Exact IgnCase Regexp
 331     set findloc "All fields"
 332     tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
 333         Comments Author Committer
 334     pack .ctop.top.bar.findloc -side right
 335     pack .ctop.top.bar.findtype -side right
 336
 337     panedwindow .ctop.cdet -orient horizontal
 338     .ctop add .ctop.cdet
 339     frame .ctop.cdet.left
 340     set ctext .ctop.cdet.left.ctext
 341     text $ctext -bg white -state disabled -font $textfont \
 342         -width $geometry(ctextw) -height $geometry(ctexth) \
 343         -yscrollcommand ".ctop.cdet.left.sb set"
 344     scrollbar .ctop.cdet.left.sb -command "$ctext yview"
 345     pack .ctop.cdet.left.sb -side right -fill y
 346     pack $ctext -side left -fill both -expand 1
 347     .ctop.cdet add .ctop.cdet.left
 348
 349     $ctext tag conf filesep -font [concat $textfont bold]
 350     $ctext tag conf hunksep -back blue -fore white
 351     $ctext tag conf d0 -back "#ff8080"
 352     $ctext tag conf d1 -back green
 353     $ctext tag conf found -back yellow
 354
 355     frame .ctop.cdet.right
 356     set cflist .ctop.cdet.right.cfiles
 357     listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
 358         -yscrollcommand ".ctop.cdet.right.sb set"
 359     scrollbar .ctop.cdet.right.sb -command "$cflist yview"
 360     pack .ctop.cdet.right.sb -side right -fill y
 361     pack $cflist -side left -fill both -expand 1
 362     .ctop.cdet add .ctop.cdet.right
 363     bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
 364
 365     pack .ctop -side top -fill both -expand 1
 366
 367     bindall <1> {selcanvline %W %x %y}
 368     #bindall <B1-Motion> {selcanvline %W %x %y}
 369     bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
 370     bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
 371     bindall <2> "allcanvs scan mark 0 %y"
 372     bindall <B2-Motion> "allcanvs scan dragto 0 %y"
 373     bind . <Key-Up> "selnextline -1"
 374     bind . <Key-Down> "selnextline 1"
 375     bind . <Key-Prior> "allcanvs yview scroll -1 pages"
 376     bind . <Key-Next> "allcanvs yview scroll 1 pages"
 377     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
 378     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
 379     bindkey <Key-space> "$ctext yview scroll 1 pages"
 380     bindkey p "selnextline -1"
 381     bindkey n "selnextline 1"
 382     bindkey b "$ctext yview scroll -1 pages"
 383     bindkey d "$ctext yview scroll 18 units"
 384     bindkey u "$ctext yview scroll -18 units"
 385     bindkey / findnext
 386     bindkey ? findprev
 387     bindkey f nextfile
 388     bind . <Control-q> doquit
 389     bind . <Control-f> dofind
 390     bind . <Control-g> findnext
 391     bind . <Control-r> findprev
 392     bind . <Control-equal> {incrfont 1}
 393     bind . <Control-KP_Add> {incrfont 1}
 394     bind . <Control-minus> {incrfont -1}
 395     bind . <Control-KP_Subtract> {incrfont -1}
 396     bind $cflist <<ListboxSelect>> listboxsel
 397     bind . <Destroy> {savestuff %W}
 398     bind . <Button-1> "click %W"
 399     bind $fstring <Key-Return> dofind
 400     bind $sha1entry <Key-Return> gotocommit
 401
 402     set maincursor [. cget -cursor]
 403     set textcursor [$ctext cget -cursor]
 404
 405     set rowctxmenu .rowctxmenu
 406     menu $rowctxmenu -tearoff 0
 407     $rowctxmenu add command -label "Diff this -> selected" \
 408         -command {diffvssel 0}
 409     $rowctxmenu add command -label "Diff selected -> this" \
 410         -command {diffvssel 1}
 411 }
 412
 413 # when we make a key binding for the toplevel, make sure
 414 # it doesn't get triggered when that key is pressed in the
 415 # find string entry widget.
 416 proc bindkey {ev script} {
 417     global entries
 418     bind . $ev $script
 419     set escript [bind Entry $ev]
 420     if {$escript == {}} {
 421         set escript [bind Entry <Key>]
 422     }
 423     foreach e $entries {
 424         bind $e $ev "$escript; break"
 425     }
 426 }
 427
 428 # set the focus back to the toplevel for any click outside
 429 # the entry widgets
 430 proc click {w} {
 431     global entries
 432     foreach e $entries {
 433         if {$w == $e} return
 434     }
 435     focus .
 436 }
 437
 438 proc savestuff {w} {
 439     global canv canv2 canv3 ctext cflist mainfont textfont
 440     global stuffsaved
 441     if {$stuffsaved} return
 442     if {![winfo viewable .]} return
 443     catch {
 444         set f [open "~/.gitk-new" w]
 445         puts $f "set mainfont {$mainfont}"
 446         puts $f "set textfont {$textfont}"
 447         puts $f "set geometry(width) [winfo width .ctop]"
 448         puts $f "set geometry(height) [winfo height .ctop]"
 449         puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
 450         puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
 451         puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
 452         puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
 453         set wid [expr {([winfo width $ctext] - 8) \
 454                            / [font measure $textfont "0"]}]
 455         puts $f "set geometry(ctextw) $wid"
 456         set wid [expr {([winfo width $cflist] - 11) \
 457                            / [font measure [$cflist cget -font] "0"]}]
 458         puts $f "set geometry(cflistw) $wid"
 459         close $f
 460         file rename -force "~/.gitk-new" "~/.gitk"
 461     }
 462     set stuffsaved 1
 463 }
 464
 465 proc resizeclistpanes {win w} {
 466     global oldwidth
 467     if [info exists oldwidth($win)] {
 468         set s0 [$win sash coord 0]
 469         set s1 [$win sash coord 1]
 470         if {$w < 60} {
 471             set sash0 [expr {int($w/2 - 2)}]
 472             set sash1 [expr {int($w*5/6 - 2)}]
 473         } else {
 474             set factor [expr {1.0 * $w / $oldwidth($win)}]
 475             set sash0 [expr {int($factor * [lindex $s0 0])}]
 476             set sash1 [expr {int($factor * [lindex $s1 0])}]
 477             if {$sash0 < 30} {
 478                 set sash0 30
 479             }
 480             if {$sash1 < $sash0 + 20} {
 481                 set sash1 [expr $sash0 + 20]
 482             }
 483             if {$sash1 > $w - 10} {
 484                 set sash1 [expr $w - 10]
 485                 if {$sash0 > $sash1 - 20} {
 486                     set sash0 [expr $sash1 - 20]
 487                 }
 488             }
 489         }
 490         $win sash place 0 $sash0 [lindex $s0 1]
 491         $win sash place 1 $sash1 [lindex $s1 1]
 492     }
 493     set oldwidth($win) $w
 494 }
 495
 496 proc resizecdetpanes {win w} {
 497     global oldwidth
 498     if [info exists oldwidth($win)] {
 499         set s0 [$win sash coord 0]
 500         if {$w < 60} {
 501             set sash0 [expr {int($w*3/4 - 2)}]
 502         } else {
 503             set factor [expr {1.0 * $w / $oldwidth($win)}]
 504             set sash0 [expr {int($factor * [lindex $s0 0])}]
 505             if {$sash0 < 45} {
 506                 set sash0 45
 507             }
 508             if {$sash0 > $w - 15} {
 509                 set sash0 [expr $w - 15]
 510             }
 511         }
 512         $win sash place 0 $sash0 [lindex $s0 1]
 513     }
 514     set oldwidth($win) $w
 515 }
 516
 517 proc allcanvs args {
 518     global canv canv2 canv3
 519     eval $canv $args
 520     eval $canv2 $args
 521     eval $canv3 $args
 522 }
 523
 524 proc bindall {event action} {
 525     global canv canv2 canv3
 526     bind $canv $event $action
 527     bind $canv2 $event $action
 528     bind $canv3 $event $action
 529 }
 530
 531 proc about {} {
 532     set w .about
 533     if {[winfo exists $w]} {
 534         raise $w
 535         return
 536     }
 537     toplevel $w
 538     wm title $w "About gitk"
 539     message $w.m -text {
 540 Gitk version 1.2
 541
 542 Copyright © 2005 Paul Mackerras
 543
 544 Use and redistribute under the terms of the GNU General Public License} \
 545             -justify center -aspect 400
 546     pack $w.m -side top -fill x -padx 20 -pady 20
 547     button $w.ok -text Close -command "destroy $w"
 548     pack $w.ok -side bottom
 549 }
 550
 551 proc assigncolor {id} {
 552     global commitinfo colormap commcolors colors nextcolor
 553     global parents nparents children nchildren
 554     global cornercrossings crossings
 555
 556     if [info exists colormap($id)] return
 557     set ncolors [llength $colors]
 558     if {$nparents($id) <= 1 && $nchildren($id) == 1} {
 559         set child [lindex $children($id) 0]
 560         if {[info exists colormap($child)]
 561             && $nparents($child) == 1} {
 562             set colormap($id) $colormap($child)
 563             return
 564         }
 565     }
 566     set badcolors {}
 567     if {[info exists cornercrossings($id)]} {
 568         foreach x $cornercrossings($id) {
 569             if {[info exists colormap($x)]
 570                 && [lsearch -exact $badcolors $colormap($x)] < 0} {
 571                 lappend badcolors $colormap($x)
 572             }
 573         }
 574         if {[llength $badcolors] >= $ncolors} {
 575             set badcolors {}
 576         }
 577     }
 578     set origbad $badcolors
 579     if {[llength $badcolors] < $ncolors - 1} {
 580         if {[info exists crossings($id)]} {
 581             foreach x $crossings($id) {
 582                 if {[info exists colormap($x)]
 583                     && [lsearch -exact $badcolors $colormap($x)] < 0} {
 584                     lappend badcolors $colormap($x)
 585                 }
 586             }
 587             if {[llength $badcolors] >= $ncolors} {
 588                 set badcolors $origbad
 589             }
 590         }
 591         set origbad $badcolors
 592     }
 593     if {[llength $badcolors] < $ncolors - 1} {
 594         foreach child $children($id) {
 595             if {[info exists colormap($child)]
 596                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
 597                 lappend badcolors $colormap($child)
 598             }
 599             if {[info exists parents($child)]} {
 600                 foreach p $parents($child) {
 601                     if {[info exists colormap($p)]
 602                         && [lsearch -exact $badcolors $colormap($p)] < 0} {
 603                         lappend badcolors $colormap($p)
 604                     }
 605                 }
 606             }
 607         }
 608         if {[llength $badcolors] >= $ncolors} {
 609             set badcolors $origbad
 610         }
 611     }
 612     for {set i 0} {$i <= $ncolors} {incr i} {
 613         set c [lindex $colors $nextcolor]
 614         if {[incr nextcolor] >= $ncolors} {
 615             set nextcolor 0
 616         }
 617         if {[lsearch -exact $badcolors $c]} break
 618     }
 619     set colormap($id) $c
 620 }
 621
 622 proc initgraph {} {
 623     global canvy canvy0 lineno numcommits lthickness nextcolor linespc
 624     global mainline sidelines
 625     global nchildren ncleft
 626
 627     allcanvs delete all
 628     set nextcolor 0
 629     set canvy $canvy0
 630     set lineno -1
 631     set numcommits 0
 632     set lthickness [expr {int($linespc / 9) + 1}]
 633     catch {unset mainline}
 634     catch {unset sidelines}
 635     foreach id [array names nchildren] {
 636         set ncleft($id) $nchildren($id)
 637     }
 638 }
 639
 640 proc bindline {t id} {
 641     global canv
 642
 643     $canv bind $t <Enter> "lineenter %x %y $id"
 644     $canv bind $t <Motion> "linemotion %x %y $id"
 645     $canv bind $t <Leave> "lineleave $id"
 646     $canv bind $t <Button-1> "lineclick %x %y $id"
 647 }
 648
 649 proc drawcommitline {level} {
 650     global parents children nparents nchildren todo
 651     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 652     global lineid linehtag linentag linedtag commitinfo
 653     global colormap numcommits currentparents dupparents
 654     global oldlevel oldnlines oldtodo
 655     global idtags idline idheads
 656     global lineno lthickness mainline sidelines
 657     global commitlisted rowtextx
 658
 659     incr numcommits
 660     incr lineno
 661     set id [lindex $todo $level]
 662     set lineid($lineno) $id
 663     set idline($id) $lineno
 664     set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
 665     if {![info exists commitinfo($id)]} {
 666         readcommit $id
 667         if {![info exists commitinfo($id)]} {
 668             set commitinfo($id) {"No commit information available"}
 669             set nparents($id) 0
 670         }
 671     }
 672     assigncolor $id
 673     set currentparents {}
 674     set dupparents {}
 675     if {[info exists commitlisted($id)] && [info exists parents($id)]} {
 676         foreach p $parents($id) {
 677             if {[lsearch -exact $currentparents $p] < 0} {
 678                 lappend currentparents $p
 679             } else {
 680                 # remember that this parent was listed twice
 681                 lappend dupparents $p
 682             }
 683         }
 684     }
 685     set x [expr $canvx0 + $level * $linespc]
 686     set y1 $canvy
 687     set canvy [expr $canvy + $linespc]
 688     allcanvs conf -scrollregion \
 689         [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
 690     if {[info exists mainline($id)]} {
 691         lappend mainline($id) $x $y1
 692         set t [$canv create line $mainline($id) \
 693                    -width $lthickness -fill $colormap($id)]
 694         $canv lower $t
 695         bindline $t $id
 696     }
 697     if {[info exists sidelines($id)]} {
 698         foreach ls $sidelines($id) {
 699             set coords [lindex $ls 0]
 700             set thick [lindex $ls 1]
 701             set t [$canv create line $coords -fill $colormap($id) \
 702                        -width [expr {$thick * $lthickness}]]
 703             $canv lower $t
 704             bindline $t $id
 705         }
 706     }
 707     set orad [expr {$linespc / 3}]
 708     set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
 709                [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
 710                -fill $ofill -outline black -width 1]
 711     $canv raise $t
 712     $canv bind $t <1> {selcanvline {} %x %y}
 713     set xt [expr $canvx0 + [llength $todo] * $linespc]
 714     if {[llength $currentparents] > 2} {
 715         set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
 716     }
 717     set rowtextx($lineno) $xt
 718     set marks {}
 719     set ntags 0
 720     if {[info exists idtags($id)]} {
 721         set marks $idtags($id)
 722         set ntags [llength $marks]
 723     }
 724     if {[info exists idheads($id)]} {
 725         set marks [concat $marks $idheads($id)]
 726     }
 727     if {$marks != {}} {
 728         set delta [expr {int(0.5 * ($linespc - $lthickness))}]
 729         set yt [expr $y1 - 0.5 * $linespc]
 730         set yb [expr $yt + $linespc - 1]
 731         set xvals {}
 732         set wvals {}
 733         foreach tag $marks {
 734             set wid [font measure $mainfont $tag]
 735             lappend xvals $xt
 736             lappend wvals $wid
 737             set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
 738         }
 739         set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
 740                    -width $lthickness -fill black]
 741         $canv lower $t
 742         foreach tag $marks x $xvals wid $wvals {
 743             set xl [expr $x + $delta]
 744             set xr [expr $x + $delta + $wid + $lthickness]
 745             if {[incr ntags -1] >= 0} {
 746                 # draw a tag
 747                 $canv create polygon $x [expr $yt + $delta] $xl $yt\
 748                     $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
 749                     -width 1 -outline black -fill yellow
 750             } else {
 751                 # draw a head
 752                 set xl [expr $xl - $delta/2]
 753                 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
 754                     -width 1 -outline black -fill green
 755             }
 756             $canv create text $xl $y1 -anchor w -text $tag \
 757                 -font $mainfont
 758         }
 759     }
 760     set headline [lindex $commitinfo($id) 0]
 761     set name [lindex $commitinfo($id) 1]
 762     set date [lindex $commitinfo($id) 2]
 763     set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
 764                                -text $headline -font $mainfont ]
 765     $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
 766     set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
 767                                -text $name -font $namefont]
 768     set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
 769                                -text $date -font $mainfont]
 770 }
 771
 772 proc updatetodo {level noshortcut} {
 773     global currentparents ncleft todo
 774     global mainline oldlevel oldtodo oldnlines
 775     global canvx0 canvy linespc mainline
 776     global commitinfo
 777
 778     set oldlevel $level
 779     set oldtodo $todo
 780     set oldnlines [llength $todo]
 781     if {!$noshortcut && [llength $currentparents] == 1} {
 782         set p [lindex $currentparents 0]
 783         if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
 784             set ncleft($p) 0
 785             set x [expr $canvx0 + $level * $linespc]
 786             set y [expr $canvy - $linespc]
 787             set mainline($p) [list $x $y]
 788             set todo [lreplace $todo $level $level $p]
 789             return 0
 790         }
 791     }
 792
 793     set todo [lreplace $todo $level $level]
 794     set i $level
 795     foreach p $currentparents {
 796         incr ncleft($p) -1
 797         set k [lsearch -exact $todo $p]
 798         if {$k < 0} {
 799             set todo [linsert $todo $i $p]
 800             incr i
 801         }
 802     }
 803     return 1
 804 }
 805
 806 proc notecrossings {id lo hi corner} {
 807     global oldtodo crossings cornercrossings
 808
 809     for {set i $lo} {[incr i] < $hi} {} {
 810         set p [lindex $oldtodo $i]
 811         if {$p == {}} continue
 812         if {$i == $corner} {
 813             if {![info exists cornercrossings($id)]
 814                 || [lsearch -exact $cornercrossings($id) $p] < 0} {
 815                 lappend cornercrossings($id) $p
 816             }
 817             if {![info exists cornercrossings($p)]
 818                 || [lsearch -exact $cornercrossings($p) $id] < 0} {
 819                 lappend cornercrossings($p) $id
 820             }
 821         } else {
 822             if {![info exists crossings($id)]
 823                 || [lsearch -exact $crossings($id) $p] < 0} {
 824                 lappend crossings($id) $p
 825             }
 826             if {![info exists crossings($p)]
 827                 || [lsearch -exact $crossings($p) $id] < 0} {
 828                 lappend crossings($p) $id
 829             }
 830         }
 831     }
 832 }
 833
 834 proc drawslants {} {
 835     global canv mainline sidelines canvx0 canvy linespc
 836     global oldlevel oldtodo todo currentparents dupparents
 837     global lthickness linespc canvy colormap
 838
 839     set y1 [expr $canvy - $linespc]
 840     set y2 $canvy
 841     set i -1
 842     foreach id $oldtodo {
 843         incr i
 844         if {$id == {}} continue
 845         set xi [expr {$canvx0 + $i * $linespc}]
 846         if {$i == $oldlevel} {
 847             foreach p $currentparents {
 848                 set j [lsearch -exact $todo $p]
 849                 set coords [list $xi $y1]
 850                 set xj [expr {$canvx0 + $j * $linespc}]
 851                 if {$j < $i - 1} {
 852                     lappend coords [expr $xj + $linespc] $y1
 853                     notecrossings $p $j $i [expr {$j + 1}]
 854                 } elseif {$j > $i + 1} {
 855                     lappend coords [expr $xj - $linespc] $y1
 856                     notecrossings $p $i $j [expr {$j - 1}]
 857                 }
 858                 if {[lsearch -exact $dupparents $p] >= 0} {
 859                     # draw a double-width line to indicate the doubled parent
 860                     lappend coords $xj $y2
 861                     lappend sidelines($p) [list $coords 2]
 862                     if {![info exists mainline($p)]} {
 863                         set mainline($p) [list $xj $y2]
 864                     }
 865                 } else {
 866                     # normal case, no parent duplicated
 867                     if {![info exists mainline($p)]} {
 868                         if {$i != $j} {
 869                             lappend coords $xj $y2
 870                         }
 871                         set mainline($p) $coords
 872                     } else {
 873                         lappend coords $xj $y2
 874                         lappend sidelines($p) [list $coords 1]
 875                     }
 876                 }
 877             }
 878         } elseif {[lindex $todo $i] != $id} {
 879             set j [lsearch -exact $todo $id]
 880             set xj [expr {$canvx0 + $j * $linespc}]
 881             lappend mainline($id) $xi $y1 $xj $y2
 882         }
 883     }
 884 }
 885
 886 proc decidenext {} {
 887     global parents children nchildren ncleft todo
 888     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 889     global datemode cdate
 890     global lineid linehtag linentag linedtag commitinfo
 891     global currentparents oldlevel oldnlines oldtodo
 892     global lineno lthickness
 893
 894     # remove the null entry if present
 895     set nullentry [lsearch -exact $todo {}]
 896     if {$nullentry >= 0} {
 897         set todo [lreplace $todo $nullentry $nullentry]
 898     }
 899
 900     # choose which one to do next time around
 901     set todol [llength $todo]
 902     set level -1
 903     set latest {}
 904     for {set k $todol} {[incr k -1] >= 0} {} {
 905         set p [lindex $todo $k]
 906         if {$ncleft($p) == 0} {
 907             if {$datemode} {
 908                 if {$latest == {} || $cdate($p) > $latest} {
 909                     set level $k
 910                     set latest $cdate($p)
 911                 }
 912             } else {
 913                 set level $k
 914                 break
 915             }
 916         }
 917     }
 918     if {$level < 0} {
 919         if {$todo != {}} {
 920             puts "ERROR: none of the pending commits can be done yet:"
 921             foreach p $todo {
 922                 puts "  $p ($ncleft($p))"
 923             }
 924         }
 925         return -1
 926     }
 927
 928     # If we are reducing, put in a null entry
 929     if {$todol < $oldnlines} {
 930         if {$nullentry >= 0} {
 931             set i $nullentry
 932             while {$i < $todol
 933                    && [lindex $oldtodo $i] == [lindex $todo $i]} {
 934                 incr i
 935             }
 936         } else {
 937             set i $oldlevel
 938             if {$level >= $i} {
 939                 incr i
 940             }
 941         }
 942         if {$i < $todol} {
 943             set todo [linsert $todo $i {}]
 944             if {$level >= $i} {
 945                 incr level
 946             }
 947         }
 948     }
 949     return $level
 950 }
 951
 952 proc drawcommit {id} {
 953     global phase todo nchildren datemode nextupdate
 954     global startcommits
 955
 956     if {$phase != "incrdraw"} {
 957         set phase incrdraw
 958         set todo $id
 959         set startcommits $id
 960         initgraph
 961         drawcommitline 0
 962         updatetodo 0 $datemode
 963     } else {
 964         if {$nchildren($id) == 0} {
 965             lappend todo $id
 966             lappend startcommits $id
 967         }
 968         set level [decidenext]
 969         if {$id != [lindex $todo $level]} {
 970             return
 971         }
 972         while 1 {
 973             drawslants
 974             drawcommitline $level
 975             if {[updatetodo $level $datemode]} {
 976                 set level [decidenext]
 977             }
 978             set id [lindex $todo $level]
 979             if {![info exists commitlisted($id)]} {
 980                 break
 981             }
 982             if {[clock clicks -milliseconds] >= $nextupdate} {
 983                 doupdate
 984                 if {$stopped} break
 985             }
 986         }
 987     }
 988 }
 989
 990 proc finishcommits {} {
 991     global phase
 992     global startcommits
 993     global ctext maincursor textcursor
 994
 995     if {$phase != "incrdraw"} {
 996         $canv delete all
 997         $canv create text 3 3 -anchor nw -text "No commits selected" \
 998             -font $mainfont -tags textitems
 999         set phase {}
1000         return
1001     }
1002     drawslants
1003     set level [decidenext]
1004     drawrest $level [llength $startcommits]
1005     . config -cursor $maincursor
1006     $ctext config -cursor $textcursor
1007 }
1008
1009 proc drawgraph {} {
1010     global nextupdate startmsecs startcommits todo
1011
1012     if {$startcommits == {}} return
1013     set startmsecs [clock clicks -milliseconds]
1014     set nextupdate [expr $startmsecs + 100]
1015     initgraph
1016     set todo [lindex $startcommits 0]
1017     drawrest 0 1
1018 }
1019
1020 proc drawrest {level startix} {
1021     global phase stopped redisplaying selectedline
1022     global datemode currentparents todo
1023     global numcommits
1024     global nextupdate startmsecs startcommits idline
1025
1026     if {$level >= 0} {
1027         set phase drawgraph
1028         set startid [lindex $startcommits $startix]
1029         set startline -1
1030         if {$startid != {}} {
1031             set startline $idline($startid)
1032         }
1033         while 1 {
1034             if {$stopped} break
1035             drawcommitline $level
1036             set hard [updatetodo $level $datemode]
1037             if {$numcommits == $startline} {
1038                 lappend todo $startid
1039                 set hard 1
1040                 incr startix
1041                 set startid [lindex $startcommits $startix]
1042                 set startline -1
1043                 if {$startid != {}} {
1044                     set startline $idline($startid)
1045                 }
1046             }
1047             if {$hard} {
1048                 set level [decidenext]
1049                 if {$level < 0} break
1050                 drawslants
1051             }
1052             if {[clock clicks -milliseconds] >= $nextupdate} {
1053                 update
1054                 incr nextupdate 100
1055             }
1056         }
1057     }
1058     set phase {}
1059     set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1060     #puts "overall $drawmsecs ms for $numcommits commits"
1061     if {$redisplaying} {
1062         if {$stopped == 0 && [info exists selectedline]} {
1063             selectline $selectedline
1064         }
1065         if {$stopped == 1} {
1066             set stopped 0
1067             after idle drawgraph
1068         } else {
1069             set redisplaying 0
1070         }
1071     }
1072 }
1073
1074 proc findmatches {f} {
1075     global findtype foundstring foundstrlen
1076     if {$findtype == "Regexp"} {
1077         set matches [regexp -indices -all -inline $foundstring $f]
1078     } else {
1079         if {$findtype == "IgnCase"} {
1080             set str [string tolower $f]
1081         } else {
1082             set str $f
1083         }
1084         set matches {}
1085         set i 0
1086         while {[set j [string first $foundstring $str $i]] >= 0} {
1087             lappend matches [list $j [expr $j+$foundstrlen-1]]
1088             set i [expr $j + $foundstrlen]
1089         }
1090     }
1091     return $matches
1092 }
1093
1094 proc dofind {} {
1095     global findtype findloc findstring markedmatches commitinfo
1096     global numcommits lineid linehtag linentag linedtag
1097     global mainfont namefont canv canv2 canv3 selectedline
1098     global matchinglines foundstring foundstrlen
1099     unmarkmatches
1100     focus .
1101     set matchinglines {}
1102     set fldtypes {Headline Author Date Committer CDate Comment}
1103     if {$findtype == "IgnCase"} {
1104         set foundstring [string tolower $findstring]
1105     } else {
1106         set foundstring $findstring
1107     }
1108     set foundstrlen [string length $findstring]
1109     if {$foundstrlen == 0} return
1110     if {![info exists selectedline]} {
1111         set oldsel -1
1112     } else {
1113         set oldsel $selectedline
1114     }
1115     set didsel 0
1116     for {set l 0} {$l < $numcommits} {incr l} {
1117         set id $lineid($l)
1118         set info $commitinfo($id)
1119         set doesmatch 0
1120         foreach f $info ty $fldtypes {
1121             if {$findloc != "All fields" && $findloc != $ty} {
1122                 continue
1123             }
1124             set matches [findmatches $f]
1125             if {$matches == {}} continue
1126             set doesmatch 1
1127             if {$ty == "Headline"} {
1128                 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1129             } elseif {$ty == "Author"} {
1130                 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1131             } elseif {$ty == "Date"} {
1132                 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1133             }
1134         }
1135         if {$doesmatch} {
1136             lappend matchinglines $l
1137             if {!$didsel && $l > $oldsel} {
1138                 findselectline $l
1139                 set didsel 1
1140             }
1141         }
1142     }
1143     if {$matchinglines == {}} {
1144         bell
1145     } elseif {!$didsel} {
1146         findselectline [lindex $matchinglines 0]
1147     }
1148 }
1149
1150 proc findselectline {l} {
1151     global findloc commentend ctext
1152     selectline $l
1153     if {$findloc == "All fields" || $findloc == "Comments"} {
1154         # highlight the matches in the comments
1155         set f [$ctext get 1.0 $commentend]
1156         set matches [findmatches $f]
1157         foreach match $matches {
1158             set start [lindex $match 0]
1159             set end [expr [lindex $match 1] + 1]
1160             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1161         }
1162     }
1163 }
1164
1165 proc findnext {} {
1166     global matchinglines selectedline
1167     if {![info exists matchinglines]} {
1168         dofind
1169         return
1170     }
1171     if {![info exists selectedline]} return
1172     foreach l $matchinglines {
1173         if {$l > $selectedline} {
1174             findselectline $l
1175             return
1176         }
1177     }
1178     bell
1179 }
1180
1181 proc findprev {} {
1182     global matchinglines selectedline
1183     if {![info exists matchinglines]} {
1184         dofind
1185         return
1186     }
1187     if {![info exists selectedline]} return
1188     set prev {}
1189     foreach l $matchinglines {
1190         if {$l >= $selectedline} break
1191         set prev $l
1192     }
1193     if {$prev != {}} {
1194         findselectline $prev
1195     } else {
1196         bell
1197     }
1198 }
1199
1200 proc markmatches {canv l str tag matches font} {
1201     set bbox [$canv bbox $tag]
1202     set x0 [lindex $bbox 0]
1203     set y0 [lindex $bbox 1]
1204     set y1 [lindex $bbox 3]
1205     foreach match $matches {
1206         set start [lindex $match 0]
1207         set end [lindex $match 1]
1208         if {$start > $end} continue
1209         set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1210         set xlen [font measure $font [string range $str 0 [expr $end]]]
1211         set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1212                    -outline {} -tags matches -fill yellow]
1213         $canv lower $t
1214     }
1215 }
1216
1217 proc unmarkmatches {} {
1218     global matchinglines
1219     allcanvs delete matches
1220     catch {unset matchinglines}
1221 }
1222
1223 proc selcanvline {w x y} {
1224     global canv canvy0 ctext linespc selectedline
1225     global lineid linehtag linentag linedtag rowtextx
1226     set ymax [lindex [$canv cget -scrollregion] 3]
1227     if {$ymax == {}} return
1228     set yfrac [lindex [$canv yview] 0]
1229     set y [expr {$y + $yfrac * $ymax}]
1230     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1231     if {$l < 0} {
1232         set l 0
1233     }
1234     if {$w eq $canv} {
1235         if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1236     }
1237     unmarkmatches
1238     selectline $l
1239 }
1240
1241 proc selectline {l} {
1242     global canv canv2 canv3 ctext commitinfo selectedline
1243     global lineid linehtag linentag linedtag
1244     global canvy0 linespc parents nparents
1245     global cflist currentid sha1entry diffids
1246     global commentend seenfile idtags
1247     $canv delete hover
1248     if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1249     $canv delete secsel
1250     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1251                -tags secsel -fill [$canv cget -selectbackground]]
1252     $canv lower $t
1253     $canv2 delete secsel
1254     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1255                -tags secsel -fill [$canv2 cget -selectbackground]]
1256     $canv2 lower $t
1257     $canv3 delete secsel
1258     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1259                -tags secsel -fill [$canv3 cget -selectbackground]]
1260     $canv3 lower $t
1261     set y [expr {$canvy0 + $l * $linespc}]
1262     set ymax [lindex [$canv cget -scrollregion] 3]
1263     set ytop [expr {$y - $linespc - 1}]
1264     set ybot [expr {$y + $linespc + 1}]
1265     set wnow [$canv yview]
1266     set wtop [expr [lindex $wnow 0] * $ymax]
1267     set wbot [expr [lindex $wnow 1] * $ymax]
1268     set wh [expr {$wbot - $wtop}]
1269     set newtop $wtop
1270     if {$ytop < $wtop} {
1271         if {$ybot < $wtop} {
1272             set newtop [expr {$y - $wh / 2.0}]
1273         } else {
1274             set newtop $ytop
1275             if {$newtop > $wtop - $linespc} {
1276                 set newtop [expr {$wtop - $linespc}]
1277             }
1278         }
1279     } elseif {$ybot > $wbot} {
1280         if {$ytop > $wbot} {
1281             set newtop [expr {$y - $wh / 2.0}]
1282         } else {
1283             set newtop [expr {$ybot - $wh}]
1284             if {$newtop < $wtop + $linespc} {
1285                 set newtop [expr {$wtop + $linespc}]
1286             }
1287         }
1288     }
1289     if {$newtop != $wtop} {
1290         if {$newtop < 0} {
1291             set newtop 0
1292         }
1293         allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1294     }
1295     set selectedline $l
1296
1297     set id $lineid($l)
1298     set currentid $id
1299     set diffids [concat $id $parents($id)]
1300     $sha1entry delete 0 end
1301     $sha1entry insert 0 $id
1302     $sha1entry selection from 0
1303     $sha1entry selection to end
1304
1305     $ctext conf -state normal
1306     $ctext delete 0.0 end
1307     $ctext mark set fmark.0 0.0
1308     $ctext mark gravity fmark.0 left
1309     set info $commitinfo($id)
1310     $ctext insert end "Author: [lindex $info 1]  [lindex $info 2]\n"
1311     $ctext insert end "Committer: [lindex $info 3]  [lindex $info 4]\n"
1312     if {[info exists idtags($id)]} {
1313         $ctext insert end "Tags:"
1314         foreach tag $idtags($id) {
1315             $ctext insert end " $tag"
1316         }
1317         $ctext insert end "\n"
1318     }
1319     $ctext insert end "\n"
1320     $ctext insert end [lindex $info 5]
1321     $ctext insert end "\n"
1322     $ctext tag delete Comments
1323     $ctext tag remove found 1.0 end
1324     $ctext conf -state disabled
1325     set commentend [$ctext index "end - 1c"]
1326
1327     $cflist delete 0 end
1328     $cflist insert end "Comments"
1329     if {$nparents($id) == 1} {
1330         startdiff
1331     }
1332     catch {unset seenfile}
1333 }
1334
1335 proc startdiff {} {
1336     global treediffs diffids treepending
1337
1338     if {![info exists treediffs($diffids)]} {
1339         if {![info exists treepending]} {
1340             gettreediffs $diffids
1341         }
1342     } else {
1343         addtocflist $diffids
1344     }
1345 }
1346
1347 proc selnextline {dir} {
1348     global selectedline
1349     if {![info exists selectedline]} return
1350     set l [expr $selectedline + $dir]
1351     unmarkmatches
1352     selectline $l
1353 }
1354
1355 proc addtocflist {ids} {
1356     global diffids treediffs cflist
1357     if {$ids != $diffids} {
1358         gettreediffs $diffids
1359         return
1360     }
1361     foreach f $treediffs($ids) {
1362         $cflist insert end $f
1363     }
1364     getblobdiffs $ids
1365 }
1366
1367 proc gettreediffs {ids} {
1368     global treediffs parents treepending
1369     set treepending $ids
1370     set treediffs($ids) {}
1371     set id [lindex $ids 0]
1372     set p [lindex $ids 1]
1373     if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1374     fconfigure $gdtf -blocking 0
1375     fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1376 }
1377
1378 proc gettreediffline {gdtf ids} {
1379     global treediffs treepending
1380     set n [gets $gdtf line]
1381     if {$n < 0} {
1382         if {![eof $gdtf]} return
1383         close $gdtf
1384         unset treepending
1385         addtocflist $ids
1386         return
1387     }
1388     set file [lindex $line 5]
1389     lappend treediffs($ids) $file
1390 }
1391
1392 proc getblobdiffs {ids} {
1393     global diffopts blobdifffd env curdifftag curtagstart
1394     global diffindex difffilestart nextupdate
1395
1396     set id [lindex $ids 0]
1397     set p [lindex $ids 1]
1398     set env(GIT_DIFF_OPTS) $diffopts
1399     if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1400         puts "error getting diffs: $err"
1401         return
1402     }
1403     fconfigure $bdf -blocking 0
1404     set blobdifffd($ids) $bdf
1405     set curdifftag Comments
1406     set curtagstart 0.0
1407     set diffindex 0
1408     catch {unset difffilestart}
1409     fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1410     set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1411 }
1412
1413 proc getblobdiffline {bdf ids} {
1414     global diffids blobdifffd ctext curdifftag curtagstart seenfile
1415     global diffnexthead diffnextnote diffindex difffilestart
1416     global nextupdate
1417
1418     set n [gets $bdf line]
1419     if {$n < 0} {
1420         if {[eof $bdf]} {
1421             close $bdf
1422             if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
1423                 $ctext tag add $curdifftag $curtagstart end
1424                 set seenfile($curdifftag) 1
1425             }
1426         }
1427         return
1428     }
1429     if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
1430         return
1431     }
1432     $ctext conf -state normal
1433     if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1434         # start of a new file
1435         $ctext insert end "\n"
1436         $ctext tag add $curdifftag $curtagstart end
1437         set seenfile($curdifftag) 1
1438         set curtagstart [$ctext index "end - 1c"]
1439         set header $fname
1440         if {[info exists diffnexthead]} {
1441             set fname $diffnexthead
1442             set header "$diffnexthead ($diffnextnote)"
1443             unset diffnexthead
1444         }
1445         set here [$ctext index "end - 1c"]
1446         set difffilestart($diffindex) $here
1447         incr diffindex
1448         # start mark names at fmark.1 for first file
1449         $ctext mark set fmark.$diffindex $here
1450         $ctext mark gravity fmark.$diffindex left
1451         set curdifftag "f:$fname"
1452         $ctext tag delete $curdifftag
1453         set l [expr {(78 - [string length $header]) / 2}]
1454         set pad [string range "----------------------------------------" 1 $l]
1455         $ctext insert end "$pad $header $pad\n" filesep
1456     } elseif {[string range $line 0 2] == "+++"} {
1457         # no need to do anything with this
1458     } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1459         set diffnexthead $fn
1460         set diffnextnote "created, mode $m"
1461     } elseif {[string range $line 0 8] == "Deleted: "} {
1462         set diffnexthead [string range $line 9 end]
1463         set diffnextnote "deleted"
1464     } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1465         # save the filename in case the next thing is "new file mode ..."
1466         set diffnexthead $fn
1467         set diffnextnote "modified"
1468     } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1469         set diffnextnote "new file, mode $m"
1470     } elseif {[string range $line 0 11] == "deleted file"} {
1471         set diffnextnote "deleted"
1472     } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1473                    $line match f1l f1c f2l f2c rest]} {
1474         $ctext insert end "\t" hunksep
1475         $ctext insert end "    $f1l    " d0 "    $f2l    " d1
1476         $ctext insert end "    $rest \n" hunksep
1477     } else {
1478         set x [string range $line 0 0]
1479         if {$x == "-" || $x == "+"} {
1480             set tag [expr {$x == "+"}]
1481             set line [string range $line 1 end]
1482             $ctext insert end "$line\n" d$tag
1483         } elseif {$x == " "} {
1484             set line [string range $line 1 end]
1485             $ctext insert end "$line\n"
1486         } elseif {$x == "\\"} {
1487             # e.g. "\ No newline at end of file"
1488             $ctext insert end "$line\n" filesep
1489         } else {
1490             # Something else we don't recognize
1491             if {$curdifftag != "Comments"} {
1492                 $ctext insert end "\n"
1493                 $ctext tag add $curdifftag $curtagstart end
1494                 set seenfile($curdifftag) 1
1495                 set curtagstart [$ctext index "end - 1c"]
1496                 set curdifftag Comments
1497             }
1498             $ctext insert end "$line\n" filesep
1499         }
1500     }
1501     $ctext conf -state disabled
1502     if {[clock clicks -milliseconds] >= $nextupdate} {
1503         incr nextupdate 100
1504         fileevent $bdf readable {}
1505         update
1506         fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1507     }
1508 }
1509
1510 proc nextfile {} {
1511     global difffilestart ctext
1512     set here [$ctext index @0,0]
1513     for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1514         if {[$ctext compare $difffilestart($i) > $here]} {
1515             $ctext yview $difffilestart($i)
1516             break
1517         }
1518     }
1519 }
1520
1521 proc listboxsel {} {
1522     global ctext cflist currentid treediffs seenfile
1523     if {![info exists currentid]} return
1524     set sel [lsort [$cflist curselection]]
1525     if {$sel eq {}} return
1526     set first [lindex $sel 0]
1527     catch {$ctext yview fmark.$first}
1528 }
1529
1530 proc setcoords {} {
1531     global linespc charspc canvx0 canvy0 mainfont
1532     set linespc [font metrics $mainfont -linespace]
1533     set charspc [font measure $mainfont "m"]
1534     set canvy0 [expr 3 + 0.5 * $linespc]
1535     set canvx0 [expr 3 + 0.5 * $linespc]
1536 }
1537
1538 proc redisplay {} {
1539     global selectedline stopped redisplaying phase
1540     if {$stopped > 1} return
1541     if {$phase == "getcommits"} return
1542     set redisplaying 1
1543     if {$phase == "drawgraph" || $phase == "incrdraw"} {
1544         set stopped 1
1545     } else {
1546         drawgraph
1547     }
1548 }
1549
1550 proc incrfont {inc} {
1551     global mainfont namefont textfont selectedline ctext canv phase
1552     global stopped entries
1553     unmarkmatches
1554     set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1555     set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1556     set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1557     setcoords
1558     $ctext conf -font $textfont
1559     $ctext tag conf filesep -font [concat $textfont bold]
1560     foreach e $entries {
1561         $e conf -font $mainfont
1562     }
1563     if {$phase == "getcommits"} {
1564         $canv itemconf textitems -font $mainfont
1565     }
1566     redisplay
1567 }
1568
1569 proc sha1change {n1 n2 op} {
1570     global sha1string currentid sha1but
1571     if {$sha1string == {}
1572         || ([info exists currentid] && $sha1string == $currentid)} {
1573         set state disabled
1574     } else {
1575         set state normal
1576     }
1577     if {[$sha1but cget -state] == $state} return
1578     if {$state == "normal"} {
1579         $sha1but conf -state normal -relief raised -text "Goto: "
1580     } else {
1581         $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1582     }
1583 }
1584
1585 proc gotocommit {} {
1586     global sha1string currentid idline tagids
1587     if {$sha1string == {}
1588         || ([info exists currentid] && $sha1string == $currentid)} return
1589     if {[info exists tagids($sha1string)]} {
1590         set id $tagids($sha1string)
1591     } else {
1592         set id [string tolower $sha1string]
1593     }
1594     if {[info exists idline($id)]} {
1595         selectline $idline($id)
1596         return
1597     }
1598     if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1599         set type "SHA1 id"
1600     } else {
1601         set type "Tag"
1602     }
1603     error_popup "$type $sha1string is not known"
1604 }
1605
1606 proc lineenter {x y id} {
1607     global hoverx hovery hoverid hovertimer
1608     global commitinfo canv
1609
1610     if {![info exists commitinfo($id)]} return
1611     set hoverx $x
1612     set hovery $y
1613     set hoverid $id
1614     if {[info exists hovertimer]} {
1615         after cancel $hovertimer
1616     }
1617     set hovertimer [after 500 linehover]
1618     $canv delete hover
1619 }
1620
1621 proc linemotion {x y id} {
1622     global hoverx hovery hoverid hovertimer
1623
1624     if {[info exists hoverid] && $id == $hoverid} {
1625         set hoverx $x
1626         set hovery $y
1627         if {[info exists hovertimer]} {
1628             after cancel $hovertimer
1629         }
1630         set hovertimer [after 500 linehover]
1631     }
1632 }
1633
1634 proc lineleave {id} {
1635     global hoverid hovertimer canv
1636
1637     if {[info exists hoverid] && $id == $hoverid} {
1638         $canv delete hover
1639         if {[info exists hovertimer]} {
1640             after cancel $hovertimer
1641             unset hovertimer
1642         }
1643         unset hoverid
1644     }
1645 }
1646
1647 proc linehover {} {
1648     global hoverx hovery hoverid hovertimer
1649     global canv linespc lthickness
1650     global commitinfo mainfont
1651
1652     set text [lindex $commitinfo($hoverid) 0]
1653     set ymax [lindex [$canv cget -scrollregion] 3]
1654     if {$ymax == {}} return
1655     set yfrac [lindex [$canv yview] 0]
1656     set x [expr {$hoverx + 2 * $linespc}]
1657     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
1658     set x0 [expr {$x - 2 * $lthickness}]
1659     set y0 [expr {$y - 2 * $lthickness}]
1660     set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
1661     set y1 [expr {$y + $linespc + 2 * $lthickness}]
1662     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
1663                -fill \#ffff80 -outline black -width 1 -tags hover]
1664     $canv raise $t
1665     set t [$canv create text $x $y -anchor nw -text $text -tags hover]
1666     $canv raise $t
1667 }
1668
1669 proc lineclick {x y id} {
1670     global ctext commitinfo children cflist canv
1671
1672     unmarkmatches
1673     $canv delete hover
1674     # fill the details pane with info about this line
1675     $ctext conf -state normal
1676     $ctext delete 0.0 end
1677     $ctext insert end "Parent:\n "
1678     catch {destroy $ctext.$id}
1679     button $ctext.$id -text "Go:" -command "selbyid $id" \
1680         -padx 4 -pady 0
1681     $ctext window create end -window $ctext.$id -align center
1682     set info $commitinfo($id)
1683     $ctext insert end "\t[lindex $info 0]\n"
1684     $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
1685     $ctext insert end "\tDate:\t[lindex $info 2]\n"
1686     $ctext insert end "\tID:\t$id\n"
1687     if {[info exists children($id)]} {
1688         $ctext insert end "\nChildren:"
1689         foreach child $children($id) {
1690             $ctext insert end "\n "
1691             catch {destroy $ctext.$child}
1692             button $ctext.$child -text "Go:" -command "selbyid $child" \
1693                 -padx 4 -pady 0
1694             $ctext window create end -window $ctext.$child -align center
1695             set info $commitinfo($child)
1696             $ctext insert end "\t[lindex $info 0]"
1697         }
1698     }
1699     $ctext conf -state disabled
1700
1701     $cflist delete 0 end
1702 }
1703
1704 proc selbyid {id} {
1705     global idline
1706     if {[info exists idline($id)]} {
1707         selectline $idline($id)
1708     }
1709 }
1710
1711 proc mstime {} {
1712     global startmstime
1713     if {![info exists startmstime]} {
1714         set startmstime [clock clicks -milliseconds]
1715     }
1716     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
1717 }
1718
1719 proc rowmenu {x y id} {
1720     global rowctxmenu idline selectedline rowmenuid
1721
1722     if {![info exists selectedline] || $idline($id) eq $selectedline} {
1723         set state disabled
1724     } else {
1725         set state normal
1726     }
1727     $rowctxmenu entryconfigure 0 -state $state
1728     $rowctxmenu entryconfigure 1 -state $state
1729     set rowmenuid $id
1730     tk_popup $rowctxmenu $x $y
1731 }
1732
1733 proc diffvssel {dirn} {
1734     global rowmenuid selectedline lineid
1735     global ctext cflist
1736     global diffids commitinfo
1737
1738     if {![info exists selectedline]} return
1739     if {$dirn} {
1740         set oldid $lineid($selectedline)
1741         set newid $rowmenuid
1742     } else {
1743         set oldid $rowmenuid
1744         set newid $lineid($selectedline)
1745     }
1746     $ctext conf -state normal
1747     $ctext delete 0.0 end
1748     $ctext mark set fmark.0 0.0
1749     $ctext mark gravity fmark.0 left
1750     $cflist delete 0 end
1751     $cflist insert end "Top"
1752     $ctext insert end "From $oldid\n     "
1753     $ctext insert end [lindex $commitinfo($oldid) 0]
1754     $ctext insert end "\n\nTo   $newid\n     "
1755     $ctext insert end [lindex $commitinfo($newid) 0]
1756     $ctext insert end "\n"
1757     $ctext conf -state disabled
1758     $ctext tag delete Comments
1759     $ctext tag remove found 1.0 end
1760     set diffids [list $newid $oldid]
1761     startdiff
1762 }
1763
1764 proc doquit {} {
1765     global stopped
1766     set stopped 100
1767     destroy .
1768 }
1769
1770 # defaults...
1771 set datemode 0
1772 set boldnames 0
1773 set diffopts "-U 5 -p"
1774
1775 set mainfont {Helvetica 9}
1776 set textfont {Courier 9}
1777
1778 set colors {green red blue magenta darkgrey brown orange}
1779
1780 catch {source ~/.gitk}
1781
1782 set namefont $mainfont
1783 if {$boldnames} {
1784     lappend namefont bold
1785 }
1786
1787 set revtreeargs {}
1788 foreach arg $argv {
1789     switch -regexp -- $arg {
1790         "^$" { }
1791         "^-b" { set boldnames 1 }
1792         "^-d" { set datemode 1 }
1793         default {
1794             lappend revtreeargs $arg
1795         }
1796     }
1797 }
1798
1799 set stopped 0
1800 set redisplaying 0
1801 set stuffsaved 0
1802 setcoords
1803 makewindow
1804 readrefs
1805 getcommits $revtreeargs