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 }
 423
 424 # when we make a key binding for the toplevel, make sure
 425 # it doesn't get triggered when that key is pressed in the
 426 # find string entry widget.
 427 proc bindkey {ev script} {
 428     global entries
 429     bind . $ev $script
 430     set escript [bind Entry $ev]
 431     if {$escript == {}} {
 432         set escript [bind Entry <Key>]
 433     }
 434     foreach e $entries {
 435         bind $e $ev "$escript; break"
 436     }
 437 }
 438
 439 # set the focus back to the toplevel for any click outside
 440 # the entry widgets
 441 proc click {w} {
 442     global entries
 443     foreach e $entries {
 444         if {$w == $e} return
 445     }
 446     focus .
 447 }
 448
 449 proc savestuff {w} {
 450     global canv canv2 canv3 ctext cflist mainfont textfont
 451     global stuffsaved
 452     if {$stuffsaved} return
 453     if {![winfo viewable .]} return
 454     catch {
 455         set f [open "~/.gitk-new" w]
 456         puts $f "set mainfont {$mainfont}"
 457         puts $f "set textfont {$textfont}"
 458         puts $f "set geometry(width) [winfo width .ctop]"
 459         puts $f "set geometry(height) [winfo height .ctop]"
 460         puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
 461         puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
 462         puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
 463         puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
 464         set wid [expr {([winfo width $ctext] - 8) \
 465                            / [font measure $textfont "0"]}]
 466         puts $f "set geometry(ctextw) $wid"
 467         set wid [expr {([winfo width $cflist] - 11) \
 468                            / [font measure [$cflist cget -font] "0"]}]
 469         puts $f "set geometry(cflistw) $wid"
 470         close $f
 471         file rename -force "~/.gitk-new" "~/.gitk"
 472     }
 473     set stuffsaved 1
 474 }
 475
 476 proc resizeclistpanes {win w} {
 477     global oldwidth
 478     if [info exists oldwidth($win)] {
 479         set s0 [$win sash coord 0]
 480         set s1 [$win sash coord 1]
 481         if {$w < 60} {
 482             set sash0 [expr {int($w/2 - 2)}]
 483             set sash1 [expr {int($w*5/6 - 2)}]
 484         } else {
 485             set factor [expr {1.0 * $w / $oldwidth($win)}]
 486             set sash0 [expr {int($factor * [lindex $s0 0])}]
 487             set sash1 [expr {int($factor * [lindex $s1 0])}]
 488             if {$sash0 < 30} {
 489                 set sash0 30
 490             }
 491             if {$sash1 < $sash0 + 20} {
 492                 set sash1 [expr $sash0 + 20]
 493             }
 494             if {$sash1 > $w - 10} {
 495                 set sash1 [expr $w - 10]
 496                 if {$sash0 > $sash1 - 20} {
 497                     set sash0 [expr $sash1 - 20]
 498                 }
 499             }
 500         }
 501         $win sash place 0 $sash0 [lindex $s0 1]
 502         $win sash place 1 $sash1 [lindex $s1 1]
 503     }
 504     set oldwidth($win) $w
 505 }
 506
 507 proc resizecdetpanes {win w} {
 508     global oldwidth
 509     if [info exists oldwidth($win)] {
 510         set s0 [$win sash coord 0]
 511         if {$w < 60} {
 512             set sash0 [expr {int($w*3/4 - 2)}]
 513         } else {
 514             set factor [expr {1.0 * $w / $oldwidth($win)}]
 515             set sash0 [expr {int($factor * [lindex $s0 0])}]
 516             if {$sash0 < 45} {
 517                 set sash0 45
 518             }
 519             if {$sash0 > $w - 15} {
 520                 set sash0 [expr $w - 15]
 521             }
 522         }
 523         $win sash place 0 $sash0 [lindex $s0 1]
 524     }
 525     set oldwidth($win) $w
 526 }
 527
 528 proc allcanvs args {
 529     global canv canv2 canv3
 530     eval $canv $args
 531     eval $canv2 $args
 532     eval $canv3 $args
 533 }
 534
 535 proc bindall {event action} {
 536     global canv canv2 canv3
 537     bind $canv $event $action
 538     bind $canv2 $event $action
 539     bind $canv3 $event $action
 540 }
 541
 542 proc about {} {
 543     set w .about
 544     if {[winfo exists $w]} {
 545         raise $w
 546         return
 547     }
 548     toplevel $w
 549     wm title $w "About gitk"
 550     message $w.m -text {
 551 Gitk version 1.2
 552
 553 Copyright © 2005 Paul Mackerras
 554
 555 Use and redistribute under the terms of the GNU General Public License} \
 556             -justify center -aspect 400
 557     pack $w.m -side top -fill x -padx 20 -pady 20
 558     button $w.ok -text Close -command "destroy $w"
 559     pack $w.ok -side bottom
 560 }
 561
 562 proc assigncolor {id} {
 563     global commitinfo colormap commcolors colors nextcolor
 564     global parents nparents children nchildren
 565     global cornercrossings crossings
 566
 567     if [info exists colormap($id)] return
 568     set ncolors [llength $colors]
 569     if {$nparents($id) <= 1 && $nchildren($id) == 1} {
 570         set child [lindex $children($id) 0]
 571         if {[info exists colormap($child)]
 572             && $nparents($child) == 1} {
 573             set colormap($id) $colormap($child)
 574             return
 575         }
 576     }
 577     set badcolors {}
 578     if {[info exists cornercrossings($id)]} {
 579         foreach x $cornercrossings($id) {
 580             if {[info exists colormap($x)]
 581                 && [lsearch -exact $badcolors $colormap($x)] < 0} {
 582                 lappend badcolors $colormap($x)
 583             }
 584         }
 585         if {[llength $badcolors] >= $ncolors} {
 586             set badcolors {}
 587         }
 588     }
 589     set origbad $badcolors
 590     if {[llength $badcolors] < $ncolors - 1} {
 591         if {[info exists crossings($id)]} {
 592             foreach x $crossings($id) {
 593                 if {[info exists colormap($x)]
 594                     && [lsearch -exact $badcolors $colormap($x)] < 0} {
 595                     lappend badcolors $colormap($x)
 596                 }
 597             }
 598             if {[llength $badcolors] >= $ncolors} {
 599                 set badcolors $origbad
 600             }
 601         }
 602         set origbad $badcolors
 603     }
 604     if {[llength $badcolors] < $ncolors - 1} {
 605         foreach child $children($id) {
 606             if {[info exists colormap($child)]
 607                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
 608                 lappend badcolors $colormap($child)
 609             }
 610             if {[info exists parents($child)]} {
 611                 foreach p $parents($child) {
 612                     if {[info exists colormap($p)]
 613                         && [lsearch -exact $badcolors $colormap($p)] < 0} {
 614                         lappend badcolors $colormap($p)
 615                     }
 616                 }
 617             }
 618         }
 619         if {[llength $badcolors] >= $ncolors} {
 620             set badcolors $origbad
 621         }
 622     }
 623     for {set i 0} {$i <= $ncolors} {incr i} {
 624         set c [lindex $colors $nextcolor]
 625         if {[incr nextcolor] >= $ncolors} {
 626             set nextcolor 0
 627         }
 628         if {[lsearch -exact $badcolors $c]} break
 629     }
 630     set colormap($id) $c
 631 }
 632
 633 proc initgraph {} {
 634     global canvy canvy0 lineno numcommits lthickness nextcolor linespc
 635     global mainline sidelines
 636     global nchildren ncleft
 637
 638     allcanvs delete all
 639     set nextcolor 0
 640     set canvy $canvy0
 641     set lineno -1
 642     set numcommits 0
 643     set lthickness [expr {int($linespc / 9) + 1}]
 644     catch {unset mainline}
 645     catch {unset sidelines}
 646     foreach id [array names nchildren] {
 647         set ncleft($id) $nchildren($id)
 648     }
 649 }
 650
 651 proc bindline {t id} {
 652     global canv
 653
 654     $canv bind $t <Enter> "lineenter %x %y $id"
 655     $canv bind $t <Motion> "linemotion %x %y $id"
 656     $canv bind $t <Leave> "lineleave $id"
 657     $canv bind $t <Button-1> "lineclick %x %y $id"
 658 }
 659
 660 proc drawcommitline {level} {
 661     global parents children nparents nchildren todo
 662     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 663     global lineid linehtag linentag linedtag commitinfo
 664     global colormap numcommits currentparents dupparents
 665     global oldlevel oldnlines oldtodo
 666     global idtags idline idheads
 667     global lineno lthickness mainline sidelines
 668     global commitlisted rowtextx
 669
 670     incr numcommits
 671     incr lineno
 672     set id [lindex $todo $level]
 673     set lineid($lineno) $id
 674     set idline($id) $lineno
 675     set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
 676     if {![info exists commitinfo($id)]} {
 677         readcommit $id
 678         if {![info exists commitinfo($id)]} {
 679             set commitinfo($id) {"No commit information available"}
 680             set nparents($id) 0
 681         }
 682     }
 683     assigncolor $id
 684     set currentparents {}
 685     set dupparents {}
 686     if {[info exists commitlisted($id)] && [info exists parents($id)]} {
 687         foreach p $parents($id) {
 688             if {[lsearch -exact $currentparents $p] < 0} {
 689                 lappend currentparents $p
 690             } else {
 691                 # remember that this parent was listed twice
 692                 lappend dupparents $p
 693             }
 694         }
 695     }
 696     set x [expr $canvx0 + $level * $linespc]
 697     set y1 $canvy
 698     set canvy [expr $canvy + $linespc]
 699     allcanvs conf -scrollregion \
 700         [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
 701     if {[info exists mainline($id)]} {
 702         lappend mainline($id) $x $y1
 703         set t [$canv create line $mainline($id) \
 704                    -width $lthickness -fill $colormap($id)]
 705         $canv lower $t
 706         bindline $t $id
 707     }
 708     if {[info exists sidelines($id)]} {
 709         foreach ls $sidelines($id) {
 710             set coords [lindex $ls 0]
 711             set thick [lindex $ls 1]
 712             set t [$canv create line $coords -fill $colormap($id) \
 713                        -width [expr {$thick * $lthickness}]]
 714             $canv lower $t
 715             bindline $t $id
 716         }
 717     }
 718     set orad [expr {$linespc / 3}]
 719     set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
 720                [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
 721                -fill $ofill -outline black -width 1]
 722     $canv raise $t
 723     $canv bind $t <1> {selcanvline {} %x %y}
 724     set xt [expr $canvx0 + [llength $todo] * $linespc]
 725     if {[llength $currentparents] > 2} {
 726         set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
 727     }
 728     set rowtextx($lineno) $xt
 729     set marks {}
 730     set ntags 0
 731     if {[info exists idtags($id)]} {
 732         set marks $idtags($id)
 733         set ntags [llength $marks]
 734     }
 735     if {[info exists idheads($id)]} {
 736         set marks [concat $marks $idheads($id)]
 737     }
 738     if {$marks != {}} {
 739         set delta [expr {int(0.5 * ($linespc - $lthickness))}]
 740         set yt [expr $y1 - 0.5 * $linespc]
 741         set yb [expr $yt + $linespc - 1]
 742         set xvals {}
 743         set wvals {}
 744         foreach tag $marks {
 745             set wid [font measure $mainfont $tag]
 746             lappend xvals $xt
 747             lappend wvals $wid
 748             set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
 749         }
 750         set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
 751                    -width $lthickness -fill black]
 752         $canv lower $t
 753         foreach tag $marks x $xvals wid $wvals {
 754             set xl [expr $x + $delta]
 755             set xr [expr $x + $delta + $wid + $lthickness]
 756             if {[incr ntags -1] >= 0} {
 757                 # draw a tag
 758                 $canv create polygon $x [expr $yt + $delta] $xl $yt\
 759                     $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
 760                     -width 1 -outline black -fill yellow
 761             } else {
 762                 # draw a head
 763                 set xl [expr $xl - $delta/2]
 764                 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
 765                     -width 1 -outline black -fill green
 766             }
 767             $canv create text $xl $y1 -anchor w -text $tag \
 768                 -font $mainfont
 769         }
 770     }
 771     set headline [lindex $commitinfo($id) 0]
 772     set name [lindex $commitinfo($id) 1]
 773     set date [lindex $commitinfo($id) 2]
 774     set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
 775                                -text $headline -font $mainfont ]
 776     $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
 777     set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
 778                                -text $name -font $namefont]
 779     set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
 780                                -text $date -font $mainfont]
 781 }
 782
 783 proc updatetodo {level noshortcut} {
 784     global currentparents ncleft todo
 785     global mainline oldlevel oldtodo oldnlines
 786     global canvx0 canvy linespc mainline
 787     global commitinfo
 788
 789     set oldlevel $level
 790     set oldtodo $todo
 791     set oldnlines [llength $todo]
 792     if {!$noshortcut && [llength $currentparents] == 1} {
 793         set p [lindex $currentparents 0]
 794         if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
 795             set ncleft($p) 0
 796             set x [expr $canvx0 + $level * $linespc]
 797             set y [expr $canvy - $linespc]
 798             set mainline($p) [list $x $y]
 799             set todo [lreplace $todo $level $level $p]
 800             return 0
 801         }
 802     }
 803
 804     set todo [lreplace $todo $level $level]
 805     set i $level
 806     foreach p $currentparents {
 807         incr ncleft($p) -1
 808         set k [lsearch -exact $todo $p]
 809         if {$k < 0} {
 810             set todo [linsert $todo $i $p]
 811             incr i
 812         }
 813     }
 814     return 1
 815 }
 816
 817 proc notecrossings {id lo hi corner} {
 818     global oldtodo crossings cornercrossings
 819
 820     for {set i $lo} {[incr i] < $hi} {} {
 821         set p [lindex $oldtodo $i]
 822         if {$p == {}} continue
 823         if {$i == $corner} {
 824             if {![info exists cornercrossings($id)]
 825                 || [lsearch -exact $cornercrossings($id) $p] < 0} {
 826                 lappend cornercrossings($id) $p
 827             }
 828             if {![info exists cornercrossings($p)]
 829                 || [lsearch -exact $cornercrossings($p) $id] < 0} {
 830                 lappend cornercrossings($p) $id
 831             }
 832         } else {
 833             if {![info exists crossings($id)]
 834                 || [lsearch -exact $crossings($id) $p] < 0} {
 835                 lappend crossings($id) $p
 836             }
 837             if {![info exists crossings($p)]
 838                 || [lsearch -exact $crossings($p) $id] < 0} {
 839                 lappend crossings($p) $id
 840             }
 841         }
 842     }
 843 }
 844
 845 proc drawslants {} {
 846     global canv mainline sidelines canvx0 canvy linespc
 847     global oldlevel oldtodo todo currentparents dupparents
 848     global lthickness linespc canvy colormap
 849
 850     set y1 [expr $canvy - $linespc]
 851     set y2 $canvy
 852     set i -1
 853     foreach id $oldtodo {
 854         incr i
 855         if {$id == {}} continue
 856         set xi [expr {$canvx0 + $i * $linespc}]
 857         if {$i == $oldlevel} {
 858             foreach p $currentparents {
 859                 set j [lsearch -exact $todo $p]
 860                 set coords [list $xi $y1]
 861                 set xj [expr {$canvx0 + $j * $linespc}]
 862                 if {$j < $i - 1} {
 863                     lappend coords [expr $xj + $linespc] $y1
 864                     notecrossings $p $j $i [expr {$j + 1}]
 865                 } elseif {$j > $i + 1} {
 866                     lappend coords [expr $xj - $linespc] $y1
 867                     notecrossings $p $i $j [expr {$j - 1}]
 868                 }
 869                 if {[lsearch -exact $dupparents $p] >= 0} {
 870                     # draw a double-width line to indicate the doubled parent
 871                     lappend coords $xj $y2
 872                     lappend sidelines($p) [list $coords 2]
 873                     if {![info exists mainline($p)]} {
 874                         set mainline($p) [list $xj $y2]
 875                     }
 876                 } else {
 877                     # normal case, no parent duplicated
 878                     if {![info exists mainline($p)]} {
 879                         if {$i != $j} {
 880                             lappend coords $xj $y2
 881                         }
 882                         set mainline($p) $coords
 883                     } else {
 884                         lappend coords $xj $y2
 885                         lappend sidelines($p) [list $coords 1]
 886                     }
 887                 }
 888             }
 889         } elseif {[lindex $todo $i] != $id} {
 890             set j [lsearch -exact $todo $id]
 891             set xj [expr {$canvx0 + $j * $linespc}]
 892             lappend mainline($id) $xi $y1 $xj $y2
 893         }
 894     }
 895 }
 896
 897 proc decidenext {} {
 898     global parents children nchildren ncleft todo
 899     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 900     global datemode cdate
 901     global lineid linehtag linentag linedtag commitinfo
 902     global currentparents oldlevel oldnlines oldtodo
 903     global lineno lthickness
 904
 905     # remove the null entry if present
 906     set nullentry [lsearch -exact $todo {}]
 907     if {$nullentry >= 0} {
 908         set todo [lreplace $todo $nullentry $nullentry]
 909     }
 910
 911     # choose which one to do next time around
 912     set todol [llength $todo]
 913     set level -1
 914     set latest {}
 915     for {set k $todol} {[incr k -1] >= 0} {} {
 916         set p [lindex $todo $k]
 917         if {$ncleft($p) == 0} {
 918             if {$datemode} {
 919                 if {$latest == {} || $cdate($p) > $latest} {
 920                     set level $k
 921                     set latest $cdate($p)
 922                 }
 923             } else {
 924                 set level $k
 925                 break
 926             }
 927         }
 928     }
 929     if {$level < 0} {
 930         if {$todo != {}} {
 931             puts "ERROR: none of the pending commits can be done yet:"
 932             foreach p $todo {
 933                 puts "  $p ($ncleft($p))"
 934             }
 935         }
 936         return -1
 937     }
 938
 939     # If we are reducing, put in a null entry
 940     if {$todol < $oldnlines} {
 941         if {$nullentry >= 0} {
 942             set i $nullentry
 943             while {$i < $todol
 944                    && [lindex $oldtodo $i] == [lindex $todo $i]} {
 945                 incr i
 946             }
 947         } else {
 948             set i $oldlevel
 949             if {$level >= $i} {
 950                 incr i
 951             }
 952         }
 953         if {$i < $todol} {
 954             set todo [linsert $todo $i {}]
 955             if {$level >= $i} {
 956                 incr level
 957             }
 958         }
 959     }
 960     return $level
 961 }
 962
 963 proc drawcommit {id} {
 964     global phase todo nchildren datemode nextupdate
 965     global startcommits
 966
 967     if {$phase != "incrdraw"} {
 968         set phase incrdraw
 969         set todo $id
 970         set startcommits $id
 971         initgraph
 972         drawcommitline 0
 973         updatetodo 0 $datemode
 974     } else {
 975         if {$nchildren($id) == 0} {
 976             lappend todo $id
 977             lappend startcommits $id
 978         }
 979         set level [decidenext]
 980         if {$id != [lindex $todo $level]} {
 981             return
 982         }
 983         while 1 {
 984             drawslants
 985             drawcommitline $level
 986             if {[updatetodo $level $datemode]} {
 987                 set level [decidenext]
 988             }
 989             set id [lindex $todo $level]
 990             if {![info exists commitlisted($id)]} {
 991                 break
 992             }
 993             if {[clock clicks -milliseconds] >= $nextupdate} {
 994                 doupdate
 995                 if {$stopped} break
 996             }
 997         }
 998     }
 999 }
