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 gitdir {} {
  11     global env
  12     if {[info exists env(GIT_DIR)]} {
  13         return $env(GIT_DIR)
  14     } else {
  15         return ".git"
  16     }
  17 }
  18
  19 proc getcommits {rargs} {
  20     global commits commfd phase canv mainfont env
  21     global startmsecs nextupdate
  22     global ctext maincursor textcursor leftover
  23
  24     # check that we can find a .git directory somewhere...
  25     set gitdir [gitdir]
  26     if {![file isdirectory $gitdir]} {
  27         error_popup "Cannot find the git directory \"$gitdir\"."
  28         exit 1
  29     }
  30     set commits {}
  31     set phase getcommits
  32     set startmsecs [clock clicks -milliseconds]
  33     set nextupdate [expr $startmsecs + 100]
  34     if [catch {
  35         set parse_args [concat --default HEAD $rargs]
  36         set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
  37     }] {
  38         # if git-rev-parse failed for some reason...
  39         if {$rargs == {}} {
  40             set rargs HEAD
  41         }
  42         set parsed_args $rargs
  43     }
  44     if [catch {
  45         set commfd [open "|git-rev-list --header --topo-order $parsed_args" r]
  46     } err] {
  47         puts stderr "Error executing git-rev-list: $err"
  48         exit 1
  49     }
  50     set leftover {}
  51     fconfigure $commfd -blocking 0 -translation binary
  52     fileevent $commfd readable "getcommitlines $commfd"
  53     $canv delete all
  54     $canv create text 3 3 -anchor nw -text "Reading commits..." \
  55         -font $mainfont -tags textitems
  56     . config -cursor watch
  57     $ctext config -cursor watch
  58 }
  59
  60 proc getcommitlines {commfd}  {
  61     global commits parents cdate children nchildren
  62     global commitlisted phase commitinfo nextupdate
  63     global stopped redisplaying leftover
  64
  65     set stuff [read $commfd]
  66     if {$stuff == {}} {
  67         if {![eof $commfd]} return
  68         # set it blocking so we wait for the process to terminate
  69         fconfigure $commfd -blocking 1
  70         if {![catch {close $commfd} err]} {
  71             after idle finishcommits
  72             return
  73         }
  74         if {[string range $err 0 4] == "usage"} {
  75             set err \
  76 {Gitk: error reading commits: bad arguments to git-rev-list.
  77 (Note: arguments to gitk are passed to git-rev-list
  78 to allow selection of commits to be displayed.)}
  79         } else {
  80             set err "Error reading commits: $err"
  81         }
  82         error_popup $err
  83         exit 1
  84     }
  85     set start 0
  86     while 1 {
  87         set i [string first "\0" $stuff $start]
  88         if {$i < 0} {
  89             append leftover [string range $stuff $start end]
  90             return
  91         }
  92         set cmit [string range $stuff $start [expr {$i - 1}]]
  93         if {$start == 0} {
  94             set cmit "$leftover$cmit"
  95             set leftover {}
  96         }
  97         set start [expr {$i + 1}]
  98         if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
  99             set shortcmit $cmit
 100             if {[string length $shortcmit] > 80} {
 101                 set shortcmit "[string range $shortcmit 0 80]..."
 102             }
 103             error_popup "Can't parse git-rev-list output: {$shortcmit}"
 104             exit 1
 105         }
 106         set cmit [string range $cmit 41 end]
 107         lappend commits $id
 108         set commitlisted($id) 1
 109         parsecommit $id $cmit 1
 110         drawcommit $id
 111         if {[clock clicks -milliseconds] >= $nextupdate} {
 112             doupdate
 113         }
 114         while {$redisplaying} {
 115             set redisplaying 0
 116             if {$stopped == 1} {
 117                 set stopped 0
 118                 set phase "getcommits"
 119                 foreach id $commits {
 120                     drawcommit $id
 121                     if {$stopped} break
 122                     if {[clock clicks -milliseconds] >= $nextupdate} {
 123                         doupdate
 124                     }
 125                 }
 126             }
 127         }
 128     }
 129 }
 130
 131 proc doupdate {} {
 132     global commfd nextupdate
 133
 134     incr nextupdate 100
 135     fileevent $commfd readable {}
 136     update
 137     fileevent $commfd readable "getcommitlines $commfd"
 138 }
 139
 140 proc readcommit {id} {
 141     if [catch {set contents [exec git-cat-file commit $id]}] return
 142     parsecommit $id $contents 0
 143 }
 144
 145 proc parsecommit {id contents listed} {
 146     global commitinfo children nchildren parents nparents cdate ncleft
 147
 148     set inhdr 1
 149     set comment {}
 150     set headline {}
 151     set auname {}
 152     set audate {}
 153     set comname {}
 154     set comdate {}
 155     if {![info exists nchildren($id)]} {
 156         set children($id) {}
 157         set nchildren($id) 0
 158         set ncleft($id) 0
 159     }
 160     set parents($id) {}
 161     set nparents($id) 0
 162     foreach line [split $contents "\n"] {
 163         if {$inhdr} {
 164             if {$line == {}} {
 165                 set inhdr 0
 166             } else {
 167                 set tag [lindex $line 0]
 168                 if {$tag == "parent"} {
 169                     set p [lindex $line 1]
 170                     if {![info exists nchildren($p)]} {
 171                         set children($p) {}
 172                         set nchildren($p) 0
 173                         set ncleft($p) 0
 174                     }
 175                     lappend parents($id) $p
 176                     incr nparents($id)
 177                     # sometimes we get a commit that lists a parent twice...
 178                     if {$listed && [lsearch -exact $children($p) $id] < 0} {
 179                         lappend children($p) $id
 180                         incr nchildren($p)
 181                         incr ncleft($p)
 182                     }
 183                 } elseif {$tag == "author"} {
 184                     set x [expr {[llength $line] - 2}]
 185                     set audate [lindex $line $x]
 186                     set auname [lrange $line 1 [expr {$x - 1}]]
 187                 } elseif {$tag == "committer"} {
 188                     set x [expr {[llength $line] - 2}]
 189                     set comdate [lindex $line $x]
 190                     set comname [lrange $line 1 [expr {$x - 1}]]
 191                 }
 192             }
 193         } else {
 194             if {$comment == {}} {
 195                 set headline [string trim $line]
 196             } else {
 197                 append comment "\n"
 198             }
 199             if {!$listed} {
 200                 # git-rev-list indents the comment by 4 spaces;
 201                 # if we got this via git-cat-file, add the indentation
 202                 append comment "    "
 203             }
 204             append comment $line
 205         }
 206     }
 207     if {$audate != {}} {
 208         set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
 209     }
 210     if {$comdate != {}} {
 211         set cdate($id) $comdate
 212         set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
 213     }
 214     set commitinfo($id) [list $headline $auname $audate \
 215                              $comname $comdate $comment]
 216 }
 217
 218 proc readrefs {} {
 219     global tagids idtags headids idheads
 220     set tags [glob -nocomplain -types f [gitdir]/refs/tags/*]
 221     foreach f $tags {
 222         catch {
 223             set fd [open $f r]
 224             set line [read $fd]
 225             if {[regexp {^[0-9a-f]{40}} $line id]} {
 226                 set direct [file tail $f]
 227                 set tagids($direct) $id
 228                 lappend idtags($id) $direct
 229                 set contents [split [exec git-cat-file tag $id] "\n"]
 230                 set obj {}
 231                 set type {}
 232                 set tag {}
 233                 foreach l $contents {
 234                     if {$l == {}} break
 235                     switch -- [lindex $l 0] {
 236                         "object" {set obj [lindex $l 1]}
 237                         "type" {set type [lindex $l 1]}
 238                         "tag" {set tag [string range $l 4 end]}
 239                     }
 240                 }
 241                 if {$obj != {} && $type == "commit" && $tag != {}} {
 242                     set tagids($tag) $obj
 243                     lappend idtags($obj) $tag
 244                 }
 245             }
 246             close $fd
 247         }
 248     }
 249     set heads [glob -nocomplain -types f [gitdir]/refs/heads/*]
 250     foreach f $heads {
 251         catch {
 252             set fd [open $f r]
 253             set line [read $fd 40]
 254             if {[regexp {^[0-9a-f]{40}} $line id]} {
 255                 set head [file tail $f]
 256                 set headids($head) $line
 257                 lappend idheads($line) $head
 258             }
 259             close $fd
 260         }
 261     }
 262 }
 263
 264 proc error_popup msg {
 265     set w .error
 266     toplevel $w
 267     wm transient $w .
 268     message $w.m -text $msg -justify center -aspect 400
 269     pack $w.m -side top -fill x -padx 20 -pady 20
 270     button $w.ok -text OK -command "destroy $w"
 271     pack $w.ok -side bottom -fill x
 272     bind $w <Visibility> "grab $w; focus $w"
 273     tkwait window $w
 274 }
 275
 276 proc makewindow {} {
 277     global canv canv2 canv3 linespc charspc ctext cflist textfont
 278     global findtype findtypemenu findloc findstring fstring geometry
 279     global entries sha1entry sha1string sha1but
 280     global maincursor textcursor
 281     global rowctxmenu gaudydiff mergemax
 282
 283     menu .bar
 284     .bar add cascade -label "File" -menu .bar.file
 285     menu .bar.file
 286     .bar.file add command -label "Quit" -command doquit
 287     menu .bar.help
 288     .bar add cascade -label "Help" -menu .bar.help
 289     .bar.help add command -label "About gitk" -command about
 290     . configure -menu .bar
 291
 292     if {![info exists geometry(canv1)]} {
 293         set geometry(canv1) [expr 45 * $charspc]
 294         set geometry(canv2) [expr 30 * $charspc]
 295         set geometry(canv3) [expr 15 * $charspc]
 296         set geometry(canvh) [expr 25 * $linespc + 4]
 297         set geometry(ctextw) 80
 298         set geometry(ctexth) 30
 299         set geometry(cflistw) 30
 300     }
 301     panedwindow .ctop -orient vertical
 302     if {[info exists geometry(width)]} {
 303         .ctop conf -width $geometry(width) -height $geometry(height)
 304         set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
 305         set geometry(ctexth) [expr {($texth - 8) /
 306                                     [font metrics $textfont -linespace]}]
 307     }
 308     frame .ctop.top
 309     frame .ctop.top.bar
 310     pack .ctop.top.bar -side bottom -fill x
 311     set cscroll .ctop.top.csb
 312     scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
 313     pack $cscroll -side right -fill y
 314     panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
 315     pack .ctop.top.clist -side top -fill both -expand 1
 316     .ctop add .ctop.top
 317     set canv .ctop.top.clist.canv
 318     canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
 319         -bg white -bd 0 \
 320         -yscrollincr $linespc -yscrollcommand "$cscroll set"
 321     .ctop.top.clist add $canv
 322     set canv2 .ctop.top.clist.canv2
 323     canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
 324         -bg white -bd 0 -yscrollincr $linespc
 325     .ctop.top.clist add $canv2
 326     set canv3 .ctop.top.clist.canv3
 327     canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
 328         -bg white -bd 0 -yscrollincr $linespc
 329     .ctop.top.clist add $canv3
 330     bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
 331
 332     set sha1entry .ctop.top.bar.sha1
 333     set entries $sha1entry
 334     set sha1but .ctop.top.bar.sha1label
 335     button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
 336         -command gotocommit -width 8
 337     $sha1but conf -disabledforeground [$sha1but cget -foreground]
 338     pack .ctop.top.bar.sha1label -side left
 339     entry $sha1entry -width 40 -font $textfont -textvariable sha1string
 340     trace add variable sha1string write sha1change
 341     pack $sha1entry -side left -pady 2
 342     button .ctop.top.bar.findbut -text "Find" -command dofind
 343     pack .ctop.top.bar.findbut -side left
 344     set findstring {}
 345     set fstring .ctop.top.bar.findstring
 346     lappend entries $fstring
 347     entry $fstring -width 30 -font $textfont -textvariable findstring
 348     pack $fstring -side left -expand 1 -fill x
 349     set findtype Exact
 350     set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
 351                           findtype Exact IgnCase Regexp]
 352     set findloc "All fields"
 353     tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
 354         Comments Author Committer Files Pickaxe
 355     pack .ctop.top.bar.findloc -side right
 356     pack .ctop.top.bar.findtype -side right
 357     # for making sure type==Exact whenever loc==Pickaxe
 358     trace add variable findloc write findlocchange
 359
 360     panedwindow .ctop.cdet -orient horizontal
 361     .ctop add .ctop.cdet
 362     frame .ctop.cdet.left
 363     set ctext .ctop.cdet.left.ctext
 364     text $ctext -bg white -state disabled -font $textfont \
 365         -width $geometry(ctextw) -height $geometry(ctexth) \
 366         -yscrollcommand ".ctop.cdet.left.sb set"
 367     scrollbar .ctop.cdet.left.sb -command "$ctext yview"
 368     pack .ctop.cdet.left.sb -side right -fill y
 369     pack $ctext -side left -fill both -expand 1
 370     .ctop.cdet add .ctop.cdet.left
 371
 372     $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
 373     if {$gaudydiff} {
 374         $ctext tag conf hunksep -back blue -fore white
 375         $ctext tag conf d0 -back "#ff8080"
 376         $ctext tag conf d1 -back green
 377     } else {
 378         $ctext tag conf hunksep -fore blue
 379         $ctext tag conf d0 -fore red
 380         $ctext tag conf d1 -fore "#00a000"
 381         $ctext tag conf m0 -fore red
 382         $ctext tag conf m1 -fore blue
 383         $ctext tag conf m2 -fore green
 384         $ctext tag conf m3 -fore purple
 385         $ctext tag conf m4 -fore brown
 386         $ctext tag conf mmax -fore darkgrey
 387         set mergemax 5
 388         $ctext tag conf mresult -font [concat $textfont bold]
 389         $ctext tag conf msep -font [concat $textfont bold]
 390         $ctext tag conf found -back yellow
 391     }
 392
 393     frame .ctop.cdet.right
 394     set cflist .ctop.cdet.right.cfiles
 395     listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
 396         -yscrollcommand ".ctop.cdet.right.sb set"
 397     scrollbar .ctop.cdet.right.sb -command "$cflist yview"
 398     pack .ctop.cdet.right.sb -side right -fill y
 399     pack $cflist -side left -fill both -expand 1
 400     .ctop.cdet add .ctop.cdet.right
 401     bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
 402
 403     pack .ctop -side top -fill both -expand 1
 404
 405     bindall <1> {selcanvline %W %x %y}
 406     #bindall <B1-Motion> {selcanvline %W %x %y}
 407     bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
 408     bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
 409     bindall <2> "allcanvs scan mark 0 %y"
 410     bindall <B2-Motion> "allcanvs scan dragto 0 %y"
 411     bind . <Key-Up> "selnextline -1"
 412     bind . <Key-Down> "selnextline 1"
 413     bind . <Key-Prior> "allcanvs yview scroll -1 pages"
 414     bind . <Key-Next> "allcanvs yview scroll 1 pages"
 415     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
 416     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
 417     bindkey <Key-space> "$ctext yview scroll 1 pages"
 418     bindkey p "selnextline -1"
 419     bindkey n "selnextline 1"
 420     bindkey b "$ctext yview scroll -1 pages"
 421     bindkey d "$ctext yview scroll 18 units"
 422     bindkey u "$ctext yview scroll -18 units"
 423     bindkey / {findnext 1}
 424     bindkey <Key-Return> {findnext 0}
 425     bindkey ? findprev
 426     bindkey f nextfile
 427     bind . <Control-q> doquit
 428     bind . <Control-f> dofind
 429     bind . <Control-g> {findnext 0}
 430     bind . <Control-r> findprev
 431     bind . <Control-equal> {incrfont 1}
 432     bind . <Control-KP_Add> {incrfont 1}
 433     bind . <Control-minus> {incrfont -1}
 434     bind . <Control-KP_Subtract> {incrfont -1}
 435     bind $cflist <<ListboxSelect>> listboxsel
 436     bind . <Destroy> {savestuff %W}
 437     bind . <Button-1> "click %W"
 438     bind $fstring <Key-Return> dofind
 439     bind $sha1entry <Key-Return> gotocommit
 440     bind $sha1entry <<PasteSelection>> clearsha1
 441
 442     set maincursor [. cget -cursor]
 443     set textcursor [$ctext cget -cursor]
 444
 445     set rowctxmenu .rowctxmenu
 446     menu $rowctxmenu -tearoff 0
 447     $rowctxmenu add command -label "Diff this -> selected" \
 448         -command {diffvssel 0}
 449     $rowctxmenu add command -label "Diff selected -> this" \
 450         -command {diffvssel 1}
 451     $rowctxmenu add command -label "Make patch" -command mkpatch
 452     $rowctxmenu add command -label "Create tag" -command mktag
 453     $rowctxmenu add command -label "Write commit to file" -command writecommit
 454 }
 455
 456 # when we make a key binding for the toplevel, make sure
 457 # it doesn't get triggered when that key is pressed in the
 458 # find string entry widget.
 459 proc bindkey {ev script} {
 460     global entries
 461     bind . $ev $script
 462     set escript [bind Entry $ev]
 463     if {$escript == {}} {
 464         set escript [bind Entry <Key>]
 465     }
 466     foreach e $entries {
 467         bind $e $ev "$escript; break"
 468     }
 469 }
 470
 471 # set the focus back to the toplevel for any click outside
 472 # the entry widgets
 473 proc click {w} {
 474     global entries
 475     foreach e $entries {
 476         if {$w == $e} return
 477     }
 478     focus .
 479 }
 480
 481 proc savestuff {w} {
 482     global canv canv2 canv3 ctext cflist mainfont textfont
 483     global stuffsaved findmergefiles gaudydiff
 484
 485     if {$stuffsaved} return
 486     if {![winfo viewable .]} return
 487     catch {
 488         set f [open "~/.gitk-new" w]
 489         puts $f [list set mainfont $mainfont]
 490         puts $f [list set textfont $textfont]
 491         puts $f [list set findmergefiles $findmergefiles]
 492         puts $f [list set gaudydiff $gaudydiff]
 493         puts $f "set geometry(width) [winfo width .ctop]"
 494         puts $f "set geometry(height) [winfo height .ctop]"
 495         puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
 496         puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
 497         puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
 498         puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
 499         set wid [expr {([winfo width $ctext] - 8) \
 500                            / [font measure $textfont "0"]}]
 501         puts $f "set geometry(ctextw) $wid"
 502         set wid [expr {([winfo width $cflist] - 11) \
 503                            / [font measure [$cflist cget -font] "0"]}]
 504         puts $f "set geometry(cflistw) $wid"
 505         close $f
 506         file rename -force "~/.gitk-new" "~/.gitk"
 507     }
 508     set stuffsaved 1
 509 }
 510
 511 proc resizeclistpanes {win w} {
 512     global oldwidth
 513     if [info exists oldwidth($win)] {
 514         set s0 [$win sash coord 0]
 515         set s1 [$win sash coord 1]
 516         if {$w < 60} {
 517             set sash0 [expr {int($w/2 - 2)}]
 518             set sash1 [expr {int($w*5/6 - 2)}]
 519         } else {
 520             set factor [expr {1.0 * $w / $oldwidth($win)}]
 521             set sash0 [expr {int($factor * [lindex $s0 0])}]
 522             set sash1 [expr {int($factor * [lindex $s1 0])}]
 523             if {$sash0 < 30} {
 524                 set sash0 30
 525             }
 526             if {$sash1 < $sash0 + 20} {
 527                 set sash1 [expr $sash0 + 20]
 528             }
 529             if {$sash1 > $w - 10} {
 530                 set sash1 [expr $w - 10]
 531                 if {$sash0 > $sash1 - 20} {
 532                     set sash0 [expr $sash1 - 20]
 533                 }
 534             }
 535         }
 536         $win sash place 0 $sash0 [lindex $s0 1]
 537         $win sash place 1 $sash1 [lindex $s1 1]
 538     }
 539     set oldwidth($win) $w
 540 }
 541
 542 proc resizecdetpanes {win w} {
 543     global oldwidth
 544     if [info exists oldwidth($win)] {
 545         set s0 [$win sash coord 0]
 546         if {$w < 60} {
 547             set sash0 [expr {int($w*3/4 - 2)}]
 548         } else {
 549             set factor [expr {1.0 * $w / $oldwidth($win)}]
 550             set sash0 [expr {int($factor * [lindex $s0 0])}]
 551             if {$sash0 < 45} {
 552                 set sash0 45
 553             }
 554             if {$sash0 > $w - 15} {
 555                 set sash0 [expr $w - 15]
 556             }
 557         }
 558         $win sash place 0 $sash0 [lindex $s0 1]
 559     }
 560     set oldwidth($win) $w
 561 }
 562
 563 proc allcanvs args {
 564     global canv canv2 canv3
 565     eval $canv $args
 566     eval $canv2 $args
 567     eval $canv3 $args
 568 }
 569
 570 proc bindall {event action} {
 571     global canv canv2 canv3
 572     bind $canv $event $action
 573     bind $canv2 $event $action
 574     bind $canv3 $event $action
 575 }
 576
 577 proc about {} {
 578     set w .about
 579     if {[winfo exists $w]} {
 580         raise $w
 581         return
 582     }
 583     toplevel $w
 584     wm title $w "About gitk"
 585     message $w.m -text {
 586 Gitk version 1.2
 587
 588 Copyright © 2005 Paul Mackerras
 589
 590 Use and redistribute under the terms of the GNU General Public License} \
 591             -justify center -aspect 400
 592     pack $w.m -side top -fill x -padx 20 -pady 20
 593     button $w.ok -text Close -command "destroy $w"
 594     pack $w.ok -side bottom
 595 }
 596
 597 proc assigncolor {id} {
 598     global commitinfo colormap commcolors colors nextcolor
 599     global parents nparents children nchildren
 600     global cornercrossings crossings
 601
 602     if [info exists colormap($id)] return
 603     set ncolors [llength $colors]
 604     if {$nparents($id) <= 1 && $nchildren($id) == 1} {
 605         set child [lindex $children($id) 0]
 606         if {[info exists colormap($child)]
 607             && $nparents($child) == 1} {
 608             set colormap($id) $colormap($child)
 609             return
 610         }
 611     }
 612     set badcolors {}
 613     if {[info exists cornercrossings($id)]} {
 614         foreach x $cornercrossings($id) {
 615             if {[info exists colormap($x)]
 616                 && [lsearch -exact $badcolors $colormap($x)] < 0} {
 617                 lappend badcolors $colormap($x)
 618             }
 619         }
 620         if {[llength $badcolors] >= $ncolors} {
 621             set badcolors {}
 622         }
 623     }
 624     set origbad $badcolors
 625     if {[llength $badcolors] < $ncolors - 1} {
 626         if {[info exists crossings($id)]} {
 627             foreach x $crossings($id) {
 628                 if {[info exists colormap($x)]
 629                     && [lsearch -exact $badcolors $colormap($x)] < 0} {
 630                     lappend badcolors $colormap($x)
 631                 }
 632             }
 633             if {[llength $badcolors] >= $ncolors} {
 634                 set badcolors $origbad
 635             }
 636         }
 637         set origbad $badcolors
 638     }
 639     if {[llength $badcolors] < $ncolors - 1} {
 640         foreach child $children($id) {
 641             if {[info exists colormap($child)]
 642                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
 643                 lappend badcolors $colormap($child)
 644             }
 645             if {[info exists parents($child)]} {
 646                 foreach p $parents($child) {
 647                     if {[info exists colormap($p)]
 648                         && [lsearch -exact $badcolors $colormap($p)] < 0} {
 649                         lappend badcolors $colormap($p)
 650                     }
 651                 }
 652             }
 653         }
 654         if {[llength $badcolors] >= $ncolors} {
 655             set badcolors $origbad
 656         }
 657     }
 658     for {set i 0} {$i <= $ncolors} {incr i} {
 659         set c [lindex $colors $nextcolor]
 660         if {[incr nextcolor] >= $ncolors} {
 661             set nextcolor 0
 662         }
 663         if {[lsearch -exact $badcolors $c]} break
 664     }
 665     set colormap($id) $c
 666 }
 667
 668 proc initgraph {} {
 669     global canvy canvy0 lineno numcommits lthickness nextcolor linespc
 670     global mainline sidelines
 671     global nchildren ncleft
 672
 673     allcanvs delete all
 674     set nextcolor 0
 675     set canvy $canvy0
 676     set lineno -1
 677     set numcommits 0
 678     set lthickness [expr {int($linespc / 9) + 1}]
 679     catch {unset mainline}
 680     catch {unset sidelines}
 681     foreach id [array names nchildren] {
 682         set ncleft($id) $nchildren($id)
 683     }
 684 }
 685
 686 proc bindline {t id} {
 687     global canv
 688
 689     $canv bind $t <Enter> "lineenter %x %y $id"
 690     $canv bind $t <Motion> "linemotion %x %y $id"
 691     $canv bind $t <Leave> "lineleave $id"
 692     $canv bind $t <Button-1> "lineclick %x %y $id"
 693 }
 694
 695 proc drawcommitline {level} {
 696     global parents children nparents nchildren todo
 697     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 698     global lineid linehtag linentag linedtag commitinfo
 699     global colormap numcommits currentparents dupparents
 700     global oldlevel oldnlines oldtodo
 701     global idtags idline idheads
 702     global lineno lthickness mainline sidelines
 703     global commitlisted rowtextx idpos
 704
 705     incr numcommits
 706     incr lineno
 707     set id [lindex $todo $level]
 708     set lineid($lineno) $id
 709     set idline($id) $lineno
 710     set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
 711     if {![info exists commitinfo($id)]} {
 712         readcommit $id
 713         if {![info exists commitinfo($id)]} {
 714             set commitinfo($id) {"No commit information available"}
 715             set nparents($id) 0
 716         }
 717     }
 718     assigncolor $id
 719     set currentparents {}
 720     set dupparents {}
 721     if {[info exists commitlisted($id)] && [info exists parents($id)]} {
 722         foreach p $parents($id) {
 723             if {[lsearch -exact $currentparents $p] < 0} {
 724                 lappend currentparents $p
 725             } else {
 726                 # remember that this parent was listed twice
 727                 lappend dupparents $p
 728             }
 729         }
 730     }
 731     set x [expr $canvx0 + $level * $linespc]
 732     set y1 $canvy
 733     set canvy [expr $canvy + $linespc]
 734     allcanvs conf -scrollregion \
 735         [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
 736     if {[info exists mainline($id)]} {
 737         lappend mainline($id) $x $y1
 738         set t [$canv create line $mainline($id) \
 739                    -width $lthickness -fill $colormap($id)]
 740         $canv lower $t
 741         bindline $t $id
 742     }
 743     if {[info exists sidelines($id)]} {
 744         foreach ls $sidelines($id) {
 745             set coords [lindex $ls 0]
 746             set thick [lindex $ls 1]
 747             set t [$canv create line $coords -fill $colormap($id) \
 748                        -width [expr {$thick * $lthickness}]]
 749             $canv lower $t
 750             bindline $t $id
 751         }
 752     }
 753     set orad [expr {$linespc / 3}]
 754     set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
 755                [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
 756                -fill $ofill -outline black -width 1]
 757     $canv raise $t
 758     $canv bind $t <1> {selcanvline {} %x %y}
 759     set xt [expr $canvx0 + [llength $todo] * $linespc]
 760     if {[llength $currentparents] > 2} {
 761         set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
 762     }
 763     set rowtextx($lineno) $xt
 764     set idpos($id) [list $x $xt $y1]
 765     if {[info exists idtags($id)] || [info exists idheads($id)]} {
 766         set xt [drawtags $id $x $xt $y1]
 767     }
 768     set headline [lindex $commitinfo($id) 0]
 769     set name [lindex $commitinfo($id) 1]
 770     set date [lindex $commitinfo($id) 2]
 771     set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
 772                                -text $headline -font $mainfont ]
 773     $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
 774     set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
 775                                -text $name -font $namefont]
 776     set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
 777                                -text $date -font $mainfont]
 778 }
 779
 780 proc drawtags {id x xt y1} {
 781     global idtags idheads
 782     global linespc lthickness
 783     global canv mainfont
 784
 785     set marks {}
 786     set ntags 0
 787     if {[info exists idtags($id)]} {
 788         set marks $idtags($id)
 789         set ntags [llength $marks]
 790     }
 791     if {[info exists idheads($id)]} {
 792         set marks [concat $marks $idheads($id)]
 793     }
 794     if {$marks eq {}} {
 795         return $xt
 796     }
 797
 798     set delta [expr {int(0.5 * ($linespc - $lthickness))}]
 799     set yt [expr $y1 - 0.5 * $linespc]
 800     set yb [expr $yt + $linespc - 1]
 801     set xvals {}
 802     set wvals {}
 803     foreach tag $marks {
 804         set wid [font measure $mainfont $tag]
 805         lappend xvals $xt
 806         lappend wvals $wid
 807         set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
 808     }
 809     set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
 810                -width $lthickness -fill black -tags tag.$id]
 811     $canv lower $t
 812     foreach tag $marks x $xvals wid $wvals {
 813         set xl [expr $x + $delta]
 814         set xr [expr $x + $delta + $wid + $lthickness]
 815         if {[incr ntags -1] >= 0} {
 816             # draw a tag
 817             $canv create polygon $x [expr $yt + $delta] $xl $yt\
 818                 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
 819                 -width 1 -outline black -fill yellow -tags tag.$id
 820         } else {
 821             # draw a head
 822             set xl [expr $xl - $delta/2]
 823             $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
 824                 -width 1 -outline black -fill green -tags tag.$id
 825         }
 826         $canv create text $xl $y1 -anchor w -text $tag \
 827             -font $mainfont -tags tag.$id
 828     }
 829     return $xt
 830 }
 831
 832 proc updatetodo {level noshortcut} {
 833     global currentparents ncleft todo
 834     global mainline oldlevel oldtodo oldnlines
 835     global canvx0 canvy linespc mainline
 836     global commitinfo
 837
 838     set oldlevel $level
 839     set oldtodo $todo
 840     set oldnlines [llength $todo]
 841     if {!$noshortcut && [llength $currentparents] == 1} {
 842         set p [lindex $currentparents 0]
 843         if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
 844             set ncleft($p) 0
 845             set x [expr $canvx0 + $level * $linespc]
 846             set y [expr $canvy - $linespc]
 847             set mainline($p) [list $x $y]
 848             set todo [lreplace $todo $level $level $p]
 849             return 0
 850         }
 851     }
 852
 853     set todo [lreplace $todo $level $level]
 854     set i $level
 855     foreach p $currentparents {
 856         incr ncleft($p) -1
 857         set k [lsearch -exact $todo $p]
 858         if {$k < 0} {
 859             set todo [linsert $todo $i $p]
 860             incr i
 861         }
 862     }
 863     return 1
 864 }
 865
 866 proc notecrossings {id lo hi corner} {
 867     global oldtodo crossings cornercrossings
 868
 869     for {set i $lo} {[incr i] < $hi} {} {
 870         set p [lindex $oldtodo $i]
 871         if {$p == {}} continue
 872         if {$i == $corner} {
 873             if {![info exists cornercrossings($id)]
 874                 || [lsearch -exact $cornercrossings($id) $p] < 0} {
 875                 lappend cornercrossings($id) $p
 876             }
 877             if {![info exists cornercrossings($p)]
 878                 || [lsearch -exact $cornercrossings($p) $id] < 0} {
 879                 lappend cornercrossings($p) $id
 880             }
 881         } else {
 882             if {![info exists crossings($id)]
 883                 || [lsearch -exact $crossings($id) $p] < 0} {
 884                 lappend crossings($id) $p
 885             }
 886             if {![info exists crossings($p)]
 887                 || [lsearch -exact $crossings($p) $id] < 0} {
 888                 lappend crossings($p) $id
 889             }
 890         }
 891     }
 892 }
 893
 894 proc drawslants {} {
 895     global canv mainline sidelines canvx0 canvy linespc
 896     global oldlevel oldtodo todo currentparents dupparents
 897     global lthickness linespc canvy colormap
 898
 899     set y1 [expr $canvy - $linespc]
 900     set y2 $canvy
 901     set i -1
 902     foreach id $oldtodo {
 903         incr i
 904         if {$id == {}} continue
 905         set xi [expr {$canvx0 + $i * $linespc}]
 906         if {$i == $oldlevel} {
 907             foreach p $currentparents {
 908                 set j [lsearch -exact $todo $p]
 909                 set coords [list $xi $y1]
 910                 set xj [expr {$canvx0 + $j * $linespc}]
 911                 if {$j < $i - 1} {
 912                     lappend coords [expr $xj + $linespc] $y1
 913                     notecrossings $p $j $i [expr {$j + 1}]
 914                 } elseif {$j > $i + 1} {
 915                     lappend coords [expr $xj - $linespc] $y1
 916                     notecrossings $p $i $j [expr {$j - 1}]
 917                 }
 918                 if {[lsearch -exact $dupparents $p] >= 0} {
 919                     # draw a double-width line to indicate the doubled parent
 920                     lappend coords $xj $y2
 921                     lappend sidelines($p) [list $coords 2]
 922                     if {![info exists mainline($p)]} {
 923                         set mainline($p) [list $xj $y2]
 924                     }
 925                 } else {
 926                     # normal case, no parent duplicated
 927                     if {![info exists mainline($p)]} {
 928                         if {$i != $j} {
 929                             lappend coords $xj $y2
 930                         }
 931                         set mainline($p) $coords
 932                     } else {
 933                         lappend coords $xj $y2
 934                         lappend sidelines($p) [list $coords 1]
 935                     }
 936                 }
 937             }
 938         } elseif {[lindex $todo $i] != $id} {
 939             set j [lsearch -exact $todo $id]
 940             set xj [expr {$canvx0 + $j * $linespc}]
 941             lappend mainline($id) $xi $y1 $xj $y2
 942         }
 943     }
 944 }
 945
 946 proc decidenext {{noread 0}} {
 947     global parents children nchildren ncleft todo
 948     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 949     global datemode cdate
 950     global commitinfo
 951     global currentparents oldlevel oldnlines oldtodo
 952     global lineno lthickness
 953
 954     # remove the null entry if present
 955     set nullentry [lsearch -exact $todo {}]
 956     if {$nullentry >= 0} {
 957         set todo [lreplace $todo $nullentry $nullentry]
 958     }
 959
 960     # choose which one to do next time around
 961     set todol [llength $todo]
 962     set level -1
 963     set latest {}
 964     for {set k $todol} {[incr k -1] >= 0} {} {
 965         set p [lindex $todo $k]
 966         if {$ncleft($p) == 0} {
 967             if {$datemode} {
 968                 if {![info exists commitinfo($p)]} {
 969                     if {$noread} {
 970                         return {}
 971                     }
 972                     readcommit $p
 973                 }
 974                 if {$latest == {} || $cdate($p) > $latest} {
 975                     set level $k
 976                     set latest $cdate($p)
 977                 }
 978             } else {
 979                 set level $k
 980                 break
 981             }
 982         }
 983     }
 984     if {$level < 0} {
 985         if {$todo != {}} {
 986             puts "ERROR: none of the pending commits can be done yet:"
 987             foreach p $todo {
 988                 puts "  $p ($ncleft($p))"
 989             }
 990         }
 991         return -1
 992     }
 993
 994     # If we are reducing, put in a null entry
 995     if {$todol < $oldnlines} {
 996         if {$nullentry >= 0} {
 997             set i $nullentry
 998             while {$i < $todol
 999                    && [lindex $oldtodo $i] == [lindex $todo $i]} {
1000                 incr i
1001             }
1002         } else {
1003             set i $oldlevel
1004             if {$level >= $i} {
1005                 incr i
1006             }
1007         }
1008         if {$i < $todol} {
1009             set todo [linsert $todo $i {}]
1010             if {$level >= $i} {
1011                 incr level
1012             }
1013         }
1014     }
1015     return $level
1016 }
1017
1018 proc drawcommit {id} {
1019     global phase todo nchildren datemode nextupdate
1020     global startcommits
1021
1022     if {$phase != "incrdraw"} {
1023         set phase incrdraw
1024         set todo $id
1025         set startcommits $id
1026         initgraph
1027         drawcommitline 0
1028         updatetodo 0 $datemode
1029     } else {
1030         if {$nchildren($id) == 0} {
1031             lappend todo $id
1032             lappend startcommits $id
1033         }
1034         set level [decidenext 1]
1035         if {$level == {} || $id != [lindex $todo $level]} {
1036             return
1037         }
1038         while 1 {
1039             drawslants
1040             drawcommitline $level
1041             if {[updatetodo $level $datemode]} {
1042                 set level [decidenext 1]
1043                 if {$level == {}} break
1044             }
1045             set id [lindex $todo $level]
1046             if {![info exists commitlisted($id)]} {
1047                 break
1048             }
1049             if {[clock clicks -milliseconds] >= $nextupdate} {
1050                 doupdate
1051                 if {$stopped} break
1052             }
1053         }
1054     }
1055 }
1056
1057 proc finishcommits {} {
1058     global phase
1059     global startcommits
1060     global canv mainfont ctext maincursor textcursor
1061
1062     if {$phase != "incrdraw"} {
1063         $canv delete all
1064         $canv create text 3 3 -anchor nw -text "No commits selected" \
1065             -font $mainfont -tags textitems
1066         set phase {}
1067     } else {
1068         drawslants
1069         set level [decidenext]
1070         drawrest $level [llength $startcommits]
1071     }
1072     . config -cursor $maincursor
1073     $ctext config -cursor $textcursor
1074 }
1075
1076 proc drawgraph {} {
1077     global nextupdate startmsecs startcommits todo
1078
1079     if {$startcommits == {}} return
1080     set startmsecs [clock clicks -milliseconds]
1081     set nextupdate [expr $startmsecs + 100]
1082     initgraph
1083     set todo [lindex $startcommits 0]
1084     drawrest 0 1
1085 }
1086
1087 proc drawrest {level startix} {
1088     global phase stopped redisplaying selectedline
1089     global datemode currentparents todo
1090     global numcommits
1091     global nextupdate startmsecs startcommits idline
1092
1093     if {$level >= 0} {
1094         set phase drawgraph
1095         set startid [lindex $startcommits $startix]
1096         set startline -1
1097         if {$startid != {}} {
1098             set startline $idline($startid)
1099         }
1100         while 1 {
1101             if {$stopped} break
1102             drawcommitline $level
1103             set hard [updatetodo $level $datemode]
1104             if {$numcommits == $startline} {
1105                 lappend todo $startid
1106                 set hard 1
1107                 incr startix
1108                 set startid [lindex $startcommits $startix]
1109                 set startline -1
1110                 if {$startid != {}} {
1111                     set startline $idline($startid)
1112                 }
1113             }
1114             if {$hard} {
1115                 set level [decidenext]
1116                 if {$level < 0} break
1117                 drawslants
1118             }
1119             if {[clock clicks -milliseconds] >= $nextupdate} {
1120                 update
1121                 incr nextupdate 100
1122             }
1123         }
1124     }
1125     set phase {}
1126     set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1127     #puts "overall $drawmsecs ms for $numcommits commits"
1128     if {$redisplaying} {
1129         if {$stopped == 0 && [info exists selectedline]} {
1130             selectline $selectedline
1131         }
1132         if {$stopped == 1} {
1133             set stopped 0
1134             after idle drawgraph
1135         } else {
1136             set redisplaying 0
1137         }
1138     }
1139 }
1140
1141 proc findmatches {f} {
1142     global findtype foundstring foundstrlen
1143     if {$findtype == "Regexp"} {
1144         set matches [regexp -indices -all -inline $foundstring $f]
1145     } else {
1146         if {$findtype == "IgnCase"} {
1147             set str [string tolower $f]
1148         } else {
1149             set str $f
1150         }
1151         set matches {}
1152         set i 0
1153         while {[set j [string first $foundstring $str $i]] >= 0} {
1154             lappend matches [list $j [expr $j+$foundstrlen-1]]
1155             set i [expr $j + $foundstrlen]
1156         }
1157     }
1158     return $matches
1159 }
1160
1161 proc dofind {} {
1162     global findtype findloc findstring markedmatches commitinfo
1163     global numcommits lineid linehtag linentag linedtag
1164     global mainfont namefont canv canv2 canv3 selectedline
1165     global matchinglines foundstring foundstrlen
1166
1167     stopfindproc
1168     unmarkmatches
1169     focus .
1170     set matchinglines {}
1171     if {$findloc == "Pickaxe"} {
1172         findpatches
1173         return
1174     }
1175     if {$findtype == "IgnCase"} {
1176         set foundstring [string tolower $findstring]
1177     } else {
1178         set foundstring $findstring
1179     }
1180     set foundstrlen [string length $findstring]
1181     if {$foundstrlen == 0} return
1182     if {$findloc == "Files"} {
1183         findfiles
1184         return
1185     }
1186     if {![info exists selectedline]} {
1187         set oldsel -1
1188     } else {
1189         set oldsel $selectedline
1190     }
1191     set didsel 0
1192     set fldtypes {Headline Author Date Committer CDate Comment}
1193     for {set l 0} {$l < $numcommits} {incr l} {
1194         set id $lineid($l)
1195         set info $commitinfo($id)
1196         set doesmatch 0
1197         foreach f $info ty $fldtypes {
1198             if {$findloc != "All fields" && $findloc != $ty} {
1199                 continue
1200             }
1201             set matches [findmatches $f]
1202             if {$matches == {}} continue
1203             set doesmatch 1
1204             if {$ty == "Headline"} {
1205                 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1206             } elseif {$ty == "Author"} {
1207                 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1208             } elseif {$ty == "Date"} {
1209                 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1210             }
1211         }
1212         if {$doesmatch} {
1213             lappend matchinglines $l
1214             if {!$didsel && $l > $oldsel} {
1215                 findselectline $l
1216                 set didsel 1
1217             }
1218         }
1219     }
1220     if {$matchinglines == {}} {
1221         bell
1222     } elseif {!$didsel} {
1223         findselectline [lindex $matchinglines 0]
1224     }
1225 }
1226
1227 proc findselectline {l} {
1228     global findloc commentend ctext
1229     selectline $l
1230     if {$findloc == "All fields" || $findloc == "Comments"} {
1231         # highlight the matches in the comments
1232         set f [$ctext get 1.0 $commentend]
1233         set matches [findmatches $f]
1234         foreach match $matches {
1235             set start [lindex $match 0]
1236             set end [expr [lindex $match 1] + 1]
1237             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1238         }
1239     }
1240 }
1241
1242 proc findnext {restart} {
1243     global matchinglines selectedline
1244     if {![info exists matchinglines]} {
1245         if {$restart} {
1246             dofind
1247         }
1248         return
1249     }
1250     if {![info exists selectedline]} return
1251     foreach l $matchinglines {
1252         if {$l > $selectedline} {
1253             findselectline $l
1254             return
1255         }
1256     }
1257     bell
1258 }
1259
1260 proc findprev {} {
1261     global matchinglines selectedline
1262     if {![info exists matchinglines]} {
1263         dofind
1264         return
1265     }
1266     if {![info exists selectedline]} return
1267     set prev {}
1268     foreach l $matchinglines {
1269         if {$l >= $selectedline} break
1270         set prev $l
1271     }
1272     if {$prev != {}} {
1273         findselectline $prev
1274     } else {
1275         bell
1276     }
1277 }
1278
1279 proc findlocchange {name ix op} {
1280     global findloc findtype findtypemenu
1281     if {$findloc == "Pickaxe"} {
1282         set findtype Exact
1283         set state disabled
1284     } else {
1285         set state normal
1286     }
1287     $findtypemenu entryconf 1 -state $state
1288     $findtypemenu entryconf 2 -state $state
1289 }
1290
1291 proc stopfindproc {{done 0}} {
1292     global findprocpid findprocfile findids
1293     global ctext findoldcursor phase maincursor textcursor
1294     global findinprogress
1295
1296     catch {unset findids}
1297     if {[info exists findprocpid]} {
1298         if {!$done} {
1299             catch {exec kill $findprocpid}
1300         }
1301         catch {close $findprocfile}
1302         unset findprocpid
1303     }
1304     if {[info exists findinprogress]} {
1305         unset findinprogress
1306         if {$phase != "incrdraw"} {
1307             . config -cursor $maincursor
1308             $ctext config -cursor $textcursor
1309         }
1310     }
1311 }
1312
1313 proc findpatches {} {
1314     global findstring selectedline numcommits
1315     global findprocpid findprocfile
1316     global finddidsel ctext lineid findinprogress
1317     global findinsertpos
1318
1319     if {$numcommits == 0} return
1320
1321     # make a list of all the ids to search, starting at the one
1322     # after the selected line (if any)
1323     if {[info exists selectedline]} {
1324         set l $selectedline
1325     } else {
1326         set l -1
1327     }
1328     set inputids {}
1329     for {set i 0} {$i < $numcommits} {incr i} {
1330         if {[incr l] >= $numcommits} {
1331             set l 0
1332         }
1333         append inputids $lineid($l) "\n"
1334     }
1335
1336     if {[catch {
1337         set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1338                          << $inputids] r]
1339     } err]} {
1340         error_popup "Error starting search process: $err"
1341         return
1342     }
1343
1344     set findinsertpos end
1345     set findprocfile $f
1346     set findprocpid [pid $f]
1347     fconfigure $f -blocking 0
1348     fileevent $f readable readfindproc
1349     set finddidsel 0
1350     . config -cursor watch
1351     $ctext config -cursor watch
1352     set findinprogress 1
1353 }
1354
1355 proc readfindproc {} {
1356     global findprocfile finddidsel
1357     global idline matchinglines findinsertpos
1358
1359     set n [gets $findprocfile line]
1360     if {$n < 0} {
1361         if {[eof $findprocfile]} {
1362             stopfindproc 1
1363             if {!$finddidsel} {
1364                 bell
1365             }
1366         }
1367         return
1368     }
1369     if {![regexp {^[0-9a-f]{40}} $line id]} {
1370         error_popup "Can't parse git-diff-tree output: $line"
1371         stopfindproc
1372         return
1373     }
1374     if {![info exists idline($id)]} {
1375         puts stderr "spurious id: $id"
1376         return
1377     }
1378     set l $idline($id)
1379     insertmatch $l $id
1380 }
1381
1382 proc insertmatch {l id} {
1383     global matchinglines findinsertpos finddidsel
1384
1385     if {$findinsertpos == "end"} {
1386         if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1387             set matchinglines [linsert $matchinglines 0 $l]
1388             set findinsertpos 1
1389         } else {
1390             lappend matchinglines $l
1391         }
1392     } else {
1393         set matchinglines [linsert $matchinglines $findinsertpos $l]
1394         incr findinsertpos
1395     }
1396     markheadline $l $id
1397     if {!$finddidsel} {
1398         findselectline $l
1399         set finddidsel 1
1400     }
1401 }
1402
1403 proc findfiles {} {
1404     global selectedline numcommits lineid ctext
1405     global ffileline finddidsel parents nparents
1406     global findinprogress findstartline findinsertpos
1407     global treediffs fdiffids fdiffsneeded fdiffpos
1408     global findmergefiles
1409
1410     if {$numcommits == 0} return
1411
1412     if {[info exists selectedline]} {
1413         set l [expr {$selectedline + 1}]
1414     } else {
1415         set l 0
1416     }
1417     set ffileline $l
1418     set findstartline $l
1419     set diffsneeded {}
1420     set fdiffsneeded {}
1421     while 1 {
1422         set id $lineid($l)
1423         if {$findmergefiles || $nparents($id) == 1} {
1424             foreach p $parents($id) {
1425                 if {![info exists treediffs([list $id $p])]} {
1426                     append diffsneeded "$id $p\n"
1427                     lappend fdiffsneeded [list $id $p]
1428                 }
1429             }
1430         }
1431         if {[incr l] >= $numcommits} {
1432             set l 0
1433         }
1434         if {$l == $findstartline} break
1435     }
1436
1437     # start off a git-diff-tree process if needed
1438     if {$diffsneeded ne {}} {
1439         if {[catch {
1440             set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1441         } err ]} {
1442             error_popup "Error starting search process: $err"
1443             return
1444         }
1445         catch {unset fdiffids}
1446         set fdiffpos 0
1447         fconfigure $df -blocking 0
1448         fileevent $df readable [list readfilediffs $df]
1449     }
1450
1451     set finddidsel 0
1452     set findinsertpos end
1453     set id $lineid($l)
1454     set p [lindex $parents($id) 0]
1455     . config -cursor watch
1456     $ctext config -cursor watch
1457     set findinprogress 1
1458     findcont [list $id $p]
1459     update
1460 }
1461
1462 proc readfilediffs {df} {
1463     global findids fdiffids fdiffs
1464
1465     set n [gets $df line]
1466     if {$n < 0} {
1467         if {[eof $df]} {
1468             donefilediff
1469             if {[catch {close $df} err]} {
1470                 stopfindproc
1471                 bell
1472                 error_popup "Error in git-diff-tree: $err"
1473             } elseif {[info exists findids]} {
1474                 set ids $findids
1475                 stopfindproc
1476                 bell
1477                 error_popup "Couldn't find diffs for {$ids}"
1478             }
1479         }
1480         return
1481     }
1482     if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1483         # start of a new string of diffs
1484         donefilediff
1485         set fdiffids [list $id $p]
1486         set fdiffs {}
1487     } elseif {[string match ":*" $line]} {
1488         lappend fdiffs [lindex $line 5]
1489     }
1490 }
1491
1492 proc donefilediff {} {
1493     global fdiffids fdiffs treediffs findids
1494     global fdiffsneeded fdiffpos
1495
1496     if {[info exists fdiffids]} {
1497         while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1498                && $fdiffpos < [llength $fdiffsneeded]} {
1499             # git-diff-tree doesn't output anything for a commit
1500             # which doesn't change anything
1501             set nullids [lindex $fdiffsneeded $fdiffpos]
1502             set treediffs($nullids) {}
1503             if {[info exists findids] && $nullids eq $findids} {
1504                 unset findids
1505                 findcont $nullids
1506             }
1507             incr fdiffpos
1508         }
1509         incr fdiffpos
1510
1511         if {![info exists treediffs($fdiffids)]} {
1512             set treediffs($fdiffids) $fdiffs
1513         }
1514         if {[info exists findids] && $fdiffids eq $findids} {
1515             unset findids
1516             findcont $fdiffids
1517         }
1518     }
1519 }
1520
1521 proc findcont {ids} {
1522     global findids treediffs parents nparents
1523     global ffileline findstartline finddidsel
1524     global lineid numcommits matchinglines findinprogress
1525     global findmergefiles
1526
1527     set id [lindex $ids 0]
1528     set p [lindex $ids 1]
1529     set pi [lsearch -exact $parents($id) $p]
1530     set l $ffileline
1531     while 1 {
1532         if {$findmergefiles || $nparents($id) == 1} {
1533             if {![info exists treediffs($ids)]} {
1534                 set findids $ids
1535                 set ffileline $l
1536                 return
1537             }
1538             set doesmatch 0
1539             foreach f $treediffs($ids) {
1540                 set x [findmatches $f]
1541                 if {$x != {}} {
1542                     set doesmatch 1
1543                     break
1544                 }
1545             }
1546             if {$doesmatch} {
1547                 insertmatch $l $id
1548                 set pi $nparents($id)
1549             }
1550         } else {
1551             set pi $nparents($id)
1552         }
1553         if {[incr pi] >= $nparents($id)} {
1554             set pi 0
1555             if {[incr l] >= $numcommits} {
1556                 set l 0
1557             }
1558             if {$l == $findstartline} break
1559             set id $lineid($l)
1560         }
1561         set p [lindex $parents($id) $pi]
1562         set ids [list $id $p]
1563     }
1564     stopfindproc
1565     if {!$finddidsel} {
1566         bell
1567     }
1568 }
1569
1570 # mark a commit as matching by putting a yellow background
1571 # behind the headline
1572 proc markheadline {l id} {
1573     global canv mainfont linehtag commitinfo
1574
1575     set bbox [$canv bbox $linehtag($l)]
1576     set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1577     $canv lower $t
1578 }
1579
1580 # mark the bits of a headline, author or date that match a find string
1581 proc markmatches {canv l str tag matches font} {
1582     set bbox [$canv bbox $tag]
1583     set x0 [lindex $bbox 0]
1584     set y0 [lindex $bbox 1]
1585     set y1 [lindex $bbox 3]
1586     foreach match $matches {
1587         set start [lindex $match 0]
1588         set end [lindex $match 1]
1589         if {$start > $end} continue
1590         set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1591         set xlen [font measure $font [string range $str 0 [expr $end]]]
1592         set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1593                    -outline {} -tags matches -fill yellow]
1594         $canv lower $t
1595     }
1596 }
1597
1598 proc unmarkmatches {} {
1599     global matchinglines findids
1600     allcanvs delete matches
1601     catch {unset matchinglines}
1602     catch {unset findids}
1603 }
1604
1605 proc selcanvline {w x y} {
1606     global canv canvy0 ctext linespc selectedline
1607     global lineid linehtag linentag linedtag rowtextx
1608     set ymax [lindex [$canv cget -scrollregion] 3]
1609     if {$ymax == {}} return
1610     set yfrac [lindex [$canv yview] 0]
1611     set y [expr {$y + $yfrac * $ymax}]
1612     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1613     if {$l < 0} {
1614         set l 0
1615     }
1616     if {$w eq $canv} {
1617         if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1618     }
1619     unmarkmatches
1620     selectline $l
1621 }
1622
1623 proc selectline {l} {
1624     global canv canv2 canv3 ctext commitinfo selectedline
1625     global lineid linehtag linentag linedtag
1626     global canvy0 linespc parents nparents
1627     global cflist currentid sha1entry
1628     global commentend idtags
1629     $canv delete hover
1630     if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1631     $canv delete secsel
1632     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1633                -tags secsel -fill [$canv cget -selectbackground]]
1634     $canv lower $t
1635     $canv2 delete secsel
1636     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1637                -tags secsel -fill [$canv2 cget -selectbackground]]
1638     $canv2 lower $t
1639     $canv3 delete secsel
1640     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1641                -tags secsel -fill [$canv3 cget -selectbackground]]
1642     $canv3 lower $t
1643     set y [expr {$canvy0 + $l * $linespc}]
1644     set ymax [lindex [$canv cget -scrollregion] 3]
1645     set ytop [expr {$y - $linespc - 1}]
1646     set ybot [expr {$y + $linespc + 1}]
1647     set wnow [$canv yview]
1648     set wtop [expr [lindex $wnow 0] * $ymax]
1649     set wbot [expr [lindex $wnow 1] * $ymax]
1650     set wh [expr {$wbot - $wtop}]
1651     set newtop $wtop
1652     if {$ytop < $wtop} {
1653         if {$ybot < $wtop} {
1654             set newtop [expr {$y - $wh / 2.0}]
1655         } else {
1656             set newtop $ytop
1657             if {$newtop > $wtop - $linespc} {
1658                 set newtop [expr {$wtop - $linespc}]
1659             }
1660         }
1661     } elseif {$ybot > $wbot} {
1662         if {$ytop > $wbot} {
1663             set newtop [expr {$y - $wh / 2.0}]
1664         } else {
1665             set newtop [expr {$ybot - $wh}]
1666             if {$newtop < $wtop + $linespc} {
1667                 set newtop [expr {$wtop + $linespc}]
1668             }
1669         }
1670     }
1671     if {$newtop != $wtop} {
1672         if {$newtop < 0} {
1673             set newtop 0
1674         }
1675         allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1676     }
1677     set selectedline $l
1678
1679     set id $lineid($l)
1680     set currentid $id
1681     $sha1entry delete 0 end
1682     $sha1entry insert 0 $id
1683     $sha1entry selection from 0
1684     $sha1entry selection to end
1685
1686     $ctext conf -state normal
1687     $ctext delete 0.0 end
1688     $ctext mark set fmark.0 0.0
1689     $ctext mark gravity fmark.0 left
1690     set info $commitinfo($id)
1691     $ctext insert end "Author: [lindex $info 1]  [lindex $info 2]\n"
1692     $ctext insert end "Committer: [lindex $info 3]  [lindex $info 4]\n"
1693     if {[info exists idtags($id)]} {
1694         $ctext insert end "Tags:"
1695         foreach tag $idtags($id) {
1696             $ctext insert end " $tag"
1697         }
1698         $ctext insert end "\n"
1699     }
1700     $ctext insert end "\n"
1701     $ctext insert end [lindex $info 5]
1702     $ctext insert end "\n"
1703     $ctext tag delete Comments
1704     $ctext tag remove found 1.0 end
1705     $ctext conf -state disabled
1706     set commentend [$ctext index "end - 1c"]
1707
1708     $cflist delete 0 end
1709     $cflist insert end "Comments"
1710     if {$nparents($id) == 1} {
1711         startdiff [concat $id $parents($id)]
1712     } elseif {$nparents($id) > 1} {
1713         mergediff $id
1714     }
1715 }
1716
1717 proc selnextline {dir} {
1718     global selectedline
1719     if {![info exists selectedline]} return
1720     set l [expr $selectedline + $dir]
1721     unmarkmatches
1722     selectline $l
1723 }
1724
1725 proc mergediff {id} {
1726     global parents diffmergeid diffmergegca mergefilelist diffpindex
1727
1728     set diffmergeid $id
1729     set diffpindex -1
1730     set diffmergegca [findgca $parents($id)]
1731     if {[info exists mergefilelist($id)]} {
1732         showmergediff
1733     } else {
1734         contmergediff {}
1735     }
1736 }
1737
1738 proc findgca {ids} {
1739     set gca {}
1740     foreach id $ids {
1741         if {$gca eq {}} {
1742             set gca $id
1743         } else {
1744             if {[catch {
1745                 set gca [exec git-merge-base $gca $id]
1746             } err]} {
1747                 return {}
1748             }
1749         }
1750     }
1751     return $gca
1752 }
1753
1754 proc contmergediff {ids} {
1755     global diffmergeid diffpindex parents nparents diffmergegca
1756     global treediffs mergefilelist diffids
1757
1758     # diff the child against each of the parents, and diff
1759     # each of the parents against the GCA.
1760     while 1 {
1761         if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
1762             set ids [list [lindex $ids 1] $diffmergegca]
1763         } else {
1764             if {[incr diffpindex] >= $nparents($diffmergeid)} break
1765             set p [lindex $parents($diffmergeid) $diffpindex]
1766             set ids [list $diffmergeid $p]
1767         }
1768         if {![info exists treediffs($ids)]} {
1769             set diffids $ids
1770             if {![info exists treepending]} {
1771                 gettreediffs $ids
1772             }
1773             return
1774         }
1775     }
1776
1777     # If a file in some parent is different from the child and also
1778     # different from the GCA, then it's interesting.
1779     # If we don't have a GCA, then a file is interesting if it is
1780     # different from the child in all the parents.
1781     if {$diffmergegca ne {}} {
1782         set files {}
1783         foreach p $parents($diffmergeid) {
1784             set gcadiffs $treediffs([list $p $diffmergegca])
1785             foreach f $treediffs([list $diffmergeid $p]) {
1786                 if {[lsearch -exact $files $f] < 0
1787                     && [lsearch -exact $gcadiffs $f] >= 0} {
1788                     lappend files $f
1789                 }
1790             }
1791         }
1792         set files [lsort $files]
1793     } else {
1794         set p [lindex $parents($diffmergeid) 0]
1795         set files $treediffs([list $diffmergeid $p])
1796         for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
1797             set p [lindex $parents($diffmergeid) $i]
1798             set df $treediffs([list $diffmergeid $p])
1799             set nf {}
1800             foreach f $files {
1801                 if {[lsearch -exact $df $f] >= 0} {
1802                     lappend nf $f
1803                 }
1804             }
1805             set files $nf
1806         }
1807     }
1808
1809     set mergefilelist($diffmergeid) $files
1810     if {$files ne {}} {
1811         showmergediff
1812     }
1813 }
1814
1815 proc showmergediff {} {
1816     global cflist diffmergeid mergefilelist parents
1817     global diffopts diffinhunk currentfile diffblocked
1818     global groupfilelast mergefds
1819
1820     set files $mergefilelist($diffmergeid)
1821     foreach f $files {
1822         $cflist insert end $f
1823     }
1824     set env(GIT_DIFF_OPTS) $diffopts
1825     set flist {}
1826     catch {unset currentfile}
1827     catch {unset currenthunk}
1828     catch {unset filelines}
1829     set groupfilelast -1
1830     foreach p $parents($diffmergeid) {
1831         set cmd [list | git-diff-tree -p $p $diffmergeid]
1832         set cmd [concat $cmd $mergefilelist($diffmergeid)]
1833         if {[catch {set f [open $cmd r]} err]} {
1834             error_popup "Error getting diffs: $err"
1835             foreach f $flist {
1836                 catch {close $f}
1837             }
1838             return
1839         }
1840         lappend flist $f
1841         set ids [list $diffmergeid $p]
1842         set mergefds($ids) $f
1843         set diffinhunk($ids) 0
1844         set diffblocked($ids) 0
1845         fconfigure $f -blocking 0
1846         fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
1847     }
1848 }
1849
1850 proc getmergediffline {f ids id} {
1851     global diffmergeid diffinhunk diffoldlines diffnewlines
1852     global currentfile currenthunk
1853     global diffoldstart diffnewstart diffoldlno diffnewlno
1854     global diffblocked mergefilelist
1855     global noldlines nnewlines difflcounts filelines
1856
1857     set n [gets $f line]
1858     if {$n < 0} {
1859         if {![eof $f]} return
1860     }
1861
1862     if {!([info exists diffmergeid] && $diffmergeid == $id)} {
1863         if {$n < 0} {
1864             close $f
1865         }
1866         return
1867     }
1868
1869     if {$diffinhunk($ids) != 0} {
1870         set fi $currentfile($ids)
1871         if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
1872             # continuing an existing hunk
1873             set line [string range $line 1 end]
1874             set p [lindex $ids 1]
1875             if {$match eq "-" || $match eq " "} {
1876                 set filelines($p,$fi,$diffoldlno($ids)) $line
1877                 incr diffoldlno($ids)
1878             }
1879             if {$match eq "+" || $match eq " "} {
1880                 set filelines($id,$fi,$diffnewlno($ids)) $line
1881                 incr diffnewlno($ids)
1882             }
1883             if {$match eq " "} {
1884                 if {$diffinhunk($ids) == 2} {
1885                     lappend difflcounts($ids) \
1886                         [list $noldlines($ids) $nnewlines($ids)]
1887                     set noldlines($ids) 0
1888                     set diffinhunk($ids) 1
1889                 }
1890                 incr noldlines($ids)
1891             } elseif {$match eq "-" || $match eq "+"} {
1892                 if {$diffinhunk($ids) == 1} {
1893                     lappend difflcounts($ids) [list $noldlines($ids)]
1894                     set noldlines($ids) 0
1895                     set nnewlines($ids) 0
1896                     set diffinhunk($ids) 2
1897                 }
1898                 if {$match eq "-"} {
1899                     incr noldlines($ids)
1900                 } else {
1901                     incr nnewlines($ids)
1902                 }
1903             }
1904             # and if it's \ No newline at end of line, then what?
1905             return
1906         }
1907         # end of a hunk
1908         if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
1909             lappend difflcounts($ids) [list $noldlines($ids)]
1910         } elseif {$diffinhunk($ids) == 2
1911                   && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
1912             lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
1913         }
1914         set currenthunk($ids) [list $currentfile($ids) \
1915                                    $diffoldstart($ids) $diffnewstart($ids) \
1916                                    $diffoldlno($ids) $diffnewlno($ids) \
1917                                    $difflcounts($ids)]
1918         set diffinhunk($ids) 0
1919         # -1 = need to block, 0 = unblocked, 1 = is blocked
1920         set diffblocked($ids) -1
1921         processhunks
1922         if {$diffblocked($ids) == -1} {
1923             fileevent $f readable {}
1924             set diffblocked($ids) 1
1925         }
1926     }
1927
1928     if {$n < 0} {
1929         # eof
1930         if {!$diffblocked($ids)} {
1931             close $f
1932             set currentfile($ids) [llength $mergefilelist($diffmergeid)]
1933             set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
1934             processhunks
1935         }
1936     } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
1937         # start of a new file
1938         set currentfile($ids) \
1939             [lsearch -exact $mergefilelist($diffmergeid) $fname]
1940     } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1941                    $line match f1l f1c f2l f2c rest]} {
1942         if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
1943             # start of a new hunk
1944             if {$f1l == 0 && $f1c == 0} {
1945                 set f1l 1
1946             }
1947             if {$f2l == 0 && $f2c == 0} {
1948                 set f2l 1
1949             }
1950             set diffinhunk($ids) 1
1951             set diffoldstart($ids) $f1l
1952             set diffnewstart($ids) $f2l
1953             set diffoldlno($ids) $f1l
1954             set diffnewlno($ids) $f2l
1955             set difflcounts($ids) {}
1956             set noldlines($ids) 0
1957             set nnewlines($ids) 0
1958         }
1959     }
1960 }
1961
1962 proc processhunks {} {
1963     global diffmergeid parents nparents currenthunk
1964     global mergefilelist diffblocked mergefds
1965     global grouphunks grouplinestart grouplineend groupfilenum
1966
1967     set nfiles [llength $mergefilelist($diffmergeid)]
1968     while 1 {
1969         set fi $nfiles
1970         set lno 0
1971         # look for the earliest hunk
1972         foreach p $parents($diffmergeid) {
1973             set ids [list $diffmergeid $p]
1974             if {![info exists currenthunk($ids)]} return
1975             set i [lindex $currenthunk($ids) 0]
1976             set l [lindex $currenthunk($ids) 2]
1977             if {$i < $fi || ($i == $fi && $l < $lno)} {
1978                 set fi $i
1979                 set lno $l
1980                 set pi $p
1981             }
1982         }
1983
1984         if {$fi < $nfiles} {
1985             set ids [list $diffmergeid $pi]
1986             set hunk $currenthunk($ids)
1987             unset currenthunk($ids)
1988             if {$diffblocked($ids) > 0} {
1989                 fileevent $mergefds($ids) readable \
1990                     [list getmergediffline $mergefds($ids) $ids $diffmergeid]
1991             }
1992             set diffblocked($ids) 0
1993
1994             if {[info exists groupfilenum] && $groupfilenum == $fi
1995                 && $lno <= $grouplineend} {
1996                 # add this hunk to the pending group
1997                 lappend grouphunks($pi) $hunk
1998                 set endln [lindex $hunk 4]
1999                 if {$endln > $grouplineend} {
2000                     set grouplineend $endln
2001                 }
2002                 continue
2003             }
2004         }
2005
2006         # succeeding stuff doesn't belong in this group, so
2007         # process the group now
2008         if {[info exists groupfilenum]} {
2009             processgroup
2010             unset groupfilenum
2011             unset grouphunks
2012         }
2013
2014         if {$fi >= $nfiles} break
2015
2016         # start a new group
2017         set groupfilenum $fi
2018         set grouphunks($pi) [list $hunk]
2019         set grouplinestart $lno
2020         set grouplineend [lindex $hunk 4]
2021     }
2022 }
2023
2024 proc processgroup {} {
2025     global groupfilelast groupfilenum difffilestart
2026     global mergefilelist diffmergeid ctext filelines
2027     global parents diffmergeid diffoffset
2028     global grouphunks grouplinestart grouplineend nparents
2029     global mergemax
2030
2031     $ctext conf -state normal
2032     set id $diffmergeid
2033     set f $groupfilenum
2034     if {$groupfilelast != $f} {
2035         $ctext insert end "\n"
2036         set here [$ctext index "end - 1c"]
2037         set difffilestart($f) $here
2038         set mark fmark.[expr {$f + 1}]
2039         $ctext mark set $mark $here
2040         $ctext mark gravity $mark left
2041         set header [lindex $mergefilelist($id) $f]
2042         set l [expr {(78 - [string length $header]) / 2}]
2043         set pad [string range "----------------------------------------" 1 $l]
2044         $ctext insert end "$pad $header $pad\n" filesep
2045         set groupfilelast $f
2046         foreach p $parents($id) {
2047             set diffoffset($p) 0
2048         }
2049     }
2050
2051     $ctext insert end "@@" msep
2052     set nlines [expr {$grouplineend - $grouplinestart}]
2053     set events {}
2054     set pnum 0
2055     foreach p $parents($id) {
2056         set startline [expr {$grouplinestart + $diffoffset($p)}]
2057         set offset($p) $diffoffset($p)
2058         set ol $startline
2059         set nl $grouplinestart
2060         if {[info exists grouphunks($p)]} {
2061             foreach h $grouphunks($p) {
2062                 set l [lindex $h 2]
2063                 if {$nl < $l} {
2064                     for {} {$nl < $l} {incr nl} {
2065                         set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2066                         incr ol
2067                     }
2068                 }
2069                 foreach chunk [lindex $h 5] {
2070                     if {[llength $chunk] == 2} {
2071                         set olc [lindex $chunk 0]
2072                         set nlc [lindex $chunk 1]
2073                         set nnl [expr {$nl + $nlc}]
2074                         lappend events [list $nl $nnl $pnum $olc $nlc]
2075                         incr ol $olc
2076                         set nl $nnl
2077                     } else {
2078                         incr ol [lindex $chunk 0]
2079                         incr nl [lindex $chunk 0]
2080                     }
2081                 }
2082             }
2083         }
2084         if {$nl < $grouplineend} {
2085             for {} {$nl < $grouplineend} {incr nl} {
2086                 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2087                 incr ol
2088             }
2089         }
2090         set nlines [expr {$ol - $startline}]
2091         $ctext insert end " -$startline,$nlines" msep
2092         incr pnum
2093     }
2094
2095     set nlines [expr {$grouplineend - $grouplinestart}]
2096     $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2097
2098     set events [lsort -integer -index 0 $events]
2099     set nevents [llength $events]
2100     set nmerge $nparents($diffmergeid)
2101     set i 0
2102     set l $grouplinestart
2103     while {$i < $nevents} {
2104         set nl [lindex $events $i 0]
2105         while {$l < $nl} {
2106             $ctext insert end " $filelines($id,$f,$l)\n"
2107             incr l
2108         }
2109         set e [lindex $events $i]
2110         set enl [lindex $e 1]
2111         set j $i
2112         set active {}
2113         while 1 {
2114             set pnum [lindex $e 2]
2115             set olc [lindex $e 3]
2116             set nlc [lindex $e 4]
2117             if {![info exists delta($pnum)]} {
2118                 set delta($pnum) [expr {$olc - $nlc}]
2119                 lappend active $pnum
2120             } else {
2121                 incr delta($pnum) [expr {$olc - $nlc}]
2122             }
2123             if {[incr j] >= $nevents} break
2124             set e [lindex $events $j]
2125             if {[lindex $e 0] >= $enl} break
2126             if {[lindex $e 1] > $enl} {
2127                 set enl [lindex $e 1]
2128             }
2129         }
2130         set nlc [expr {$enl - $l}]
2131         set ncol mresult
2132         if {[llength $active] == $nmerge - 1} {
2133             for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2134                 if {![info exists delta($pnum)]} {
2135                     if {$pnum < $mergemax} {
2136                         lappend ncol m$pnum
2137                     } else {
2138                         lappend ncol mmax
2139                     }
2140                     break
2141                 }
2142             }
2143         }
2144         set pnum -1
2145         foreach p $parents($id) {
2146             incr pnum
2147             if {![info exists delta($pnum)]} continue
2148             set olc [expr {$nlc + $delta($pnum)}]
2149             set ol [expr {$l + $diffoffset($p)}]
2150             incr diffoffset($p) $delta($pnum)
2151             unset delta($pnum)
2152             for {} {$olc > 0} {incr olc -1} {
2153                 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2154                 incr ol
2155             }
2156         }
2157         for {} {$nlc > 0} {incr nlc -1} {
2158             $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2159             incr l
2160         }
2161         set i $j
2162     }
2163     while {$l < $grouplineend} {
2164         $ctext insert end " $filelines($id,$f,$l)\n"
2165         incr l
2166     }
2167     $ctext conf -state disabled
2168 }
2169
2170 proc startdiff {ids} {
2171     global treediffs diffids treepending diffmergeid
2172
2173     set diffids $ids
2174     catch {unset diffmergeid}
2175     if {![info exists treediffs($ids)]} {
2176         if {![info exists treepending]} {
2177             gettreediffs $ids
2178         }
2179     } else {
2180         addtocflist $ids
2181     }
2182 }
2183
2184 proc addtocflist {ids} {
2185     global treediffs cflist
2186     foreach f $treediffs($ids) {
2187         $cflist insert end $f
2188     }
2189     getblobdiffs $ids
2190 }
2191
2192 proc gettreediffs {ids} {
2193     global treediff parents treepending
2194     set treepending $ids
2195     set treediff {}
2196     set id [lindex $ids 0]
2197     set p [lindex $ids 1]
2198     if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
2199     fconfigure $gdtf -blocking 0
2200     fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2201 }
2202
2203 proc gettreediffline {gdtf ids} {
2204     global treediff treediffs treepending diffids diffmergeid
2205
2206     set n [gets $gdtf line]
2207     if {$n < 0} {
2208         if {![eof $gdtf]} return
2209         close $gdtf
2210         set treediffs($ids) $treediff
2211         unset treepending
2212         if {$ids != $diffids} {
2213             gettreediffs $diffids
2214         } else {
2215             if {[info exists diffmergeid]} {
2216                 contmergediff $ids
2217             } else {
2218                 addtocflist $ids
2219             }
2220         }
2221         return
2222     }
2223     set file [lindex $line 5]
2224     lappend treediff $file
2225 }
2226
2227 proc getblobdiffs {ids} {
2228     global diffopts blobdifffd diffids env curdifftag curtagstart
2229     global difffilestart nextupdate diffinhdr treediffs
2230
2231     set id [lindex $ids 0]
2232     set p [lindex $ids 1]
2233     set env(GIT_DIFF_OPTS) $diffopts
2234     set cmd [list | git-diff-tree -r -p -C $p $id]
2235     if {[catch {set bdf [open $cmd r]} err]} {
2236         puts "error getting diffs: $err"
2237         return
2238     }
2239     set diffinhdr 0
2240     fconfigure $bdf -blocking 0
2241     set blobdifffd($ids) $bdf
2242     set curdifftag Comments
2243     set curtagstart 0.0
2244     catch {unset difffilestart}
2245     fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2246     set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2247 }
2248
2249 proc getblobdiffline {bdf ids} {
2250     global diffids blobdifffd ctext curdifftag curtagstart
2251     global diffnexthead diffnextnote difffilestart
2252     global nextupdate diffinhdr treediffs
2253     global gaudydiff
2254
2255     set n [gets $bdf line]
2256     if {$n < 0} {
2257         if {[eof $bdf]} {
2258             close $bdf
2259             if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2260                 $ctext tag add $curdifftag $curtagstart end
2261             }
2262         }
2263         return
2264     }
2265     if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2266         return
2267     }
2268     $ctext conf -state normal
2269     if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2270         # start of a new file
2271         $ctext insert end "\n"
2272         $ctext tag add $curdifftag $curtagstart end
2273         set curtagstart [$ctext index "end - 1c"]
2274         set header $newname
2275         set here [$ctext index "end - 1c"]
2276         set i [lsearch -exact $treediffs($diffids) $fname]
2277         if {$i >= 0} {
2278             set difffilestart($i) $here
2279             incr i
2280             $ctext mark set fmark.$i $here
2281             $ctext mark gravity fmark.$i left
2282         }
2283         if {$newname != $fname} {
2284             set i [lsearch -exact $treediffs($diffids) $newname]
2285             if {$i >= 0} {
2286                 set difffilestart($i) $here
2287                 incr i
2288                 $ctext mark set fmark.$i $here
2289                 $ctext mark gravity fmark.$i left
2290             }
2291         }
2292         set curdifftag "f:$fname"
2293         $ctext tag delete $curdifftag
2294         set l [expr {(78 - [string length $header]) / 2}]
2295         set pad [string range "----------------------------------------" 1 $l]
2296         $ctext insert end "$pad $header $pad\n" filesep
2297         set diffinhdr 1
2298     } elseif {[regexp {^(---|\+\+\+)} $line]} {
2299         set diffinhdr 0
2300     } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2301                    $line match f1l f1c f2l f2c rest]} {
2302         if {$gaudydiff} {
2303             $ctext insert end "\t" hunksep
2304             $ctext insert end "    $f1l    " d0 "    $f2l    " d1
2305             $ctext insert end "    $rest \n" hunksep
2306         } else {
2307             $ctext insert end "$line\n" hunksep
2308         }
2309         set diffinhdr 0
2310     } else {
2311         set x [string range $line 0 0]
2312         if {$x == "-" || $x == "+"} {
2313             set tag [expr {$x == "+"}]
2314             if {$gaudydiff} {
2315                 set line [string range $line 1 end]
2316             }
2317             $ctext insert end "$line\n" d$tag
2318         } elseif {$x == " "} {
2319             if {$gaudydiff} {
2320                 set line [string range $line 1 end]
2321             }
2322             $ctext insert end "$line\n"
2323         } elseif {$diffinhdr || $x == "\\"} {
2324             # e.g. "\ No newline at end of file"
2325             $ctext insert end "$line\n" filesep
2326         } else {
2327             # Something else we don't recognize
2328             if {$curdifftag != "Comments"} {
2329                 $ctext insert end "\n"
2330                 $ctext tag add $curdifftag $curtagstart end
2331                 set curtagstart [$ctext index "end - 1c"]
2332                 set curdifftag Comments
2333             }
2334             $ctext insert end "$line\n" filesep
2335         }
2336     }
2337     $ctext conf -state disabled
2338     if {[clock clicks -milliseconds] >= $nextupdate} {
2339         incr nextupdate 100
2340         fileevent $bdf readable {}
2341         update
2342         fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2343     }
2344 }
2345
2346 proc nextfile {} {
2347     global difffilestart ctext
2348     set here [$ctext index @0,0]
2349     for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2350         if {[$ctext compare $difffilestart($i) > $here]} {
2351             if {![info exists pos]
2352                 || [$ctext compare $difffilestart($i) < $pos]} {
2353                 set pos $difffilestart($i)
2354             }
2355         }
2356     }
2357     if {[info exists pos]} {
2358         $ctext yview $pos
2359     }
2360 }
2361
2362 proc listboxsel {} {
2363     global ctext cflist currentid
2364     if {![info exists currentid]} return
2365     set sel [lsort [$cflist curselection]]
2366     if {$sel eq {}} return
2367     set first [lindex $sel 0]
2368     catch {$ctext yview fmark.$first}
2369 }
2370
2371 proc setcoords {} {
2372     global linespc charspc canvx0 canvy0 mainfont
2373     set linespc [font metrics $mainfont -linespace]
2374     set charspc [font measure $mainfont "m"]
2375     set canvy0 [expr 3 + 0.5 * $linespc]
2376     set canvx0 [expr 3 + 0.5 * $linespc]
2377 }
2378
2379 proc redisplay {} {
2380     global selectedline stopped redisplaying phase
2381     if {$stopped > 1} return
2382     if {$phase == "getcommits"} return
2383     set redisplaying 1
2384     if {$phase == "drawgraph" || $phase == "incrdraw"} {
2385         set stopped 1
2386     } else {
2387         drawgraph
2388     }
2389 }
2390
2391 proc incrfont {inc} {
2392     global mainfont namefont textfont selectedline ctext canv phase
2393     global stopped entries
2394     unmarkmatches
2395     set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2396     set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2397     set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2398     setcoords
2399     $ctext conf -font $textfont
2400     $ctext tag conf filesep -font [concat $textfont bold]
2401     foreach e $entries {
2402         $e conf -font $mainfont
2403     }
2404     if {$phase == "getcommits"} {
2405         $canv itemconf textitems -font $mainfont
2406     }
2407     redisplay
2408 }
2409
2410 proc clearsha1 {} {
2411     global sha1entry sha1string
2412     if {[string length $sha1string] == 40} {
2413         $sha1entry delete 0 end
2414     }
2415 }
2416
2417 proc sha1change {n1 n2 op} {
2418     global sha1string currentid sha1but
2419     if {$sha1string == {}
2420         || ([info exists currentid] && $sha1string == $currentid)} {
2421         set state disabled
2422     } else {
2423         set state normal
2424     }
2425     if {[$sha1but cget -state] == $state} return
2426     if {$state == "normal"} {
2427         $sha1but conf -state normal -relief raised -text "Goto: "
2428     } else {
2429         $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
2430     }
2431 }
2432
2433 proc gotocommit {} {
2434     global sha1string currentid idline tagids
2435     global lineid numcommits
2436
2437     if {$sha1string == {}
2438         || ([info exists currentid] && $sha1string == $currentid)} return
2439     if {[info exists tagids($sha1string)]} {
2440         set id $tagids($sha1string)
2441     } else {
2442         set id [string tolower $sha1string]
2443         if {[regexp {^[0-9a-f]{4,39}$} $id]} {
2444             set matches {}
2445             for {set l 0} {$l < $numcommits} {incr l} {
2446                 if {[string match $id* $lineid($l)]} {
2447                     lappend matches $lineid($l)
2448                 }
2449             }
2450             if {$matches ne {}} {
2451                 if {[llength $matches] > 1} {
2452                     error_popup "Short SHA1 id $id is ambiguous"
2453                     return
2454                 }
2455                 set id [lindex $matches 0]
2456             }
2457         }
2458     }
2459     if {[info exists idline($id)]} {
2460         selectline $idline($id)
2461         return
2462     }
2463     if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
2464         set type "SHA1 id"
2465     } else {
2466         set type "Tag"
2467     }
2468     error_popup "$type $sha1string is not known"
2469 }
2470
2471 proc lineenter {x y id} {
2472     global hoverx hovery hoverid hovertimer
2473     global commitinfo canv
2474
2475     if {![info exists commitinfo($id)]} return
2476     set hoverx $x
2477     set hovery $y
2478     set hoverid $id
2479     if {[info exists hovertimer]} {
2480         after cancel $hovertimer
2481     }
2482     set hovertimer [after 500 linehover]
2483     $canv delete hover
2484 }
2485
2486 proc linemotion {x y id} {
2487     global hoverx hovery hoverid hovertimer
2488
2489     if {[info exists hoverid] && $id == $hoverid} {
2490         set hoverx $x
2491         set hovery $y
2492         if {[info exists hovertimer]} {
2493             after cancel $hovertimer
2494         }
2495         set hovertimer [after 500 linehover]
2496     }
2497 }
2498
2499 proc lineleave {id} {
2500     global hoverid hovertimer canv
2501
2502     if {[info exists hoverid] && $id == $hoverid} {
2503         $canv delete hover
2504         if {[info exists hovertimer]} {
2505             after cancel $hovertimer
2506             unset hovertimer
2507         }
2508         unset hoverid
2509     }
2510 }
2511
2512 proc linehover {} {
2513     global hoverx hovery hoverid hovertimer
2514     global canv linespc lthickness
2515     global commitinfo mainfont
2516
2517     set text [lindex $commitinfo($hoverid) 0]
2518     set ymax [lindex [$canv cget -scrollregion] 3]
2519     if {$ymax == {}} return
2520     set yfrac [lindex [$canv yview] 0]
2521     set x [expr {$hoverx + 2 * $linespc}]
2522     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2523     set x0 [expr {$x - 2 * $lthickness}]
2524     set y0 [expr {$y - 2 * $lthickness}]
2525     set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2526     set y1 [expr {$y + $linespc + 2 * $lthickness}]
2527     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2528                -fill \#ffff80 -outline black -width 1 -tags hover]
2529     $canv raise $t
2530     set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2531     $canv raise $t
2532 }
2533
2534 proc lineclick {x y id} {
2535     global ctext commitinfo children cflist canv
2536
2537     unmarkmatches
2538     $canv delete hover
2539     # fill the details pane with info about this line
2540     $ctext conf -state normal
2541     $ctext delete 0.0 end
2542     $ctext insert end "Parent:\n "
2543     catch {destroy $ctext.$id}
2544     button $ctext.$id -text "Go:" -command "selbyid $id" \
2545         -padx 4 -pady 0
2546     $ctext window create end -window $ctext.$id -align center
2547     set info $commitinfo($id)
2548     $ctext insert end "\t[lindex $info 0]\n"
2549     $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2550     $ctext insert end "\tDate:\t[lindex $info 2]\n"
2551     $ctext insert end "\tID:\t$id\n"
2552     if {[info exists children($id)]} {
2553         $ctext insert end "\nChildren:"
2554         foreach child $children($id) {
2555             $ctext insert end "\n "
2556             catch {destroy $ctext.$child}
2557             button $ctext.$child -text "Go:" -command "selbyid $child" \
2558                 -padx 4 -pady 0
2559             $ctext window create end -window $ctext.$child -align center
2560             set info $commitinfo($child)
2561             $ctext insert end "\t[lindex $info 0]"
2562         }
2563     }
2564     $ctext conf -state disabled
2565
2566     $cflist delete 0 end
2567 }
2568
2569 proc selbyid {id} {
2570     global idline
2571     if {[info exists idline($id)]} {
2572         selectline $idline($id)
2573     }
2574 }
2575
2576 proc mstime {} {
2577     global startmstime
2578     if {![info exists startmstime]} {
2579         set startmstime [clock clicks -milliseconds]
2580     }
2581     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2582 }
2583
2584 proc rowmenu {x y id} {
2585     global rowctxmenu idline selectedline rowmenuid
2586
2587     if {![info exists selectedline] || $idline($id) eq $selectedline} {
2588         set state disabled
2589     } else {
2590         set state normal
2591     }
2592     $rowctxmenu entryconfigure 0 -state $state
2593     $rowctxmenu entryconfigure 1 -state $state
2594     $rowctxmenu entryconfigure 2 -state $state
2595     set rowmenuid $id
2596     tk_popup $rowctxmenu $x $y
2597 }
2598
2599 proc diffvssel {dirn} {
2600     global rowmenuid selectedline lineid
2601     global ctext cflist
2602     global commitinfo
2603
2604     if {![info exists selectedline]} return
2605     if {$dirn} {
2606         set oldid $lineid($selectedline)
2607         set newid $rowmenuid
2608     } else {
2609         set oldid $rowmenuid
2610         set newid $lineid($selectedline)
2611     }
2612     $ctext conf -state normal
2613     $ctext delete 0.0 end
2614     $ctext mark set fmark.0 0.0
2615     $ctext mark gravity fmark.0 left
2616     $cflist delete 0 end
2617     $cflist insert end "Top"
2618     $ctext insert end "From $oldid\n     "
2619     $ctext insert end [lindex $commitinfo($oldid) 0]
2620     $ctext insert end "\n\nTo   $newid\n     "
2621     $ctext insert end [lindex $commitinfo($newid) 0]
2622     $ctext insert end "\n"
2623     $ctext conf -state disabled
2624     $ctext tag delete Comments
2625     $ctext tag remove found 1.0 end
2626     startdiff $newid [list $oldid]
2627 }
2628
2629 proc mkpatch {} {
2630     global rowmenuid currentid commitinfo patchtop patchnum
2631
2632     if {![info exists currentid]} return
2633     set oldid $currentid
2634     set oldhead [lindex $commitinfo($oldid) 0]
2635     set newid $rowmenuid
2636     set newhead [lindex $commitinfo($newid) 0]
2637     set top .patch
2638     set patchtop $top
2639     catch {destroy $top}
2640     toplevel $top
2641     label $top.title -text "Generate patch"
2642     grid $top.title - -pady 10
2643     label $top.from -text "From:"
2644     entry $top.fromsha1 -width 40 -relief flat
2645     $top.fromsha1 insert 0 $oldid
2646     $top.fromsha1 conf -state readonly
2647     grid $top.from $top.fromsha1 -sticky w
2648     entry $top.fromhead -width 60 -relief flat
2649     $top.fromhead insert 0 $oldhead
2650     $top.fromhead conf -state readonly
2651     grid x $top.fromhead -sticky w
2652     label $top.to -text "To:"
2653     entry $top.tosha1 -width 40 -relief flat
2654     $top.tosha1 insert 0 $newid
2655     $top.tosha1 conf -state readonly
2656     grid $top.to $top.tosha1 -sticky w
2657     entry $top.tohead -width 60 -relief flat
2658     $top.tohead insert 0 $newhead
2659     $top.tohead conf -state readonly
2660     grid x $top.tohead -sticky w
2661     button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2662     grid $top.rev x -pady 10
2663     label $top.flab -text "Output file:"
2664     entry $top.fname -width 60
2665     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2666     incr patchnum
2667     grid $top.flab $top.fname -sticky w
2668     frame $top.buts
2669     button $top.buts.gen -text "Generate" -command mkpatchgo
2670     button $top.buts.can -text "Cancel" -command mkpatchcan
2671     grid $top.buts.gen $top.buts.can
2672     grid columnconfigure $top.buts 0 -weight 1 -uniform a
2673     grid columnconfigure $top.buts 1 -weight 1 -uniform a
2674     grid $top.buts - -pady 10 -sticky ew
2675     focus $top.fname
2676 }
2677
2678 proc mkpatchrev {} {
2679     global patchtop
2680
2681     set oldid [$patchtop.fromsha1 get]
2682     set oldhead [$patchtop.fromhead get]
2683     set newid [$patchtop.tosha1 get]
2684     set newhead [$patchtop.tohead get]
2685     foreach e [list fromsha1 fromhead tosha1 tohead] \
2686             v [list $newid $newhead $oldid $oldhead] {
2687         $patchtop.$e conf -state normal
2688         $patchtop.$e delete 0 end
2689         $patchtop.$e insert 0 $v
2690         $patchtop.$e conf -state readonly
2691     }
2692 }
2693
2694 proc mkpatchgo {} {
2695     global patchtop
2696
2697     set oldid [$patchtop.fromsha1 get]
2698     set newid [$patchtop.tosha1 get]
2699     set fname [$patchtop.fname get]
2700     if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
2701         error_popup "Error creating patch: $err"
2702     }
2703     catch {destroy $patchtop}
2704     unset patchtop
2705 }
2706
2707 proc mkpatchcan {} {
2708     global patchtop
2709
2710     catch {destroy $patchtop}
2711     unset patchtop
2712 }
2713
2714 proc mktag {} {
2715     global rowmenuid mktagtop commitinfo
2716
2717     set top .maketag
2718     set mktagtop $top
2719     catch {destroy $top}
2720     toplevel $top
2721     label $top.title -text "Create tag"
2722     grid $top.title - -pady 10
2723     label $top.id -text "ID:"
2724     entry $top.sha1 -width 40 -relief flat
2725     $top.sha1 insert 0 $rowmenuid
2726     $top.sha1 conf -state readonly
2727     grid $top.id $top.sha1 -sticky w
2728     entry $top.head -width 60 -relief flat
2729     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2730     $top.head conf -state readonly
2731     grid x $top.head -sticky w
2732     label $top.tlab -text "Tag name:"
2733     entry $top.tag -width 60
2734     grid $top.tlab $top.tag -sticky w
2735     frame $top.buts
2736     button $top.buts.gen -text "Create" -command mktaggo
2737     button $top.buts.can -text "Cancel" -command mktagcan
2738     grid $top.buts.gen $top.buts.can
2739     grid columnconfigure $top.buts 0 -weight 1 -uniform a
2740     grid columnconfigure $top.buts 1 -weight 1 -uniform a
2741     grid $top.buts - -pady 10 -sticky ew
2742     focus $top.tag
2743 }
2744
2745 proc domktag {} {
2746     global mktagtop env tagids idtags
2747     global idpos idline linehtag canv selectedline
2748
2749     set id [$mktagtop.sha1 get]
2750     set tag [$mktagtop.tag get]
2751     if {$tag == {}} {
2752         error_popup "No tag name specified"
2753         return
2754     }
2755     if {[info exists tagids($tag)]} {
2756         error_popup "Tag \"$tag\" already exists"
2757         return
2758     }
2759     if {[catch {
2760         set dir [gitdir]
2761         set fname [file join $dir "refs/tags" $tag]
2762         set f [open $fname w]
2763         puts $f $id
2764         close $f
2765     } err]} {
2766         error_popup "Error creating tag: $err"
2767         return
2768     }
2769
2770     set tagids($tag) $id
2771     lappend idtags($id) $tag
2772     $canv delete tag.$id
2773     set xt [eval drawtags $id $idpos($id)]
2774     $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
2775     if {[info exists selectedline] && $selectedline == $idline($id)} {
2776         selectline $selectedline
2777     }
2778 }
2779
2780 proc mktagcan {} {
2781     global mktagtop
2782
2783     catch {destroy $mktagtop}
2784     unset mktagtop
2785 }
2786
2787 proc mktaggo {} {
2788     domktag
2789     mktagcan
2790 }
2791
2792 proc writecommit {} {
2793     global rowmenuid wrcomtop commitinfo wrcomcmd
2794
2795     set top .writecommit
2796     set wrcomtop $top
2797     catch {destroy $top}
2798     toplevel $top
2799     label $top.title -text "Write commit to file"
2800     grid $top.title - -pady 10
2801     label $top.id -text "ID:"
2802     entry $top.sha1 -width 40 -relief flat
2803     $top.sha1 insert 0 $rowmenuid
2804     $top.sha1 conf -state readonly
2805     grid $top.id $top.sha1 -sticky w
2806     entry $top.head -width 60 -relief flat
2807     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2808     $top.head conf -state readonly
2809     grid x $top.head -sticky w
2810     label $top.clab -text "Command:"
2811     entry $top.cmd -width 60 -textvariable wrcomcmd
2812     grid $top.clab $top.cmd -sticky w -pady 10
2813     label $top.flab -text "Output file:"
2814     entry $top.fname -width 60
2815     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
2816     grid $top.flab $top.fname -sticky w
2817     frame $top.buts
2818     button $top.buts.gen -text "Write" -command wrcomgo
2819     button $top.buts.can -text "Cancel" -command wrcomcan
2820     grid $top.buts.gen $top.buts.can
2821     grid columnconfigure $top.buts 0 -weight 1 -uniform a
2822     grid columnconfigure $top.buts 1 -weight 1 -uniform a
2823     grid $top.buts - -pady 10 -sticky ew
2824     focus $top.fname
2825 }
2826
2827 proc wrcomgo {} {
2828     global wrcomtop
2829
2830     set id [$wrcomtop.sha1 get]
2831     set cmd "echo $id | [$wrcomtop.cmd get]"
2832     set fname [$wrcomtop.fname get]
2833     if {[catch {exec sh -c $cmd >$fname &} err]} {
2834         error_popup "Error writing commit: $err"
2835     }
2836     catch {destroy $wrcomtop}
2837     unset wrcomtop
2838 }
2839
2840 proc wrcomcan {} {
2841     global wrcomtop
2842
2843     catch {destroy $wrcomtop}
2844     unset wrcomtop
2845 }
2846
2847 proc doquit {} {
2848     global stopped
2849     set stopped 100
2850     destroy .
2851 }
2852
2853 # defaults...
2854 set datemode 0
2855 set boldnames 0
2856 set diffopts "-U 5 -p"
2857 set wrcomcmd "git-diff-tree --stdin -p --pretty"
2858
2859 set mainfont {Helvetica 9}
2860 set textfont {Courier 9}
2861 set findmergefiles 0
2862 set gaudydiff 0
2863
2864 set colors {green red blue magenta darkgrey brown orange}
2865
2866 catch {source ~/.gitk}
2867
2868 set namefont $mainfont
2869 if {$boldnames} {
2870     lappend namefont bold
2871 }
2872
2873 set revtreeargs {}
2874 foreach arg $argv {
2875     switch -regexp -- $arg {
2876         "^$" { }
2877         "^-b" { set boldnames 1 }
2878         "^-d" { set datemode 1 }
2879         default {
2880             lappend revtreeargs $arg
2881         }
2882     }
2883 }
2884
2885 set stopped 0
2886 set redisplaying 0
2887 set stuffsaved 0
2888 set patchnum 0
2889 setcoords
2890 makewindow
2891 readrefs
2892 getcommits $revtreeargs