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             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 {{noread 0}} {
 898     global parents children nchildren ncleft todo
 899     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 900     global datemode cdate
 901     global 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 {![info exists commitinfo($p)]} {
 920                     if {$noread} {
 921                         return {}
 922                     }
 923                     readcommit $p
 924                 }
 925                 if {$latest == {} || $cdate($p) > $latest} {
 926                     set level $k
 927                     set latest $cdate($p)
 928                 }
 929             } else {
 930                 set level $k
 931                 break
 932             }
 933         }
 934     }
 935     if {$level < 0} {
 936         if {$todo != {}} {
 937             puts "ERROR: none of the pending commits can be done yet:"
 938             foreach p $todo {
 939                 puts "  $p ($ncleft($p))"
 940             }
 941         }
 942         return -1
 943     }
 944
 945     # If we are reducing, put in a null entry
 946     if {$todol < $oldnlines} {
 947         if {$nullentry >= 0} {
 948             set i $nullentry
 949             while {$i < $todol
 950                    && [lindex $oldtodo $i] == [lindex $todo $i]} {
 951                 incr i
 952             }
 953         } else {
 954             set i $oldlevel
 955             if {$level >= $i} {
 956                 incr i
 957             }
 958         }
 959         if {$i < $todol} {
 960             set todo [linsert $todo $i {}]
 961             if {$level >= $i} {
 962                 incr level
 963             }
 964         }
 965     }
 966     return $level
 967 }
 968
 969 proc drawcommit {id} {
 970     global phase todo nchildren datemode nextupdate
 971     global startcommits
 972
 973     if {$phase != "incrdraw"} {
 974         set phase incrdraw
 975         set todo $id
 976         set startcommits $id
 977         initgraph
 978         drawcommitline 0
 979         updatetodo 0 $datemode
 980     } else {
 981         if {$nchildren($id) == 0} {
 982             lappend todo $id
 983             lappend startcommits $id
 984         }
 985         set level [decidenext 1]
 986         if {$level == {} || $id != [lindex $todo $level]} {
 987             return
 988         }
 989         while 1 {
 990             drawslants
 991             drawcommitline $level
 992             if {[updatetodo $level $datemode]} {
 993                 set level [decidenext 1]
 994                 if {$level == {}} break
 995             }
 996             set id [lindex $todo $level]
 997             if {![info exists commitlisted($id)]} {
 998                 break
 999             }
1000             if {[clock clicks -milliseconds] >= $nextupdate} {
1001                 doupdate
1002                 if {$stopped} break
1003             }
1004         }
1005     }
1006 }
1007
1008 proc finishcommits {} {
1009     global phase
1010     global startcommits
1011     global canv mainfont ctext maincursor textcursor
1012
1013     if {$phase != "incrdraw"} {
1014         $canv delete all
1015         $canv create text 3 3 -anchor nw -text "No commits selected" \
1016             -font $mainfont -tags textitems
1017         set phase {}
1018     } else {
1019         drawslants
1020         set level [decidenext]
1021         drawrest $level [llength $startcommits]
1022     }
1023     . config -cursor $maincursor
1024     $ctext config -cursor $textcursor
1025 }
1026
1027 proc drawgraph {} {
1028     global nextupdate startmsecs startcommits todo
1029
1030     if {$startcommits == {}} return
1031     set startmsecs [clock clicks -milliseconds]
1032     set nextupdate [expr $startmsecs + 100]
1033     initgraph
1034     set todo [lindex $startcommits 0]
1035     drawrest 0 1
1036 }
1037
1038 proc drawrest {level startix} {
1039     global phase stopped redisplaying selectedline
1040     global datemode currentparents todo
1041     global numcommits
1042     global nextupdate startmsecs startcommits idline
1043
1044     if {$level >= 0} {
1045         set phase drawgraph
1046         set startid [lindex $startcommits $startix]
1047         set startline -1
1048         if {$startid != {}} {
1049             set startline $idline($startid)
1050         }
1051         while 1 {
1052             if {$stopped} break
1053             drawcommitline $level
1054             set hard [updatetodo $level $datemode]
1055             if {$numcommits == $startline} {
1056                 lappend todo $startid
1057                 set hard 1
1058                 incr startix
1059                 set startid [lindex $startcommits $startix]
1060                 set startline -1
1061                 if {$startid != {}} {
1062                     set startline $idline($startid)
1063                 }
1064             }
1065             if {$hard} {
1066                 set level [decidenext]
1067                 if {$level < 0} break
1068                 drawslants
1069             }
1070             if {[clock clicks -milliseconds] >= $nextupdate} {
1071                 update
1072                 incr nextupdate 100
1073             }
1074         }
1075     }
1076     set phase {}
1077     set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1078     #puts "overall $drawmsecs ms for $numcommits commits"
1079     if {$redisplaying} {
1080         if {$stopped == 0 && [info exists selectedline]} {
1081             selectline $selectedline
1082         }
1083         if {$stopped == 1} {
1084             set stopped 0
1085             after idle drawgraph
1086         } else {
1087             set redisplaying 0
1088         }
1089     }
1090 }
1091
1092 proc findmatches {f} {
1093     global findtype foundstring foundstrlen
1094     if {$findtype == "Regexp"} {
1095         set matches [regexp -indices -all -inline $foundstring $f]
1096     } else {
1097         if {$findtype == "IgnCase"} {
1098             set str [string tolower $f]
1099         } else {
1100             set str $f
1101         }
1102         set matches {}
1103         set i 0
1104         while {[set j [string first $foundstring $str $i]] >= 0} {
1105             lappend matches [list $j [expr $j+$foundstrlen-1]]
1106             set i [expr $j + $foundstrlen]
1107         }
1108     }
1109     return $matches
1110 }
1111
1112 proc dofind {} {
1113     global findtype findloc findstring markedmatches commitinfo
1114     global numcommits lineid linehtag linentag linedtag
1115     global mainfont namefont canv canv2 canv3 selectedline
1116     global matchinglines foundstring foundstrlen
1117     unmarkmatches
1118     focus .
1119     set matchinglines {}
1120     set fldtypes {Headline Author Date Committer CDate Comment}
1121     if {$findtype == "IgnCase"} {
1122         set foundstring [string tolower $findstring]
1123     } else {
1124         set foundstring $findstring
1125     }
1126     set foundstrlen [string length $findstring]
1127     if {$foundstrlen == 0} return
1128     if {![info exists selectedline]} {
1129         set oldsel -1
1130     } else {
1131         set oldsel $selectedline
1132     }
1133     set didsel 0
1134     for {set l 0} {$l < $numcommits} {incr l} {
1135         set id $lineid($l)
1136         set info $commitinfo($id)
1137         set doesmatch 0
1138         foreach f $info ty $fldtypes {
1139             if {$findloc != "All fields" && $findloc != $ty} {
1140                 continue
1141             }
1142             set matches [findmatches $f]
1143             if {$matches == {}} continue
1144             set doesmatch 1
1145             if {$ty == "Headline"} {
1146                 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1147             } elseif {$ty == "Author"} {
1148                 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1149             } elseif {$ty == "Date"} {
1150                 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1151             }
1152         }
1153         if {$doesmatch} {
1154             lappend matchinglines $l
1155             if {!$didsel && $l > $oldsel} {
1156                 findselectline $l
1157                 set didsel 1
1158             }
1159         }
1160     }
1161     if {$matchinglines == {}} {
1162         bell
1163     } elseif {!$didsel} {
1164         findselectline [lindex $matchinglines 0]
1165     }
1166 }
1167
1168 proc findselectline {l} {
1169     global findloc commentend ctext
1170     selectline $l
1171     if {$findloc == "All fields" || $findloc == "Comments"} {
1172         # highlight the matches in the comments
1173         set f [$ctext get 1.0 $commentend]
1174         set matches [findmatches $f]
1175         foreach match $matches {
1176             set start [lindex $match 0]
1177             set end [expr [lindex $match 1] + 1]
1178             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1179         }
1180     }
1181 }
1182
1183 proc findnext {} {
1184     global matchinglines selectedline
1185     if {![info exists matchinglines]} {
1186         dofind
1187         return
1188     }
1189     if {![info exists selectedline]} return
1190     foreach l $matchinglines {
1191         if {$l > $selectedline} {
1192             findselectline $l
1193             return
1194         }
1195     }
1196     bell
1197 }
1198
1199 proc findprev {} {
1200     global matchinglines selectedline
1201     if {![info exists matchinglines]} {
1202         dofind
1203         return
1204     }
1205     if {![info exists selectedline]} return
1206     set prev {}
1207     foreach l $matchinglines {
1208         if {$l >= $selectedline} break
1209         set prev $l
1210     }
1211     if {$prev != {}} {
1212         findselectline $prev
1213     } else {
1214         bell
1215     }
1216 }
1217
1218 proc markmatches {canv l str tag matches font} {
1219     set bbox [$canv bbox $tag]
1220     set x0 [lindex $bbox 0]
1221     set y0 [lindex $bbox 1]
1222     set y1 [lindex $bbox 3]
1223     foreach match $matches {
1224         set start [lindex $match 0]
1225         set end [lindex $match 1]
1226         if {$start > $end} continue
1227         set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1228         set xlen [font measure $font [string range $str 0 [expr $end]]]
1229         set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1230                    -outline {} -tags matches -fill yellow]
1231         $canv lower $t
1232     }
1233 }
1234
1235 proc unmarkmatches {} {
1236     global matchinglines
1237     allcanvs delete matches
1238     catch {unset matchinglines}
1239 }
1240
1241 proc selcanvline {w x y} {
1242     global canv canvy0 ctext linespc selectedline
1243     global lineid linehtag linentag linedtag rowtextx
1244     set ymax [lindex [$canv cget -scrollregion] 3]
1245     if {$ymax == {}} return
1246     set yfrac [lindex [$canv yview] 0]
1247     set y [expr {$y + $yfrac * $ymax}]
1248     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1249     if {$l < 0} {
1250         set l 0
1251     }
1252     if {$w eq $canv} {
1253         if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1254     }
1255     unmarkmatches
1256     selectline $l
1257 }
1258
1259 proc selectline {l} {
1260     global canv canv2 canv3 ctext commitinfo selectedline
1261     global lineid linehtag linentag linedtag
1262     global canvy0 linespc parents nparents
1263     global cflist currentid sha1entry diffids
1264     global commentend seenfile idtags
1265     $canv delete hover
1266     if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1267     $canv delete secsel
1268     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1269                -tags secsel -fill [$canv cget -selectbackground]]
1270     $canv lower $t
1271     $canv2 delete secsel
1272     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1273                -tags secsel -fill [$canv2 cget -selectbackground]]
1274     $canv2 lower $t
1275     $canv3 delete secsel
1276     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1277                -tags secsel -fill [$canv3 cget -selectbackground]]
1278     $canv3 lower $t
1279     set y [expr {$canvy0 + $l * $linespc}]
1280     set ymax [lindex [$canv cget -scrollregion] 3]
1281     set ytop [expr {$y - $linespc - 1}]
1282     set ybot [expr {$y + $linespc + 1}]
1283     set wnow [$canv yview]
1284     set wtop [expr [lindex $wnow 0] * $ymax]
1285     set wbot [expr [lindex $wnow 1] * $ymax]
1286     set wh [expr {$wbot - $wtop}]
1287     set newtop $wtop
1288     if {$ytop < $wtop} {
1289         if {$ybot < $wtop} {
1290             set newtop [expr {$y - $wh / 2.0}]
1291         } else {
1292             set newtop $ytop
1293             if {$newtop > $wtop - $linespc} {
1294                 set newtop [expr {$wtop - $linespc}]
1295             }
1296         }
1297     } elseif {$ybot > $wbot} {
1298         if {$ytop > $wbot} {
1299             set newtop [expr {$y - $wh / 2.0}]
1300         } else {
1301             set newtop [expr {$ybot - $wh}]
1302             if {$newtop < $wtop + $linespc} {
1303                 set newtop [expr {$wtop + $linespc}]
1304             }
1305         }
1306     }
1307     if {$newtop != $wtop} {
1308         if {$newtop < 0} {
1309             set newtop 0
1310         }
1311         allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1312     }
1313     set selectedline $l
1314
1315     set id $lineid($l)
1316     set currentid $id
1317     set diffids [concat $id $parents($id)]
1318     $sha1entry delete 0 end
1319     $sha1entry insert 0 $id
1320     $sha1entry selection from 0
1321     $sha1entry selection to end
1322
1323     $ctext conf -state normal
1324     $ctext delete 0.0 end
1325     $ctext mark set fmark.0 0.0
1326     $ctext mark gravity fmark.0 left
1327     set info $commitinfo($id)
1328     $ctext insert end "Author: [lindex $info 1]  [lindex $info 2]\n"
1329     $ctext insert end "Committer: [lindex $info 3]  [lindex $info 4]\n"
1330     if {[info exists idtags($id)]} {
1331         $ctext insert end "Tags:"
1332         foreach tag $idtags($id) {
1333             $ctext insert end " $tag"
1334         }
1335         $ctext insert end "\n"
1336     }
1337     $ctext insert end "\n"
1338     $ctext insert end [lindex $info 5]
1339     $ctext insert end "\n"
1340     $ctext tag delete Comments
1341     $ctext tag remove found 1.0 end
1342     $ctext conf -state disabled
1343     set commentend [$ctext index "end - 1c"]
1344
1345     $cflist delete 0 end
1346     $cflist insert end "Comments"
1347     if {$nparents($id) == 1} {
1348         startdiff
1349     }
1350     catch {unset seenfile}
1351 }
1352
1353 proc startdiff {} {
1354     global treediffs diffids treepending
1355
1356     if {![info exists treediffs($diffids)]} {
1357         if {![info exists treepending]} {
1358             gettreediffs $diffids
1359         }
1360     } else {
1361         addtocflist $diffids
1362     }
1363 }
1364
1365 proc selnextline {dir} {
1366     global selectedline
1367     if {![info exists selectedline]} return
1368     set l [expr $selectedline + $dir]
1369     unmarkmatches
1370     selectline $l
1371 }
1372
1373 proc addtocflist {ids} {
1374     global diffids treediffs cflist
1375     if {$ids != $diffids} {
1376         gettreediffs $diffids
1377         return
1378     }
1379     foreach f $treediffs($ids) {
1380         $cflist insert end $f
1381     }
1382     getblobdiffs $ids
1383 }
1384
1385 proc gettreediffs {ids} {
1386     global treediffs parents treepending
1387     set treepending $ids
1388     set treediffs($ids) {}
1389     set id [lindex $ids 0]
1390     set p [lindex $ids 1]
1391     if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1392     fconfigure $gdtf -blocking 0
1393     fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1394 }
1395
1396 proc gettreediffline {gdtf ids} {
1397     global treediffs treepending
1398     set n [gets $gdtf line]
1399     if {$n < 0} {
1400         if {![eof $gdtf]} return
1401         close $gdtf
1402         unset treepending
1403         addtocflist $ids
1404         return
1405     }
1406     set file [lindex $line 5]
1407     lappend treediffs($ids) $file
1408 }
1409
1410 proc getblobdiffs {ids} {
1411     global diffopts blobdifffd env curdifftag curtagstart
1412     global diffindex difffilestart nextupdate
1413
1414     set id [lindex $ids 0]
1415     set p [lindex $ids 1]
1416     set env(GIT_DIFF_OPTS) $diffopts
1417     if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1418         puts "error getting diffs: $err"
1419         return
1420     }
1421     fconfigure $bdf -blocking 0
1422     set blobdifffd($ids) $bdf
1423     set curdifftag Comments
1424     set curtagstart 0.0
1425     set diffindex 0
1426     catch {unset difffilestart}
1427     fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1428     set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1429 }
1430
1431 proc getblobdiffline {bdf ids} {
1432     global diffids blobdifffd ctext curdifftag curtagstart seenfile
1433     global diffnexthead diffnextnote diffindex difffilestart
1434     global nextupdate
1435
1436     set n [gets $bdf line]
1437     if {$n < 0} {
1438         if {[eof $bdf]} {
1439             close $bdf
1440             if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
1441                 $ctext tag add $curdifftag $curtagstart end
1442                 set seenfile($curdifftag) 1
1443             }
1444         }
1445         return
1446     }
1447     if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
1448         return
1449     }
1450     $ctext conf -state normal
1451     if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1452         # start of a new file
1453         $ctext insert end "\n"
1454         $ctext tag add $curdifftag $curtagstart end
1455         set seenfile($curdifftag) 1
1456         set curtagstart [$ctext index "end - 1c"]
1457         set header $fname
1458         if {[info exists diffnexthead]} {
1459             set fname $diffnexthead
1460             set header "$diffnexthead ($diffnextnote)"
1461             unset diffnexthead
1462         }
1463         set here [$ctext index "end - 1c"]
1464         set difffilestart($diffindex) $here
1465         incr diffindex
1466         # start mark names at fmark.1 for first file
1467         $ctext mark set fmark.$diffindex $here
1468         $ctext mark gravity fmark.$diffindex left
1469         set curdifftag "f:$fname"
1470         $ctext tag delete $curdifftag
1471         set l [expr {(78 - [string length $header]) / 2}]
1472         set pad [string range "----------------------------------------" 1 $l]
1473         $ctext insert end "$pad $header $pad\n" filesep
1474     } elseif {[string range $line 0 2] == "+++"} {
1475         # no need to do anything with this
1476     } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1477         set diffnexthead $fn
1478         set diffnextnote "created, mode $m"
1479     } elseif {[string range $line 0 8] == "Deleted: "} {
1480         set diffnexthead [string range $line 9 end]
1481         set diffnextnote "deleted"
1482     } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1483         # save the filename in case the next thing is "new file mode ..."
1484         set diffnexthead $fn
1485         set diffnextnote "modified"
1486     } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1487         set diffnextnote "new file, mode $m"
1488     } elseif {[string range $line 0 11] == "deleted file"} {
1489         set diffnextnote "deleted"
1490     } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1491                    $line match f1l f1c f2l f2c rest]} {
1492         $ctext insert end "\t" hunksep
1493         $ctext insert end "    $f1l    " d0 "    $f2l    " d1
1494         $ctext insert end "    $rest \n" hunksep
1495     } else {
1496         set x [string range $line 0 0]
1497         if {$x == "-" || $x == "+"} {
1498             set tag [expr {$x == "+"}]
1499             set line [string range $line 1 end]
1500             $ctext insert end "$line\n" d$tag
1501         } elseif {$x == " "} {
1502             set line [string range $line 1 end]
1503             $ctext insert end "$line\n"
1504         } elseif {$x == "\\"} {
1505             # e.g. "\ No newline at end of file"
1506             $ctext insert end "$line\n" filesep
1507         } else {
1508             # Something else we don't recognize
1509             if {$curdifftag != "Comments"} {
1510                 $ctext insert end "\n"
1511                 $ctext tag add $curdifftag $curtagstart end
1512                 set seenfile($curdifftag) 1
1513                 set curtagstart [$ctext index "end - 1c"]
1514                 set curdifftag Comments
1515             }
1516             $ctext insert end "$line\n" filesep
1517         }
1518     }
1519     $ctext conf -state disabled
1520     if {[clock clicks -milliseconds] >= $nextupdate} {
1521         incr nextupdate 100
1522         fileevent $bdf readable {}
1523         update
1524         fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1525     }
1526 }
1527
1528 proc nextfile {} {
1529     global difffilestart ctext
1530     set here [$ctext index @0,0]
1531     for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1532         if {[$ctext compare $difffilestart($i) > $here]} {
1533             $ctext yview $difffilestart($i)
1534             break
1535         }
1536     }
1537 }
1538
1539 proc listboxsel {} {
1540     global ctext cflist currentid treediffs seenfile
1541     if {![info exists currentid]} return
1542     set sel [lsort [$cflist curselection]]
1543     if {$sel eq {}} return
1544     set first [lindex $sel 0]
1545     catch {$ctext yview fmark.$first}
1546 }
1547
1548 proc setcoords {} {
1549     global linespc charspc canvx0 canvy0 mainfont
1550     set linespc [font metrics $mainfont -linespace]
1551     set charspc [font measure $mainfont "m"]
1552     set canvy0 [expr 3 + 0.5 * $linespc]
1553     set canvx0 [expr 3 + 0.5 * $linespc]
1554 }
1555
1556 proc redisplay {} {
1557     global selectedline stopped redisplaying phase
1558     if {$stopped > 1} return
1559     if {$phase == "getcommits"} return
1560     set redisplaying 1
1561     if {$phase == "drawgraph" || $phase == "incrdraw"} {
1562         set stopped 1
1563     } else {
1564         drawgraph
1565     }
1566 }
1567
1568 proc incrfont {inc} {
1569     global mainfont namefont textfont selectedline ctext canv phase
1570     global stopped entries
1571     unmarkmatches
1572     set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1573     set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1574     set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1575     setcoords
1576     $ctext conf -font $textfont
1577     $ctext tag conf filesep -font [concat $textfont bold]
1578     foreach e $entries {
1579         $e conf -font $mainfont
1580     }
1581     if {$phase == "getcommits"} {
1582         $canv itemconf textitems -font $mainfont
1583     }
1584     redisplay
1585 }
1586
1587 proc clearsha1 {} {
1588     global sha1entry sha1string
1589     if {[string length $sha1string] == 40} {
1590         $sha1entry delete 0 end
1591     }
1592 }
1593
1594 proc sha1change {n1 n2 op} {
1595     global sha1string currentid sha1but
1596     if {$sha1string == {}
1597         || ([info exists currentid] && $sha1string == $currentid)} {
1598         set state disabled
1599     } else {
1600         set state normal
1601     }
1602     if {[$sha1but cget -state] == $state} return
1603     if {$state == "normal"} {
1604         $sha1but conf -state normal -relief raised -text "Goto: "
1605     } else {
1606         $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1607     }
1608 }
1609
1610 proc gotocommit {} {
1611     global sha1string currentid idline tagids
1612     if {$sha1string == {}
1613         || ([info exists currentid] && $sha1string == $currentid)} return
1614     if {[info exists tagids($sha1string)]} {
1615         set id $tagids($sha1string)
1616     } else {
1617         set id [string tolower $sha1string]
1618     }
1619     if {[info exists idline($id)]} {
1620         selectline $idline($id)
1621         return
1622     }
1623     if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1624         set type "SHA1 id"
1625     } else {
1626         set type "Tag"
1627     }
1628     error_popup "$type $sha1string is not known"
1629 }
1630
1631 proc lineenter {x y id} {
1632     global hoverx hovery hoverid hovertimer
1633     global commitinfo canv
1634
1635     if {![info exists commitinfo($id)]} return
1636     set hoverx $x
1637     set hovery $y
1638     set hoverid $id
1639     if {[info exists hovertimer]} {
1640         after cancel $hovertimer
1641     }
1642     set hovertimer [after 500 linehover]
1643     $canv delete hover
1644 }
1645
1646 proc linemotion {x y id} {
1647     global hoverx hovery hoverid hovertimer
1648
1649     if {[info exists hoverid] && $id == $hoverid} {
1650         set hoverx $x
1651         set hovery $y
1652         if {[info exists hovertimer]} {
1653             after cancel $hovertimer
1654         }
1655         set hovertimer [after 500 linehover]
1656     }
1657 }
1658
1659 proc lineleave {id} {
1660     global hoverid hovertimer canv
1661
1662     if {[info exists hoverid] && $id == $hoverid} {
1663         $canv delete hover
1664         if {[info exists hovertimer]} {
1665             after cancel $hovertimer
1666             unset hovertimer
1667         }
1668         unset hoverid
1669     }
1670 }
1671
1672 proc linehover {} {
1673     global hoverx hovery hoverid hovertimer
1674     global canv linespc lthickness
1675     global commitinfo mainfont
1676
1677     set text [lindex $commitinfo($hoverid) 0]
1678     set ymax [lindex [$canv cget -scrollregion] 3]
1679     if {$ymax == {}} return
1680     set yfrac [lindex [$canv yview] 0]
1681     set x [expr {$hoverx + 2 * $linespc}]
1682     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
1683     set x0 [expr {$x - 2 * $lthickness}]
1684     set y0 [expr {$y - 2 * $lthickness}]
1685     set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
1686     set y1 [expr {$y + $linespc + 2 * $lthickness}]
1687     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
1688                -fill \#ffff80 -outline black -width 1 -tags hover]
1689     $canv raise $t
1690     set t [$canv create text $x $y -anchor nw -text $text -tags hover]
1691     $canv raise $t
1692 }
1693
1694 proc lineclick {x y id} {
1695     global ctext commitinfo children cflist canv
1696
1697     unmarkmatches
1698     $canv delete hover
1699     # fill the details pane with info about this line
1700     $ctext conf -state normal
1701     $ctext delete 0.0 end
1702     $ctext insert end "Parent:\n "
1703     catch {destroy $ctext.$id}
1704     button $ctext.$id -text "Go:" -command "selbyid $id" \
1705         -padx 4 -pady 0
1706     $ctext window create end -window $ctext.$id -align center
1707     set info $commitinfo($id)
1708     $ctext insert end "\t[lindex $info 0]\n"
1709     $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
1710     $ctext insert end "\tDate:\t[lindex $info 2]\n"
1711     $ctext insert end "\tID:\t$id\n"
1712     if {[info exists children($id)]} {
1713         $ctext insert end "\nChildren:"
1714         foreach child $children($id) {
1715             $ctext insert end "\n "
1716             catch {destroy $ctext.$child}
1717             button $ctext.$child -text "Go:" -command "selbyid $child" \
1718                 -padx 4 -pady 0
1719             $ctext window create end -window $ctext.$child -align center
1720             set info $commitinfo($child)
1721             $ctext insert end "\t[lindex $info 0]"
1722         }
1723     }
1724     $ctext conf -state disabled
1725
1726     $cflist delete 0 end
1727 }
1728
1729 proc selbyid {id} {
1730     global idline
1731     if {[info exists idline($id)]} {
1732         selectline $idline($id)
1733     }
1734 }
1735
1736 proc mstime {} {
1737     global startmstime
1738     if {![info exists startmstime]} {
1739         set startmstime [clock clicks -milliseconds]
1740     }
1741     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
1742 }
1743
1744 proc rowmenu {x y id} {
1745     global rowctxmenu idline selectedline rowmenuid
1746
1747     if {![info exists selectedline] || $idline($id) eq $selectedline} {
1748         set state disabled
1749     } else {
1750         set state normal
1751     }
1752     $rowctxmenu entryconfigure 0 -state $state
1753     $rowctxmenu entryconfigure 1 -state $state
1754     set rowmenuid $id
1755     tk_popup $rowctxmenu $x $y
1756 }
1757
1758 proc diffvssel {dirn} {
1759     global rowmenuid selectedline lineid
1760     global ctext cflist
1761     global diffids commitinfo
1762
1763     if {![info exists selectedline]} return
1764     if {$dirn} {
1765         set oldid $lineid($selectedline)
1766         set newid $rowmenuid
1767     } else {
1768         set oldid $rowmenuid
1769         set newid $lineid($selectedline)
1770     }
1771     $ctext conf -state normal
1772     $ctext delete 0.0 end
1773     $ctext mark set fmark.0 0.0
1774     $ctext mark gravity fmark.0 left
1775     $cflist delete 0 end
1776     $cflist insert end "Top"
1777     $ctext insert end "From $oldid\n     "
1778     $ctext insert end [lindex $commitinfo($oldid) 0]
1779     $ctext insert end "\n\nTo   $newid\n     "
1780     $ctext insert end [lindex $commitinfo($newid) 0]
1781     $ctext insert end "\n"
1782     $ctext conf -state disabled
1783     $ctext tag delete Comments
1784     $ctext tag remove found 1.0 end
1785     set diffids [list $newid $oldid]
1786     startdiff
1787 }
1788
1789 proc doquit {} {
1790     global stopped
1791     set stopped 100
1792     destroy .
1793 }
1794
1795 # defaults...
1796 set datemode 0
1797 set boldnames 0
1798 set diffopts "-U 5 -p"
1799
1800 set mainfont {Helvetica 9}
1801 set textfont {Courier 9}
1802
1803 set colors {green red blue magenta darkgrey brown orange}
1804
1805 catch {source ~/.gitk}
1806
1807 set namefont $mainfont
1808 if {$boldnames} {
1809     lappend namefont bold
1810 }
1811
1812 set revtreeargs {}
1813 foreach arg $argv {
1814     switch -regexp -- $arg {
1815         "^$" { }
1816         "^-b" { set boldnames 1 }
1817         "^-d" { set datemode 1 }
1818         default {
1819             lappend revtreeargs $arg
1820         }
1821     }
1822 }
1823
1824 set stopped 0
1825 set redisplaying 0
1826 set stuffsaved 0
1827 setcoords
1828 makewindow
1829 readrefs
1830 getcommits $revtreeargs