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 findtypemenu 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     set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
 346                           findtype Exact IgnCase Regexp]
 347     set findloc "All fields"
 348     tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
 349         Comments Author Committer Files Pickaxe
 350     pack .ctop.top.bar.findloc -side right
 351     pack .ctop.top.bar.findtype -side right
 352     # for making sure type==Exact whenever loc==Pickaxe
 353     trace add variable findloc write findlocchange
 354
 355     panedwindow .ctop.cdet -orient horizontal
 356     .ctop add .ctop.cdet
 357     frame .ctop.cdet.left
 358     set ctext .ctop.cdet.left.ctext
 359     text $ctext -bg white -state disabled -font $textfont \
 360         -width $geometry(ctextw) -height $geometry(ctexth) \
 361         -yscrollcommand ".ctop.cdet.left.sb set"
 362     scrollbar .ctop.cdet.left.sb -command "$ctext yview"
 363     pack .ctop.cdet.left.sb -side right -fill y
 364     pack $ctext -side left -fill both -expand 1
 365     .ctop.cdet add .ctop.cdet.left
 366
 367     $ctext tag conf filesep -font [concat $textfont bold]
 368     $ctext tag conf hunksep -back blue -fore white
 369     $ctext tag conf d0 -back "#ff8080"
 370     $ctext tag conf d1 -back green
 371     $ctext tag conf found -back yellow
 372
 373     frame .ctop.cdet.right
 374     set cflist .ctop.cdet.right.cfiles
 375     listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
 376         -yscrollcommand ".ctop.cdet.right.sb set"
 377     scrollbar .ctop.cdet.right.sb -command "$cflist yview"
 378     pack .ctop.cdet.right.sb -side right -fill y
 379     pack $cflist -side left -fill both -expand 1
 380     .ctop.cdet add .ctop.cdet.right
 381     bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
 382
 383     pack .ctop -side top -fill both -expand 1
 384
 385     bindall <1> {selcanvline %W %x %y}
 386     #bindall <B1-Motion> {selcanvline %W %x %y}
 387     bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
 388     bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
 389     bindall <2> "allcanvs scan mark 0 %y"
 390     bindall <B2-Motion> "allcanvs scan dragto 0 %y"
 391     bind . <Key-Up> "selnextline -1"
 392     bind . <Key-Down> "selnextline 1"
 393     bind . <Key-Prior> "allcanvs yview scroll -1 pages"
 394     bind . <Key-Next> "allcanvs yview scroll 1 pages"
 395     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
 396     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
 397     bindkey <Key-space> "$ctext yview scroll 1 pages"
 398     bindkey p "selnextline -1"
 399     bindkey n "selnextline 1"
 400     bindkey b "$ctext yview scroll -1 pages"
 401     bindkey d "$ctext yview scroll 18 units"
 402     bindkey u "$ctext yview scroll -18 units"
 403     bindkey / {findnext 1}
 404     bindkey <Key-Return> {findnext 0}
 405     bindkey ? findprev
 406     bindkey f nextfile
 407     bind . <Control-q> doquit
 408     bind . <Control-f> dofind
 409     bind . <Control-g> {findnext 0}
 410     bind . <Control-r> findprev
 411     bind . <Control-equal> {incrfont 1}
 412     bind . <Control-KP_Add> {incrfont 1}
 413     bind . <Control-minus> {incrfont -1}
 414     bind . <Control-KP_Subtract> {incrfont -1}
 415     bind $cflist <<ListboxSelect>> listboxsel
 416     bind . <Destroy> {savestuff %W}
 417     bind . <Button-1> "click %W"
 418     bind $fstring <Key-Return> dofind
 419     bind $sha1entry <Key-Return> gotocommit
 420     bind $sha1entry <<PasteSelection>> clearsha1
 421
 422     set maincursor [. cget -cursor]
 423     set textcursor [$ctext cget -cursor]
 424
 425     set rowctxmenu .rowctxmenu
 426     menu $rowctxmenu -tearoff 0
 427     $rowctxmenu add command -label "Diff this -> selected" \
 428         -command {diffvssel 0}
 429     $rowctxmenu add command -label "Diff selected -> this" \
 430         -command {diffvssel 1}
 431     $rowctxmenu add command -label "Make patch" -command mkpatch
 432     $rowctxmenu add command -label "Create tag" -command mktag
 433     $rowctxmenu add command -label "Write commit to file" -command writecommit
 434 }
 435
 436 # when we make a key binding for the toplevel, make sure
 437 # it doesn't get triggered when that key is pressed in the
 438 # find string entry widget.
 439 proc bindkey {ev script} {
 440     global entries
 441     bind . $ev $script
 442     set escript [bind Entry $ev]
 443     if {$escript == {}} {
 444         set escript [bind Entry <Key>]
 445     }
 446     foreach e $entries {
 447         bind $e $ev "$escript; break"
 448     }
 449 }
 450
 451 # set the focus back to the toplevel for any click outside
 452 # the entry widgets
 453 proc click {w} {
 454     global entries
 455     foreach e $entries {
 456         if {$w == $e} return
 457     }
 458     focus .
 459 }
 460
 461 proc savestuff {w} {
 462     global canv canv2 canv3 ctext cflist mainfont textfont
 463     global stuffsaved
 464     if {$stuffsaved} return
 465     if {![winfo viewable .]} return
 466     catch {
 467         set f [open "~/.gitk-new" w]
 468         puts $f "set mainfont {$mainfont}"
 469         puts $f "set textfont {$textfont}"
 470         puts $f "set geometry(width) [winfo width .ctop]"
 471         puts $f "set geometry(height) [winfo height .ctop]"
 472         puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
 473         puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
 474         puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
 475         puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
 476         set wid [expr {([winfo width $ctext] - 8) \
 477                            / [font measure $textfont "0"]}]
 478         puts $f "set geometry(ctextw) $wid"
 479         set wid [expr {([winfo width $cflist] - 11) \
 480                            / [font measure [$cflist cget -font] "0"]}]
 481         puts $f "set geometry(cflistw) $wid"
 482         close $f
 483         file rename -force "~/.gitk-new" "~/.gitk"
 484     }
 485     set stuffsaved 1
 486 }
 487
 488 proc resizeclistpanes {win w} {
 489     global oldwidth
 490     if [info exists oldwidth($win)] {
 491         set s0 [$win sash coord 0]
 492         set s1 [$win sash coord 1]
 493         if {$w < 60} {
 494             set sash0 [expr {int($w/2 - 2)}]
 495             set sash1 [expr {int($w*5/6 - 2)}]
 496         } else {
 497             set factor [expr {1.0 * $w / $oldwidth($win)}]
 498             set sash0 [expr {int($factor * [lindex $s0 0])}]
 499             set sash1 [expr {int($factor * [lindex $s1 0])}]
 500             if {$sash0 < 30} {
 501                 set sash0 30
 502             }
 503             if {$sash1 < $sash0 + 20} {
 504                 set sash1 [expr $sash0 + 20]
 505             }
 506             if {$sash1 > $w - 10} {
 507                 set sash1 [expr $w - 10]
 508                 if {$sash0 > $sash1 - 20} {
 509                     set sash0 [expr $sash1 - 20]
 510                 }
 511             }
 512         }
 513         $win sash place 0 $sash0 [lindex $s0 1]
 514         $win sash place 1 $sash1 [lindex $s1 1]
 515     }
 516     set oldwidth($win) $w
 517 }
 518
 519 proc resizecdetpanes {win w} {
 520     global oldwidth
 521     if [info exists oldwidth($win)] {
 522         set s0 [$win sash coord 0]
 523         if {$w < 60} {
 524             set sash0 [expr {int($w*3/4 - 2)}]
 525         } else {
 526             set factor [expr {1.0 * $w / $oldwidth($win)}]
 527             set sash0 [expr {int($factor * [lindex $s0 0])}]
 528             if {$sash0 < 45} {
 529                 set sash0 45
 530             }
 531             if {$sash0 > $w - 15} {
 532                 set sash0 [expr $w - 15]
 533             }
 534         }
 535         $win sash place 0 $sash0 [lindex $s0 1]
 536     }
 537     set oldwidth($win) $w
 538 }
 539
 540 proc allcanvs args {
 541     global canv canv2 canv3
 542     eval $canv $args
 543     eval $canv2 $args
 544     eval $canv3 $args
 545 }
 546
 547 proc bindall {event action} {
 548     global canv canv2 canv3
 549     bind $canv $event $action
 550     bind $canv2 $event $action
 551     bind $canv3 $event $action
 552 }
 553
 554 proc about {} {
 555     set w .about
 556     if {[winfo exists $w]} {
 557         raise $w
 558         return
 559     }
 560     toplevel $w
 561     wm title $w "About gitk"
 562     message $w.m -text {
 563 Gitk version 1.2
 564
 565 Copyright © 2005 Paul Mackerras
 566
 567 Use and redistribute under the terms of the GNU General Public License} \
 568             -justify center -aspect 400
 569     pack $w.m -side top -fill x -padx 20 -pady 20
 570     button $w.ok -text Close -command "destroy $w"
 571     pack $w.ok -side bottom
 572 }
 573
 574 proc assigncolor {id} {
 575     global commitinfo colormap commcolors colors nextcolor
 576     global parents nparents children nchildren
 577     global cornercrossings crossings
 578
 579     if [info exists colormap($id)] return
 580     set ncolors [llength $colors]
 581     if {$nparents($id) <= 1 && $nchildren($id) == 1} {
 582         set child [lindex $children($id) 0]
 583         if {[info exists colormap($child)]
 584             && $nparents($child) == 1} {
 585             set colormap($id) $colormap($child)
 586             return
 587         }
 588     }
 589     set badcolors {}
 590     if {[info exists cornercrossings($id)]} {
 591         foreach x $cornercrossings($id) {
 592             if {[info exists colormap($x)]
 593                 && [lsearch -exact $badcolors $colormap($x)] < 0} {
 594                 lappend badcolors $colormap($x)
 595             }
 596         }
 597         if {[llength $badcolors] >= $ncolors} {
 598             set badcolors {}
 599         }
 600     }
 601     set origbad $badcolors
 602     if {[llength $badcolors] < $ncolors - 1} {
 603         if {[info exists crossings($id)]} {
 604             foreach x $crossings($id) {
 605                 if {[info exists colormap($x)]
 606                     && [lsearch -exact $badcolors $colormap($x)] < 0} {
 607                     lappend badcolors $colormap($x)
 608                 }
 609             }
 610             if {[llength $badcolors] >= $ncolors} {
 611                 set badcolors $origbad
 612             }
 613         }
 614         set origbad $badcolors
 615     }
 616     if {[llength $badcolors] < $ncolors - 1} {
 617         foreach child $children($id) {
 618             if {[info exists colormap($child)]
 619                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
 620                 lappend badcolors $colormap($child)
 621             }
 622             if {[info exists parents($child)]} {
 623                 foreach p $parents($child) {
 624                     if {[info exists colormap($p)]
 625                         && [lsearch -exact $badcolors $colormap($p)] < 0} {
 626                         lappend badcolors $colormap($p)
 627                     }
 628                 }
 629             }
 630         }
 631         if {[llength $badcolors] >= $ncolors} {
 632             set badcolors $origbad
 633         }
 634     }
 635     for {set i 0} {$i <= $ncolors} {incr i} {
 636         set c [lindex $colors $nextcolor]
 637         if {[incr nextcolor] >= $ncolors} {
 638             set nextcolor 0
 639         }
 640         if {[lsearch -exact $badcolors $c]} break
 641     }
 642     set colormap($id) $c
 643 }
 644
 645 proc initgraph {} {
 646     global canvy canvy0 lineno numcommits lthickness nextcolor linespc
 647     global mainline sidelines
 648     global nchildren ncleft
 649
 650     allcanvs delete all
 651     set nextcolor 0
 652     set canvy $canvy0
 653     set lineno -1
 654     set numcommits 0
 655     set lthickness [expr {int($linespc / 9) + 1}]
 656     catch {unset mainline}
 657     catch {unset sidelines}
 658     foreach id [array names nchildren] {
 659         set ncleft($id) $nchildren($id)
 660     }
 661 }
 662
 663 proc bindline {t id} {
 664     global canv
 665
 666     $canv bind $t <Enter> "lineenter %x %y $id"
 667     $canv bind $t <Motion> "linemotion %x %y $id"
 668     $canv bind $t <Leave> "lineleave $id"
 669     $canv bind $t <Button-1> "lineclick %x %y $id"
 670 }
 671
 672 proc drawcommitline {level} {
 673     global parents children nparents nchildren todo
 674     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 675     global lineid linehtag linentag linedtag commitinfo
 676     global colormap numcommits currentparents dupparents
 677     global oldlevel oldnlines oldtodo
 678     global idtags idline idheads
 679     global lineno lthickness mainline sidelines
 680     global commitlisted rowtextx idpos
 681
 682     incr numcommits
 683     incr lineno
 684     set id [lindex $todo $level]
 685     set lineid($lineno) $id
 686     set idline($id) $lineno
 687     set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
 688     if {![info exists commitinfo($id)]} {
 689         readcommit $id
 690         if {![info exists commitinfo($id)]} {
 691             set commitinfo($id) {"No commit information available"}
 692             set nparents($id) 0
 693         }
 694     }
 695     assigncolor $id
 696     set currentparents {}
 697     set dupparents {}
 698     if {[info exists commitlisted($id)] && [info exists parents($id)]} {
 699         foreach p $parents($id) {
 700             if {[lsearch -exact $currentparents $p] < 0} {
 701                 lappend currentparents $p
 702             } else {
 703                 # remember that this parent was listed twice
 704                 lappend dupparents $p
 705             }
 706         }
 707     }
 708     set x [expr $canvx0 + $level * $linespc]
 709     set y1 $canvy
 710     set canvy [expr $canvy + $linespc]
 711     allcanvs conf -scrollregion \
 712         [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
 713     if {[info exists mainline($id)]} {
 714         lappend mainline($id) $x $y1
 715         set t [$canv create line $mainline($id) \
 716                    -width $lthickness -fill $colormap($id)]
 717         $canv lower $t
 718         bindline $t $id
 719     }
 720     if {[info exists sidelines($id)]} {
 721         foreach ls $sidelines($id) {
 722             set coords [lindex $ls 0]
 723             set thick [lindex $ls 1]
 724             set t [$canv create line $coords -fill $colormap($id) \
 725                        -width [expr {$thick * $lthickness}]]
 726             $canv lower $t
 727             bindline $t $id
 728         }
 729     }
 730     set orad [expr {$linespc / 3}]
 731     set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
 732                [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
 733                -fill $ofill -outline black -width 1]
 734     $canv raise $t
 735     $canv bind $t <1> {selcanvline {} %x %y}
 736     set xt [expr $canvx0 + [llength $todo] * $linespc]
 737     if {[llength $currentparents] > 2} {
 738         set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
 739     }
 740     set rowtextx($lineno) $xt
 741     set idpos($id) [list $x $xt $y1]
 742     if {[info exists idtags($id)] || [info exists idheads($id)]} {
 743         set xt [drawtags $id $x $xt $y1]
 744     }
 745     set headline [lindex $commitinfo($id) 0]
 746     set name [lindex $commitinfo($id) 1]
 747     set date [lindex $commitinfo($id) 2]
 748     set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
 749                                -text $headline -font $mainfont ]
 750     $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
 751     set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
 752                                -text $name -font $namefont]
 753     set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
 754                                -text $date -font $mainfont]
 755 }
 756
 757 proc drawtags {id x xt y1} {
 758     global idtags idheads
 759     global linespc lthickness
 760     global canv mainfont
 761
 762     set marks {}
 763     set ntags 0
 764     if {[info exists idtags($id)]} {
 765         set marks $idtags($id)
 766         set ntags [llength $marks]
 767     }
 768     if {[info exists idheads($id)]} {
 769         set marks [concat $marks $idheads($id)]
 770     }
 771     if {$marks eq {}} {
 772         return $xt
 773     }
 774
 775     set delta [expr {int(0.5 * ($linespc - $lthickness))}]
 776     set yt [expr $y1 - 0.5 * $linespc]
 777     set yb [expr $yt + $linespc - 1]
 778     set xvals {}
 779     set wvals {}
 780     foreach tag $marks {
 781         set wid [font measure $mainfont $tag]
 782         lappend xvals $xt
 783         lappend wvals $wid
 784         set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
 785     }
 786     set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
 787                -width $lthickness -fill black -tags tag.$id]
 788     $canv lower $t
 789     foreach tag $marks x $xvals wid $wvals {
 790         set xl [expr $x + $delta]
 791         set xr [expr $x + $delta + $wid + $lthickness]
 792         if {[incr ntags -1] >= 0} {
 793             # draw a tag
 794             $canv create polygon $x [expr $yt + $delta] $xl $yt\
 795                 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
 796                 -width 1 -outline black -fill yellow -tags tag.$id
 797         } else {
 798             # draw a head
 799             set xl [expr $xl - $delta/2]
 800             $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
 801                 -width 1 -outline black -fill green -tags tag.$id
 802         }
 803         $canv create text $xl $y1 -anchor w -text $tag \
 804             -font $mainfont -tags tag.$id
 805     }
 806     return $xt
 807 }
 808
 809 proc updatetodo {level noshortcut} {
 810     global currentparents ncleft todo
 811     global mainline oldlevel oldtodo oldnlines
 812     global canvx0 canvy linespc mainline
 813     global commitinfo
 814
 815     set oldlevel $level
 816     set oldtodo $todo
 817     set oldnlines [llength $todo]
 818     if {!$noshortcut && [llength $currentparents] == 1} {
 819         set p [lindex $currentparents 0]
 820         if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
 821             set ncleft($p) 0
 822             set x [expr $canvx0 + $level * $linespc]
 823             set y [expr $canvy - $linespc]
 824             set mainline($p) [list $x $y]
 825             set todo [lreplace $todo $level $level $p]
 826             return 0
 827         }
 828     }
 829
 830     set todo [lreplace $todo $level $level]
 831     set i $level
 832     foreach p $currentparents {
 833         incr ncleft($p) -1
 834         set k [lsearch -exact $todo $p]
 835         if {$k < 0} {
 836             set todo [linsert $todo $i $p]
 837             incr i
 838         }
 839     }
 840     return 1
 841 }
 842
 843 proc notecrossings {id lo hi corner} {
 844     global oldtodo crossings cornercrossings
 845
 846     for {set i $lo} {[incr i] < $hi} {} {
 847         set p [lindex $oldtodo $i]
 848         if {$p == {}} continue
 849         if {$i == $corner} {
 850             if {![info exists cornercrossings($id)]
 851                 || [lsearch -exact $cornercrossings($id) $p] < 0} {
 852                 lappend cornercrossings($id) $p
 853             }
 854             if {![info exists cornercrossings($p)]
 855                 || [lsearch -exact $cornercrossings($p) $id] < 0} {
 856                 lappend cornercrossings($p) $id
 857             }
 858         } else {
 859             if {![info exists crossings($id)]
 860                 || [lsearch -exact $crossings($id) $p] < 0} {
 861                 lappend crossings($id) $p
 862             }
 863             if {![info exists crossings($p)]
 864                 || [lsearch -exact $crossings($p) $id] < 0} {
 865                 lappend crossings($p) $id
 866             }
 867         }
 868     }
 869 }
 870
 871 proc drawslants {} {
 872     global canv mainline sidelines canvx0 canvy linespc
 873     global oldlevel oldtodo todo currentparents dupparents
 874     global lthickness linespc canvy colormap
 875
 876     set y1 [expr $canvy - $linespc]
 877     set y2 $canvy
 878     set i -1
 879     foreach id $oldtodo {
 880         incr i
 881         if {$id == {}} continue
 882         set xi [expr {$canvx0 + $i * $linespc}]
 883         if {$i == $oldlevel} {
 884             foreach p $currentparents {
 885                 set j [lsearch -exact $todo $p]
 886                 set coords [list $xi $y1]
 887                 set xj [expr {$canvx0 + $j * $linespc}]
 888                 if {$j < $i - 1} {
 889                     lappend coords [expr $xj + $linespc] $y1
 890                     notecrossings $p $j $i [expr {$j + 1}]
 891                 } elseif {$j > $i + 1} {
 892                     lappend coords [expr $xj - $linespc] $y1
 893                     notecrossings $p $i $j [expr {$j - 1}]
 894                 }
 895                 if {[lsearch -exact $dupparents $p] >= 0} {
 896                     # draw a double-width line to indicate the doubled parent
 897                     lappend coords $xj $y2
 898                     lappend sidelines($p) [list $coords 2]
 899                     if {![info exists mainline($p)]} {
 900                         set mainline($p) [list $xj $y2]
 901                     }
 902                 } else {
 903                     # normal case, no parent duplicated
 904                     if {![info exists mainline($p)]} {
 905                         if {$i != $j} {
 906                             lappend coords $xj $y2
 907                         }
 908                         set mainline($p) $coords
 909                     } else {
 910                         lappend coords $xj $y2
 911                         lappend sidelines($p) [list $coords 1]
 912                     }
 913                 }
 914             }
 915         } elseif {[lindex $todo $i] != $id} {
 916             set j [lsearch -exact $todo $id]
 917             set xj [expr {$canvx0 + $j * $linespc}]
 918             lappend mainline($id) $xi $y1 $xj $y2
 919         }
 920     }
 921 }
 922
 923 proc decidenext {{noread 0}} {
 924     global parents children nchildren ncleft todo
 925     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 926     global datemode cdate
 927     global commitinfo
 928     global currentparents oldlevel oldnlines oldtodo
 929     global lineno lthickness
 930
 931     # remove the null entry if present
 932     set nullentry [lsearch -exact $todo {}]
 933     if {$nullentry >= 0} {
 934         set todo [lreplace $todo $nullentry $nullentry]
 935     }
 936
 937     # choose which one to do next time around
 938     set todol [llength $todo]
 939     set level -1
 940     set latest {}
 941     for {set k $todol} {[incr k -1] >= 0} {} {
 942         set p [lindex $todo $k]
 943         if {$ncleft($p) == 0} {
 944             if {$datemode} {
 945                 if {![info exists commitinfo($p)]} {
 946                     if {$noread} {
 947                         return {}
 948                     }
 949                     readcommit $p
 950                 }
 951                 if {$latest == {} || $cdate($p) > $latest} {
 952                     set level $k
 953                     set latest $cdate($p)
 954                 }
 955             } else {
 956                 set level $k
 957                 break
 958             }
 959         }
 960     }
 961     if {$level < 0} {
 962         if {$todo != {}} {
 963             puts "ERROR: none of the pending commits can be done yet:"
 964             foreach p $todo {
 965                 puts "  $p ($ncleft($p))"
 966             }
 967         }
 968         return -1
 969     }
 970
 971     # If we are reducing, put in a null entry
 972     if {$todol < $oldnlines} {
 973         if {$nullentry >= 0} {
 974             set i $nullentry
 975             while {$i < $todol
 976                    && [lindex $oldtodo $i] == [lindex $todo $i]} {
 977                 incr i
 978             }
 979         } else {
 980             set i $oldlevel
 981             if {$level >= $i} {
 982                 incr i
 983             }
 984         }
 985         if {$i < $todol} {
 986             set todo [linsert $todo $i {}]
 987             if {$level >= $i} {
 988                 incr level
 989             }
 990         }
 991     }
 992     return $level
 993 }
 994
 995 proc drawcommit {id} {
 996     global phase todo nchildren datemode nextupdate
 997     global startcommits
 998
 999     if {$phase != "incrdraw"} {
1000         set phase incrdraw
1001         set todo $id
1002         set startcommits $id
1003         initgraph
1004         drawcommitline 0
1005         updatetodo 0 $datemode
1006     } else {
1007         if {$nchildren($id) == 0} {
1008             lappend todo $id
1009             lappend startcommits $id
1010         }
1011         set level [decidenext 1]
1012         if {$level == {} || $id != [lindex $todo $level]} {
1013             return
1014         }
1015         while 1 {
1016             drawslants
1017             drawcommitline $level
1018             if {[updatetodo $level $datemode]} {
1019                 set level [decidenext 1]
1020                 if {$level == {}} break
1021             }
1022             set id [lindex $todo $level]
1023             if {![info exists commitlisted($id)]} {
1024                 break
1025             }
1026             if {[clock clicks -milliseconds] >= $nextupdate} {
1027                 doupdate
1028                 if {$stopped} break
1029             }
1030         }
1031     }
1032 }
1033
1034 proc finishcommits {} {
1035     global phase
1036     global startcommits
1037     global canv mainfont ctext maincursor textcursor
1038
1039     if {$phase != "incrdraw"} {
1040         $canv delete all
1041         $canv create text 3 3 -anchor nw -text "No commits selected" \
1042             -font $mainfont -tags textitems
1043         set phase {}
1044     } else {
1045         drawslants
1046         set level [decidenext]
1047         drawrest $level [llength $startcommits]
1048     }
1049     . config -cursor $maincursor
1050     $ctext config -cursor $textcursor
1051 }
1052
1053 proc drawgraph {} {
1054     global nextupdate startmsecs startcommits todo
1055
1056     if {$startcommits == {}} return
1057     set startmsecs [clock clicks -milliseconds]
1058     set nextupdate [expr $startmsecs + 100]
1059     initgraph
1060     set todo [lindex $startcommits 0]
1061     drawrest 0 1
1062 }
1063
1064 proc drawrest {level startix} {
1065     global phase stopped redisplaying selectedline
1066     global datemode currentparents todo
1067     global numcommits
1068     global nextupdate startmsecs startcommits idline
1069
1070     if {$level >= 0} {
1071         set phase drawgraph
1072         set startid [lindex $startcommits $startix]
1073         set startline -1
1074         if {$startid != {}} {
1075             set startline $idline($startid)
1076         }
1077         while 1 {
1078             if {$stopped} break
1079             drawcommitline $level
1080             set hard [updatetodo $level $datemode]
1081             if {$numcommits == $startline} {
1082                 lappend todo $startid
1083                 set hard 1
1084                 incr startix
1085                 set startid [lindex $startcommits $startix]
1086                 set startline -1
1087                 if {$startid != {}} {
1088                     set startline $idline($startid)
1089                 }
1090             }
1091             if {$hard} {
1092                 set level [decidenext]
1093                 if {$level < 0} break
1094                 drawslants
1095             }
1096             if {[clock clicks -milliseconds] >= $nextupdate} {
1097                 update
1098                 incr nextupdate 100
1099             }
1100         }
1101     }
1102     set phase {}
1103     set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1104     #puts "overall $drawmsecs ms for $numcommits commits"
1105     if {$redisplaying} {
1106         if {$stopped == 0 && [info exists selectedline]} {
1107             selectline $selectedline
1108         }
1109         if {$stopped == 1} {
1110             set stopped 0
1111             after idle drawgraph
1112         } else {
1113             set redisplaying 0
1114         }
1115     }
1116 }
1117
1118 proc findmatches {f} {
1119     global findtype foundstring foundstrlen
1120     if {$findtype == "Regexp"} {
1121         set matches [regexp -indices -all -inline $foundstring $f]
1122     } else {
1123         if {$findtype == "IgnCase"} {
1124             set str [string tolower $f]
1125         } else {
1126             set str $f
1127         }
1128         set matches {}
1129         set i 0
1130         while {[set j [string first $foundstring $str $i]] >= 0} {
1131             lappend matches [list $j [expr $j+$foundstrlen-1]]
1132             set i [expr $j + $foundstrlen]
1133         }
1134     }
1135     return $matches
1136 }
1137
1138 proc dofind {} {
1139     global findtype findloc findstring markedmatches commitinfo
1140     global numcommits lineid linehtag linentag linedtag
1141     global mainfont namefont canv canv2 canv3 selectedline
1142     global matchinglines foundstring foundstrlen
1143
1144     stopfindproc
1145     unmarkmatches
1146     focus .
1147     set matchinglines {}
1148     if {$findloc == "Pickaxe"} {
1149         findpatches
1150         return
1151     }
1152     if {$findtype == "IgnCase"} {
1153         set foundstring [string tolower $findstring]
1154     } else {
1155         set foundstring $findstring
1156     }
1157     set foundstrlen [string length $findstring]
1158     if {$foundstrlen == 0} return
1159     if {$findloc == "Files"} {
1160         findfiles
1161         return
1162     }
1163     if {![info exists selectedline]} {
1164         set oldsel -1
1165     } else {
1166         set oldsel $selectedline
1167     }
1168     set didsel 0
1169     set fldtypes {Headline Author Date Committer CDate Comment}
1170     for {set l 0} {$l < $numcommits} {incr l} {
1171         set id $lineid($l)
1172         set info $commitinfo($id)
1173         set doesmatch 0
1174         foreach f $info ty $fldtypes {
1175             if {$findloc != "All fields" && $findloc != $ty} {
1176                 continue
1177             }
1178             set matches [findmatches $f]
1179             if {$matches == {}} continue
1180             set doesmatch 1
1181             if {$ty == "Headline"} {
1182                 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1183             } elseif {$ty == "Author"} {
1184                 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1185             } elseif {$ty == "Date"} {
1186                 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1187             }
1188         }
1189         if {$doesmatch} {
1190             lappend matchinglines $l
1191             if {!$didsel && $l > $oldsel} {
1192                 findselectline $l
1193                 set didsel 1
1194             }
1195         }
1196     }
1197     if {$matchinglines == {}} {
1198         bell
1199     } elseif {!$didsel} {
1200         findselectline [lindex $matchinglines 0]
1201     }
1202 }
1203
1204 proc findselectline {l} {
1205     global findloc commentend ctext
1206     selectline $l
1207     if {$findloc == "All fields" || $findloc == "Comments"} {
1208         # highlight the matches in the comments
1209         set f [$ctext get 1.0 $commentend]
1210         set matches [findmatches $f]
1211         foreach match $matches {
1212             set start [lindex $match 0]
1213             set end [expr [lindex $match 1] + 1]
1214             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1215         }
1216     }
1217 }
1218
1219 proc findnext {restart} {
1220     global matchinglines selectedline
1221     if {![info exists matchinglines]} {
1222         if {$restart} {
1223             dofind
1224         }
1225         return
1226     }
1227     if {![info exists selectedline]} return
1228     foreach l $matchinglines {
1229         if {$l > $selectedline} {
1230             findselectline $l
1231             return
1232         }
1233     }
1234     bell
1235 }
1236
1237 proc findprev {} {
1238     global matchinglines selectedline
1239     if {![info exists matchinglines]} {
1240         dofind
1241         return
1242     }
1243     if {![info exists selectedline]} return
1244     set prev {}
1245     foreach l $matchinglines {
1246         if {$l >= $selectedline} break
1247         set prev $l
1248     }
1249     if {$prev != {}} {
1250         findselectline $prev
1251     } else {
1252         bell
1253     }
1254 }
1255
1256 proc findlocchange {name ix op} {
1257     global findloc findtype findtypemenu
1258     if {$findloc == "Pickaxe"} {
1259         set findtype Exact
1260         set state disabled
1261     } else {
1262         set state normal
1263     }
1264     $findtypemenu entryconf 1 -state $state
1265     $findtypemenu entryconf 2 -state $state
1266 }
1267
1268 proc stopfindproc {{done 0}} {
1269     global findprocpid findprocfile findids
1270     global ctext findoldcursor phase maincursor textcursor
1271     global findinprogress
1272
1273     catch {unset findids}
1274     if {[info exists findprocpid]} {
1275         if {!$done} {
1276             catch {exec kill $findprocpid}
1277         }
1278         catch {close $findprocfile}
1279         unset findprocpid
1280     }
1281     if {[info exists findinprogress]} {
1282         unset findinprogress
1283         if {$phase != "incrdraw"} {
1284             . config -cursor $maincursor
1285             $ctext config -cursor $textcursor
1286         }
1287     }
1288 }
1289
1290 proc findpatches {} {
1291     global findstring selectedline numcommits
1292     global findprocpid findprocfile
1293     global finddidsel ctext lineid findinprogress
1294     global findinsertpos
1295
1296     if {$numcommits == 0} return
1297
1298     # make a list of all the ids to search, starting at the one
1299     # after the selected line (if any)
1300     if {[info exists selectedline]} {
1301         set l $selectedline
1302     } else {
1303         set l -1
1304     }
1305     set inputids {}
1306     for {set i 0} {$i < $numcommits} {incr i} {
1307         if {[incr l] >= $numcommits} {
1308             set l 0
1309         }
1310         append inputids $lineid($l) "\n"
1311     }
1312
1313     if {[catch {
1314         set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1315                          << $inputids] r]
1316     } err]} {
1317         error_popup "Error starting search process: $err"
1318         return
1319     }
1320
1321     set findinsertpos end
1322     set findprocfile $f
1323     set findprocpid [pid $f]
1324     fconfigure $f -blocking 0
1325     fileevent $f readable readfindproc
1326     set finddidsel 0
1327     . config -cursor watch
1328     $ctext config -cursor watch
1329     set findinprogress 1
1330 }
1331
1332 proc readfindproc {} {
1333     global findprocfile finddidsel
1334     global idline matchinglines findinsertpos
1335
1336     set n [gets $findprocfile line]
1337     if {$n < 0} {
1338         if {[eof $findprocfile]} {
1339             stopfindproc 1
1340             if {!$finddidsel} {
1341                 bell
1342             }
1343         }
1344         return
1345     }
1346     if {![regexp {^[0-9a-f]{40}} $line id]} {
1347         error_popup "Can't parse git-diff-tree output: $line"
1348         stopfindproc
1349         return
1350     }
1351     if {![info exists idline($id)]} {
1352         puts stderr "spurious id: $id"
1353         return
1354     }
1355     set l $idline($id)
1356     insertmatch $l $id
1357 }
1358
1359 proc insertmatch {l id} {
1360     global matchinglines findinsertpos finddidsel
1361
1362     if {$findinsertpos == "end"} {
1363         if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1364             set matchinglines [linsert $matchinglines 0 $l]
1365             set findinsertpos 1
1366         } else {
1367             lappend matchinglines $l
1368         }
1369     } else {
1370         set matchinglines [linsert $matchinglines $findinsertpos $l]
1371         incr findinsertpos
1372     }
1373     markheadline $l $id
1374     if {!$finddidsel} {
1375         findselectline $l
1376         set finddidsel 1
1377     }
1378 }
1379
1380 proc findfiles {} {
1381     global selectedline numcommits lineid ctext
1382     global ffileline finddidsel parents nparents
1383     global findinprogress findstartline findinsertpos
1384     global treediffs fdiffids fdiffsneeded fdiffpos
1385     global findmergefiles
1386
1387     if {$numcommits == 0} return
1388
1389     if {[info exists selectedline]} {
1390         set l [expr {$selectedline + 1}]
1391     } else {
1392         set l 0
1393     }
1394     set ffileline $l
1395     set findstartline $l
1396     set diffsneeded {}
1397     set fdiffsneeded {}
1398     while 1 {
1399         set id $lineid($l)
1400         if {$findmergefiles || $nparents($id) == 1} {
1401             foreach p $parents($id) {
1402                 if {![info exists treediffs([list $id $p])]} {
1403                     append diffsneeded "$id $p\n"
1404                     lappend fdiffsneeded [list $id $p]
1405                 }
1406             }
1407         }
1408         if {[incr l] >= $numcommits} {
1409             set l 0
1410         }
1411         if {$l == $findstartline} break
1412     }
1413
1414     # start off a git-diff-tree process if needed
1415     if {$diffsneeded ne {}} {
1416         if {[catch {
1417             set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1418         } err ]} {
1419             error_popup "Error starting search process: $err"
1420             return
1421         }
1422         catch {unset fdiffids}
1423         set fdiffpos 0
1424         fconfigure $df -blocking 0
1425         fileevent $df readable [list readfilediffs $df]
1426     }
1427
1428     set finddidsel 0
1429     set findinsertpos end
1430     set id $lineid($l)
1431     set p [lindex $parents($id) 0]
1432     . config -cursor watch
1433     $ctext config -cursor watch
1434     set findinprogress 1
1435     findcont [list $id $p]
1436     update
1437 }
1438
1439 proc readfilediffs {df} {
1440     global findids fdiffids fdiffs
1441
1442     set n [gets $df line]
1443     if {$n < 0} {
1444         if {[eof $df]} {
1445             donefilediff
1446             if {[catch {close $df} err]} {
1447                 stopfindproc
1448                 bell
1449                 error_popup "Error in git-diff-tree: $err"
1450             } elseif {[info exists findids]} {
1451                 set ids $findids
1452                 stopfindproc
1453                 bell
1454                 error_popup "Couldn't find diffs for {$ids}"
1455             }
1456         }
1457         return
1458     }
1459     if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1460         # start of a new string of diffs
1461         donefilediff
1462         set fdiffids [list $id $p]
1463         set fdiffs {}
1464     } elseif {[string match ":*" $line]} {
1465         lappend fdiffs [lindex $line 5]
1466     }
1467 }
1468
1469 proc donefilediff {} {
1470     global fdiffids fdiffs treediffs findids
1471     global fdiffsneeded fdiffpos
1472
1473     if {[info exists fdiffids]} {
1474         while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1475                && $fdiffpos < [llength $fdiffsneeded]} {
1476             # git-diff-tree doesn't output anything for a commit
1477             # which doesn't change anything
1478             set nullids [lindex $fdiffsneeded $fdiffpos]
1479             set treediffs($nullids) {}
1480             if {[info exists findids] && $nullids eq $findids} {
1481                 unset findids
1482                 findcont $nullids
1483             }
1484             incr fdiffpos
1485         }
1486         incr fdiffpos
1487
1488         if {![info exists treediffs($fdiffids)]} {
1489             set treediffs($fdiffids) $fdiffs
1490         }
1491         if {[info exists findids] && $fdiffids eq $findids} {
1492             unset findids
1493             findcont $fdiffids
1494         }
1495     }
1496 }
1497
1498 proc findcont {ids} {
1499     global findids treediffs parents nparents treepending
1500     global ffileline findstartline finddidsel
1501     global lineid numcommits matchinglines findinprogress
1502     global findmergefiles
1503
1504     set id [lindex $ids 0]
1505     set p [lindex $ids 1]
1506     set pi [lsearch -exact $parents($id) $p]
1507     set l $ffileline
1508     while 1 {
1509         if {$findmergefiles || $nparents($id) == 1} {
1510             if {![info exists treediffs($ids)]} {
1511                 set findids $ids
1512                 set ffileline $l
1513                 return
1514             }
1515             set doesmatch 0
1516             foreach f $treediffs($ids) {
1517                 set x [findmatches $f]
1518                 if {$x != {}} {
1519                     set doesmatch 1
1520                     break
1521                 }
1522             }
1523             if {$doesmatch} {
1524                 insertmatch $l $id
1525                 set pi $nparents($id)
1526             }
1527         } else {
1528             set pi $nparents($id)
1529         }
1530         if {[incr pi] >= $nparents($id)} {
1531             set pi 0
1532             if {[incr l] >= $numcommits} {
1533                 set l 0
1534             }
1535             if {$l == $findstartline} break
1536             set id $lineid($l)
1537         }
1538         set p [lindex $parents($id) $pi]
1539         set ids [list $id $p]
1540     }
1541     stopfindproc
1542     if {!$finddidsel} {
1543         bell
1544     }
1545 }
1546
1547 # mark a commit as matching by putting a yellow background
1548 # behind the headline
1549 proc markheadline {l id} {
1550     global canv mainfont linehtag commitinfo
1551
1552     set bbox [$canv bbox $linehtag($l)]
1553     set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1554     $canv lower $t
1555 }
1556
1557 # mark the bits of a headline, author or date that match a find string
1558 proc markmatches {canv l str tag matches font} {
1559     set bbox [$canv bbox $tag]
1560     set x0 [lindex $bbox 0]
1561     set y0 [lindex $bbox 1]
1562     set y1 [lindex $bbox 3]
1563     foreach match $matches {
1564         set start [lindex $match 0]
1565         set end [lindex $match 1]
1566         if {$start > $end} continue
1567         set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1568         set xlen [font measure $font [string range $str 0 [expr $end]]]
1569         set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1570                    -outline {} -tags matches -fill yellow]
1571         $canv lower $t
1572     }
1573 }
1574
1575 proc unmarkmatches {} {
1576     global matchinglines findids
1577     allcanvs delete matches
1578     catch {unset matchinglines}
1579     catch {unset findids}
1580 }
1581
1582 proc selcanvline {w x y} {
1583     global canv canvy0 ctext linespc selectedline
1584     global lineid linehtag linentag linedtag rowtextx
1585     set ymax [lindex [$canv cget -scrollregion] 3]
1586     if {$ymax == {}} return
1587     set yfrac [lindex [$canv yview] 0]
1588     set y [expr {$y + $yfrac * $ymax}]
1589     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1590     if {$l < 0} {
1591         set l 0
1592     }
1593     if {$w eq $canv} {
1594         if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1595     }
1596     unmarkmatches
1597     selectline $l
1598 }
1599
1600 proc selectline {l} {
1601     global canv canv2 canv3 ctext commitinfo selectedline
1602     global lineid linehtag linentag linedtag
1603     global canvy0 linespc parents nparents
1604     global cflist currentid sha1entry
1605     global commentend seenfile idtags
1606     $canv delete hover
1607     if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1608     $canv delete secsel
1609     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1610                -tags secsel -fill [$canv cget -selectbackground]]
1611     $canv lower $t
1612     $canv2 delete secsel
1613     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1614                -tags secsel -fill [$canv2 cget -selectbackground]]
1615     $canv2 lower $t
1616     $canv3 delete secsel
1617     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1618                -tags secsel -fill [$canv3 cget -selectbackground]]
1619     $canv3 lower $t
1620     set y [expr {$canvy0 + $l * $linespc}]
1621     set ymax [lindex [$canv cget -scrollregion] 3]
1622     set ytop [expr {$y - $linespc - 1}]
1623     set ybot [expr {$y + $linespc + 1}]
1624     set wnow [$canv yview]
1625     set wtop [expr [lindex $wnow 0] * $ymax]
1626     set wbot [expr [lindex $wnow 1] * $ymax]
1627     set wh [expr {$wbot - $wtop}]
1628     set newtop $wtop
1629     if {$ytop < $wtop} {
1630         if {$ybot < $wtop} {
1631             set newtop [expr {$y - $wh / 2.0}]
1632         } else {
1633             set newtop $ytop
1634             if {$newtop > $wtop - $linespc} {
1635                 set newtop [expr {$wtop - $linespc}]
1636             }
1637         }
1638     } elseif {$ybot > $wbot} {
1639         if {$ytop > $wbot} {
1640             set newtop [expr {$y - $wh / 2.0}]
1641         } else {
1642             set newtop [expr {$ybot - $wh}]
1643             if {$newtop < $wtop + $linespc} {
1644                 set newtop [expr {$wtop + $linespc}]
1645             }
1646         }
1647     }
1648     if {$newtop != $wtop} {
1649         if {$newtop < 0} {
1650             set newtop 0
1651         }
1652         allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1653     }
1654     set selectedline $l
1655
1656     set id $lineid($l)
1657     set currentid $id
1658     $sha1entry delete 0 end
1659     $sha1entry insert 0 $id
1660     $sha1entry selection from 0
1661     $sha1entry selection to end
1662
1663     $ctext conf -state normal
1664     $ctext delete 0.0 end
1665     $ctext mark set fmark.0 0.0
1666     $ctext mark gravity fmark.0 left
1667     set info $commitinfo($id)
1668     $ctext insert end "Author: [lindex $info 1]  [lindex $info 2]\n"
1669     $ctext insert end "Committer: [lindex $info 3]  [lindex $info 4]\n"
1670     if {[info exists idtags($id)]} {
1671         $ctext insert end "Tags:"
1672         foreach tag $idtags($id) {
1673             $ctext insert end " $tag"
1674         }
1675         $ctext insert end "\n"
1676     }
1677     $ctext insert end "\n"
1678     $ctext insert end [lindex $info 5]
1679     $ctext insert end "\n"
1680     $ctext tag delete Comments
1681     $ctext tag remove found 1.0 end
1682     $ctext conf -state disabled
1683     set commentend [$ctext index "end - 1c"]
1684
1685     $cflist delete 0 end
1686     $cflist insert end "Comments"
1687     if {$nparents($id) == 1} {
1688         startdiff [concat $id $parents($id)]
1689     }
1690     catch {unset seenfile}
1691 }
1692
1693 proc startdiff {ids} {
1694     global treediffs diffids treepending
1695
1696     if {![info exists treediffs($ids)]} {
1697         set diffids $ids
1698         if {![info exists treepending]} {
1699             gettreediffs $ids
1700         }
1701     } else {
1702         addtocflist $ids
1703     }
1704 }
1705
1706 proc selnextline {dir} {
1707     global selectedline
1708     if {![info exists selectedline]} return
1709     set l [expr $selectedline + $dir]
1710     unmarkmatches
1711     selectline $l
1712 }
1713
1714 proc addtocflist {ids} {
1715     global treediffs cflist
1716     foreach f $treediffs($ids) {
1717         $cflist insert end $f
1718     }
1719     getblobdiffs $ids
1720 }
1721
1722 proc gettreediffs {ids} {
1723     global treediffs parents treepending
1724     set treepending $ids
1725     set treediffs($ids) {}
1726     set id [lindex $ids 0]
1727     set p [lindex $ids 1]
1728     if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1729     fconfigure $gdtf -blocking 0
1730     fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1731 }
1732
1733 proc gettreediffline {gdtf ids} {
1734     global treediffs treepending diffids
1735     set n [gets $gdtf line]
1736     if {$n < 0} {
1737         if {![eof $gdtf]} return
1738         close $gdtf
1739         unset treepending
1740         if {[info exists diffids]} {
1741             if {$ids != $diffids} {
1742                 gettreediffs $diffids
1743             } else {
1744                 unset diffids
1745                 addtocflist $ids
1746             }
1747         }
1748         return
1749     }
1750     set file [lindex $line 5]
1751     lappend treediffs($ids) $file
1752 }
1753
1754 proc getblobdiffs {ids} {
1755     global diffopts blobdifffd blobdiffids env curdifftag curtagstart
1756     global diffindex difffilestart nextupdate
1757
1758     set id [lindex $ids 0]
1759     set p [lindex $ids 1]
1760     set env(GIT_DIFF_OPTS) $diffopts
1761     if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1762         puts "error getting diffs: $err"
1763         return
1764     }
1765     fconfigure $bdf -blocking 0
1766     set blobdiffids $ids
1767     set blobdifffd($ids) $bdf
1768     set curdifftag Comments
1769     set curtagstart 0.0
1770     set diffindex 0
1771     catch {unset difffilestart}
1772     fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1773     set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1774 }
1775
1776 proc getblobdiffline {bdf ids} {
1777     global blobdiffids blobdifffd ctext curdifftag curtagstart seenfile
1778     global diffnexthead diffnextnote diffindex difffilestart
1779     global nextupdate
1780
1781     set n [gets $bdf line]
1782     if {$n < 0} {
1783         if {[eof $bdf]} {
1784             close $bdf
1785             if {$ids == $blobdiffids && $bdf == $blobdifffd($ids)} {
1786                 $ctext tag add $curdifftag $curtagstart end
1787                 set seenfile($curdifftag) 1
1788             }
1789         }
1790         return
1791     }
1792     if {$ids != $blobdiffids || $bdf != $blobdifffd($ids)} {
1793         return
1794     }
1795     $ctext conf -state normal
1796     if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1797         # start of a new file
1798         $ctext insert end "\n"
1799         $ctext tag add $curdifftag $curtagstart end
1800         set seenfile($curdifftag) 1
1801         set curtagstart [$ctext index "end - 1c"]
1802         set header $fname
1803         if {[info exists diffnexthead]} {
1804             set fname $diffnexthead
1805             set header "$diffnexthead ($diffnextnote)"
1806             unset diffnexthead
1807         }
1808         set here [$ctext index "end - 1c"]
1809         set difffilestart($diffindex) $here
1810         incr diffindex
1811         # start mark names at fmark.1 for first file
1812         $ctext mark set fmark.$diffindex $here
1813         $ctext mark gravity fmark.$diffindex left
1814         set curdifftag "f:$fname"
1815         $ctext tag delete $curdifftag
1816         set l [expr {(78 - [string length $header]) / 2}]
1817         set pad [string range "----------------------------------------" 1 $l]
1818         $ctext insert end "$pad $header $pad\n" filesep
1819     } elseif {[string range $line 0 2] == "+++"} {
1820         # no need to do anything with this
1821     } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1822         set diffnexthead $fn
1823         set diffnextnote "created, mode $m"
1824     } elseif {[string range $line 0 8] == "Deleted: "} {
1825         set diffnexthead [string range $line 9 end]
1826         set diffnextnote "deleted"
1827     } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1828         # save the filename in case the next thing is "new file mode ..."
1829         set diffnexthead $fn
1830         set diffnextnote "modified"
1831     } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1832         set diffnextnote "new file, mode $m"
1833     } elseif {[string range $line 0 11] == "deleted file"} {
1834         set diffnextnote "deleted"
1835     } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1836                    $line match f1l f1c f2l f2c rest]} {
1837         $ctext insert end "\t" hunksep
1838         $ctext insert end "    $f1l    " d0 "    $f2l    " d1
1839         $ctext insert end "    $rest \n" hunksep
1840     } else {
1841         set x [string range $line 0 0]
1842         if {$x == "-" || $x == "+"} {
1843             set tag [expr {$x == "+"}]
1844             set line [string range $line 1 end]
1845             $ctext insert end "$line\n" d$tag
1846         } elseif {$x == " "} {
1847             set line [string range $line 1 end]
1848             $ctext insert end "$line\n"
1849         } elseif {$x == "\\"} {
1850             # e.g. "\ No newline at end of file"
1851             $ctext insert end "$line\n" filesep
1852         } else {
1853             # Something else we don't recognize
1854             if {$curdifftag != "Comments"} {
1855                 $ctext insert end "\n"
1856                 $ctext tag add $curdifftag $curtagstart end
1857                 set seenfile($curdifftag) 1
1858                 set curtagstart [$ctext index "end - 1c"]
1859                 set curdifftag Comments
1860             }
1861             $ctext insert end "$line\n" filesep
1862         }
1863     }
1864     $ctext conf -state disabled
1865     if {[clock clicks -milliseconds] >= $nextupdate} {
1866         incr nextupdate 100
1867         fileevent $bdf readable {}
1868         update
1869         fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1870     }
1871 }
1872
1873 proc nextfile {} {
1874     global difffilestart ctext
1875     set here [$ctext index @0,0]
1876     for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1877         if {[$ctext compare $difffilestart($i) > $here]} {
1878             $ctext yview $difffilestart($i)
1879             break
1880         }
1881     }
1882 }
1883
1884 proc listboxsel {} {
1885     global ctext cflist currentid treediffs seenfile
1886     if {![info exists currentid]} return
1887     set sel [lsort [$cflist curselection]]
1888     if {$sel eq {}} return
1889     set first [lindex $sel 0]
1890     catch {$ctext yview fmark.$first}
1891 }
1892
1893 proc setcoords {} {
1894     global linespc charspc canvx0 canvy0 mainfont
1895     set linespc [font metrics $mainfont -linespace]
1896     set charspc [font measure $mainfont "m"]
1897     set canvy0 [expr 3 + 0.5 * $linespc]
1898     set canvx0 [expr 3 + 0.5 * $linespc]
1899 }
1900
1901 proc redisplay {} {
1902     global selectedline stopped redisplaying phase
1903     if {$stopped > 1} return
1904     if {$phase == "getcommits"} return
1905     set redisplaying 1
1906     if {$phase == "drawgraph" || $phase == "incrdraw"} {
1907         set stopped 1
1908     } else {
1909         drawgraph
1910     }
1911 }
1912
1913 proc incrfont {inc} {
1914     global mainfont namefont textfont selectedline ctext canv phase
1915     global stopped entries
1916     unmarkmatches
1917     set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1918     set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1919     set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1920     setcoords
1921     $ctext conf -font $textfont
1922     $ctext tag conf filesep -font [concat $textfont bold]
1923     foreach e $entries {
1924         $e conf -font $mainfont
1925     }
1926     if {$phase == "getcommits"} {
1927         $canv itemconf textitems -font $mainfont
1928     }
1929     redisplay
1930 }
1931
1932 proc clearsha1 {} {
1933     global sha1entry sha1string
1934     if {[string length $sha1string] == 40} {
1935         $sha1entry delete 0 end
1936     }
1937 }
1938
1939 proc sha1change {n1 n2 op} {
1940     global sha1string currentid sha1but
1941     if {$sha1string == {}
1942         || ([info exists currentid] && $sha1string == $currentid)} {
1943         set state disabled
1944     } else {
1945         set state normal
1946     }
1947     if {[$sha1but cget -state] == $state} return
1948     if {$state == "normal"} {
1949         $sha1but conf -state normal -relief raised -text "Goto: "
1950     } else {
1951         $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1952     }
1953 }
1954
1955 proc gotocommit {} {
1956     global sha1string currentid idline tagids
1957     if {$sha1string == {}
1958         || ([info exists currentid] && $sha1string == $currentid)} return
1959     if {[info exists tagids($sha1string)]} {
1960         set id $tagids($sha1string)
1961     } else {
1962         set id [string tolower $sha1string]
1963     }
1964     if {[info exists idline($id)]} {
1965         selectline $idline($id)
1966         return
1967     }
1968     if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1969         set type "SHA1 id"
1970     } else {
1971         set type "Tag"
1972     }
1973     error_popup "$type $sha1string is not known"
1974 }
1975
1976 proc lineenter {x y id} {
1977     global hoverx hovery hoverid hovertimer
1978     global commitinfo canv
1979
1980     if {![info exists commitinfo($id)]} return
1981     set hoverx $x
1982     set hovery $y
1983     set hoverid $id
1984     if {[info exists hovertimer]} {
1985         after cancel $hovertimer
1986     }
1987     set hovertimer [after 500 linehover]
1988     $canv delete hover
1989 }
1990
1991 proc linemotion {x y id} {
1992     global hoverx hovery hoverid hovertimer
1993
1994     if {[info exists hoverid] && $id == $hoverid} {
1995         set hoverx $x
1996         set hovery $y
1997         if {[info exists hovertimer]} {
1998             after cancel $hovertimer
1999         }
2000         set hovertimer [after 500 linehover]
2001     }
2002 }
2003
2004 proc lineleave {id} {
2005     global hoverid hovertimer canv
2006
2007     if {[info exists hoverid] && $id == $hoverid} {
2008         $canv delete hover
2009         if {[info exists hovertimer]} {
2010             after cancel $hovertimer
2011             unset hovertimer
2012         }
2013         unset hoverid
2014     }
2015 }
2016
2017 proc linehover {} {
2018     global hoverx hovery hoverid hovertimer
2019     global canv linespc lthickness
2020     global commitinfo mainfont
2021
2022     set text [lindex $commitinfo($hoverid) 0]
2023     set ymax [lindex [$canv cget -scrollregion] 3]
2024     if {$ymax == {}} return
2025     set yfrac [lindex [$canv yview] 0]
2026     set x [expr {$hoverx + 2 * $linespc}]
2027     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2028     set x0 [expr {$x - 2 * $lthickness}]
2029     set y0 [expr {$y - 2 * $lthickness}]
2030     set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2031     set y1 [expr {$y + $linespc + 2 * $lthickness}]
2032     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2033                -fill \#ffff80 -outline black -width 1 -tags hover]
2034     $canv raise $t
2035     set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2036     $canv raise $t
2037 }
2038
2039 proc lineclick {x y id} {
2040     global ctext commitinfo children cflist canv
2041
2042     unmarkmatches
2043     $canv delete hover
2044     # fill the details pane with info about this line
2045     $ctext conf -state normal
2046     $ctext delete 0.0 end
2047     $ctext insert end "Parent:\n "
2048     catch {destroy $ctext.$id}
2049     button $ctext.$id -text "Go:" -command "selbyid $id" \
2050         -padx 4 -pady 0
2051     $ctext window create end -window $ctext.$id -align center
2052     set info $commitinfo($id)
2053     $ctext insert end "\t[lindex $info 0]\n"
2054     $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2055     $ctext insert end "\tDate:\t[lindex $info 2]\n"
2056     $ctext insert end "\tID:\t$id\n"
2057     if {[info exists children($id)]} {
2058         $ctext insert end "\nChildren:"
2059         foreach child $children($id) {
2060             $ctext insert end "\n "
2061             catch {destroy $ctext.$child}
2062             button $ctext.$child -text "Go:" -command "selbyid $child" \
2063                 -padx 4 -pady 0
2064             $ctext window create end -window $ctext.$child -align center
2065             set info $commitinfo($child)
2066             $ctext insert end "\t[lindex $info 0]"
2067         }
2068     }
2069     $ctext conf -state disabled
2070
2071     $cflist delete 0 end
2072 }
2073
2074 proc selbyid {id} {
2075     global idline
2076     if {[info exists idline($id)]} {
2077         selectline $idline($id)
2078     }
2079 }
2080
2081 proc mstime {} {
2082     global startmstime
2083     if {![info exists startmstime]} {
2084         set startmstime [clock clicks -milliseconds]
2085     }
2086     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2087 }
2088
2089 proc rowmenu {x y id} {
2090     global rowctxmenu idline selectedline rowmenuid
2091
2092     if {![info exists selectedline] || $idline($id) eq $selectedline} {
2093         set state disabled
2094     } else {
2095         set state normal
2096     }
2097     $rowctxmenu entryconfigure 0 -state $state
2098     $rowctxmenu entryconfigure 1 -state $state
2099     $rowctxmenu entryconfigure 2 -state $state
2100     set rowmenuid $id
2101     tk_popup $rowctxmenu $x $y
2102 }
2103
2104 proc diffvssel {dirn} {
2105     global rowmenuid selectedline lineid
2106     global ctext cflist
2107     global commitinfo
2108
2109     if {![info exists selectedline]} return
2110     if {$dirn} {
2111         set oldid $lineid($selectedline)
2112         set newid $rowmenuid
2113     } else {
2114         set oldid $rowmenuid
2115         set newid $lineid($selectedline)
2116     }
2117     $ctext conf -state normal
2118     $ctext delete 0.0 end
2119     $ctext mark set fmark.0 0.0
2120     $ctext mark gravity fmark.0 left
2121     $cflist delete 0 end
2122     $cflist insert end "Top"
2123     $ctext insert end "From $oldid\n     "
2124     $ctext insert end [lindex $commitinfo($oldid) 0]
2125     $ctext insert end "\n\nTo   $newid\n     "
2126     $ctext insert end [lindex $commitinfo($newid) 0]
2127     $ctext insert end "\n"
2128     $ctext conf -state disabled
2129     $ctext tag delete Comments
2130     $ctext tag remove found 1.0 end
2131     startdiff [list $newid $oldid]
2132 }
2133
2134 proc mkpatch {} {
2135     global rowmenuid currentid commitinfo patchtop patchnum
2136
2137     if {![info exists currentid]} return
2138     set oldid $currentid
2139     set oldhead [lindex $commitinfo($oldid) 0]
2140     set newid $rowmenuid
2141     set newhead [lindex $commitinfo($newid) 0]
2142     set top .patch
2143     set patchtop $top
2144     catch {destroy $top}
2145     toplevel $top
2146     label $top.title -text "Generate patch"
2147     grid $top.title - -pady 10
2148     label $top.from -text "From:"
2149     entry $top.fromsha1 -width 40 -relief flat
2150     $top.fromsha1 insert 0 $oldid
2151     $top.fromsha1 conf -state readonly
2152     grid $top.from $top.fromsha1 -sticky w
2153     entry $top.fromhead -width 60 -relief flat
2154     $top.fromhead insert 0 $oldhead
2155     $top.fromhead conf -state readonly
2156     grid x $top.fromhead -sticky w
2157     label $top.to -text "To:"
2158     entry $top.tosha1 -width 40 -relief flat
2159     $top.tosha1 insert 0 $newid
2160     $top.tosha1 conf -state readonly
2161     grid $top.to $top.tosha1 -sticky w
2162     entry $top.tohead -width 60 -relief flat
2163     $top.tohead insert 0 $newhead
2164     $top.tohead conf -state readonly
2165     grid x $top.tohead -sticky w
2166     button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2167     grid $top.rev x -pady 10
2168     label $top.flab -text "Output file:"
2169     entry $top.fname -width 60
2170     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2171     incr patchnum
2172     grid $top.flab $top.fname -sticky w
2173     frame $top.buts
2174     button $top.buts.gen -text "Generate" -command mkpatchgo
2175     button $top.buts.can -text "Cancel" -command mkpatchcan
2176     grid $top.buts.gen $top.buts.can
2177     grid columnconfigure $top.buts 0 -weight 1 -uniform a
2178     grid columnconfigure $top.buts 1 -weight 1 -uniform a
2179     grid $top.buts - -pady 10 -sticky ew
2180     focus $top.fname
2181 }
2182
2183 proc mkpatchrev {} {
2184     global patchtop
2185
2186     set oldid [$patchtop.fromsha1 get]
2187     set oldhead [$patchtop.fromhead get]
2188     set newid [$patchtop.tosha1 get]
2189     set newhead [$patchtop.tohead get]
2190     foreach e [list fromsha1 fromhead tosha1 tohead] \
2191             v [list $newid $newhead $oldid $oldhead] {
2192         $patchtop.$e conf -state normal
2193         $patchtop.$e delete 0 end
2194         $patchtop.$e insert 0 $v
2195         $patchtop.$e conf -state readonly
2196     }
2197 }
2198
2199 proc mkpatchgo {} {
2200     global patchtop
2201
2202     set oldid [$patchtop.fromsha1 get]
2203     set newid [$patchtop.tosha1 get]
2204     set fname [$patchtop.fname get]
2205     if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
2206         error_popup "Error creating patch: $err"
2207     }
2208     catch {destroy $patchtop}
2209     unset patchtop
2210 }
2211
2212 proc mkpatchcan {} {
2213     global patchtop
2214
2215     catch {destroy $patchtop}
2216     unset patchtop
2217 }
2218
2219 proc mktag {} {
2220     global rowmenuid mktagtop commitinfo
2221
2222     set top .maketag
2223     set mktagtop $top
2224     catch {destroy $top}
2225     toplevel $top
2226     label $top.title -text "Create tag"
2227     grid $top.title - -pady 10
2228     label $top.id -text "ID:"
2229     entry $top.sha1 -width 40 -relief flat
2230     $top.sha1 insert 0 $rowmenuid
2231     $top.sha1 conf -state readonly
2232     grid $top.id $top.sha1 -sticky w
2233     entry $top.head -width 60 -relief flat
2234     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2235     $top.head conf -state readonly
2236     grid x $top.head -sticky w
2237     label $top.tlab -text "Tag name:"
2238     entry $top.tag -width 60
2239     grid $top.tlab $top.tag -sticky w
2240     frame $top.buts
2241     button $top.buts.gen -text "Create" -command mktaggo
2242     button $top.buts.can -text "Cancel" -command mktagcan
2243     grid $top.buts.gen $top.buts.can
2244     grid columnconfigure $top.buts 0 -weight 1 -uniform a
2245     grid columnconfigure $top.buts 1 -weight 1 -uniform a
2246     grid $top.buts - -pady 10 -sticky ew
2247     focus $top.tag
2248 }
2249
2250 proc domktag {} {
2251     global mktagtop env tagids idtags
2252     global idpos idline linehtag canv selectedline
2253
2254     set id [$mktagtop.sha1 get]
2255     set tag [$mktagtop.tag get]
2256     if {$tag == {}} {
2257         error_popup "No tag name specified"
2258         return
2259     }
2260     if {[info exists tagids($tag)]} {
2261         error_popup "Tag \"$tag\" already exists"
2262         return
2263     }
2264     if {[catch {
2265         set dir ".git"
2266         if {[info exists env(GIT_DIR)]} {
2267             set dir $env(GIT_DIR)
2268         }
2269         set fname [file join $dir "refs/tags" $tag]
2270         set f [open $fname w]
2271         puts $f $id
2272         close $f
2273     } err]} {
2274         error_popup "Error creating tag: $err"
2275         return
2276     }
2277
2278     set tagids($tag) $id
2279     lappend idtags($id) $tag
2280     $canv delete tag.$id
2281     set xt [eval drawtags $id $idpos($id)]
2282     $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
2283     if {[info exists selectedline] && $selectedline == $idline($id)} {
2284         selectline $selectedline
2285     }
2286 }
2287
2288 proc mktagcan {} {
2289     global mktagtop
2290
2291     catch {destroy $mktagtop}
2292     unset mktagtop
2293 }
2294
2295 proc mktaggo {} {
2296     domktag
2297     mktagcan
2298 }
2299
2300 proc writecommit {} {
2301     global rowmenuid wrcomtop commitinfo wrcomcmd
2302
2303     set top .writecommit
2304     set wrcomtop $top
2305     catch {destroy $top}
2306     toplevel $top
2307     label $top.title -text "Write commit to file"
2308     grid $top.title - -pady 10
2309     label $top.id -text "ID:"
2310     entry $top.sha1 -width 40 -relief flat
2311     $top.sha1 insert 0 $rowmenuid
2312     $top.sha1 conf -state readonly
2313     grid $top.id $top.sha1 -sticky w
2314     entry $top.head -width 60 -relief flat
2315     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2316     $top.head conf -state readonly
2317     grid x $top.head -sticky w
2318     label $top.clab -text "Command:"
2319     entry $top.cmd -width 60 -textvariable wrcomcmd
2320     grid $top.clab $top.cmd -sticky w -pady 10
2321     label $top.flab -text "Output file:"
2322     entry $top.fname -width 60
2323     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
2324     grid $top.flab $top.fname -sticky w
2325     frame $top.buts
2326     button $top.buts.gen -text "Write" -command wrcomgo
2327     button $top.buts.can -text "Cancel" -command wrcomcan
2328     grid $top.buts.gen $top.buts.can
2329     grid columnconfigure $top.buts 0 -weight 1 -uniform a
2330     grid columnconfigure $top.buts 1 -weight 1 -uniform a
2331     grid $top.buts - -pady 10 -sticky ew
2332     focus $top.fname
2333 }
2334
2335 proc wrcomgo {} {
2336     global wrcomtop
2337
2338     set id [$wrcomtop.sha1 get]
2339     set cmd "echo $id | [$wrcomtop.cmd get]"
2340     set fname [$wrcomtop.fname get]
2341     if {[catch {exec sh -c $cmd >$fname &} err]} {
2342         error_popup "Error writing commit: $err"
2343     }
2344     catch {destroy $wrcomtop}
2345     unset wrcomtop
2346 }
2347
2348 proc wrcomcan {} {
2349     global wrcomtop
2350
2351     catch {destroy $wrcomtop}
2352     unset wrcomtop
2353 }
2354
2355 proc doquit {} {
2356     global stopped
2357     set stopped 100
2358     destroy .
2359 }
2360
2361 # defaults...
2362 set datemode 0
2363 set boldnames 0
2364 set diffopts "-U 5 -p"
2365 set wrcomcmd "git-diff-tree --stdin -p --pretty"
2366
2367 set mainfont {Helvetica 9}
2368 set textfont {Courier 9}
2369 set findmergefiles 0
2370
2371 set colors {green red blue magenta darkgrey brown orange}
2372
2373 catch {source ~/.gitk}
2374
2375 set namefont $mainfont
2376 if {$boldnames} {
2377     lappend namefont bold
2378 }
2379
2380 set revtreeargs {}
2381 foreach arg $argv {
2382     switch -regexp -- $arg {
2383         "^$" { }
2384         "^-b" { set boldnames 1 }
2385         "^-d" { set datemode 1 }
2386         default {
2387             lappend revtreeargs $arg
2388         }
2389     }
2390 }
2391
2392 set stopped 0
2393 set redisplaying 0
2394 set stuffsaved 0
2395 set patchnum 0
2396 setcoords
2397 makewindow
2398 readrefs
2399 getcommits $revtreeargs