git.oblomov.eu Git - git/blob - gitk

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