gitkon commit csum-file: fix missing buf pointer update (2700628)
   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
  10# CVS $Revision: 1.24 $
  11
  12proc getcommits {rargs} {
  13    global commits commfd phase canv mainfont
  14    global startmsecs nextupdate
  15    global ctext maincursor textcursor leftover
  16
  17    set commits {}
  18    set phase getcommits
  19    set startmsecs [clock clicks -milliseconds]
  20    set nextupdate [expr $startmsecs + 100]
  21    if [catch {
  22        set parse_args [concat --default HEAD $rargs]
  23        set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
  24    }] {
  25        # if git-rev-parse failed for some reason...
  26        if {$rargs == {}} {
  27            set rargs HEAD
  28        }
  29        set parsed_args $rargs
  30    }
  31    if [catch {
  32        set commfd [open "|git-rev-list --header --merge-order $parsed_args" r]
  33    } err] {
  34        puts stderr "Error executing git-rev-list: $err"
  35        exit 1
  36    }
  37    set leftover {}
  38    fconfigure $commfd -blocking 0 -translation binary
  39    fileevent $commfd readable "getcommitlines $commfd"
  40    $canv delete all
  41    $canv create text 3 3 -anchor nw -text "Reading commits..." \
  42        -font $mainfont -tags textitems
  43    . config -cursor watch
  44    $ctext config -cursor watch
  45}
  46
  47proc getcommitlines {commfd}  {
  48    global commits parents cdate children nchildren
  49    global commitlisted phase commitinfo nextupdate
  50    global stopped redisplaying leftover
  51
  52    set stuff [read $commfd]
  53    if {$stuff == {}} {
  54        if {![eof $commfd]} return
  55        # this works around what is apparently a bug in Tcl...
  56        fconfigure $commfd -blocking 1
  57        if {![catch {close $commfd} err]} {
  58            after idle finishcommits
  59            return
  60        }
  61        if {[string range $err 0 4] == "usage"} {
  62            set err \
  63{Gitk: error reading commits: bad arguments to git-rev-list.
  64(Note: arguments to gitk are passed to git-rev-list
  65to allow selection of commits to be displayed.)}
  66        } else {
  67            set err "Error reading commits: $err"
  68        }
  69        error_popup $err
  70        exit 1
  71    }
  72    set start 0
  73    while 1 {
  74        set i [string first "\0" $stuff $start]
  75        if {$i < 0} {
  76            set leftover [string range $stuff $start end]
  77            return
  78        }
  79        set cmit [string range $stuff $start [expr {$i - 1}]]
  80        if {$start == 0} {
  81            set cmit "$leftover$cmit"
  82        }
  83        set start [expr {$i + 1}]
  84        if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
  85            error_popup "Can't parse git-rev-list output: {$cmit}"
  86            exit 1
  87        }
  88        set cmit [string range $cmit 41 end]
  89        lappend commits $id
  90        set commitlisted($id) 1
  91        parsecommit $id $cmit 1
  92        drawcommit $id
  93        if {[clock clicks -milliseconds] >= $nextupdate} {
  94            doupdate
  95        }
  96        while {$redisplaying} {
  97            set redisplaying 0
  98            if {$stopped == 1} {
  99                set stopped 0
 100                set phase "getcommits"
 101                foreach id $commits {
 102                    drawcommit $id
 103                    if {$stopped} break
 104                    if {[clock clicks -milliseconds] >= $nextupdate} {
 105                        doupdate
 106                    }
 107                }
 108            }
 109        }
 110    }
 111}
 112
 113proc doupdate {} {
 114    global commfd nextupdate
 115
 116    incr nextupdate 100
 117    fileevent $commfd readable {}
 118    update
 119    fileevent $commfd readable "getcommitlines $commfd"
 120}
 121
 122proc readcommit {id} {
 123    if [catch {set contents [exec git-cat-file commit $id]}] return
 124    parsecommit $id $contents 0
 125}
 126
 127proc parsecommit {id contents listed} {
 128    global commitinfo children nchildren parents nparents cdate ncleft
 129
 130    set inhdr 1
 131    set comment {}
 132    set headline {}
 133    set auname {}
 134    set audate {}
 135    set comname {}
 136    set comdate {}
 137    if {![info exists nchildren($id)]} {
 138        set children($id) {}
 139        set nchildren($id) 0
 140        set ncleft($id) 0
 141    }
 142    set parents($id) {}
 143    set nparents($id) 0
 144    foreach line [split $contents "\n"] {
 145        if {$inhdr} {
 146            if {$line == {}} {
 147                set inhdr 0
 148            } else {
 149                set tag [lindex $line 0]
 150                if {$tag == "parent"} {
 151                    set p [lindex $line 1]
 152                    if {![info exists nchildren($p)]} {
 153                        set children($p) {}
 154                        set nchildren($p) 0
 155                        set ncleft($p) 0
 156                    }
 157                    lappend parents($id) $p
 158                    incr nparents($id)
 159                    # sometimes we get a commit that lists a parent twice...
 160                    if {$listed && [lsearch -exact $children($p) $id] < 0} {
 161                        lappend children($p) $id
 162                        incr nchildren($p)
 163                        incr ncleft($p)
 164                    }
 165                } elseif {$tag == "author"} {
 166                    set x [expr {[llength $line] - 2}]
 167                    set audate [lindex $line $x]
 168                    set auname [lrange $line 1 [expr {$x - 1}]]
 169                } elseif {$tag == "committer"} {
 170                    set x [expr {[llength $line] - 2}]
 171                    set comdate [lindex $line $x]
 172                    set comname [lrange $line 1 [expr {$x - 1}]]
 173                }
 174            }
 175        } else {
 176            if {$comment == {}} {
 177                set headline [string trim $line]
 178            } else {
 179                append comment "\n"
 180            }
 181            if {!$listed} {
 182                # git-rev-list indents the comment by 4 spaces;
 183                # if we got this via git-cat-file, add the indentation
 184                append comment "    "
 185            }
 186            append comment $line
 187        }
 188    }
 189    if {$audate != {}} {
 190        set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
 191    }
 192    if {$comdate != {}} {
 193        set cdate($id) $comdate
 194        set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
 195    }
 196    set commitinfo($id) [list $headline $auname $audate \
 197                             $comname $comdate $comment]
 198}
 199
 200proc readrefs {} {
 201    global tagids idtags headids idheads
 202    set tags [glob -nocomplain -types f .git/refs/tags/*]
 203    foreach f $tags {
 204        catch {
 205            set fd [open $f r]
 206            set line [read $fd]
 207            if {[regexp {^[0-9a-f]{40}} $line id]} {
 208                set direct [file tail $f]
 209                set tagids($direct) $id
 210                lappend idtags($id) $direct
 211                set contents [split [exec git-cat-file tag $id] "\n"]
 212                set obj {}
 213                set type {}
 214                set tag {}
 215                foreach l $contents {
 216                    if {$l == {}} break
 217                    switch -- [lindex $l 0] {
 218                        "object" {set obj [lindex $l 1]}
 219                        "type" {set type [lindex $l 1]}
 220                        "tag" {set tag [string range $l 4 end]}
 221                    }
 222                }
 223                if {$obj != {} && $type == "commit" && $tag != {}} {
 224                    set tagids($tag) $obj
 225                    lappend idtags($obj) $tag
 226                }
 227            }
 228            close $fd
 229        }
 230    }
 231    set heads [glob -nocomplain -types f .git/refs/heads/*]
 232    foreach f $heads {
 233        catch {
 234            set fd [open $f r]
 235            set line [read $fd 40]
 236            if {[regexp {^[0-9a-f]{40}} $line id]} {
 237                set head [file tail $f]
 238                set headids($head) $line
 239                lappend idheads($line) $head
 240            }
 241            close $fd
 242        }
 243    }
 244}
 245
 246proc error_popup msg {
 247    set w .error
 248    toplevel $w
 249    wm transient $w .
 250    message $w.m -text $msg -justify center -aspect 400
 251    pack $w.m -side top -fill x -padx 20 -pady 20
 252    button $w.ok -text OK -command "destroy $w"
 253    pack $w.ok -side bottom -fill x
 254    bind $w <Visibility> "grab $w; focus $w"
 255    tkwait window $w
 256}
 257
 258proc makewindow {} {
 259    global canv canv2 canv3 linespc charspc ctext cflist textfont
 260    global findtype findloc findstring fstring geometry
 261    global entries sha1entry sha1string sha1but
 262    global maincursor textcursor
 263    global linectxmenu
 264
 265    menu .bar
 266    .bar add cascade -label "File" -menu .bar.file
 267    menu .bar.file
 268    .bar.file add command -label "Quit" -command doquit
 269    menu .bar.help
 270    .bar add cascade -label "Help" -menu .bar.help
 271    .bar.help add command -label "About gitk" -command about
 272    . configure -menu .bar
 273
 274    if {![info exists geometry(canv1)]} {
 275        set geometry(canv1) [expr 45 * $charspc]
 276        set geometry(canv2) [expr 30 * $charspc]
 277        set geometry(canv3) [expr 15 * $charspc]
 278        set geometry(canvh) [expr 25 * $linespc + 4]
 279        set geometry(ctextw) 80
 280        set geometry(ctexth) 30
 281        set geometry(cflistw) 30
 282    }
 283    panedwindow .ctop -orient vertical
 284    if {[info exists geometry(width)]} {
 285        .ctop conf -width $geometry(width) -height $geometry(height)
 286        set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
 287        set geometry(ctexth) [expr {($texth - 8) /
 288                                    [font metrics $textfont -linespace]}]
 289    }
 290    frame .ctop.top
 291    frame .ctop.top.bar
 292    pack .ctop.top.bar -side bottom -fill x
 293    set cscroll .ctop.top.csb
 294    scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
 295    pack $cscroll -side right -fill y
 296    panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
 297    pack .ctop.top.clist -side top -fill both -expand 1
 298    .ctop add .ctop.top
 299    set canv .ctop.top.clist.canv
 300    canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
 301        -bg white -bd 0 \
 302        -yscrollincr $linespc -yscrollcommand "$cscroll set"
 303    .ctop.top.clist add $canv
 304    set canv2 .ctop.top.clist.canv2
 305    canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
 306        -bg white -bd 0 -yscrollincr $linespc
 307    .ctop.top.clist add $canv2
 308    set canv3 .ctop.top.clist.canv3
 309    canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
 310        -bg white -bd 0 -yscrollincr $linespc
 311    .ctop.top.clist add $canv3
 312    bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
 313
 314    set sha1entry .ctop.top.bar.sha1
 315    set entries $sha1entry
 316    set sha1but .ctop.top.bar.sha1label
 317    button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
 318        -command gotocommit -width 8
 319    $sha1but conf -disabledforeground [$sha1but cget -foreground]
 320    pack .ctop.top.bar.sha1label -side left
 321    entry $sha1entry -width 40 -font $textfont -textvariable sha1string
 322    trace add variable sha1string write sha1change
 323    pack $sha1entry -side left -pady 2
 324    button .ctop.top.bar.findbut -text "Find" -command dofind
 325    pack .ctop.top.bar.findbut -side left
 326    set findstring {}
 327    set fstring .ctop.top.bar.findstring
 328    lappend entries $fstring
 329    entry $fstring -width 30 -font $textfont -textvariable findstring
 330    pack $fstring -side left -expand 1 -fill x
 331    set findtype Exact
 332    tk_optionMenu .ctop.top.bar.findtype findtype Exact IgnCase Regexp
 333    set findloc "All fields"
 334    tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
 335        Comments Author Committer
 336    pack .ctop.top.bar.findloc -side right
 337    pack .ctop.top.bar.findtype -side right
 338
 339    panedwindow .ctop.cdet -orient horizontal
 340    .ctop add .ctop.cdet
 341    frame .ctop.cdet.left
 342    set ctext .ctop.cdet.left.ctext
 343    text $ctext -bg white -state disabled -font $textfont \
 344        -width $geometry(ctextw) -height $geometry(ctexth) \
 345        -yscrollcommand ".ctop.cdet.left.sb set"
 346    scrollbar .ctop.cdet.left.sb -command "$ctext yview"
 347    pack .ctop.cdet.left.sb -side right -fill y
 348    pack $ctext -side left -fill both -expand 1
 349    .ctop.cdet add .ctop.cdet.left
 350
 351    $ctext tag conf filesep -font [concat $textfont bold]
 352    $ctext tag conf hunksep -back blue -fore white
 353    $ctext tag conf d0 -back "#ff8080"
 354    $ctext tag conf d1 -back green
 355    $ctext tag conf found -back yellow
 356
 357    frame .ctop.cdet.right
 358    set cflist .ctop.cdet.right.cfiles
 359    listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
 360        -yscrollcommand ".ctop.cdet.right.sb set"
 361    scrollbar .ctop.cdet.right.sb -command "$cflist yview"
 362    pack .ctop.cdet.right.sb -side right -fill y
 363    pack $cflist -side left -fill both -expand 1
 364    .ctop.cdet add .ctop.cdet.right
 365    bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
 366
 367    pack .ctop -side top -fill both -expand 1
 368
 369    bindall <1> {selcanvline %x %y}
 370    bindall <B1-Motion> {selcanvline %x %y}
 371    bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
 372    bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
 373    bindall <2> "allcanvs scan mark 0 %y"
 374    bindall <B2-Motion> "allcanvs scan dragto 0 %y"
 375    bind . <Key-Up> "selnextline -1"
 376    bind . <Key-Down> "selnextline 1"
 377    bind . <Key-Prior> "allcanvs yview scroll -1 pages"
 378    bind . <Key-Next> "allcanvs yview scroll 1 pages"
 379    bindkey <Key-Delete> "$ctext yview scroll -1 pages"
 380    bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
 381    bindkey <Key-space> "$ctext yview scroll 1 pages"
 382    bindkey p "selnextline -1"
 383    bindkey n "selnextline 1"
 384    bindkey b "$ctext yview scroll -1 pages"
 385    bindkey d "$ctext yview scroll 18 units"
 386    bindkey u "$ctext yview scroll -18 units"
 387    bindkey / findnext
 388    bindkey ? findprev
 389    bindkey f nextfile
 390    bind . <Control-q> doquit
 391    bind . <Control-f> dofind
 392    bind . <Control-g> findnext
 393    bind . <Control-r> findprev
 394    bind . <Control-equal> {incrfont 1}
 395    bind . <Control-KP_Add> {incrfont 1}
 396    bind . <Control-minus> {incrfont -1}
 397    bind . <Control-KP_Subtract> {incrfont -1}
 398    bind $cflist <<ListboxSelect>> listboxsel
 399    bind . <Destroy> {savestuff %W}
 400    bind . <Button-1> "click %W"
 401    bind $fstring <Key-Return> dofind
 402    bind $sha1entry <Key-Return> gotocommit
 403
 404    set maincursor [. cget -cursor]
 405    set textcursor [$ctext cget -cursor]
 406
 407    set linectxmenu .linectxmenu
 408    menu $linectxmenu -tearoff 0
 409    $linectxmenu add command -label "Select" -command lineselect
 410}
 411
 412# when we make a key binding for the toplevel, make sure
 413# it doesn't get triggered when that key is pressed in the
 414# find string entry widget.
 415proc bindkey {ev script} {
 416    global entries
 417    bind . $ev $script
 418    set escript [bind Entry $ev]
 419    if {$escript == {}} {
 420        set escript [bind Entry <Key>]
 421    }
 422    foreach e $entries {
 423        bind $e $ev "$escript; break"
 424    }
 425}
 426
 427# set the focus back to the toplevel for any click outside
 428# the entry widgets
 429proc click {w} {
 430    global entries
 431    foreach e $entries {
 432        if {$w == $e} return
 433    }
 434    focus .
 435}
 436
 437proc savestuff {w} {
 438    global canv canv2 canv3 ctext cflist mainfont textfont
 439    global stuffsaved
 440    if {$stuffsaved} return
 441    if {![winfo viewable .]} return
 442    catch {
 443        set f [open "~/.gitk-new" w]
 444        puts $f "set mainfont {$mainfont}"
 445        puts $f "set textfont {$textfont}"
 446        puts $f "set geometry(width) [winfo width .ctop]"
 447        puts $f "set geometry(height) [winfo height .ctop]"
 448        puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
 449        puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
 450        puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
 451        puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
 452        set wid [expr {([winfo width $ctext] - 8) \
 453                           / [font measure $textfont "0"]}]
 454        puts $f "set geometry(ctextw) $wid"
 455        set wid [expr {([winfo width $cflist] - 11) \
 456                           / [font measure [$cflist cget -font] "0"]}]
 457        puts $f "set geometry(cflistw) $wid"
 458        close $f
 459        file rename -force "~/.gitk-new" "~/.gitk"
 460    }
 461    set stuffsaved 1
 462}
 463
 464proc resizeclistpanes {win w} {
 465    global oldwidth
 466    if [info exists oldwidth($win)] {
 467        set s0 [$win sash coord 0]
 468        set s1 [$win sash coord 1]
 469        if {$w < 60} {
 470            set sash0 [expr {int($w/2 - 2)}]
 471            set sash1 [expr {int($w*5/6 - 2)}]
 472        } else {
 473            set factor [expr {1.0 * $w / $oldwidth($win)}]
 474            set sash0 [expr {int($factor * [lindex $s0 0])}]
 475            set sash1 [expr {int($factor * [lindex $s1 0])}]
 476            if {$sash0 < 30} {
 477                set sash0 30
 478            }
 479            if {$sash1 < $sash0 + 20} {
 480                set sash1 [expr $sash0 + 20]
 481            }
 482            if {$sash1 > $w - 10} {
 483                set sash1 [expr $w - 10]
 484                if {$sash0 > $sash1 - 20} {
 485                    set sash0 [expr $sash1 - 20]
 486                }
 487            }
 488        }
 489        $win sash place 0 $sash0 [lindex $s0 1]
 490        $win sash place 1 $sash1 [lindex $s1 1]
 491    }
 492    set oldwidth($win) $w
 493}
 494
 495proc resizecdetpanes {win w} {
 496    global oldwidth
 497    if [info exists oldwidth($win)] {
 498        set s0 [$win sash coord 0]
 499        if {$w < 60} {
 500            set sash0 [expr {int($w*3/4 - 2)}]
 501        } else {
 502            set factor [expr {1.0 * $w / $oldwidth($win)}]
 503            set sash0 [expr {int($factor * [lindex $s0 0])}]
 504            if {$sash0 < 45} {
 505                set sash0 45
 506            }
 507            if {$sash0 > $w - 15} {
 508                set sash0 [expr $w - 15]
 509            }
 510        }
 511        $win sash place 0 $sash0 [lindex $s0 1]
 512    }
 513    set oldwidth($win) $w
 514}
 515
 516proc allcanvs args {
 517    global canv canv2 canv3
 518    eval $canv $args
 519    eval $canv2 $args
 520    eval $canv3 $args
 521}
 522
 523proc bindall {event action} {
 524    global canv canv2 canv3
 525    bind $canv $event $action
 526    bind $canv2 $event $action
 527    bind $canv3 $event $action
 528}
 529
 530proc about {} {
 531    set w .about
 532    if {[winfo exists $w]} {
 533        raise $w
 534        return
 535    }
 536    toplevel $w
 537    wm title $w "About gitk"
 538    message $w.m -text {
 539Gitk version 1.1
 540
 541Copyright © 2005 Paul Mackerras
 542
 543Use and redistribute under the terms of the GNU General Public License
 544
 545(CVS $Revision: 1.24 $)} \
 546            -justify center -aspect 400
 547    pack $w.m -side top -fill x -padx 20 -pady 20
 548    button $w.ok -text Close -command "destroy $w"
 549    pack $w.ok -side bottom
 550}
 551
 552proc assigncolor {id} {
 553    global commitinfo colormap commcolors colors nextcolor
 554    global parents nparents children nchildren
 555    global cornercrossings crossings
 556
 557    if [info exists colormap($id)] return
 558    set ncolors [llength $colors]
 559    if {$nparents($id) <= 1 && $nchildren($id) == 1} {
 560        set child [lindex $children($id) 0]
 561        if {[info exists colormap($child)]
 562            && $nparents($child) == 1} {
 563            set colormap($id) $colormap($child)
 564            return
 565        }
 566    }
 567    set badcolors {}
 568    if {[info exists cornercrossings($id)]} {
 569        foreach x $cornercrossings($id) {
 570            if {[info exists colormap($x)]
 571                && [lsearch -exact $badcolors $colormap($x)] < 0} {
 572                lappend badcolors $colormap($x)
 573            }
 574        }
 575        if {[llength $badcolors] >= $ncolors} {
 576            set badcolors {}
 577        }
 578    }
 579    set origbad $badcolors
 580    if {[llength $badcolors] < $ncolors - 1} {
 581        if {[info exists crossings($id)]} {
 582            foreach x $crossings($id) {
 583                if {[info exists colormap($x)]
 584                    && [lsearch -exact $badcolors $colormap($x)] < 0} {
 585                    lappend badcolors $colormap($x)
 586                }
 587            }
 588            if {[llength $badcolors] >= $ncolors} {
 589                set badcolors $origbad
 590            }
 591        }
 592        set origbad $badcolors
 593    }
 594    if {[llength $badcolors] < $ncolors - 1} {
 595        foreach child $children($id) {
 596            if {[info exists colormap($child)]
 597                && [lsearch -exact $badcolors $colormap($child)] < 0} {
 598                lappend badcolors $colormap($child)
 599            }
 600            if {[info exists parents($child)]} {
 601                foreach p $parents($child) {
 602                    if {[info exists colormap($p)]
 603                        && [lsearch -exact $badcolors $colormap($p)] < 0} {
 604                        lappend badcolors $colormap($p)
 605                    }
 606                }
 607            }
 608        }
 609        if {[llength $badcolors] >= $ncolors} {
 610            set badcolors $origbad
 611        }
 612    }
 613    for {set i 0} {$i <= $ncolors} {incr i} {
 614        set c [lindex $colors $nextcolor]
 615        if {[incr nextcolor] >= $ncolors} {
 616            set nextcolor 0
 617        }
 618        if {[lsearch -exact $badcolors $c]} break
 619    }
 620    set colormap($id) $c
 621}
 622
 623proc initgraph {} {
 624    global canvy canvy0 lineno numcommits lthickness nextcolor linespc
 625    global mainline sidelines
 626    global nchildren ncleft
 627
 628    allcanvs delete all
 629    set nextcolor 0
 630    set canvy $canvy0
 631    set lineno -1
 632    set numcommits 0
 633    set lthickness [expr {int($linespc / 9) + 1}]
 634    catch {unset mainline}
 635    catch {unset sidelines}
 636    foreach id [array names nchildren] {
 637        set ncleft($id) $nchildren($id)
 638    }
 639}
 640
 641proc bindline {t id} {
 642    global canv
 643
 644    $canv bind $t <Button-3> "linemenu %X %Y $id"
 645    $canv bind $t <Enter> "lineenter %x %y $id"
 646    $canv bind $t <Motion> "linemotion %x %y $id"
 647    $canv bind $t <Leave> "lineleave $id"
 648}
 649
 650proc drawcommitline {level} {
 651    global parents children nparents nchildren todo
 652    global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 653    global lineid linehtag linentag linedtag commitinfo
 654    global colormap numcommits currentparents dupparents
 655    global oldlevel oldnlines oldtodo
 656    global idtags idline idheads
 657    global lineno lthickness mainline sidelines
 658    global commitlisted
 659
 660    incr numcommits
 661    incr lineno
 662    set id [lindex $todo $level]
 663    set lineid($lineno) $id
 664    set idline($id) $lineno
 665    set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
 666    if {![info exists commitinfo($id)]} {
 667        readcommit $id
 668        if {![info exists commitinfo($id)]} {
 669            set commitinfo($id) {"No commit information available"}
 670            set nparents($id) 0
 671        }
 672    }
 673    assigncolor $id
 674    set currentparents {}
 675    set dupparents {}
 676    if {[info exists commitlisted($id)] && [info exists parents($id)]} {
 677        foreach p $parents($id) {
 678            if {[lsearch -exact $currentparents $p] < 0} {
 679                lappend currentparents $p
 680            } else {
 681                # remember that this parent was listed twice
 682                lappend dupparents $p
 683            }
 684        }
 685    }
 686    set x [expr $canvx0 + $level * $linespc]
 687    set y1 $canvy
 688    set canvy [expr $canvy + $linespc]
 689    allcanvs conf -scrollregion \
 690        [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
 691    if {[info exists mainline($id)]} {
 692        lappend mainline($id) $x $y1
 693        set t [$canv create line $mainline($id) \
 694                   -width $lthickness -fill $colormap($id)]
 695        $canv lower $t
 696        bindline $t $id
 697    }
 698    if {[info exists sidelines($id)]} {
 699        foreach ls $sidelines($id) {
 700            set coords [lindex $ls 0]
 701            set thick [lindex $ls 1]
 702            set t [$canv create line $coords -fill $colormap($id) \
 703                       -width [expr {$thick * $lthickness}]]
 704            $canv lower $t
 705            bindline $t $id
 706        }
 707    }
 708    set orad [expr {$linespc / 3}]
 709    set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
 710               [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
 711               -fill $ofill -outline black -width 1]
 712    $canv raise $t
 713    set xt [expr $canvx0 + [llength $todo] * $linespc]
 714    if {[llength $currentparents] > 2} {
 715        set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
 716    }
 717    set marks {}
 718    set ntags 0
 719    if {[info exists idtags($id)]} {
 720        set marks $idtags($id)
 721        set ntags [llength $marks]
 722    }
 723    if {[info exists idheads($id)]} {
 724        set marks [concat $marks $idheads($id)]
 725    }
 726    if {$marks != {}} {
 727        set delta [expr {int(0.5 * ($linespc - $lthickness))}]
 728        set yt [expr $y1 - 0.5 * $linespc]
 729        set yb [expr $yt + $linespc - 1]
 730        set xvals {}
 731        set wvals {}
 732        foreach tag $marks {
 733            set wid [font measure $mainfont $tag]
 734            lappend xvals $xt
 735            lappend wvals $wid
 736            set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
 737        }
 738        set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
 739                   -width $lthickness -fill black]
 740        $canv lower $t
 741        foreach tag $marks x $xvals wid $wvals {
 742            set xl [expr $x + $delta]
 743            set xr [expr $x + $delta + $wid + $lthickness]
 744            if {[incr ntags -1] >= 0} {
 745                # draw a tag
 746                $canv create polygon $x [expr $yt + $delta] $xl $yt\
 747                    $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
 748                    -width 1 -outline black -fill yellow
 749            } else {
 750                # draw a head
 751                set xl [expr $xl - $delta/2]
 752                $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
 753                    -width 1 -outline black -fill green
 754            }
 755            $canv create text $xl $y1 -anchor w -text $tag \
 756                -font $mainfont
 757        }
 758    }
 759    set headline [lindex $commitinfo($id) 0]
 760    set name [lindex $commitinfo($id) 1]
 761    set date [lindex $commitinfo($id) 2]
 762    set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
 763                               -text $headline -font $mainfont ]
 764    set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
 765                               -text $name -font $namefont]
 766    set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
 767                               -text $date -font $mainfont]
 768}
 769
 770proc updatetodo {level noshortcut} {
 771    global currentparents ncleft todo
 772    global mainline oldlevel oldtodo oldnlines
 773    global canvx0 canvy linespc mainline
 774    global commitinfo
 775
 776    set oldlevel $level
 777    set oldtodo $todo
 778    set oldnlines [llength $todo]
 779    if {!$noshortcut && [llength $currentparents] == 1} {
 780        set p [lindex $currentparents 0]
 781        if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
 782            set ncleft($p) 0
 783            set x [expr $canvx0 + $level * $linespc]
 784            set y [expr $canvy - $linespc]
 785            set mainline($p) [list $x $y]
 786            set todo [lreplace $todo $level $level $p]
 787            return 0
 788        }
 789    }
 790
 791    set todo [lreplace $todo $level $level]
 792    set i $level
 793    foreach p $currentparents {
 794        incr ncleft($p) -1
 795        set k [lsearch -exact $todo $p]
 796        if {$k < 0} {
 797            set todo [linsert $todo $i $p]
 798            incr i
 799        }
 800    }
 801    return 1
 802}
 803
 804proc notecrossings {id lo hi corner} {
 805    global oldtodo crossings cornercrossings
 806
 807    for {set i $lo} {[incr i] < $hi} {} {
 808        set p [lindex $oldtodo $i]
 809        if {$p == {}} continue
 810        if {$i == $corner} {
 811            if {![info exists cornercrossings($id)]
 812                || [lsearch -exact $cornercrossings($id) $p] < 0} {
 813                lappend cornercrossings($id) $p
 814            }
 815            if {![info exists cornercrossings($p)]
 816                || [lsearch -exact $cornercrossings($p) $id] < 0} {
 817                lappend cornercrossings($p) $id
 818            }
 819        } else {
 820            if {![info exists crossings($id)]
 821                || [lsearch -exact $crossings($id) $p] < 0} {
 822                lappend crossings($id) $p
 823            }
 824            if {![info exists crossings($p)]
 825                || [lsearch -exact $crossings($p) $id] < 0} {
 826                lappend crossings($p) $id
 827            }
 828        }
 829    }
 830}
 831
 832proc drawslants {} {
 833    global canv mainline sidelines canvx0 canvy linespc
 834    global oldlevel oldtodo todo currentparents dupparents
 835    global lthickness linespc canvy colormap
 836
 837    set y1 [expr $canvy - $linespc]
 838    set y2 $canvy
 839    set i -1
 840    foreach id $oldtodo {
 841        incr i
 842        if {$id == {}} continue
 843        set xi [expr {$canvx0 + $i * $linespc}]
 844        if {$i == $oldlevel} {
 845            foreach p $currentparents {
 846                set j [lsearch -exact $todo $p]
 847                set coords [list $xi $y1]
 848                set xj [expr {$canvx0 + $j * $linespc}]
 849                if {$j < $i - 1} {
 850                    lappend coords [expr $xj + $linespc] $y1
 851                    notecrossings $p $j $i [expr {$j + 1}]
 852                } elseif {$j > $i + 1} {
 853                    lappend coords [expr $xj - $linespc] $y1
 854                    notecrossings $p $i $j [expr {$j - 1}]
 855                }
 856                if {[lsearch -exact $dupparents $p] >= 0} {
 857                    # draw a double-width line to indicate the doubled parent
 858                    lappend coords $xj $y2
 859                    lappend sidelines($p) [list $coords 2]
 860                    if {![info exists mainline($p)]} {
 861                        set mainline($p) [list $xj $y2]
 862                    }
 863                } else {
 864                    # normal case, no parent duplicated
 865                    if {![info exists mainline($p)]} {
 866                        if {$i != $j} {
 867                            lappend coords $xj $y2
 868                        }
 869                        set mainline($p) $coords
 870                    } else {
 871                        lappend coords $xj $y2
 872                        lappend sidelines($p) [list $coords 1]
 873                    }
 874                }
 875            }
 876        } elseif {[lindex $todo $i] != $id} {
 877            set j [lsearch -exact $todo $id]
 878            set xj [expr {$canvx0 + $j * $linespc}]
 879            lappend mainline($id) $xi $y1 $xj $y2
 880        }
 881    }
 882}
 883
 884proc decidenext {} {
 885    global parents children nchildren ncleft todo
 886    global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 887    global datemode cdate
 888    global lineid linehtag linentag linedtag commitinfo
 889    global currentparents oldlevel oldnlines oldtodo
 890    global lineno lthickness
 891
 892    # remove the null entry if present
 893    set nullentry [lsearch -exact $todo {}]
 894    if {$nullentry >= 0} {
 895        set todo [lreplace $todo $nullentry $nullentry]
 896    }
 897
 898    # choose which one to do next time around
 899    set todol [llength $todo]
 900    set level -1
 901    set latest {}
 902    for {set k $todol} {[incr k -1] >= 0} {} {
 903        set p [lindex $todo $k]
 904        if {$ncleft($p) == 0} {
 905            if {$datemode} {
 906                if {$latest == {} || $cdate($p) > $latest} {
 907                    set level $k
 908                    set latest $cdate($p)
 909                }
 910            } else {
 911                set level $k
 912                break
 913            }
 914        }
 915    }
 916    if {$level < 0} {
 917        if {$todo != {}} {
 918            puts "ERROR: none of the pending commits can be done yet:"
 919            foreach p $todo {
 920                puts "  $p ($ncleft($p))"
 921            }
 922        }
 923        return -1
 924    }
 925
 926    # If we are reducing, put in a null entry
 927    if {$todol < $oldnlines} {
 928        if {$nullentry >= 0} {
 929            set i $nullentry
 930            while {$i < $todol
 931                   && [lindex $oldtodo $i] == [lindex $todo $i]} {
 932                incr i
 933            }
 934        } else {
 935            set i $oldlevel
 936            if {$level >= $i} {
 937                incr i
 938            }
 939        }
 940        if {$i < $todol} {
 941            set todo [linsert $todo $i {}]
 942            if {$level >= $i} {
 943                incr level
 944            }
 945        }
 946    }
 947    return $level
 948}
 949
 950proc drawcommit {id} {
 951    global phase todo nchildren datemode nextupdate
 952    global startcommits
 953
 954    if {$phase != "incrdraw"} {
 955        set phase incrdraw
 956        set todo $id
 957        set startcommits $id
 958        initgraph
 959        drawcommitline 0
 960        updatetodo 0 $datemode
 961    } else {
 962        if {$nchildren($id) == 0} {
 963            lappend todo $id
 964            lappend startcommits $id
 965        }
 966        set level [decidenext]
 967        if {$id != [lindex $todo $level]} {
 968            return
 969        }
 970        while 1 {
 971            drawslants
 972            drawcommitline $level
 973            if {[updatetodo $level $datemode]} {
 974                set level [decidenext]
 975            }
 976            set id [lindex $todo $level]
 977            if {![info exists commitlisted($id)]} {
 978                break
 979            }
 980            if {[clock clicks -milliseconds] >= $nextupdate} {
 981                doupdate
 982                if {$stopped} break
 983            }
 984        }
 985    }
 986}
 987
 988proc finishcommits {} {
 989    global phase
 990    global startcommits
 991    global ctext maincursor textcursor
 992
 993    if {$phase != "incrdraw"} {
 994        $canv delete all
 995        $canv create text 3 3 -anchor nw -text "No commits selected" \
 996            -font $mainfont -tags textitems
 997        set phase {}
 998        return
 999    }
1000    drawslants
1001    set level [decidenext]
1002    drawrest $level [llength $startcommits]
1003    . config -cursor $maincursor
1004    $ctext config -cursor $textcursor
1005}
1006
1007proc drawgraph {} {
1008    global nextupdate startmsecs startcommits todo
1009
1010    if {$startcommits == {}} return
1011    set startmsecs [clock clicks -milliseconds]
1012    set nextupdate [expr $startmsecs + 100]
1013    initgraph
1014    set todo [lindex $startcommits 0]
1015    drawrest 0 1
1016}
1017
1018proc drawrest {level startix} {
1019    global phase stopped redisplaying selectedline
1020    global datemode currentparents todo
1021    global numcommits
1022    global nextupdate startmsecs startcommits idline
1023
1024    if {$level >= 0} {
1025        set phase drawgraph
1026        set startid [lindex $startcommits $startix]
1027        set startline -1
1028        if {$startid != {}} {
1029            set startline $idline($startid)
1030        }
1031        while 1 {
1032            if {$stopped} break
1033            drawcommitline $level
1034            set hard [updatetodo $level $datemode]
1035            if {$numcommits == $startline} {
1036                lappend todo $startid
1037                set hard 1
1038                incr startix
1039                set startid [lindex $startcommits $startix]
1040                set startline -1
1041                if {$startid != {}} {
1042                    set startline $idline($startid)
1043                }
1044            }
1045            if {$hard} {
1046                set level [decidenext]
1047                if {$level < 0} break
1048                drawslants
1049            }
1050            if {[clock clicks -milliseconds] >= $nextupdate} {
1051                update
1052                incr nextupdate 100
1053            }
1054        }
1055    }
1056    set phase {}
1057    set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1058    #puts "overall $drawmsecs ms for $numcommits commits"
1059    if {$redisplaying} {
1060        if {$stopped == 0 && [info exists selectedline]} {
1061            selectline $selectedline
1062        }
1063        if {$stopped == 1} {
1064            set stopped 0
1065            after idle drawgraph
1066        } else {
1067            set redisplaying 0
1068        }
1069    }
1070}
1071
1072proc findmatches {f} {
1073    global findtype foundstring foundstrlen
1074    if {$findtype == "Regexp"} {
1075        set matches [regexp -indices -all -inline $foundstring $f]
1076    } else {
1077        if {$findtype == "IgnCase"} {
1078            set str [string tolower $f]
1079        } else {
1080            set str $f
1081        }
1082        set matches {}
1083        set i 0
1084        while {[set j [string first $foundstring $str $i]] >= 0} {
1085            lappend matches [list $j [expr $j+$foundstrlen-1]]
1086            set i [expr $j + $foundstrlen]
1087        }
1088    }
1089    return $matches
1090}
1091
1092proc dofind {} {
1093    global findtype findloc findstring markedmatches commitinfo
1094    global numcommits lineid linehtag linentag linedtag
1095    global mainfont namefont canv canv2 canv3 selectedline
1096    global matchinglines foundstring foundstrlen
1097    unmarkmatches
1098    focus .
1099    set matchinglines {}
1100    set fldtypes {Headline Author Date Committer CDate Comment}
1101    if {$findtype == "IgnCase"} {
1102        set foundstring [string tolower $findstring]
1103    } else {
1104        set foundstring $findstring
1105    }
1106    set foundstrlen [string length $findstring]
1107    if {$foundstrlen == 0} return
1108    if {![info exists selectedline]} {
1109        set oldsel -1
1110    } else {
1111        set oldsel $selectedline
1112    }
1113    set didsel 0
1114    for {set l 0} {$l < $numcommits} {incr l} {
1115        set id $lineid($l)
1116        set info $commitinfo($id)
1117        set doesmatch 0
1118        foreach f $info ty $fldtypes {
1119            if {$findloc != "All fields" && $findloc != $ty} {
1120                continue
1121            }
1122            set matches [findmatches $f]
1123            if {$matches == {}} continue
1124            set doesmatch 1
1125            if {$ty == "Headline"} {
1126                markmatches $canv $l $f $linehtag($l) $matches $mainfont
1127            } elseif {$ty == "Author"} {
1128                markmatches $canv2 $l $f $linentag($l) $matches $namefont
1129            } elseif {$ty == "Date"} {
1130                markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1131            }
1132        }
1133        if {$doesmatch} {
1134            lappend matchinglines $l
1135            if {!$didsel && $l > $oldsel} {
1136                findselectline $l
1137                set didsel 1
1138            }
1139        }
1140    }
1141    if {$matchinglines == {}} {
1142        bell
1143    } elseif {!$didsel} {
1144        findselectline [lindex $matchinglines 0]
1145    }
1146}
1147
1148proc findselectline {l} {
1149    global findloc commentend ctext
1150    selectline $l
1151    if {$findloc == "All fields" || $findloc == "Comments"} {
1152        # highlight the matches in the comments
1153        set f [$ctext get 1.0 $commentend]
1154        set matches [findmatches $f]
1155        foreach match $matches {
1156            set start [lindex $match 0]
1157            set end [expr [lindex $match 1] + 1]
1158            $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1159        }
1160    }
1161}
1162
1163proc findnext {} {
1164    global matchinglines selectedline
1165    if {![info exists matchinglines]} {
1166        dofind
1167        return
1168    }
1169    if {![info exists selectedline]} return
1170    foreach l $matchinglines {
1171        if {$l > $selectedline} {
1172            findselectline $l
1173            return
1174        }
1175    }
1176    bell
1177}
1178
1179proc findprev {} {
1180    global matchinglines selectedline
1181    if {![info exists matchinglines]} {
1182        dofind
1183        return
1184    }
1185    if {![info exists selectedline]} return
1186    set prev {}
1187    foreach l $matchinglines {
1188        if {$l >= $selectedline} break
1189        set prev $l
1190    }
1191    if {$prev != {}} {
1192        findselectline $prev
1193    } else {
1194        bell
1195    }
1196}
1197
1198proc markmatches {canv l str tag matches font} {
1199    set bbox [$canv bbox $tag]
1200    set x0 [lindex $bbox 0]
1201    set y0 [lindex $bbox 1]
1202    set y1 [lindex $bbox 3]
1203    foreach match $matches {
1204        set start [lindex $match 0]
1205        set end [lindex $match 1]
1206        if {$start > $end} continue
1207        set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1208        set xlen [font measure $font [string range $str 0 [expr $end]]]
1209        set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1210                   -outline {} -tags matches -fill yellow]
1211        $canv lower $t
1212    }
1213}
1214
1215proc unmarkmatches {} {
1216    global matchinglines
1217    allcanvs delete matches
1218    catch {unset matchinglines}
1219}
1220
1221proc selcanvline {x y} {
1222    global canv canvy0 ctext linespc selectedline
1223    global lineid linehtag linentag linedtag
1224    set ymax [lindex [$canv cget -scrollregion] 3]
1225    if {$ymax == {}} return
1226    set yfrac [lindex [$canv yview] 0]
1227    set y [expr {$y + $yfrac * $ymax}]
1228    set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1229    if {$l < 0} {
1230        set l 0
1231    }
1232    if {[info exists selectedline] && $selectedline == $l} return
1233    unmarkmatches
1234    selectline $l
1235}
1236
1237proc selectline {l} {
1238    global canv canv2 canv3 ctext commitinfo selectedline
1239    global lineid linehtag linentag linedtag
1240    global canvy0 linespc nparents treepending
1241    global cflist treediffs currentid sha1entry
1242    global commentend seenfile idtags
1243    $canv delete hover
1244    if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1245    $canv delete secsel
1246    set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1247               -tags secsel -fill [$canv cget -selectbackground]]
1248    $canv lower $t
1249    $canv2 delete secsel
1250    set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1251               -tags secsel -fill [$canv2 cget -selectbackground]]
1252    $canv2 lower $t
1253    $canv3 delete secsel
1254    set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1255               -tags secsel -fill [$canv3 cget -selectbackground]]
1256    $canv3 lower $t
1257    set y [expr {$canvy0 + $l * $linespc}]
1258    set ymax [lindex [$canv cget -scrollregion] 3]
1259    set ytop [expr {$y - $linespc - 1}]
1260    set ybot [expr {$y + $linespc + 1}]
1261    set wnow [$canv yview]
1262    set wtop [expr [lindex $wnow 0] * $ymax]
1263    set wbot [expr [lindex $wnow 1] * $ymax]
1264    set wh [expr {$wbot - $wtop}]
1265    set newtop $wtop
1266    if {$ytop < $wtop} {
1267        if {$ybot < $wtop} {
1268            set newtop [expr {$y - $wh / 2.0}]
1269        } else {
1270            set newtop $ytop
1271            if {$newtop > $wtop - $linespc} {
1272                set newtop [expr {$wtop - $linespc}]
1273            }
1274        }
1275    } elseif {$ybot > $wbot} {
1276        if {$ytop > $wbot} {
1277            set newtop [expr {$y - $wh / 2.0}]
1278        } else {
1279            set newtop [expr {$ybot - $wh}]
1280            if {$newtop < $wtop + $linespc} {
1281                set newtop [expr {$wtop + $linespc}]
1282            }
1283        }
1284    }
1285    if {$newtop != $wtop} {
1286        if {$newtop < 0} {
1287            set newtop 0
1288        }
1289        allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1290    }
1291    set selectedline $l
1292
1293    set id $lineid($l)
1294    set currentid $id
1295    $sha1entry delete 0 end
1296    $sha1entry insert 0 $id
1297    $sha1entry selection from 0
1298    $sha1entry selection to end
1299
1300    $ctext conf -state normal
1301    $ctext delete 0.0 end
1302    set info $commitinfo($id)
1303    $ctext insert end "Author: [lindex $info 1]  [lindex $info 2]\n"
1304    $ctext insert end "Committer: [lindex $info 3]  [lindex $info 4]\n"
1305    if {[info exists idtags($id)]} {
1306        $ctext insert end "Tags:"
1307        foreach tag $idtags($id) {
1308            $ctext insert end " $tag"
1309        }
1310        $ctext insert end "\n"
1311    }
1312    $ctext insert end "\n"
1313    $ctext insert end [lindex $info 5]
1314    $ctext insert end "\n"
1315    $ctext tag delete Comments
1316    $ctext tag remove found 1.0 end
1317    $ctext conf -state disabled
1318    set commentend [$ctext index "end - 1c"]
1319
1320    $cflist delete 0 end
1321    if {$nparents($id) == 1} {
1322        if {![info exists treediffs($id)]} {
1323            if {![info exists treepending]} {
1324                gettreediffs $id
1325            }
1326        } else {
1327            addtocflist $id
1328        }
1329    }
1330    catch {unset seenfile}
1331}
1332
1333proc selnextline {dir} {
1334    global selectedline
1335    if {![info exists selectedline]} return
1336    set l [expr $selectedline + $dir]
1337    unmarkmatches
1338    selectline $l
1339}
1340
1341proc addtocflist {id} {
1342    global currentid treediffs cflist treepending
1343    if {$id != $currentid} {
1344        gettreediffs $currentid
1345        return
1346    }
1347    $cflist insert end "All files"
1348    foreach f $treediffs($currentid) {
1349        $cflist insert end $f
1350    }
1351    getblobdiffs $id
1352}
1353
1354proc gettreediffs {id} {
1355    global treediffs parents treepending
1356    set treepending $id
1357    set treediffs($id) {}
1358    set p [lindex $parents($id) 0]
1359    if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1360    fconfigure $gdtf -blocking 0
1361    fileevent $gdtf readable "gettreediffline $gdtf $id"
1362}
1363
1364proc gettreediffline {gdtf id} {
1365    global treediffs treepending
1366    set n [gets $gdtf line]
1367    if {$n < 0} {
1368        if {![eof $gdtf]} return
1369        close $gdtf
1370        unset treepending
1371        addtocflist $id
1372        return
1373    }
1374    set file [lindex $line 5]
1375    lappend treediffs($id) $file
1376}
1377
1378proc getblobdiffs {id} {
1379    global parents diffopts blobdifffd env curdifftag curtagstart
1380    global diffindex difffilestart
1381    set p [lindex $parents($id) 0]
1382    set env(GIT_DIFF_OPTS) $diffopts
1383    if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1384        puts "error getting diffs: $err"
1385        return
1386    }
1387    fconfigure $bdf -blocking 0
1388    set blobdifffd($id) $bdf
1389    set curdifftag Comments
1390    set curtagstart 0.0
1391    set diffindex 0
1392    catch {unset difffilestart}
1393    fileevent $bdf readable "getblobdiffline $bdf $id"
1394}
1395
1396proc getblobdiffline {bdf id} {
1397    global currentid blobdifffd ctext curdifftag curtagstart seenfile
1398    global diffnexthead diffnextnote diffindex difffilestart
1399    set n [gets $bdf line]
1400    if {$n < 0} {
1401        if {[eof $bdf]} {
1402            close $bdf
1403            if {$id == $currentid && $bdf == $blobdifffd($id)} {
1404                $ctext tag add $curdifftag $curtagstart end
1405                set seenfile($curdifftag) 1
1406            }
1407        }
1408        return
1409    }
1410    if {$id != $currentid || $bdf != $blobdifffd($id)} {
1411        return
1412    }
1413    $ctext conf -state normal
1414    if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1415        # start of a new file
1416        $ctext insert end "\n"
1417        $ctext tag add $curdifftag $curtagstart end
1418        set seenfile($curdifftag) 1
1419        set curtagstart [$ctext index "end - 1c"]
1420        set header $fname
1421        if {[info exists diffnexthead]} {
1422            set fname $diffnexthead
1423            set header "$diffnexthead ($diffnextnote)"
1424            unset diffnexthead
1425        }
1426        set difffilestart($diffindex) [$ctext index "end - 1c"]
1427        incr diffindex
1428        set curdifftag "f:$fname"
1429        $ctext tag delete $curdifftag
1430        set l [expr {(78 - [string length $header]) / 2}]
1431        set pad [string range "----------------------------------------" 1 $l]
1432        $ctext insert end "$pad $header $pad\n" filesep
1433    } elseif {[string range $line 0 2] == "+++"} {
1434        # no need to do anything with this
1435    } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1436        set diffnexthead $fn
1437        set diffnextnote "created, mode $m"
1438    } elseif {[string range $line 0 8] == "Deleted: "} {
1439        set diffnexthead [string range $line 9 end]
1440        set diffnextnote "deleted"
1441    } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1442        # save the filename in case the next thing is "new file mode ..."
1443        set diffnexthead $fn
1444        set diffnextnote "modified"
1445    } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1446        set diffnextnote "new file, mode $m"
1447    } elseif {[string range $line 0 11] == "deleted file"} {
1448        set diffnextnote "deleted"
1449    } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1450                   $line match f1l f1c f2l f2c rest]} {
1451        $ctext insert end "\t" hunksep
1452        $ctext insert end "    $f1l    " d0 "    $f2l    " d1
1453        $ctext insert end "    $rest \n" hunksep
1454    } else {
1455        set x [string range $line 0 0]
1456        if {$x == "-" || $x == "+"} {
1457            set tag [expr {$x == "+"}]
1458            set line [string range $line 1 end]
1459            $ctext insert end "$line\n" d$tag
1460        } elseif {$x == " "} {
1461            set line [string range $line 1 end]
1462            $ctext insert end "$line\n"
1463        } elseif {$x == "\\"} {
1464            # e.g. "\ No newline at end of file"
1465            $ctext insert end "$line\n" filesep
1466        } else {
1467            # Something else we don't recognize
1468            if {$curdifftag != "Comments"} {
1469                $ctext insert end "\n"
1470                $ctext tag add $curdifftag $curtagstart end
1471                set seenfile($curdifftag) 1
1472                set curtagstart [$ctext index "end - 1c"]
1473                set curdifftag Comments
1474            }
1475            $ctext insert end "$line\n" filesep
1476        }
1477    }
1478    $ctext conf -state disabled
1479}
1480
1481proc nextfile {} {
1482    global difffilestart ctext
1483    set here [$ctext index @0,0]
1484    for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1485        if {[$ctext compare $difffilestart($i) > $here]} {
1486            $ctext yview $difffilestart($i)
1487            break
1488        }
1489    }
1490}
1491
1492proc listboxsel {} {
1493    global ctext cflist currentid treediffs seenfile
1494    if {![info exists currentid]} return
1495    set sel [$cflist curselection]
1496    if {$sel == {} || [lsearch -exact $sel 0] >= 0} {
1497        # show everything
1498        $ctext tag conf Comments -elide 0
1499        foreach f $treediffs($currentid) {
1500            if [info exists seenfile(f:$f)] {
1501                $ctext tag conf "f:$f" -elide 0
1502            }
1503        }
1504    } else {
1505        # just show selected files
1506        $ctext tag conf Comments -elide 1
1507        set i 1
1508        foreach f $treediffs($currentid) {
1509            set elide [expr {[lsearch -exact $sel $i] < 0}]
1510            if [info exists seenfile(f:$f)] {
1511                $ctext tag conf "f:$f" -elide $elide
1512            }
1513            incr i
1514        }
1515    }
1516}
1517
1518proc setcoords {} {
1519    global linespc charspc canvx0 canvy0 mainfont
1520    set linespc [font metrics $mainfont -linespace]
1521    set charspc [font measure $mainfont "m"]
1522    set canvy0 [expr 3 + 0.5 * $linespc]
1523    set canvx0 [expr 3 + 0.5 * $linespc]
1524}
1525
1526proc redisplay {} {
1527    global selectedline stopped redisplaying phase
1528    if {$stopped > 1} return
1529    if {$phase == "getcommits"} return
1530    set redisplaying 1
1531    if {$phase == "drawgraph" || $phase == "incrdraw"} {
1532        set stopped 1
1533    } else {
1534        drawgraph
1535    }
1536}
1537
1538proc incrfont {inc} {
1539    global mainfont namefont textfont selectedline ctext canv phase
1540    global stopped entries
1541    unmarkmatches
1542    set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1543    set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1544    set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1545    setcoords
1546    $ctext conf -font $textfont
1547    $ctext tag conf filesep -font [concat $textfont bold]
1548    foreach e $entries {
1549        $e conf -font $mainfont
1550    }
1551    if {$phase == "getcommits"} {
1552        $canv itemconf textitems -font $mainfont
1553    }
1554    redisplay
1555}
1556
1557proc sha1change {n1 n2 op} {
1558    global sha1string currentid sha1but
1559    if {$sha1string == {}
1560        || ([info exists currentid] && $sha1string == $currentid)} {
1561        set state disabled
1562    } else {
1563        set state normal
1564    }
1565    if {[$sha1but cget -state] == $state} return
1566    if {$state == "normal"} {
1567        $sha1but conf -state normal -relief raised -text "Goto: "
1568    } else {
1569        $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1570    }
1571}
1572
1573proc gotocommit {} {
1574    global sha1string currentid idline tagids
1575    if {$sha1string == {}
1576        || ([info exists currentid] && $sha1string == $currentid)} return
1577    if {[info exists tagids($sha1string)]} {
1578        set id $tagids($sha1string)
1579    } else {
1580        set id [string tolower $sha1string]
1581    }
1582    if {[info exists idline($id)]} {
1583        selectline $idline($id)
1584        return
1585    }
1586    if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1587        set type "SHA1 id"
1588    } else {
1589        set type "Tag"
1590    }
1591    error_popup "$type $sha1string is not known"
1592}
1593
1594proc linemenu {x y id} {
1595    global linectxmenu linemenuid
1596    set linemenuid $id
1597    $linectxmenu post $x $y
1598}
1599
1600proc lineselect {} {
1601    global linemenuid idline
1602    if {[info exists linemenuid] && [info exists idline($linemenuid)]} {
1603        selectline $idline($linemenuid)
1604    }
1605}
1606
1607proc lineenter {x y id} {
1608    global hoverx hovery hoverid hovertimer
1609    global commitinfo canv
1610
1611    if {![info exists commitinfo($id)]} return
1612    set hoverx $x
1613    set hovery $y
1614    set hoverid $id
1615    if {[info exists hovertimer]} {
1616        after cancel $hovertimer
1617    }
1618    set hovertimer [after 500 linehover]
1619    $canv delete hover
1620}
1621
1622proc linemotion {x y id} {
1623    global hoverx hovery hoverid hovertimer
1624
1625    if {[info exists hoverid] && $id == $hoverid} {
1626        set hoverx $x
1627        set hovery $y
1628        if {[info exists hovertimer]} {
1629            after cancel $hovertimer
1630        }
1631        set hovertimer [after 500 linehover]
1632    }
1633}
1634
1635proc lineleave {id} {
1636    global hoverid hovertimer canv
1637
1638    if {[info exists hoverid] && $id == $hoverid} {
1639        $canv delete hover
1640        if {[info exists hovertimer]} {
1641            after cancel $hovertimer
1642            unset hovertimer
1643        }
1644        unset hoverid
1645    }
1646}
1647
1648proc linehover {} {
1649    global hoverx hovery hoverid hovertimer
1650    global canv linespc lthickness
1651    global commitinfo mainfont
1652
1653    set text [lindex $commitinfo($hoverid) 0]
1654    set ymax [lindex [$canv cget -scrollregion] 3]
1655    if {$ymax == {}} return
1656    set yfrac [lindex [$canv yview] 0]
1657    set x [expr {$hoverx + 2 * $linespc}]
1658    set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
1659    set x0 [expr {$x - 2 * $lthickness}]
1660    set y0 [expr {$y - 2 * $lthickness}]
1661    set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
1662    set y1 [expr {$y + $linespc + 2 * $lthickness}]
1663    set t [$canv create rectangle $x0 $y0 $x1 $y1 \
1664               -fill \#ffff80 -outline black -width 1 -tags hover]
1665    $canv raise $t
1666    set t [$canv create text $x $y -anchor nw -text $text -tags hover]
1667    $canv raise $t
1668}
1669
1670proc doquit {} {
1671    global stopped
1672    set stopped 100
1673    destroy .
1674}
1675
1676# defaults...
1677set datemode 0
1678set boldnames 0
1679set diffopts "-U 5 -p"
1680
1681set mainfont {Helvetica 9}
1682set textfont {Courier 9}
1683
1684set colors {green red blue magenta darkgrey brown orange}
1685
1686catch {source ~/.gitk}
1687
1688set namefont $mainfont
1689if {$boldnames} {
1690    lappend namefont bold
1691}
1692
1693set revtreeargs {}
1694foreach arg $argv {
1695    switch -regexp -- $arg {
1696        "^$" { }
1697        "^-b" { set boldnames 1 }
1698        "^-d" { set datemode 1 }
1699        default {
1700            lappend revtreeargs $arg
1701        }
1702    }
1703}
1704
1705set stopped 0
1706set redisplaying 0
1707set stuffsaved 0
1708setcoords
1709makewindow
1710readrefs
1711getcommits $revtreeargs