Andrew's git / gitweb.git / gitk
?
gitkon commit First cut at displaying the diffs for a merge. (e2ed432)
   1#!/bin/sh
   2# Tcl ignores the next line -*- tcl -*- \
   3exec 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
  10proc 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
  55proc 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
  73to 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
 126proc doupdate {} {
 127    global commfd nextupdate
 128
 129    incr nextupdate 100
 130    fileevent $commfd readable {}
 131    update
 132    fileevent $commfd readable "getcommitlines $commfd"
 133}
 134
 135proc readcommit {id} {
 136    if [catch {set contents [exec git-cat-file commit $id]}] return
 137    parsecommit $id $contents 0
 138}
 139
 140proc 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
 213proc 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
 259proc 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
 271proc 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.
 439proc 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
 453proc click {w} {
 454    global entries
 455    foreach e $entries {
 456        if {$w == $e} return
 457    }
 458    focus .
 459}
 460
 461proc 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
 488proc 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
 519proc 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
 540proc allcanvs args {
 541    global canv canv2 canv3
 542    eval $canv $args
 543    eval $canv2 $args
 544    eval $canv3 $args
 545}
 546
 547proc 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
 554proc 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 {
 563Gitk version 1.2
 564
 565Copyright © 2005 Paul Mackerras
 566
 567Use 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
 574proc 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
 645proc 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
 663proc 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
 672proc 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
 757proc 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
 809proc 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
 843proc 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
 871proc 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
 923proc 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
 995proc 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
1034proc 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
1053proc 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
1064proc 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
1118proc 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
1138proc 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
1204proc 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
1219proc 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
1237proc 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
1256proc 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
1268proc 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
1290proc 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
1332proc 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
1359proc 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
1380proc 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
1439proc 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
1469proc 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
1498proc 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
1549proc 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
1558proc 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
1575proc unmarkmatches {} {
1576    global matchinglines findids
1577    allcanvs delete matches
1578    catch {unset matchinglines}
1579    catch {unset findids}
1580}
1581
1582proc 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
1600proc selectline {l} {
1601    global canv canv2 canv3 ctext commitinfo selectedline
1602    global lineid linehtag linentag linedtag
1603    global canvy0 linespc parents nparents
1604    global cflist currentid sha1entry
1605    global commentend seenfile idtags
1606    $canv delete hover
1607    if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1608    $canv delete secsel
1609    set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1610               -tags secsel -fill [$canv cget -selectbackground]]
1611    $canv lower $t
1612    $canv2 delete secsel
1613    set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1614               -tags secsel -fill [$canv2 cget -selectbackground]]
1615    $canv2 lower $t
1616    $canv3 delete secsel
1617    set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1618               -tags secsel -fill [$canv3 cget -selectbackground]]
1619    $canv3 lower $t
1620    set y [expr {$canvy0 + $l * $linespc}]
1621    set ymax [lindex [$canv cget -scrollregion] 3]
1622    set ytop [expr {$y - $linespc - 1}]
1623    set ybot [expr {$y + $linespc + 1}]
1624    set wnow [$canv yview]
1625    set wtop [expr [lindex $wnow 0] * $ymax]
1626    set wbot [expr [lindex $wnow 1] * $ymax]
1627    set wh [expr {$wbot - $wtop}]
1628    set newtop $wtop
1629    if {$ytop < $wtop} {
1630        if {$ybot < $wtop} {
1631            set newtop [expr {$y - $wh / 2.0}]
1632        } else {
1633            set newtop $ytop
1634            if {$newtop > $wtop - $linespc} {
1635                set newtop [expr {$wtop - $linespc}]
1636            }
1637        }
1638    } elseif {$ybot > $wbot} {
1639        if {$ytop > $wbot} {
1640            set newtop [expr {$y - $wh / 2.0}]
1641        } else {
1642            set newtop [expr {$ybot - $wh}]
1643            if {$newtop < $wtop + $linespc} {
1644                set newtop [expr {$wtop + $linespc}]
1645            }
1646        }
1647    }
1648    if {$newtop != $wtop} {
1649        if {$newtop < 0} {
1650            set newtop 0
1651        }
1652        allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1653    }
1654    set selectedline $l
1655
1656    set id $lineid($l)
1657    set currentid $id
1658    $sha1entry delete 0 end
1659    $sha1entry insert 0 $id
1660    $sha1entry selection from 0
1661    $sha1entry selection to end
1662
1663    $ctext conf -state normal
1664    $ctext delete 0.0 end
1665    $ctext mark set fmark.0 0.0
1666    $ctext mark gravity fmark.0 left
1667    set info $commitinfo($id)
1668    $ctext insert end "Author: [lindex $info 1]  [lindex $info 2]\n"
1669    $ctext insert end "Committer: [lindex $info 3]  [lindex $info 4]\n"
1670    if {[info exists idtags($id)]} {
1671        $ctext insert end "Tags:"
1672        foreach tag $idtags($id) {
1673            $ctext insert end " $tag"
1674        }
1675        $ctext insert end "\n"
1676    }
1677    $ctext insert end "\n"
1678    $ctext insert end [lindex $info 5]
1679    $ctext insert end "\n"
1680    $ctext tag delete Comments
1681    $ctext tag remove found 1.0 end
1682    $ctext conf -state disabled
1683    set commentend [$ctext index "end - 1c"]
1684
1685    $cflist delete 0 end
1686    $cflist insert end "Comments"
1687    startdiff $id $parents($id)
1688}
1689
1690proc startdiff {id vs} {
1691    global diffpending diffpindex
1692    global diffindex difffilestart seenfile
1693    global curdifftag curtagstart
1694
1695    set diffpending $vs
1696    set diffpindex 0
1697    catch {unset seenfile}
1698    set diffindex 0
1699    catch {unset difffilestart}
1700    set curdifftag Comments
1701    set curtagstart 0.0
1702    contdiff [list $id [lindex $vs 0]]
1703}
1704
1705proc contdiff {ids} {
1706    global treediffs diffids treepending
1707
1708    if {![info exists treediffs($ids)]} {
1709        set diffids $ids
1710        if {![info exists treepending]} {
1711            gettreediffs $ids
1712        }
1713    } else {
1714        addtocflist $ids
1715    }
1716}
1717
1718proc selnextline {dir} {
1719    global selectedline
1720    if {![info exists selectedline]} return
1721    set l [expr $selectedline + $dir]
1722    unmarkmatches
1723    selectline $l
1724}
1725
1726proc addtocflist {ids} {
1727    global treediffs cflist diffpindex
1728
1729    set colors {black blue green red cyan magenta}
1730    set color [lindex $colors [expr {$diffpindex % [llength $colors]}]]
1731    foreach f $treediffs($ids) {
1732        $cflist insert end $f
1733        $cflist itemconf end -foreground $color
1734    }
1735    getblobdiffs $ids
1736}
1737
1738proc gettreediffs {ids} {
1739    global treediffs parents treepending
1740    set treepending $ids
1741    set treediffs($ids) {}
1742    set id [lindex $ids 0]
1743    set p [lindex $ids 1]
1744    if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1745    fconfigure $gdtf -blocking 0
1746    fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1747}
1748
1749proc gettreediffline {gdtf ids} {
1750    global treediffs treepending diffids
1751    set n [gets $gdtf line]
1752    if {$n < 0} {
1753        if {![eof $gdtf]} return
1754        close $gdtf
1755        unset treepending
1756        if {[info exists diffids]} {
1757            if {$ids != $diffids} {
1758                gettreediffs $diffids
1759            } else {
1760                addtocflist $ids
1761            }
1762        }
1763        return
1764    }
1765    set file [lindex $line 5]
1766    lappend treediffs($ids) $file
1767}
1768
1769proc getblobdiffs {ids} {
1770    global diffopts blobdifffd diffids env
1771    global nextupdate
1772
1773    set id [lindex $ids 0]
1774    set p [lindex $ids 1]
1775    set env(GIT_DIFF_OPTS) $diffopts
1776    if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1777        puts "error getting diffs: $err"
1778        return
1779    }
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
1786proc getblobdiffline {bdf ids} {
1787    global diffids blobdifffd ctext curdifftag curtagstart seenfile
1788    global diffnexthead diffnextnote diffindex difffilestart
1789    global nextupdate diffpending diffpindex
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                set seenfile($curdifftag) 1
1798                if {[incr diffpindex] < [llength $diffpending]} {
1799                    set id [lindex $ids 0]
1800                    set p [lindex $diffpending $diffpindex]
1801                    contdiff [list $id $p]
1802                }
1803            }
1804        }
1805        return
1806    }
1807    if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
1808        return
1809    }
1810    $ctext conf -state normal
1811    if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1812        # start of a new file
1813        $ctext insert end "\n"
1814        $ctext tag add $curdifftag $curtagstart end
1815        set seenfile($curdifftag) 1
1816        set curtagstart [$ctext index "end - 1c"]
1817        set header $fname
1818        if {[info exists diffnexthead]} {
1819            set fname $diffnexthead
1820            set header "$diffnexthead ($diffnextnote)"
1821            unset diffnexthead
1822        }
1823        set here [$ctext index "end - 1c"]
1824        set difffilestart($diffindex) $here
1825        incr diffindex
1826        # start mark names at fmark.1 for first file
1827        $ctext mark set fmark.$diffindex $here
1828        $ctext mark gravity fmark.$diffindex left
1829        set curdifftag "f:$fname"
1830        $ctext tag delete $curdifftag
1831        set l [expr {(78 - [string length $header]) / 2}]
1832        set pad [string range "----------------------------------------" 1 $l]
1833        $ctext insert end "$pad $header $pad\n" filesep
1834    } elseif {[string range $line 0 2] == "+++"} {
1835        # no need to do anything with this
1836    } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1837        set diffnexthead $fn
1838        set diffnextnote "created, mode $m"
1839    } elseif {[string range $line 0 8] == "Deleted: "} {
1840        set diffnexthead [string range $line 9 end]
1841        set diffnextnote "deleted"
1842    } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1843        # save the filename in case the next thing is "new file mode ..."
1844        set diffnexthead $fn
1845        set diffnextnote "modified"
1846    } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1847        set diffnextnote "new file, mode $m"
1848    } elseif {[string range $line 0 11] == "deleted file"} {
1849        set diffnextnote "deleted"
1850    } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1851                   $line match f1l f1c f2l f2c rest]} {
1852        $ctext insert end "\t" hunksep
1853        $ctext insert end "    $f1l    " d0 "    $f2l    " d1
1854        $ctext insert end "    $rest \n" hunksep
1855    } else {
1856        set x [string range $line 0 0]
1857        if {$x == "-" || $x == "+"} {
1858            set tag [expr {$x == "+"}]
1859            set line [string range $line 1 end]
1860            $ctext insert end "$line\n" d$tag
1861        } elseif {$x == " "} {
1862            set line [string range $line 1 end]
1863            $ctext insert end "$line\n"
1864        } elseif {$x == "\\"} {
1865            # e.g. "\ No newline at end of file"
1866            $ctext insert end "$line\n" filesep
1867        } else {
1868            # Something else we don't recognize
1869            if {$curdifftag != "Comments"} {
1870                $ctext insert end "\n"
1871                $ctext tag add $curdifftag $curtagstart end
1872                set seenfile($curdifftag) 1
1873                set curtagstart [$ctext index "end - 1c"]
1874                set curdifftag Comments
1875            }
1876            $ctext insert end "$line\n" filesep
1877        }
1878    }
1879    $ctext conf -state disabled
1880    if {[clock clicks -milliseconds] >= $nextupdate} {
1881        incr nextupdate 100
1882        fileevent $bdf readable {}
1883        update
1884        fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1885    }
1886}
1887
1888proc nextfile {} {
1889    global difffilestart ctext
1890    set here [$ctext index @0,0]
1891    for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1892        if {[$ctext compare $difffilestart($i) > $here]} {
1893            $ctext yview $difffilestart($i)
1894            break
1895        }
1896    }
1897}
1898
1899proc listboxsel {} {
1900    global ctext cflist currentid treediffs
1901    if {![info exists currentid]} return
1902    set sel [lsort [$cflist curselection]]
1903    if {$sel eq {}} return
1904    set first [lindex $sel 0]
1905    catch {$ctext yview fmark.$first}
1906}
1907
1908proc setcoords {} {
1909    global linespc charspc canvx0 canvy0 mainfont
1910    set linespc [font metrics $mainfont -linespace]
1911    set charspc [font measure $mainfont "m"]
1912    set canvy0 [expr 3 + 0.5 * $linespc]
1913    set canvx0 [expr 3 + 0.5 * $linespc]
1914}
1915
1916proc redisplay {} {
1917    global selectedline stopped redisplaying phase
1918    if {$stopped > 1} return
1919    if {$phase == "getcommits"} return
1920    set redisplaying 1
1921    if {$phase == "drawgraph" || $phase == "incrdraw"} {
1922        set stopped 1
1923    } else {
1924        drawgraph
1925    }
1926}
1927
1928proc incrfont {inc} {
1929    global mainfont namefont textfont selectedline ctext canv phase
1930    global stopped entries
1931    unmarkmatches
1932    set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1933    set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1934    set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1935    setcoords
1936    $ctext conf -font $textfont
1937    $ctext tag conf filesep -font [concat $textfont bold]
1938    foreach e $entries {
1939        $e conf -font $mainfont
1940    }
1941    if {$phase == "getcommits"} {
1942        $canv itemconf textitems -font $mainfont
1943    }
1944    redisplay
1945}
1946
1947proc clearsha1 {} {
1948    global sha1entry sha1string
1949    if {[string length $sha1string] == 40} {
1950        $sha1entry delete 0 end
1951    }
1952}
1953
1954proc sha1change {n1 n2 op} {
1955    global sha1string currentid sha1but
1956    if {$sha1string == {}
1957        || ([info exists currentid] && $sha1string == $currentid)} {
1958        set state disabled
1959    } else {
1960        set state normal
1961    }
1962    if {[$sha1but cget -state] == $state} return
1963    if {$state == "normal"} {
1964        $sha1but conf -state normal -relief raised -text "Goto: "
1965    } else {
1966        $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1967    }
1968}
1969
1970proc gotocommit {} {
1971    global sha1string currentid idline tagids
1972    if {$sha1string == {}
1973        || ([info exists currentid] && $sha1string == $currentid)} return
1974    if {[info exists tagids($sha1string)]} {
1975        set id $tagids($sha1string)
1976    } else {
1977        set id [string tolower $sha1string]
1978    }
1979    if {[info exists idline($id)]} {
1980        selectline $idline($id)
1981        return
1982    }
1983    if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1984        set type "SHA1 id"
1985    } else {
1986        set type "Tag"
1987    }
1988    error_popup "$type $sha1string is not known"
1989}
1990
1991proc lineenter {x y id} {
1992    global hoverx hovery hoverid hovertimer
1993    global commitinfo canv
1994
1995    if {![info exists commitinfo($id)]} return
1996    set hoverx $x
1997    set hovery $y
1998    set hoverid $id
1999    if {[info exists hovertimer]} {
2000        after cancel $hovertimer
2001    }
2002    set hovertimer [after 500 linehover]
2003    $canv delete hover
2004}
2005
2006proc linemotion {x y id} {
2007    global hoverx hovery hoverid hovertimer
2008
2009    if {[info exists hoverid] && $id == $hoverid} {
2010        set hoverx $x
2011        set hovery $y
2012        if {[info exists hovertimer]} {
2013            after cancel $hovertimer
2014        }
2015        set hovertimer [after 500 linehover]
2016    }
2017}
2018
2019proc lineleave {id} {
2020    global hoverid hovertimer canv
2021
2022    if {[info exists hoverid] && $id == $hoverid} {
2023        $canv delete hover
2024        if {[info exists hovertimer]} {
2025            after cancel $hovertimer
2026            unset hovertimer
2027        }
2028        unset hoverid
2029    }
2030}
2031
2032proc linehover {} {
2033    global hoverx hovery hoverid hovertimer
2034    global canv linespc lthickness
2035    global commitinfo mainfont
2036
2037    set text [lindex $commitinfo($hoverid) 0]
2038    set ymax [lindex [$canv cget -scrollregion] 3]
2039    if {$ymax == {}} return
2040    set yfrac [lindex [$canv yview] 0]
2041    set x [expr {$hoverx + 2 * $linespc}]
2042    set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
2043    set x0 [expr {$x - 2 * $lthickness}]
2044    set y0 [expr {$y - 2 * $lthickness}]
2045    set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
2046    set y1 [expr {$y + $linespc + 2 * $lthickness}]
2047    set t [$canv create rectangle $x0 $y0 $x1 $y1 \
2048               -fill \#ffff80 -outline black -width 1 -tags hover]
2049    $canv raise $t
2050    set t [$canv create text $x $y -anchor nw -text $text -tags hover]
2051    $canv raise $t
2052}
2053
2054proc lineclick {x y id} {
2055    global ctext commitinfo children cflist canv
2056
2057    unmarkmatches
2058    $canv delete hover
2059    # fill the details pane with info about this line
2060    $ctext conf -state normal
2061    $ctext delete 0.0 end
2062    $ctext insert end "Parent:\n "
2063    catch {destroy $ctext.$id}
2064    button $ctext.$id -text "Go:" -command "selbyid $id" \
2065        -padx 4 -pady 0
2066    $ctext window create end -window $ctext.$id -align center
2067    set info $commitinfo($id)
2068    $ctext insert end "\t[lindex $info 0]\n"
2069    $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
2070    $ctext insert end "\tDate:\t[lindex $info 2]\n"
2071    $ctext insert end "\tID:\t$id\n"
2072    if {[info exists children($id)]} {
2073        $ctext insert end "\nChildren:"
2074        foreach child $children($id) {
2075            $ctext insert end "\n "
2076            catch {destroy $ctext.$child}
2077            button $ctext.$child -text "Go:" -command "selbyid $child" \
2078                -padx 4 -pady 0
2079            $ctext window create end -window $ctext.$child -align center
2080            set info $commitinfo($child)
2081            $ctext insert end "\t[lindex $info 0]"
2082        }
2083    }
2084    $ctext conf -state disabled
2085
2086    $cflist delete 0 end
2087}
2088
2089proc selbyid {id} {
2090    global idline
2091    if {[info exists idline($id)]} {
2092        selectline $idline($id)
2093    }
2094}
2095
2096proc mstime {} {
2097    global startmstime
2098    if {![info exists startmstime]} {
2099        set startmstime [clock clicks -milliseconds]
2100    }
2101    return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
2102}
2103
2104proc rowmenu {x y id} {
2105    global rowctxmenu idline selectedline rowmenuid
2106
2107    if {![info exists selectedline] || $idline($id) eq $selectedline} {
2108        set state disabled
2109    } else {
2110        set state normal
2111    }
2112    $rowctxmenu entryconfigure 0 -state $state
2113    $rowctxmenu entryconfigure 1 -state $state
2114    $rowctxmenu entryconfigure 2 -state $state
2115    set rowmenuid $id
2116    tk_popup $rowctxmenu $x $y
2117}
2118
2119proc diffvssel {dirn} {
2120    global rowmenuid selectedline lineid
2121    global ctext cflist
2122    global commitinfo
2123
2124    if {![info exists selectedline]} return
2125    if {$dirn} {
2126        set oldid $lineid($selectedline)
2127        set newid $rowmenuid
2128    } else {
2129        set oldid $rowmenuid
2130        set newid $lineid($selectedline)
2131    }
2132    $ctext conf -state normal
2133    $ctext delete 0.0 end
2134    $ctext mark set fmark.0 0.0
2135    $ctext mark gravity fmark.0 left
2136    $cflist delete 0 end
2137    $cflist insert end "Top"
2138    $ctext insert end "From $oldid\n     "
2139    $ctext insert end [lindex $commitinfo($oldid) 0]
2140    $ctext insert end "\n\nTo   $newid\n     "
2141    $ctext insert end [lindex $commitinfo($newid) 0]
2142    $ctext insert end "\n"
2143    $ctext conf -state disabled
2144    $ctext tag delete Comments
2145    $ctext tag remove found 1.0 end
2146    startdiff [list $newid $oldid]
2147}
2148
2149proc mkpatch {} {
2150    global rowmenuid currentid commitinfo patchtop patchnum
2151
2152    if {![info exists currentid]} return
2153    set oldid $currentid
2154    set oldhead [lindex $commitinfo($oldid) 0]
2155    set newid $rowmenuid
2156    set newhead [lindex $commitinfo($newid) 0]
2157    set top .patch
2158    set patchtop $top
2159    catch {destroy $top}
2160    toplevel $top
2161    label $top.title -text "Generate patch"
2162    grid $top.title - -pady 10
2163    label $top.from -text "From:"
2164    entry $top.fromsha1 -width 40 -relief flat
2165    $top.fromsha1 insert 0 $oldid
2166    $top.fromsha1 conf -state readonly
2167    grid $top.from $top.fromsha1 -sticky w
2168    entry $top.fromhead -width 60 -relief flat
2169    $top.fromhead insert 0 $oldhead
2170    $top.fromhead conf -state readonly
2171    grid x $top.fromhead -sticky w
2172    label $top.to -text "To:"
2173    entry $top.tosha1 -width 40 -relief flat
2174    $top.tosha1 insert 0 $newid
2175    $top.tosha1 conf -state readonly
2176    grid $top.to $top.tosha1 -sticky w
2177    entry $top.tohead -width 60 -relief flat
2178    $top.tohead insert 0 $newhead
2179    $top.tohead conf -state readonly
2180    grid x $top.tohead -sticky w
2181    button $top.rev -text "Reverse" -command mkpatchrev -padx 5
2182    grid $top.rev x -pady 10
2183    label $top.flab -text "Output file:"
2184    entry $top.fname -width 60
2185    $top.fname insert 0 [file normalize "patch$patchnum.patch"]
2186    incr patchnum
2187    grid $top.flab $top.fname -sticky w
2188    frame $top.buts
2189    button $top.buts.gen -text "Generate" -command mkpatchgo
2190    button $top.buts.can -text "Cancel" -command mkpatchcan
2191    grid $top.buts.gen $top.buts.can
2192    grid columnconfigure $top.buts 0 -weight 1 -uniform a
2193    grid columnconfigure $top.buts 1 -weight 1 -uniform a
2194    grid $top.buts - -pady 10 -sticky ew
2195    focus $top.fname
2196}
2197
2198proc mkpatchrev {} {
2199    global patchtop
2200
2201    set oldid [$patchtop.fromsha1 get]
2202    set oldhead [$patchtop.fromhead get]
2203    set newid [$patchtop.tosha1 get]
2204    set newhead [$patchtop.tohead get]
2205    foreach e [list fromsha1 fromhead tosha1 tohead] \
2206            v [list $newid $newhead $oldid $oldhead] {
2207        $patchtop.$e conf -state normal
2208        $patchtop.$e delete 0 end
2209        $patchtop.$e insert 0 $v
2210        $patchtop.$e conf -state readonly
2211    }
2212}
2213
2214proc mkpatchgo {} {
2215    global patchtop
2216
2217    set oldid [$patchtop.fromsha1 get]
2218    set newid [$patchtop.tosha1 get]
2219    set fname [$patchtop.fname get]
2220    if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
2221        error_popup "Error creating patch: $err"
2222    }
2223    catch {destroy $patchtop}
2224    unset patchtop
2225}
2226
2227proc mkpatchcan {} {
2228    global patchtop
2229
2230    catch {destroy $patchtop}
2231    unset patchtop
2232}
2233
2234proc mktag {} {
2235    global rowmenuid mktagtop commitinfo
2236
2237    set top .maketag
2238    set mktagtop $top
2239    catch {destroy $top}
2240    toplevel $top
2241    label $top.title -text "Create tag"
2242    grid $top.title - -pady 10
2243    label $top.id -text "ID:"
2244    entry $top.sha1 -width 40 -relief flat
2245    $top.sha1 insert 0 $rowmenuid
2246    $top.sha1 conf -state readonly
2247    grid $top.id $top.sha1 -sticky w
2248    entry $top.head -width 60 -relief flat
2249    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2250    $top.head conf -state readonly
2251    grid x $top.head -sticky w
2252    label $top.tlab -text "Tag name:"
2253    entry $top.tag -width 60
2254    grid $top.tlab $top.tag -sticky w
2255    frame $top.buts
2256    button $top.buts.gen -text "Create" -command mktaggo
2257    button $top.buts.can -text "Cancel" -command mktagcan
2258    grid $top.buts.gen $top.buts.can
2259    grid columnconfigure $top.buts 0 -weight 1 -uniform a
2260    grid columnconfigure $top.buts 1 -weight 1 -uniform a
2261    grid $top.buts - -pady 10 -sticky ew
2262    focus $top.tag
2263}
2264
2265proc domktag {} {
2266    global mktagtop env tagids idtags
2267    global idpos idline linehtag canv selectedline
2268
2269    set id [$mktagtop.sha1 get]
2270    set tag [$mktagtop.tag get]
2271    if {$tag == {}} {
2272        error_popup "No tag name specified"
2273        return
2274    }
2275    if {[info exists tagids($tag)]} {
2276        error_popup "Tag \"$tag\" already exists"
2277        return
2278    }
2279    if {[catch {
2280        set dir ".git"
2281        if {[info exists env(GIT_DIR)]} {
2282            set dir $env(GIT_DIR)
2283        }
2284        set fname [file join $dir "refs/tags" $tag]
2285        set f [open $fname w]
2286        puts $f $id
2287        close $f
2288    } err]} {
2289        error_popup "Error creating tag: $err"
2290        return
2291    }
2292
2293    set tagids($tag) $id
2294    lappend idtags($id) $tag
2295    $canv delete tag.$id
2296    set xt [eval drawtags $id $idpos($id)]
2297    $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
2298    if {[info exists selectedline] && $selectedline == $idline($id)} {
2299        selectline $selectedline
2300    }
2301}
2302
2303proc mktagcan {} {
2304    global mktagtop
2305
2306    catch {destroy $mktagtop}
2307    unset mktagtop
2308}
2309
2310proc mktaggo {} {
2311    domktag
2312    mktagcan
2313}
2314
2315proc writecommit {} {
2316    global rowmenuid wrcomtop commitinfo wrcomcmd
2317
2318    set top .writecommit
2319    set wrcomtop $top
2320    catch {destroy $top}
2321    toplevel $top
2322    label $top.title -text "Write commit to file"
2323    grid $top.title - -pady 10
2324    label $top.id -text "ID:"
2325    entry $top.sha1 -width 40 -relief flat
2326    $top.sha1 insert 0 $rowmenuid
2327    $top.sha1 conf -state readonly
2328    grid $top.id $top.sha1 -sticky w
2329    entry $top.head -width 60 -relief flat
2330    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
2331    $top.head conf -state readonly
2332    grid x $top.head -sticky w
2333    label $top.clab -text "Command:"
2334    entry $top.cmd -width 60 -textvariable wrcomcmd
2335    grid $top.clab $top.cmd -sticky w -pady 10
2336    label $top.flab -text "Output file:"
2337    entry $top.fname -width 60
2338    $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
2339    grid $top.flab $top.fname -sticky w
2340    frame $top.buts
2341    button $top.buts.gen -text "Write" -command wrcomgo
2342    button $top.buts.can -text "Cancel" -command wrcomcan
2343    grid $top.buts.gen $top.buts.can
2344    grid columnconfigure $top.buts 0 -weight 1 -uniform a
2345    grid columnconfigure $top.buts 1 -weight 1 -uniform a
2346    grid $top.buts - -pady 10 -sticky ew
2347    focus $top.fname
2348}
2349
2350proc wrcomgo {} {
2351    global wrcomtop
2352
2353    set id [$wrcomtop.sha1 get]
2354    set cmd "echo $id | [$wrcomtop.cmd get]"
2355    set fname [$wrcomtop.fname get]
2356    if {[catch {exec sh -c $cmd >$fname &} err]} {
2357        error_popup "Error writing commit: $err"
2358    }
2359    catch {destroy $wrcomtop}
2360    unset wrcomtop
2361}
2362
2363proc wrcomcan {} {
2364    global wrcomtop
2365
2366    catch {destroy $wrcomtop}
2367    unset wrcomtop
2368}
2369
2370proc doquit {} {
2371    global stopped
2372    set stopped 100
2373    destroy .
2374}
2375
2376# defaults...
2377set datemode 0
2378set boldnames 0
2379set diffopts "-U 5 -p"
2380set wrcomcmd "git-diff-tree --stdin -p --pretty"
2381
2382set mainfont {Helvetica 9}
2383set textfont {Courier 9}
2384set findmergefiles 0
2385
2386set colors {green red blue magenta darkgrey brown orange}
2387
2388catch {source ~/.gitk}
2389
2390set namefont $mainfont
2391if {$boldnames} {
2392    lappend namefont bold
2393}
2394
2395set revtreeargs {}
2396foreach arg $argv {
2397    switch -regexp -- $arg {
2398        "^$" { }
2399        "^-b" { set boldnames 1 }
2400        "^-d" { set datemode 1 }
2401        default {
2402            lappend revtreeargs $arg
2403        }
2404    }
2405}
2406
2407set stopped 0
2408set redisplaying 0
2409set stuffsaved 0
2410set patchnum 0
2411setcoords
2412makewindow
2413readrefs
2414getcommits $revtreeargs