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
1295     if {$numcommits == 0} return
1296
1297     # make a list of all the ids to search, starting at the one
1298     # after the selected line (if any)
1299     if {[info exists selectedline]} {
1300         set l $selectedline
1301     } else {
1302         set l -1
1303     }
1304     set inputids {}
1305     for {set i 0} {$i < $numcommits} {incr i} {
1306         if {[incr l] >= $numcommits} {
1307             set l 0
1308         }
1309         append inputids $lineid($l) "\n"
1310     }
1311
1312     if {[catch {
1313         set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1314                          << $inputids] r]
1315     } err]} {
1316         error_popup "Error starting search process: $err"
1317         return
1318     }
1319
1320     set findprocfile $f
1321     set findprocpid [pid $f]
1322     fconfigure $f -blocking 0
1323     fileevent $f readable readfindproc
1324     set finddidsel 0
1325     . config -cursor watch
1326     $ctext config -cursor watch
1327     set findinprogress 1
1328 }
1329
1330 proc readfindproc {} {
1331     global findprocfile finddidsel
1332     global idline matchinglines
1333
1334     set n [gets $findprocfile line]
1335     if {$n < 0} {
1336         if {[eof $findprocfile]} {
1337             stopfindproc 1
1338             if {!$finddidsel} {
1339                 bell
1340             }
1341         }
1342         return
1343     }
1344     if {![regexp {^[0-9a-f]{40}} $line id]} {
1345         error_popup "Can't parse git-diff-tree output: $line"
1346         stopfindproc
1347         return
1348     }
1349     if {![info exists idline($id)]} {
1350         puts stderr "spurious id: $id"
1351         return
1352     }
1353     set l $idline($id)
1354     lappend matchinglines $l
1355     if {!$finddidsel} {
1356         findselectline $l
1357         set finddidsel 1
1358     }
1359 }
1360
1361 proc findfiles {} {
1362     global selectedline numcommits lineid
1363     global ffileline finddidsel parents findstartline
1364     global findinprogress ctext
1365
1366     if {$numcommits == 0} return
1367
1368     if {[info exists selectedline]} {
1369         set l [expr {$selectedline + 1}]
1370     } else {
1371         set l 0
1372     }
1373     set ffileline $l
1374     set finddidsel 0
1375     set findstartline $l
1376     set id $lineid($l)
1377     set p [lindex $parents($id) 0]
1378     . config -cursor watch
1379     $ctext config -cursor watch
1380     set findinprogress 1
1381     update
1382     findcont [list $id $p]
1383 }
1384
1385 proc findcont {ids} {
1386     global findids treediffs parents nparents treepending
1387     global ffileline findstartline finddidsel
1388     global lineid numcommits matchinglines findinprogress
1389     global findmergefiles
1390
1391     set id [lindex $ids 0]
1392     set p [lindex $ids 1]
1393     set pi [lsearch -exact $parents($id) $p]
1394     set l $ffileline
1395     while 1 {
1396         if {$findmergefiles || $nparents($id) == 1} {
1397             if {![info exists treediffs($ids)]} {
1398                 set findids $ids
1399                 set ffileline $l
1400                 if {![info exists treepending]} {
1401                     gettreediffs $ids
1402                 }
1403                 return
1404             }
1405             set doesmatch 0
1406             foreach f $treediffs($ids) {
1407                 set x [findmatches $f]
1408                 if {$x != {}} {
1409                     set doesmatch 1
1410                     break
1411                 }
1412             }
1413             if {$doesmatch} {
1414                 lappend matchinglines $l
1415                 markheadline $l $id
1416                 if {!$finddidsel} {
1417                     findselectline $l
1418                     set finddidsel 1
1419                 }
1420                 set pi $nparents($id)
1421             }
1422         } else {
1423             set pi $nparents($id)
1424         }
1425         if {[incr pi] >= $nparents($id)} {
1426             set pi 0
1427             if {[incr l] >= $numcommits} {
1428                 set l 0
1429             }
1430             if {$l == $findstartline} break
1431             set id $lineid($l)
1432         }
1433         set p [lindex $parents($id) $pi]
1434         set ids [list $id $p]
1435     }
1436     stopfindproc
1437     if {!$finddidsel} {
1438         bell
1439     }
1440 }
1441
1442 # mark a commit as matching by putting a yellow background
1443 # behind the headline
1444 proc markheadline {l id} {
1445     global canv mainfont linehtag commitinfo
1446
1447     set bbox [$canv bbox $linehtag($l)]
1448     set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1449     $canv lower $t
1450 }
1451
1452 # mark the bits of a headline, author or date that match a find string
1453 proc markmatches {canv l str tag matches font} {
1454     set bbox [$canv bbox $tag]
1455     set x0 [lindex $bbox 0]
1456     set y0 [lindex $bbox 1]
1457     set y1 [lindex $bbox 3]
1458     foreach match $matches {
1459         set start [lindex $match 0]
1460         set end [lindex $match 1]
1461         if {$start > $end} continue
1462         set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1463         set xlen [font measure $font [string range $str 0 [expr $end]]]
1464         set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1465                    -outline {} -tags matches -fill yellow]
1466         $canv lower $t
1467     }
1468 }
1469
1470 proc unmarkmatches {} {
1471     global matchinglines findids
1472     allcanvs delete matches
1473     catch {unset matchinglines}
1474     catch {unset findids}
1475 }
1476
1477 proc selcanvline {w x y} {
1478     global canv canvy0 ctext linespc selectedline
1479     global lineid linehtag linentag linedtag rowtextx
1480     set ymax [lindex [$canv cget -scrollregion] 3]
1481     if {$ymax == {}} return
1482     set yfrac [lindex [$canv yview] 0]
1483     set y [expr {$y + $yfrac * $ymax}]
1484     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1485     if {$l < 0} {
1486         set l 0
1487     }
1488     if {$w eq $canv} {
1489         if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1490     }
1491     unmarkmatches
1492     selectline $l
1493 }
1494
1495 proc selectline {l} {
1496     global canv canv2 canv3 ctext commitinfo selectedline
1497     global lineid linehtag linentag linedtag
1498     global canvy0 linespc parents nparents
1499     global cflist currentid sha1entry diffids
1500     global commentend seenfile idtags
1501     $canv delete hover
1502     if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1503     $canv delete secsel
1504     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1505                -tags secsel -fill [$canv cget -selectbackground]]
1506     $canv lower $t
1507     $canv2 delete secsel
1508     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1509                -tags secsel -fill [$canv2 cget -selectbackground]]
1510     $canv2 lower $t
1511     $canv3 delete secsel
1512     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1513                -tags secsel -fill [$canv3 cget -selectbackground]]
1514     $canv3 lower $t
1515     set y [expr {$canvy0 + $l * $linespc}]
1516     set ymax [lindex [$canv cget -scrollregion] 3]
1517     set ytop [expr {$y - $linespc - 1}]
1518     set ybot [expr {$y + $linespc + 1}]
1519     set wnow [$canv yview]
1520     set wtop [expr [lindex $wnow 0] * $ymax]
1521     set wbot [expr [lindex $wnow 1] * $ymax]
1522     set wh [expr {$wbot - $wtop}]
1523     set newtop $wtop
1524     if {$ytop < $wtop} {
1525         if {$ybot < $wtop} {
1526             set newtop [expr {$y - $wh / 2.0}]
1527         } else {
1528             set newtop $ytop
1529             if {$newtop > $wtop - $linespc} {
1530                 set newtop [expr {$wtop - $linespc}]
1531             }
1532         }
1533     } elseif {$ybot > $wbot} {
1534         if {$ytop > $wbot} {
1535             set newtop [expr {$y - $wh / 2.0}]
1536         } else {
1537             set newtop [expr {$ybot - $wh}]
1538             if {$newtop < $wtop + $linespc} {
1539                 set newtop [expr {$wtop + $linespc}]
1540             }
1541         }
1542     }
1543     if {$newtop != $wtop} {
1544         if {$newtop < 0} {
1545             set newtop 0
1546         }
1547         allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1548     }
1549     set selectedline $l
1550
1551     set id $lineid($l)
1552     set currentid $id
1553     set diffids [concat $id $parents($id)]
1554     $sha1entry delete 0 end
1555     $sha1entry insert 0 $id
1556     $sha1entry selection from 0
1557     $sha1entry selection to end
1558
1559     $ctext conf -state normal
1560     $ctext delete 0.0 end
1561     $ctext mark set fmark.0 0.0
1562     $ctext mark gravity fmark.0 left
1563     set info $commitinfo($id)
1564     $ctext insert end "Author: [lindex $info 1]  [lindex $info 2]\n"
1565     $ctext insert end "Committer: [lindex $info 3]  [lindex $info 4]\n"
1566     if {[info exists idtags($id)]} {
1567         $ctext insert end "Tags:"
1568         foreach tag $idtags($id) {
1569             $ctext insert end " $tag"
1570         }
1571         $ctext insert end "\n"
1572     }
1573     $ctext insert end "\n"
1574     $ctext insert end [lindex $info 5]
1575     $ctext insert end "\n"
1576     $ctext tag delete Comments
1577     $ctext tag remove found 1.0 end
1578     $ctext conf -state disabled
1579     set commentend [$ctext index "end - 1c"]
1580
1581     $cflist delete 0 end
1582     $cflist insert end "Comments"
1583     if {$nparents($id) == 1} {
1584         startdiff
1585     }
1586     catch {unset seenfile}
1587 }
1588
1589 proc startdiff {} {
1590     global treediffs diffids treepending
1591
1592     if {![info exists treediffs($diffids)]} {
1593         if {![info exists treepending]} {
1594             gettreediffs $diffids
1595         }
1596     } else {
1597         addtocflist $diffids
1598     }
1599 }
1600
1601 proc selnextline {dir} {
1602     global selectedline
1603     if {![info exists selectedline]} return
1604     set l [expr $selectedline + $dir]
1605     unmarkmatches
1606     selectline $l
1607 }
1608
1609 proc addtocflist {ids} {
1610     global treediffs cflist
1611     foreach f $treediffs($ids) {
1612         $cflist insert end $f
1613     }
1614     getblobdiffs $ids
1615 }
1616
1617 proc gettreediffs {ids} {
1618     global treediffs parents treepending
1619     set treepending $ids
1620     set treediffs($ids) {}
1621     set id [lindex $ids 0]
1622     set p [lindex $ids 1]
1623     if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1624     fconfigure $gdtf -blocking 0
1625     fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1626 }
1627
1628 proc gettreediffline {gdtf ids} {
1629     global treediffs treepending diffids findids
1630     set n [gets $gdtf line]
1631     if {$n < 0} {
1632         if {![eof $gdtf]} return
1633         close $gdtf
1634         unset treepending
1635         if {[info exists diffids]} {
1636             if {$ids != $diffids} {
1637                 gettreediffs $diffids
1638             } else {
1639                 addtocflist $ids
1640             }
1641         }
1642         if {[info exists findids]} {
1643             if {$ids != $findids} {
1644                 if {![info exists treepending]} {
1645                     gettreediffs $findids
1646                 }
1647             } else {
1648                 findcont $ids
1649             }
1650         }
1651         return
1652     }
1653     set file [lindex $line 5]
1654     lappend treediffs($ids) $file
1655 }
1656
1657 proc getblobdiffs {ids} {
1658     global diffopts blobdifffd env curdifftag curtagstart
1659     global diffindex difffilestart nextupdate
1660
1661     set id [lindex $ids 0]
1662     set p [lindex $ids 1]
1663     set env(GIT_DIFF_OPTS) $diffopts
1664     if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1665         puts "error getting diffs: $err"
1666         return
1667     }
1668     fconfigure $bdf -blocking 0
1669     set blobdifffd($ids) $bdf
1670     set curdifftag Comments
1671     set curtagstart 0.0
1672     set diffindex 0
1673     catch {unset difffilestart}
1674     fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1675     set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1676 }
1677
1678 proc getblobdiffline {bdf ids} {
1679     global diffids blobdifffd ctext curdifftag curtagstart seenfile
1680     global diffnexthead diffnextnote diffindex difffilestart
1681     global nextupdate
1682
1683     set n [gets $bdf line]
1684     if {$n < 0} {
1685         if {[eof $bdf]} {
1686             close $bdf
1687             if {[info exists diffids] && $ids == $diffids
1688                 && $bdf == $blobdifffd($ids)} {
1689                 $ctext tag add $curdifftag $curtagstart end
1690                 set seenfile($curdifftag) 1
1691                 unset diffids
1692             }
1693         }
1694         return
1695     }
1696     if {![info exists diffids] || $ids != $diffids
1697         || $bdf != $blobdifffd($ids)} {
1698         return
1699     }
1700     $ctext conf -state normal
1701     if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1702         # start of a new file
1703         $ctext insert end "\n"
1704         $ctext tag add $curdifftag $curtagstart end
1705         set seenfile($curdifftag) 1
1706         set curtagstart [$ctext index "end - 1c"]
1707         set header $fname
1708         if {[info exists diffnexthead]} {
1709             set fname $diffnexthead
1710             set header "$diffnexthead ($diffnextnote)"
1711             unset diffnexthead
1712         }
1713         set here [$ctext index "end - 1c"]
1714         set difffilestart($diffindex) $here
1715         incr diffindex
1716         # start mark names at fmark.1 for first file
1717         $ctext mark set fmark.$diffindex $here
1718         $ctext mark gravity fmark.$diffindex left
1719         set curdifftag "f:$fname"
1720         $ctext tag delete $curdifftag
1721         set l [expr {(78 - [string length $header]) / 2}]
1722         set pad [string range "----------------------------------------" 1 $l]
1723         $ctext insert end "$pad $header $pad\n" filesep
1724     } elseif {[string range $line 0 2] == "+++"} {
1725         # no need to do anything with this
1726     } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1727         set diffnexthead $fn
1728         set diffnextnote "created, mode $m"
1729     } elseif {[string range $line 0 8] == "Deleted: "} {
1730         set diffnexthead [string range $line 9 end]
1731         set diffnextnote "deleted"
1732     } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1733         # save the filename in case the next thing is "new file mode ..."
1734         set diffnexthead $fn
1735         set diffnextnote "modified"
1736     } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1737         set diffnextnote "new file, mode $m"
1738     } elseif {[string range $line 0 11] == "deleted file"} {
1739         set diffnextnote "deleted"
1740     } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1741                    $line match f1l f1c f2l f2c rest]} {
1742         $ctext insert end "\t" hunksep
1743         $ctext insert end "    $f1l    " d0 "    $f2l    " d1
1744         $ctext insert end "    $rest \n" hunksep
1745     } else {
1746         set x [string range $line 0 0]
1747         if {$x == "-" || $x == "+"} {
1748             set tag [expr {$x == "+"}]
1749             set line [string range $line 1 end]
1750             $ctext insert end "$line\n" d$tag
1751         } elseif {$x == " "} {
1752             set line [string range $line 1 end]
1753             $ctext insert end "$line\n"
1754         } elseif {$x == "\\"} {
1755             # e.g. "\ No newline at end of file"
1756             $ctext insert end "$line\n" filesep
1757         } else {
1758             # Something else we don't recognize
1759             if {$curdifftag != "Comments"} {
1760                 $ctext insert end "\n"
1761                 $ctext tag add $curdifftag $curtagstart end
1762                 set seenfile($curdifftag) 1
1763                 set curtagstart [$ctext index "end - 1c"]
1764                 set curdifftag Comments
1765             }
1766             $ctext insert end "$line\n" filesep
1767         }
1768     }
1769     $ctext conf -state disabled
1770     if {[clock clicks -milliseconds] >= $nextupdate} {
1771         incr nextupdate 100
1772         fileevent $bdf readable {}
1773         update
1774         fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1775     }
1776 }
1777
1778 proc nextfile {} {
1779     global difffilestart ctext
1780     set here [$ctext index @0,0]
1781     for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1782         if {[$ctext compare $difffilestart($i) > $here]} {
1783             $ctext yview $difffilestart($i)
1784             break
1785         }
1786     }
1787 }
1788
1789 proc listboxsel {} {
1790     global ctext cflist currentid treediffs seenfile
1791     if {![info exists currentid]} return
1792     set sel [lsort [$cflist curselection]]
1793     if {$sel eq {}} return
1794     set first [lindex $sel 0]
1795     catch {$ctext yview fmark.$first}
1796 }
1797
1798 proc setcoords {} {
1799     global linespc charspc canvx0 canvy0 mainfont
1800     set linespc [font metrics $mainfont -linespace]
1801     set charspc [font measure $mainfont "m"]
1802     set canvy0 [expr 3 + 0.5 * $linespc]
1803     set canvx0 [expr 3 + 0.5 * $linespc]
1804 }
1805
1806 proc redisplay {} {
1807     global selectedline stopped redisplaying phase
1808     if {$stopped > 1} return
1809     if {$phase == "getcommits"} return
1810     set redisplaying 1
1811     if {$phase == "drawgraph" || $phase == "incrdraw"} {
1812         set stopped 1
1813     } else {
1814         drawgraph
1815     }
1816 }
1817
1818 proc incrfont {inc} {
1819     global mainfont namefont textfont selectedline ctext canv phase
1820     global stopped entries
1821     unmarkmatches
1822     set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1823     set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1824     set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1825     setcoords
1826     $ctext conf -font $textfont
1827     $ctext tag conf filesep -font [concat $textfont bold]
1828     foreach e $entries {
1829         $e conf -font $mainfont
1830     }
1831     if {$phase == "getcommits"} {
1832         $canv itemconf textitems -font $mainfont
1833     }
1834     redisplay
1835 }
1836
1837 proc clearsha1 {} {
1838     global sha1entry sha1string
1839     if {[string length $sha1string] == 40} {
1840         $sha1entry delete 0 end
1841     }
1842 }
1843
1844 proc sha1change {n1 n2 op} {
1845     global sha1string currentid sha1but
1846     if {$sha1string == {}
1847         || ([info exists currentid] && $sha1string == $currentid)} {
1848         set state disabled
1849     } else {
1850         set state normal
1851     }
1852     if {[$sha1but cget -state] == $state} return
1853     if {$state == "normal"} {
1854         $sha1but conf -state normal -relief raised -text "Goto: "
1855     } else {
1856         $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1857     }
1858 }
1859
1860 proc gotocommit {} {
1861     global sha1string currentid idline tagids
1862     if {$sha1string == {}
1863         || ([info exists currentid] && $sha1string == $currentid)} return
1864     if {[info exists tagids($sha1string)]} {
1865         set id $tagids($sha1string)
1866     } else {
1867         set id [string tolower $sha1string]
1868     }
1869     if {[info exists idline($id)]} {
1870         selectline $idline($id)
1871         return
1872     }
1873     if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1874         set type "SHA1 id"
1875     } else {
1876         set type "Tag"
1877     }
1878     error_popup "$type $sha1string is not known"
1879 }
1880
1881 proc lineenter {x y id} {
1882     global hoverx hovery hoverid hovertimer
1883     global commitinfo canv
1884
1885     if {![info exists commitinfo($id)]} return
1886     set hoverx $x
1887     set hovery $y
1888     set hoverid $id
1889     if {[info exists hovertimer]} {
1890         after cancel $hovertimer
1891     }
1892     set hovertimer [after 500 linehover]
1893     $canv delete hover
1894 }
1895
1896 proc linemotion {x y id} {
1897     global hoverx hovery hoverid hovertimer
1898
1899     if {[info exists hoverid] && $id == $hoverid} {
1900         set hoverx $x
1901         set hovery $y
1902         if {[info exists hovertimer]} {
1903             after cancel $hovertimer
1904         }
1905         set hovertimer [after 500 linehover]
1906     }
1907 }
1908
1909 proc lineleave {id} {
1910     global hoverid hovertimer canv
1911
1912     if {[info exists hoverid] && $id == $hoverid} {
1913         $canv delete hover
1914         if {[info exists hovertimer]} {
1915             after cancel $hovertimer
1916             unset hovertimer
1917         }
1918         unset hoverid
1919     }
1920 }
1921
1922 proc linehover {} {
1923     global hoverx hovery hoverid hovertimer
1924     global canv linespc lthickness
1925     global commitinfo mainfont
1926
1927     set text [lindex $commitinfo($hoverid) 0]
1928     set ymax [lindex [$canv cget -scrollregion] 3]
1929     if {$ymax == {}} return
1930     set yfrac [lindex [$canv yview] 0]
1931     set x [expr {$hoverx + 2 * $linespc}]
1932     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
1933     set x0 [expr {$x - 2 * $lthickness}]
1934     set y0 [expr {$y - 2 * $lthickness}]
1935     set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
1936     set y1 [expr {$y + $linespc + 2 * $lthickness}]
1937     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
1938                -fill \#ffff80 -outline black -width 1 -tags hover]
1939     $canv raise $t
1940     set t [$canv create text $x $y -anchor nw -text $text -tags hover]
1941     $canv raise $t
1942 }
1943
1944 proc lineclick {x y id} {
1945     global ctext commitinfo children cflist canv
1946
1947     unmarkmatches
1948     $canv delete hover
1949     # fill the details pane with info about this line
1950     $ctext conf -state normal
1951     $ctext delete 0.0 end
1952     $ctext insert end "Parent:\n "
1953     catch {destroy $ctext.$id}
1954     button $ctext.$id -text "Go:" -command "selbyid $id" \
1955         -padx 4 -pady 0
1956     $ctext window create end -window $ctext.$id -align center
1957     set info $commitinfo($id)
1958     $ctext insert end "\t[lindex $info 0]\n"
1959     $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
1960     $ctext insert end "\tDate:\t[lindex $info 2]\n"
1961     $ctext insert end "\tID:\t$id\n"
1962     if {[info exists children($id)]} {
1963         $ctext insert end "\nChildren:"
1964         foreach child $children($id) {
1965             $ctext insert end "\n "
1966             catch {destroy $ctext.$child}
1967             button $ctext.$child -text "Go:" -command "selbyid $child" \
1968                 -padx 4 -pady 0
1969             $ctext window create end -window $ctext.$child -align center
1970             set info $commitinfo($child)
1971             $ctext insert end "\t[lindex $info 0]"
1972         }
1973     }
1974     $ctext conf -state disabled
1975
1976     $cflist delete 0 end
1977 }
1978
1979 proc selbyid {id} {
1980     global idline
1981     if {[info exists idline($id)]} {
1982         selectline $idline($id)
1983     }
1984 }
1985
1986 proc mstime {} {
1987     global startmstime
1988     if {![info exists startmstime]} {
1989         set startmstime [clock clicks -milliseconds]
1990     }
1991     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
1992 }
1993
1994 proc rowmenu {x y id} {
1995     global rowctxmenu idline selectedline rowmenuid
1996
1997     if {![info exists selectedline] || $idline($id) eq $selectedline} {
1998         set state disabled
1999     } else {
2000         set state normal
2001     }
2002     $rowctxmenu entryconfigure 0 -state $state
2003     $rowctxmenu entryconfigure 1 -state $state
2004     $rowctxmenu entryconfigure 2 -state $state
2005     set rowmenuid $id
2006     tk_popup $rowctxmenu $x $y
2007 }
2008
2009 proc diffvssel {dirn} {
2010     global rowmenuid selectedline lineid
2011     global ctext cflist
2012     global diffids commitinfo
2013
2014     if {![info exists selectedline]} return
2015     if {$dirn} {
2016         set oldid $lineid($selectedline)
2017         set newid $rowmenuid
2018     } else {
2019         set oldid $rowmenuid
2020         set newid $lineid($selectedline)
2021     }
2022     $ctext conf -state normal
2023     $ctext delete 0.0 end
2024     $ctext mark set fmark.0 0.0
2025     $ctext mark gravity fmark.0 left
2026     $cflist delete 0 end
2027     $cflist insert end "Top"
2028     $ctext insert end "From $oldid\n     "
2029     $ctext insert end [lindex $commitinfo($oldid) 0]
2030     $ctext insert end "\n\nTo   $newid\n     "
2031     $ctext insert end [lindex $commitinfo($newid) 0]
2032     $ctext insert end "\n"
2033     $ctext conf -state disabled
2034     $ctext tag delete Comments
2035     $ctext tag remove found 1.0 end
2036     set diffids [list $newid $oldid]
2037     startdiff
2038 }
2039
2040 proc mkpatch {} {
2041     global rowmenuid currentid commitinfo patchtop patchnum
2042
2043     if {![info exists currentid]} return
2044     set oldid $currentid
2045     set oldhead [lindex $commitinfo($oldid) 0]
2046     set newid $rowmenuid
2047     set newhead [lindex $commitinfo($newid) 0]
2048     set top .patch
2049     set patchtop $top
2050     catch {destroy $top}
2051     toplevel $top
2052     label $top.title -text "Generate patch"
2053     grid $top.title - -pady 10
2054     label $top.from -text "From:"
2055     entry $top.fromsha1 -width 40 -relief flat
2056     $top.fromsha1 insert 0 $oldid
2057     $top.fromsha1 conf -state readonly
2058     grid $top.from $top.fromsha1 -sticky w
2059     entry $top.fromhead -width 60 -relief flat
2060     $top.fromhead insert 0 $oldhead
2061     $top.fromhead conf -state readonly
2062     grid x $top.fromhead -sticky w
2063     label $top.to -text "To:"
2064     entry $top.tosha1 -width 40 -relief flat
2065     $top.tosha1 insert 0 $newid
2066     $top.tosha1 conf -state readonly
2067     grid $top.to $top.tosha1 -sticky w
2068     entry $top.tohead -width 60 -relief flat
2069     $top.tohead insert 0 $newhead
2070     $top.tohead conf -state readonly
2071     grid x $top.tohead -sticky w
2072     button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2073     grid $top.rev x -pady 10
2074     label $top.flab -text "Output file:"
2075     entry $top.fname -width 60
2076     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2077     incr patchnum
2078     grid $top.flab $top.fname -sticky w
2079     frame $top.buts
2080     button $top.buts.gen -text "Generate" -command mkpatchgo
2081     button $top.buts.can -text "Cancel" -command mkpatchcan
2082     grid $top.buts.gen $top.buts.can
2083     grid columnconfigure $top.buts 0 -weight 1 -uniform a
2084     grid columnconfigure $top.buts 1 -weight 1 -uniform a
2085     grid $top.buts - -pady 10 -sticky ew
2086     focus $top.fname
2087 }
2088
2089 proc mkpatchrev {} {
2090     global patchtop
2091
2092     set oldid [$patchtop.fromsha1 get]
2093     set oldhead [$patchtop.fromhead get]
2094     set newid [$patchtop.tosha1 get]
2095     set newhead [$patchtop.tohead get]
2096     foreach e [list fromsha1 fromhead tosha1 tohead] \
2097             v [list $newid $newhead $oldid $oldhead] {
2098         $patchtop.$e conf -state normal
2099         $patchtop.$e delete 0 end
2100         $patchtop.$e insert 0 $v
2101         $patchtop.$e conf -state readonly
2102     }
2103 }
2104
2105 proc mkpatchgo {} {
2106     global patchtop
2107
2108     set oldid [$patchtop.fromsha1 get]
2109     set newid [$patchtop.tosha1 get]
2110     set fname [$patchtop.fname get]
2111     if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
2112         error_popup "Error creating patch: $err"
2113     }
2114     catch {destroy $patchtop}
2115     unset patchtop
2116 }
2117
2118 proc mkpatchcan {} {
2119     global patchtop
2120
2121     catch {destroy $patchtop}
2122     unset patchtop
2123 }
2124
2125 proc mktag {} {
2126     global rowmenuid mktagtop commitinfo
2127
2128     set top .maketag
2129     set mktagtop $top
2130     catch {destroy $top}
2131     toplevel $top
2132     label $top.title -text "Create tag"
2133     grid $top.title - -pady 10
2134     label $top.id -text "ID:"
2135     entry $top.sha1 -width 40 -relief flat
2136     $top.sha1 insert 0 $rowmenuid
2137     $top.sha1 conf -state readonly
2138     grid $top.id $top.sha1 -sticky w
2139     entry $top.head -width 60 -relief flat
2140     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2141     $top.head conf -state readonly
2142     grid x $top.head -sticky w
2143     label $top.tlab -text "Tag name:"
2144     entry $top.tag -width 60
2145     grid $top.tlab $top.tag -sticky w
2146     frame $top.buts
2147     button $top.buts.gen -text "Create" -command mktaggo
2148     button $top.buts.can -text "Cancel" -command mktagcan
2149     grid $top.buts.gen $top.buts.can
2150     grid columnconfigure $top.buts 0 -weight 1 -uniform a
2151     grid columnconfigure $top.buts 1 -weight 1 -uniform a
2152     grid $top.buts - -pady 10 -sticky ew
2153     focus $top.tag
2154 }
2155
2156 proc domktag {} {
2157     global mktagtop env tagids idtags
2158     global idpos idline linehtag canv selectedline
2159
2160     set id [$mktagtop.sha1 get]
2161     set tag [$mktagtop.tag get]
2162     if {$tag == {}} {
2163         error_popup "No tag name specified"
2164         return
2165     }
2166     if {[info exists tagids($tag)]} {
2167         error_popup "Tag \"$tag\" already exists"
2168         return
2169     }
2170     if {[catch {
2171         set dir ".git"
2172         if {[info exists env(GIT_DIR)]} {
2173             set dir $env(GIT_DIR)
2174         }
2175         set fname [file join $dir "refs/tags" $tag]
2176         set f [open $fname w]
2177         puts $f $id
2178         close $f
2179     } err]} {
2180         error_popup "Error creating tag: $err"
2181         return
2182     }
2183
2184     set tagids($tag) $id
2185     lappend idtags($id) $tag
2186     $canv delete tag.$id
2187     set xt [eval drawtags $id $idpos($id)]
2188     $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
2189     if {[info exists selectedline] && $selectedline == $idline($id)} {
2190         selectline $selectedline
2191     }
2192 }
2193
2194 proc mktagcan {} {
2195     global mktagtop
2196
2197     catch {destroy $mktagtop}
2198     unset mktagtop
2199 }
2200
2201 proc mktaggo {} {
2202     domktag
2203     mktagcan
2204 }
2205
2206 proc writecommit {} {
2207     global rowmenuid wrcomtop commitinfo wrcomcmd
2208
2209     set top .writecommit
2210     set wrcomtop $top
2211     catch {destroy $top}
2212     toplevel $top
2213     label $top.title -text "Write commit to file"
2214     grid $top.title - -pady 10
2215     label $top.id -text "ID:"
2216     entry $top.sha1 -width 40 -relief flat
2217     $top.sha1 insert 0 $rowmenuid
2218     $top.sha1 conf -state readonly
2219     grid $top.id $top.sha1 -sticky w
2220     entry $top.head -width 60 -relief flat
2221     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2222     $top.head conf -state readonly
2223     grid x $top.head -sticky w
2224     label $top.clab -text "Command:"
2225     entry $top.cmd -width 60 -textvariable wrcomcmd
2226     grid $top.clab $top.cmd -sticky w -pady 10
2227     label $top.flab -text "Output file:"
2228     entry $top.fname -width 60
2229     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
2230     grid $top.flab $top.fname -sticky w
2231     frame $top.buts
2232     button $top.buts.gen -text "Write" -command wrcomgo
2233     button $top.buts.can -text "Cancel" -command wrcomcan
2234     grid $top.buts.gen $top.buts.can
2235     grid columnconfigure $top.buts 0 -weight 1 -uniform a
2236     grid columnconfigure $top.buts 1 -weight 1 -uniform a
2237     grid $top.buts - -pady 10 -sticky ew
2238     focus $top.fname
2239 }
2240
2241 proc wrcomgo {} {
2242     global wrcomtop
2243
2244     set id [$wrcomtop.sha1 get]
2245     set cmd "echo $id | [$wrcomtop.cmd get]"
2246     set fname [$wrcomtop.fname get]
2247     if {[catch {exec sh -c $cmd >$fname &} err]} {
2248         error_popup "Error writing commit: $err"
2249     }
2250     catch {destroy $wrcomtop}
2251     unset wrcomtop
2252 }
2253
2254 proc wrcomcan {} {
2255     global wrcomtop
2256
2257     catch {destroy $wrcomtop}
2258     unset wrcomtop
2259 }
2260
2261 proc doquit {} {
2262     global stopped
2263     set stopped 100
2264     destroy .
2265 }
2266
2267 # defaults...
2268 set datemode 0
2269 set boldnames 0
2270 set diffopts "-U 5 -p"
2271 set wrcomcmd "git-diff-tree --stdin -p --pretty"
2272
2273 set mainfont {Helvetica 9}
2274 set textfont {Courier 9}
2275 set findmergefiles 0
2276
2277 set colors {green red blue magenta darkgrey brown orange}
2278
2279 catch {source ~/.gitk}
2280
2281 set namefont $mainfont
2282 if {$boldnames} {
2283     lappend namefont bold
2284 }
2285
2286 set revtreeargs {}
2287 foreach arg $argv {
2288     switch -regexp -- $arg {
2289         "^$" { }
2290         "^-b" { set boldnames 1 }
2291         "^-d" { set datemode 1 }
2292         default {
2293             lappend revtreeargs $arg
2294         }
2295     }
2296 }
2297
2298 set stopped 0
2299 set redisplaying 0
2300 set stuffsaved 0
2301 set patchnum 0
2302 setcoords
2303 makewindow
2304 readrefs
2305 getcommits $revtreeargs