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