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