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