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