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