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