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