1000
1001 proc finishcommits {} {
1002     global phase
1003     global startcommits
1004     global ctext maincursor textcursor
1005
1006     if {$phase != "incrdraw"} {
1007         $canv delete all
1008         $canv create text 3 3 -anchor nw -text "No commits selected" \
1009             -font $mainfont -tags textitems
1010         set phase {}
1011         return
1012     }
1013     drawslants
1014     set level [decidenext]
1015     drawrest $level [llength $startcommits]
1016     . config -cursor $maincursor
1017     $ctext config -cursor $textcursor
1018 }
1019
1020 proc drawgraph {} {
1021     global nextupdate startmsecs startcommits todo
1022
1023     if {$startcommits == {}} return
1024     set startmsecs [clock clicks -milliseconds]
1025     set nextupdate [expr $startmsecs + 100]
1026     initgraph
1027     set todo [lindex $startcommits 0]
1028     drawrest 0 1
1029 }
1030
1031 proc drawrest {level startix} {
1032     global phase stopped redisplaying selectedline
1033     global datemode currentparents todo
1034     global numcommits
1035     global nextupdate startmsecs startcommits idline
1036
1037     if {$level >= 0} {
1038         set phase drawgraph
1039         set startid [lindex $startcommits $startix]
1040         set startline -1
1041         if {$startid != {}} {
1042             set startline $idline($startid)
1043         }
1044         while 1 {
1045             if {$stopped} break
1046             drawcommitline $level
1047             set hard [updatetodo $level $datemode]
1048             if {$numcommits == $startline} {
1049                 lappend todo $startid
1050                 set hard 1
1051                 incr startix
1052                 set startid [lindex $startcommits $startix]
1053                 set startline -1
1054                 if {$startid != {}} {
1055                     set startline $idline($startid)
1056                 }
1057             }
1058             if {$hard} {
1059                 set level [decidenext]
1060                 if {$level < 0} break
1061                 drawslants
1062             }
1063             if {[clock clicks -milliseconds] >= $nextupdate} {
1064                 update
1065                 incr nextupdate 100
1066             }
1067         }
1068     }
1069     set phase {}
1070     set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1071     #puts "overall $drawmsecs ms for $numcommits commits"
1072     if {$redisplaying} {
1073         if {$stopped == 0 && [info exists selectedline]} {
1074             selectline $selectedline
1075         }
1076         if {$stopped == 1} {
1077             set stopped 0
1078             after idle drawgraph
1079         } else {
1080             set redisplaying 0
1081         }
1082     }
1083 }
1084
1085 proc findmatches {f} {
1086     global findtype foundstring foundstrlen
1087     if {$findtype == "Regexp"} {
1088         set matches [regexp -indices -all -inline $foundstring $f]
1089     } else {
1090         if {$findtype == "IgnCase"} {
1091             set str [string tolower $f]
1092         } else {
1093             set str $f
1094         }
1095         set matches {}
1096         set i 0
1097         while {[set j [string first $foundstring $str $i]] >= 0} {
1098             lappend matches [list $j [expr $j+$foundstrlen-1]]
1099             set i [expr $j + $foundstrlen]
1100         }
1101     }
1102     return $matches
1103 }
1104
1105 proc dofind {} {
1106     global findtype findloc findstring markedmatches commitinfo
1107     global numcommits lineid linehtag linentag linedtag
1108     global mainfont namefont canv canv2 canv3 selectedline
1109     global matchinglines foundstring foundstrlen
1110     unmarkmatches
1111     focus .
1112     set matchinglines {}
1113     set fldtypes {Headline Author Date Committer CDate Comment}
1114     if {$findtype == "IgnCase"} {
1115         set foundstring [string tolower $findstring]
1116     } else {
1117         set foundstring $findstring
1118     }
1119     set foundstrlen [string length $findstring]
1120     if {$foundstrlen == 0} return
1121     if {![info exists selectedline]} {
1122         set oldsel -1
1123     } else {
1124         set oldsel $selectedline
1125     }
1126     set didsel 0
1127     for {set l 0} {$l < $numcommits} {incr l} {
1128         set id $lineid($l)
1129         set info $commitinfo($id)
1130         set doesmatch 0
1131         foreach f $info ty $fldtypes {
1132             if {$findloc != "All fields" && $findloc != $ty} {
1133                 continue
1134             }
1135             set matches [findmatches $f]
1136             if {$matches == {}} continue
1137             set doesmatch 1
1138             if {$ty == "Headline"} {
1139                 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1140             } elseif {$ty == "Author"} {
1141                 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1142             } elseif {$ty == "Date"} {
1143                 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1144             }
1145         }
1146         if {$doesmatch} {
1147             lappend matchinglines $l
1148             if {!$didsel && $l > $oldsel} {
1149                 findselectline $l
1150                 set didsel 1
1151             }
1152         }
1153     }
1154     if {$matchinglines == {}} {
1155         bell
1156     } elseif {!$didsel} {
1157         findselectline [lindex $matchinglines 0]
1158     }
1159 }
1160
1161 proc findselectline {l} {
1162     global findloc commentend ctext
1163     selectline $l
1164     if {$findloc == "All fields" || $findloc == "Comments"} {
1165         # highlight the matches in the comments
1166         set f [$ctext get 1.0 $commentend]
1167         set matches [findmatches $f]
1168         foreach match $matches {
1169             set start [lindex $match 0]
1170             set end [expr [lindex $match 1] + 1]
1171             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1172         }
1173     }
1174 }
1175
1176 proc findnext {} {
1177     global matchinglines selectedline
1178     if {![info exists matchinglines]} {
1179         dofind
1180         return
1181     }
1182     if {![info exists selectedline]} return
1183     foreach l $matchinglines {
1184         if {$l > $selectedline} {
1185             findselectline $l
1186             return
1187         }
1188     }
1189     bell
1190 }
1191
1192 proc findprev {} {
1193     global matchinglines selectedline
1194     if {![info exists matchinglines]} {
1195         dofind
1196         return
1197     }
1198     if {![info exists selectedline]} return
1199     set prev {}
1200     foreach l $matchinglines {
1201         if {$l >= $selectedline} break
1202         set prev $l
1203     }
1204     if {$prev != {}} {
1205         findselectline $prev
1206     } else {
1207         bell
1208     }
1209 }
1210
1211 proc markmatches {canv l str tag matches font} {
1212     set bbox [$canv bbox $tag]
1213     set x0 [lindex $bbox 0]
1214     set y0 [lindex $bbox 1]
1215     set y1 [lindex $bbox 3]
1216     foreach match $matches {
1217         set start [lindex $match 0]
1218         set end [lindex $match 1]
1219         if {$start > $end} continue
1220         set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1221         set xlen [font measure $font [string range $str 0 [expr $end]]]
1222         set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1223                    -outline {} -tags matches -fill yellow]
1224         $canv lower $t
1225     }
1226 }
1227
1228 proc unmarkmatches {} {
1229     global matchinglines
1230     allcanvs delete matches
1231     catch {unset matchinglines}
1232 }
1233
1234 proc selcanvline {w x y} {
1235     global canv canvy0 ctext linespc selectedline
1236     global lineid linehtag linentag linedtag rowtextx
1237     set ymax [lindex [$canv cget -scrollregion] 3]
1238     if {$ymax == {}} return
1239     set yfrac [lindex [$canv yview] 0]
1240     set y [expr {$y + $yfrac * $ymax}]
1241     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1242     if {$l < 0} {
1243         set l 0
1244     }
1245     if {$w eq $canv} {
1246         if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1247     }
1248     unmarkmatches
1249     selectline $l
1250 }
1251
1252 proc selectline {l} {
1253     global canv canv2 canv3 ctext commitinfo selectedline
1254     global lineid linehtag linentag linedtag
1255     global canvy0 linespc parents nparents
1256     global cflist currentid sha1entry diffids
1257     global commentend seenfile idtags
1258     $canv delete hover
1259     if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1260     $canv delete secsel
1261     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1262                -tags secsel -fill [$canv cget -selectbackground]]
1263     $canv lower $t
1264     $canv2 delete secsel
1265     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1266                -tags secsel -fill [$canv2 cget -selectbackground]]
1267     $canv2 lower $t
1268     $canv3 delete secsel
1269     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1270                -tags secsel -fill [$canv3 cget -selectbackground]]
1271     $canv3 lower $t
1272     set y [expr {$canvy0 + $l * $linespc}]
1273     set ymax [lindex [$canv cget -scrollregion] 3]
1274     set ytop [expr {$y - $linespc - 1}]
1275     set ybot [expr {$y + $linespc + 1}]
1276     set wnow [$canv yview]
1277     set wtop [expr [lindex $wnow 0] * $ymax]
1278     set wbot [expr [lindex $wnow 1] * $ymax]
1279     set wh [expr {$wbot - $wtop}]
1280     set newtop $wtop
1281     if {$ytop < $wtop} {
1282         if {$ybot < $wtop} {
1283             set newtop [expr {$y - $wh / 2.0}]
1284         } else {
1285             set newtop $ytop
1286             if {$newtop > $wtop - $linespc} {
1287                 set newtop [expr {$wtop - $linespc}]
1288             }
1289         }
1290     } elseif {$ybot > $wbot} {
1291         if {$ytop > $wbot} {
1292             set newtop [expr {$y - $wh / 2.0}]
1293         } else {
1294             set newtop [expr {$ybot - $wh}]
1295             if {$newtop < $wtop + $linespc} {
1296                 set newtop [expr {$wtop + $linespc}]
1297             }
1298         }
1299     }
1300     if {$newtop != $wtop} {
1301         if {$newtop < 0} {
1302             set newtop 0
1303         }
1304         allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1305     }
1306     set selectedline $l
1307
1308     set id $lineid($l)
1309     set currentid $id
1310     set diffids [concat $id $parents($id)]
1311     $sha1entry delete 0 end
1312     $sha1entry insert 0 $id
1313     $sha1entry selection from 0
1314     $sha1entry selection to end
1315
1316     $ctext conf -state normal
1317     $ctext delete 0.0 end
1318     $ctext mark set fmark.0 0.0
1319     $ctext mark gravity fmark.0 left
1320     set info $commitinfo($id)
1321     $ctext insert end "Author: [lindex $info 1]  [lindex $info 2]\n"
1322     $ctext insert end "Committer: [lindex $info 3]  [lindex $info 4]\n"
1323     if {[info exists idtags($id)]} {
1324         $ctext insert end "Tags:"
1325         foreach tag $idtags($id) {
1326             $ctext insert end " $tag"
1327         }
1328         $ctext insert end "\n"
1329     }
1330     $ctext insert end "\n"
1331     $ctext insert end [lindex $info 5]
1332     $ctext insert end "\n"
1333     $ctext tag delete Comments
1334     $ctext tag remove found 1.0 end
1335     $ctext conf -state disabled
1336     set commentend [$ctext index "end - 1c"]
1337
1338     $cflist delete 0 end
1339     $cflist insert end "Comments"
1340     if {$nparents($id) == 1} {
1341         startdiff
1342     }
1343     catch {unset seenfile}
1344 }
1345
1346 proc startdiff {} {
1347     global treediffs diffids treepending
1348
1349     if {![info exists treediffs($diffids)]} {
1350         if {![info exists treepending]} {
1351             gettreediffs $diffids
1352         }
1353     } else {
1354         addtocflist $diffids
1355     }
1356 }
1357
1358 proc selnextline {dir} {
1359     global selectedline
1360     if {![info exists selectedline]} return
1361     set l [expr $selectedline + $dir]
1362     unmarkmatches
1363     selectline $l
1364 }
1365
1366 proc addtocflist {ids} {
1367     global diffids treediffs cflist
1368     if {$ids != $diffids} {
1369         gettreediffs $diffids
1370         return
1371     }
1372     foreach f $treediffs($ids) {
1373         $cflist insert end $f
1374     }
1375     getblobdiffs $ids
1376 }
1377
1378 proc gettreediffs {ids} {
1379     global treediffs parents treepending
1380     set treepending $ids
1381     set treediffs($ids) {}
1382     set id [lindex $ids 0]
1383     set p [lindex $ids 1]
1384     if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1385     fconfigure $gdtf -blocking 0
1386     fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1387 }
1388
1389 proc gettreediffline {gdtf ids} {
1390     global treediffs treepending
1391     set n [gets $gdtf line]
1392     if {$n < 0} {
1393         if {![eof $gdtf]} return
1394         close $gdtf
1395         unset treepending
1396         addtocflist $ids
1397         return
1398     }
1399     set file [lindex $line 5]
1400     lappend treediffs($ids) $file
1401 }
1402
1403 proc getblobdiffs {ids} {
1404     global diffopts blobdifffd env curdifftag curtagstart
1405     global diffindex difffilestart nextupdate
1406
1407     set id [lindex $ids 0]
1408     set p [lindex $ids 1]
1409     set env(GIT_DIFF_OPTS) $diffopts
1410     if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1411         puts "error getting diffs: $err"
1412         return
1413     }
1414     fconfigure $bdf -blocking 0
1415     set blobdifffd($ids) $bdf
1416     set curdifftag Comments
1417     set curtagstart 0.0
1418     set diffindex 0
1419     catch {unset difffilestart}
1420     fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1421     set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1422 }
1423
1424 proc getblobdiffline {bdf ids} {
1425     global diffids blobdifffd ctext curdifftag curtagstart seenfile
1426     global diffnexthead diffnextnote diffindex difffilestart
1427     global nextupdate
1428
1429     set n [gets $bdf line]
1430     if {$n < 0} {
1431         if {[eof $bdf]} {
1432             close $bdf
1433             if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
1434                 $ctext tag add $curdifftag $curtagstart end
1435                 set seenfile($curdifftag) 1
1436             }
1437         }
1438         return
1439     }
1440     if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
1441         return
1442     }
1443     $ctext conf -state normal
1444     if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1445         # start of a new file
1446         $ctext insert end "\n"
1447         $ctext tag add $curdifftag $curtagstart end
1448         set seenfile($curdifftag) 1
1449         set curtagstart [$ctext index "end - 1c"]
1450         set header $fname
1451         if {[info exists diffnexthead]} {
1452             set fname $diffnexthead
1453             set header "$diffnexthead ($diffnextnote)"
1454             unset diffnexthead
1455         }
1456         set here [$ctext index "end - 1c"]
1457         set difffilestart($diffindex) $here
1458         incr diffindex
1459         # start mark names at fmark.1 for first file
1460         $ctext mark set fmark.$diffindex $here
1461         $ctext mark gravity fmark.$diffindex left
1462         set curdifftag "f:$fname"
1463         $ctext tag delete $curdifftag
1464         set l [expr {(78 - [string length $header]) / 2}]
1465         set pad [string range "----------------------------------------" 1 $l]
1466         $ctext insert end "$pad $header $pad\n" filesep
1467     } elseif {[string range $line 0 2] == "+++"} {
1468         # no need to do anything with this
1469     } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1470         set diffnexthead $fn
1471         set diffnextnote "created, mode $m"
1472     } elseif {[string range $line 0 8] == "Deleted: "} {
1473         set diffnexthead [string range $line 9 end]
1474         set diffnextnote "deleted"
1475     } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1476         # save the filename in case the next thing is "new file mode ..."
1477         set diffnexthead $fn
1478         set diffnextnote "modified"
1479     } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1480         set diffnextnote "new file, mode $m"
1481     } elseif {[string range $line 0 11] == "deleted file"} {
1482         set diffnextnote "deleted"
1483     } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1484                    $line match f1l f1c f2l f2c rest]} {
1485         $ctext insert end "\t" hunksep
1486         $ctext insert end "    $f1l    " d0 "    $f2l    " d1
1487         $ctext insert end "    $rest \n" hunksep
1488     } else {
1489         set x [string range $line 0 0]
1490         if {$x == "-" || $x == "+"} {
1491             set tag [expr {$x == "+"}]
1492             set line [string range $line 1 end]
1493             $ctext insert end "$line\n" d$tag
1494         } elseif {$x == " "} {
1495             set line [string range $line 1 end]
1496             $ctext insert end "$line\n"
1497         } elseif {$x == "\\"} {
1498             # e.g. "\ No newline at end of file"
1499             $ctext insert end "$line\n" filesep
1500         } else {
1501             # Something else we don't recognize
1502             if {$curdifftag != "Comments"} {
1503                 $ctext insert end "\n"
1504                 $ctext tag add $curdifftag $curtagstart end
1505                 set seenfile($curdifftag) 1
1506                 set curtagstart [$ctext index "end - 1c"]
1507                 set curdifftag Comments
1508             }
1509             $ctext insert end "$line\n" filesep
1510         }
1511     }
1512     $ctext conf -state disabled
1513     if {[clock clicks -milliseconds] >= $nextupdate} {
1514         incr nextupdate 100
1515         fileevent $bdf readable {}
1516         update
1517         fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1518     }
1519 }
1520
1521 proc nextfile {} {
1522     global difffilestart ctext
1523     set here [$ctext index @0,0]
1524     for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1525         if {[$ctext compare $difffilestart($i) > $here]} {
1526             $ctext yview $difffilestart($i)
1527             break
1528         }
1529     }
1530 }
1531
1532 proc listboxsel {} {
1533     global ctext cflist currentid treediffs seenfile
1534     if {![info exists currentid]} return
1535     set sel [lsort [$cflist curselection]]
1536     if {$sel eq {}} return
1537     set first [lindex $sel 0]
1538     catch {$ctext yview fmark.$first}
1539 }
1540
1541 proc setcoords {} {
1542     global linespc charspc canvx0 canvy0 mainfont
1543     set linespc [font metrics $mainfont -linespace]
1544     set charspc [font measure $mainfont "m"]
1545     set canvy0 [expr 3 + 0.5 * $linespc]
1546     set canvx0 [expr 3 + 0.5 * $linespc]
1547 }
1548
1549 proc redisplay {} {
1550     global selectedline stopped redisplaying phase
1551     if {$stopped > 1} return
1552     if {$phase == "getcommits"} return
1553     set redisplaying 1
1554     if {$phase == "drawgraph" || $phase == "incrdraw"} {
1555         set stopped 1
1556     } else {
1557         drawgraph
1558     }
1559 }
1560
1561 proc incrfont {inc} {
1562     global mainfont namefont textfont selectedline ctext canv phase
1563     global stopped entries
1564     unmarkmatches
1565     set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1566     set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1567     set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1568     setcoords
1569     $ctext conf -font $textfont
1570     $ctext tag conf filesep -font [concat $textfont bold]
1571     foreach e $entries {
1572         $e conf -font $mainfont
1573     }
1574     if {$phase == "getcommits"} {
1575         $canv itemconf textitems -font $mainfont
1576     }
1577     redisplay
1578 }
1579
1580 proc clearsha1 {} {
1581     global sha1entry sha1string
1582     if {[string length $sha1string] == 40} {
1583         $sha1entry delete 0 end
1584     }
1585 }
1586
1587 proc sha1change {n1 n2 op} {
1588     global sha1string currentid sha1but
1589     if {$sha1string == {}
1590         || ([info exists currentid] && $sha1string == $currentid)} {
1591         set state disabled
1592     } else {
1593         set state normal
1594     }
1595     if {[$sha1but cget -state] == $state} return
1596     if {$state == "normal"} {
1597         $sha1but conf -state normal -relief raised -text "Goto: "
1598     } else {
1599         $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1600     }
1601 }
1602
1603 proc gotocommit {} {
1604     global sha1string currentid idline tagids
1605     if {$sha1string == {}
1606         || ([info exists currentid] && $sha1string == $currentid)} return
1607     if {[info exists tagids($sha1string)]} {
1608         set id $tagids($sha1string)
1609     } else {
1610         set id [string tolower $sha1string]
1611     }
1612     if {[info exists idline($id)]} {
1613         selectline $idline($id)
1614         return
1615     }
1616     if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1617         set type "SHA1 id"
1618     } else {
1619         set type "Tag"
1620     }
1621     error_popup "$type $sha1string is not known"
1622 }
1623
1624 proc lineenter {x y id} {
1625     global hoverx hovery hoverid hovertimer
1626     global commitinfo canv
1627
1628     if {![info exists commitinfo($id)]} return
1629     set hoverx $x
1630     set hovery $y
1631     set hoverid $id
1632     if {[info exists hovertimer]} {
1633         after cancel $hovertimer
1634     }
1635     set hovertimer [after 500 linehover]
1636     $canv delete hover
1637 }
1638
1639 proc linemotion {x y id} {
1640     global hoverx hovery hoverid hovertimer
1641
1642     if {[info exists hoverid] && $id == $hoverid} {
1643         set hoverx $x
1644         set hovery $y
1645         if {[info exists hovertimer]} {
1646             after cancel $hovertimer
1647         }
1648         set hovertimer [after 500 linehover]
1649     }
1650 }
1651
1652 proc lineleave {id} {
1653     global hoverid hovertimer canv
1654
1655     if {[info exists hoverid] && $id == $hoverid} {
1656         $canv delete hover
1657         if {[info exists hovertimer]} {
1658             after cancel $hovertimer
1659             unset hovertimer
1660         }
1661         unset hoverid
1662     }
1663 }
1664
1665 proc linehover {} {
1666     global hoverx hovery hoverid hovertimer
1667     global canv linespc lthickness
1668     global commitinfo mainfont
1669
1670     set text [lindex $commitinfo($hoverid) 0]
1671     set ymax [lindex [$canv cget -scrollregion] 3]
1672     if {$ymax == {}} return
1673     set yfrac [lindex [$canv yview] 0]
1674     set x [expr {$hoverx + 2 * $linespc}]
1675     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
1676     set x0 [expr {$x - 2 * $lthickness}]
1677     set y0 [expr {$y - 2 * $lthickness}]
1678     set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
1679     set y1 [expr {$y + $linespc + 2 * $lthickness}]
1680     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
1681                -fill \#ffff80 -outline black -width 1 -tags hover]
1682     $canv raise $t
1683     set t [$canv create text $x $y -anchor nw -text $text -tags hover]
1684     $canv raise $t
1685 }
1686
1687 proc lineclick {x y id} {
1688     global ctext commitinfo children cflist canv
1689
1690     unmarkmatches
1691     $canv delete hover
1692     # fill the details pane with info about this line
1693     $ctext conf -state normal
1694     $ctext delete 0.0 end
1695     $ctext insert end "Parent:\n "
1696     catch {destroy $ctext.$id}
1697     button $ctext.$id -text "Go:" -command "selbyid $id" \
1698         -padx 4 -pady 0
1699     $ctext window create end -window $ctext.$id -align center
1700     set info $commitinfo($id)
1701     $ctext insert end "\t[lindex $info 0]\n"
1702     $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
1703     $ctext insert end "\tDate:\t[lindex $info 2]\n"
1704     $ctext insert end "\tID:\t$id\n"
1705     if {[info exists children($id)]} {
1706         $ctext insert end "\nChildren:"
1707         foreach child $children($id) {
1708             $ctext insert end "\n "
1709             catch {destroy $ctext.$child}
1710             button $ctext.$child -text "Go:" -command "selbyid $child" \
1711                 -padx 4 -pady 0
1712             $ctext window create end -window $ctext.$child -align center
1713             set info $commitinfo($child)
1714             $ctext insert end "\t[lindex $info 0]"
1715         }
1716     }
1717     $ctext conf -state disabled
1718
1719     $cflist delete 0 end
1720 }
1721
1722 proc selbyid {id} {
1723     global idline
1724     if {[info exists idline($id)]} {
1725         selectline $idline($id)
1726     }
1727 }
1728
1729 proc mstime {} {
1730     global startmstime
1731     if {![info exists startmstime]} {
1732         set startmstime [clock clicks -milliseconds]
1733     }
1734     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
1735 }
1736
1737 proc rowmenu {x y id} {
1738     global rowctxmenu idline selectedline rowmenuid
1739
1740     if {![info exists selectedline] || $idline($id) eq $selectedline} {
1741         set state disabled
1742     } else {
1743         set state normal
1744     }
1745     $rowctxmenu entryconfigure 0 -state $state
1746     $rowctxmenu entryconfigure 1 -state $state
1747     set rowmenuid $id
1748     tk_popup $rowctxmenu $x $y
1749 }
1750
1751 proc diffvssel {dirn} {
1752     global rowmenuid selectedline lineid
1753     global ctext cflist
1754     global diffids commitinfo
1755
1756     if {![info exists selectedline]} return
1757     if {$dirn} {
1758         set oldid $lineid($selectedline)
1759         set newid $rowmenuid
1760     } else {
1761         set oldid $rowmenuid
1762         set newid $lineid($selectedline)
1763     }
1764     $ctext conf -state normal
1765     $ctext delete 0.0 end
1766     $ctext mark set fmark.0 0.0
1767     $ctext mark gravity fmark.0 left
1768     $cflist delete 0 end
1769     $cflist insert end "Top"
1770     $ctext insert end "From $oldid\n     "
1771     $ctext insert end [lindex $commitinfo($oldid) 0]
1772     $ctext insert end "\n\nTo   $newid\n     "
1773     $ctext insert end [lindex $commitinfo($newid) 0]
1774     $ctext insert end "\n"
1775     $ctext conf -state disabled
1776     $ctext tag delete Comments
1777     $ctext tag remove found 1.0 end
1778     set diffids [list $newid $oldid]
1779     startdiff
1780 }
1781
1782 proc doquit {} {
1783     global stopped
1784     set stopped 100
1785     destroy .
1786 }
1787
1788 # defaults...
1789 set datemode 0
1790 set boldnames 0
1791 set diffopts "-U 5 -p"
1792
1793 set mainfont {Helvetica 9}
1794 set textfont {Courier 9}
1795
1796 set colors {green red blue magenta darkgrey brown orange}
1797
1798 catch {source ~/.gitk}
1799
1800 set namefont $mainfont
1801 if {$boldnames} {
1802     lappend namefont bold
1803 }
1804
1805 set revtreeargs {}
1806 foreach arg $argv {
1807     switch -regexp -- $arg {
1808         "^$" { }
1809         "^-b" { set boldnames 1 }
1810         "^-d" { set datemode 1 }
1811         default {
1812             lappend revtreeargs $arg
1813         }
1814     }
1815 }
1816
1817 set stopped 0
1818 set redisplaying 0
1819 set stuffsaved 0
1820 setcoords
1821 makewindow
1822 readrefs
1823 getcommits $revtreeargs