gitk

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