9c5de3f45dd2559fb3381ef1fef28f9bec7588c3
   1#!/bin/sh
   2# Tcl ignores the next line -*- tcl -*- \
   3exec wish "$0" -- "$@"
   4
   5# Copyright (C) 2005-2006 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 gitdir {} {
  11    global env
  12    if {[info exists env(GIT_DIR)]} {
  13        return $env(GIT_DIR)
  14    } else {
  15        return [exec git rev-parse --git-dir]
  16    }
  17}
  18
  19# A simple scheduler for compute-intensive stuff.
  20# The aim is to make sure that event handlers for GUI actions can
  21# run at least every 50-100 ms.  Unfortunately fileevent handlers are
  22# run before X event handlers, so reading from a fast source can
  23# make the GUI completely unresponsive.
  24proc run args {
  25    global isonrunq runq
  26
  27    set script $args
  28    if {[info exists isonrunq($script)]} return
  29    if {$runq eq {}} {
  30        after idle dorunq
  31    }
  32    lappend runq [list {} $script]
  33    set isonrunq($script) 1
  34}
  35
  36proc filerun {fd script} {
  37    fileevent $fd readable [list filereadable $fd $script]
  38}
  39
  40proc filereadable {fd script} {
  41    global runq
  42
  43    fileevent $fd readable {}
  44    if {$runq eq {}} {
  45        after idle dorunq
  46    }
  47    lappend runq [list $fd $script]
  48}
  49
  50proc nukefile {fd} {
  51    global runq
  52
  53    for {set i 0} {$i < [llength $runq]} {} {
  54        if {[lindex $runq $i 0] eq $fd} {
  55            set runq [lreplace $runq $i $i]
  56        } else {
  57            incr i
  58        }
  59    }
  60}
  61
  62proc dorunq {} {
  63    global isonrunq runq
  64
  65    set tstart [clock clicks -milliseconds]
  66    set t0 $tstart
  67    while {[llength $runq] > 0} {
  68        set fd [lindex $runq 0 0]
  69        set script [lindex $runq 0 1]
  70        set repeat [eval $script]
  71        set t1 [clock clicks -milliseconds]
  72        set t [expr {$t1 - $t0}]
  73        set runq [lrange $runq 1 end]
  74        if {$repeat ne {} && $repeat} {
  75            if {$fd eq {} || $repeat == 2} {
  76                # script returns 1 if it wants to be readded
  77                # file readers return 2 if they could do more straight away
  78                lappend runq [list $fd $script]
  79            } else {
  80                fileevent $fd readable [list filereadable $fd $script]
  81            }
  82        } elseif {$fd eq {}} {
  83            unset isonrunq($script)
  84        }
  85        set t0 $t1
  86        if {$t1 - $tstart >= 80} break
  87    }
  88    if {$runq ne {}} {
  89        after idle dorunq
  90    }
  91}
  92
  93# Start off a git rev-list process and arrange to read its output
  94proc start_rev_list {view} {
  95    global startmsecs
  96    global commfd leftover tclencoding datemode
  97    global viewargs viewfiles commitidx viewcomplete vnextroot
  98    global showlocalchanges commitinterest mainheadid
  99    global progressdirn progresscoords proglastnc curview
 100    global viewincl viewactive loginstance viewinstances
 101
 102    set startmsecs [clock clicks -milliseconds]
 103    set commitidx($view) 0
 104    set viewcomplete($view) 0
 105    set viewactive($view) 1
 106    set vnextroot($view) 0
 107    varcinit $view
 108
 109    set commits [eval exec git rev-parse --default HEAD --revs-only \
 110                     $viewargs($view)]
 111    set viewincl($view) {}
 112    foreach c $commits {
 113        if {![string match "^*" $c]} {
 114            lappend viewincl($view) $c
 115        }
 116    }
 117    if {[catch {
 118        set fd [open [concat | git log --no-color -z --pretty=raw --parents \
 119                         --boundary $commits "--" $viewfiles($view)] r]
 120    } err]} {
 121        error_popup "Error executing git log: $err"
 122        exit 1
 123    }
 124    set i [incr loginstance]
 125    set viewinstances($view) [list $i]
 126    set commfd($i) $fd
 127    set leftover($i) {}
 128    if {$showlocalchanges} {
 129        lappend commitinterest($mainheadid) {dodiffindex}
 130    }
 131    fconfigure $fd -blocking 0 -translation lf -eofchar {}
 132    if {$tclencoding != {}} {
 133        fconfigure $fd -encoding $tclencoding
 134    }
 135    filerun $fd [list getcommitlines $fd $i $view]
 136    nowbusy $view "Reading"
 137    if {$view == $curview} {
 138        set progressdirn 1
 139        set progresscoords {0 0}
 140        set proglastnc 0
 141    }
 142}
 143
 144proc stop_rev_list {view} {
 145    global commfd viewinstances leftover
 146
 147    foreach inst $viewinstances($view) {
 148        set fd $commfd($inst)
 149        catch {
 150            set pid [pid $fd]
 151            exec kill $pid
 152        }
 153        catch {close $fd}
 154        nukefile $fd
 155        unset commfd($inst)
 156        unset leftover($inst)
 157    }
 158    set viewinstances($view) {}
 159}
 160
 161proc getcommits {} {
 162    global canv curview
 163
 164    initlayout
 165    start_rev_list $curview
 166    show_status "Reading commits..."
 167}
 168
 169proc updatecommits {} {
 170    global curview viewargs viewfiles viewincl viewinstances
 171    global viewactive viewcomplete loginstance tclencoding
 172    global varcid startmsecs commfd getdbg showneartags leftover
 173
 174    set getdbg 1
 175    set view $curview
 176    set commits [exec git rev-parse --default HEAD --revs-only \
 177                     $viewargs($view)]
 178    set pos {}
 179    set neg {}
 180    foreach c $commits {
 181        if {[string match "^*" $c]} {
 182            lappend neg $c
 183        } else {
 184            if {!([info exists varcid($view,$c)] ||
 185                  [lsearch -exact $viewincl($view) $c] >= 0)} {
 186                lappend pos $c
 187            }
 188        }
 189    }
 190    if {$pos eq {}} {
 191        return
 192    }
 193    foreach id $viewincl($view) {
 194        lappend neg "^$id"
 195    }
 196    set viewincl($view) [concat $viewincl($view) $pos]
 197    if {[catch {
 198        set fd [open [concat | git log --no-color -z --pretty=raw --parents \
 199                         --boundary $pos $neg "--" $viewfiles($view)] r]
 200    } err]} {
 201        error_popup "Error executing git log: $err"
 202        exit 1
 203    }
 204    if {$viewactive($view) == 0} {
 205        set startmsecs [clock clicks -milliseconds]
 206    }
 207    set i [incr loginstance]
 208    lappend viewinstances($view) $i
 209    set commfd($i) $fd
 210    set leftover($i) {}
 211    fconfigure $fd -blocking 0 -translation lf -eofchar {}
 212    if {$tclencoding != {}} {
 213        fconfigure $fd -encoding $tclencoding
 214    }
 215    filerun $fd [list getcommitlines $fd $i $view]
 216    incr viewactive($view)
 217    set viewcomplete($view) 0
 218    nowbusy $view "Reading"
 219    readrefs
 220    changedrefs
 221    if {$showneartags} {
 222        getallcommits
 223    }
 224}
 225
 226proc reloadcommits {} {
 227    global curview viewcomplete selectedline currentid thickerline
 228    global showneartags treediffs commitinterest cached_commitrow
 229    global progresscoords
 230
 231    if {!$viewcomplete($curview)} {
 232        stop_rev_list $curview
 233        set progresscoords {0 0}
 234        adjustprogress
 235    }
 236    resetvarcs $curview
 237    catch {unset selectedline}
 238    catch {unset currentid}
 239    catch {unset thickerline}
 240    catch {unset treediffs}
 241    readrefs
 242    changedrefs
 243    if {$showneartags} {
 244        getallcommits
 245    }
 246    clear_display
 247    catch {unset commitinterest}
 248    catch {unset cached_commitrow}
 249    setcanvscroll
 250    getcommits
 251}
 252
 253# This makes a string representation of a positive integer which
 254# sorts as a string in numerical order
 255proc strrep {n} {
 256    if {$n < 16} {
 257        return [format "%x" $n]
 258    } elseif {$n < 256} {
 259        return [format "x%.2x" $n]
 260    } elseif {$n < 65536} {
 261        return [format "y%.4x" $n]
 262    }
 263    return [format "z%.8x" $n]
 264}
 265
 266# Procedures used in reordering commits from git log (without
 267# --topo-order) into the order for display.
 268
 269proc varcinit {view} {
 270    global vseeds varcstart vupptr vdownptr vleftptr varctok varcrow
 271    global vtokmod varcmod vrowmod varcix uat
 272
 273    set vseeds($view) {}
 274    set varcstart($view) {{}}
 275    set vupptr($view) {0}
 276    set vdownptr($view) {0}
 277    set vleftptr($view) {0}
 278    set varctok($view) {{}}
 279    set varcrow($view) {{}}
 280    set vtokmod($view) {}
 281    set varcmod($view) 0
 282    set vrowmod($view) 0
 283    set varcix($view) {{}}
 284    set uat 0
 285}
 286
 287proc resetvarcs {view} {
 288    global varcid varccommits parents children vseedcount ordertok
 289
 290    foreach vid [array names varcid $view,*] {
 291        unset varcid($vid)
 292        unset children($vid)
 293        unset parents($vid)
 294    }
 295    # some commits might have children but haven't been seen yet
 296    foreach vid [array names children $view,*] {
 297        unset children($vid)
 298    }
 299    foreach va [array names varccommits $view,*] {
 300        unset varccommits($va)
 301    }
 302    foreach vd [array names vseedcount $view,*] {
 303        unset vseedcount($vd)
 304    }
 305    catch {unset ordertok}
 306}
 307
 308proc newvarc {view id} {
 309    global varcid varctok parents children vseeds
 310    global vupptr vdownptr vleftptr varcrow varcix varcstart
 311    global commitdata commitinfo vseedcount varccommits
 312
 313    set a [llength $varctok($view)]
 314    set vid $view,$id
 315    if {[llength $children($vid)] == 0} {
 316        if {![info exists commitinfo($id)]} {
 317            parsecommit $id $commitdata($id) 1
 318        }
 319        set cdate [lindex $commitinfo($id) 4]
 320        if {![string is integer -strict $cdate]} {
 321            set cdate 0
 322        }
 323        if {![info exists vseedcount($view,$cdate)]} {
 324            set vseedcount($view,$cdate) -1
 325        }
 326        set c [incr vseedcount($view,$cdate)]
 327        set cdate [expr {$cdate ^ 0xffffffff}]
 328        set tok "s[strrep $cdate][strrep $c]"
 329        lappend vseeds($view) $id
 330        lappend vupptr($view) 0
 331        set ka [lindex $vdownptr($view) 0]
 332        if {$ka == 0 ||
 333            [string compare $tok [lindex $varctok($view) $ka]] < 0} {
 334            lset vdownptr($view) 0 $a
 335            lappend vleftptr($view) $ka
 336        } else {
 337            while {[set b [lindex $vleftptr($view) $ka]] != 0 &&
 338                   [string compare $tok [lindex $varctok($view) $b]] >= 0} {
 339                set ka $b
 340            }
 341            lset vleftptr($view) $ka $a
 342            lappend vleftptr($view) $b
 343        }
 344    } else {
 345        set tok {}
 346        foreach k $children($vid) {
 347            set ka $varcid($view,$k)
 348            if {[string compare [lindex $varctok($view) $ka] $tok] > 0} {
 349                set ki $k
 350                set tok [lindex $varctok($view) $ka]
 351            }
 352        }
 353        set ka $varcid($view,$ki)
 354        lappend vupptr($view) $ka
 355        set i [lsearch -exact $parents($view,$ki) $id]
 356        set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
 357        set rsib 0
 358        while {[incr i] < [llength $parents($view,$ki)]} {
 359            set bi [lindex $parents($view,$ki) $i]
 360            if {[info exists varcid($view,$bi)]} {
 361                set b $varcid($view,$bi)
 362                if {[lindex $vupptr($view) $b] == $ka} {
 363                    set rsib $b
 364                    lappend vleftptr($view) [lindex $vleftptr($view) $b]
 365                    lset vleftptr($view) $b $a
 366                    break
 367                }
 368            }
 369        }
 370        if {$rsib == 0} {
 371            lappend vleftptr($view) [lindex $vdownptr($view) $ka]
 372            lset vdownptr($view) $ka $a
 373        }
 374        append tok [strrep $j]
 375    }
 376    lappend varctok($view) $tok
 377    lappend varcstart($view) $id
 378    lappend vdownptr($view) 0
 379    lappend varcrow($view) {}
 380    lappend varcix($view) {}
 381    set varccommits($view,$a) {}
 382    return $a
 383}
 384
 385proc splitvarc {p v} {
 386    global varcid varcstart varccommits varctok
 387    global vupptr vdownptr vleftptr varcix varcrow
 388
 389    set oa $varcid($v,$p)
 390    set ac $varccommits($v,$oa)
 391    set i [lsearch -exact $varccommits($v,$oa) $p]
 392    if {$i <= 0} return
 393    set na [llength $varctok($v)]
 394    # "%" sorts before "0"...
 395    set tok "[lindex $varctok($v) $oa]%[strrep $i]"
 396    lappend varctok($v) $tok
 397    lappend varcrow($v) {}
 398    lappend varcix($v) {}
 399    set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
 400    set varccommits($v,$na) [lrange $ac $i end]
 401    lappend varcstart($v) $p
 402    foreach id $varccommits($v,$na) {
 403        set varcid($v,$id) $na
 404    }
 405    lappend vdownptr($v) [lindex $vdownptr($v) $oa]
 406    lset vdownptr($v) $oa $na
 407    lappend vupptr($v) $oa
 408    lappend vleftptr($v) 0
 409    for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
 410        lset vupptr($v) $b $na
 411    }
 412}
 413
 414proc renumbervarc {a v} {
 415    global parents children varctok varcstart varccommits
 416    global vupptr vdownptr vleftptr varcid vtokmod
 417
 418    set t1 [clock clicks -milliseconds]
 419    set todo {}
 420    set isrelated($a) 1
 421    set ntot 0
 422    while {$a != 0} {
 423        if {[info exists isrelated($a)]} {
 424            lappend todo $a
 425            set id [lindex $varccommits($v,$a) end]
 426            foreach p $parents($v,$id) {
 427                if {[info exists varcid($v,$p)]} {
 428                    set isrelated($varcid($v,$p)) 1
 429                }
 430            }
 431        }
 432        incr ntot
 433        set b [lindex $vdownptr($v) $a]
 434        if {$b == 0} {
 435            while {$a != 0} {
 436                set b [lindex $vleftptr($v) $a]
 437                if {$b != 0} break
 438                set a [lindex $vupptr($v) $a]
 439            }
 440        }
 441        set a $b
 442    }
 443    foreach a $todo {
 444        set id [lindex $varcstart($v) $a]
 445        set tok {}
 446        foreach k $children($v,$id) {
 447            set ka $varcid($v,$k)
 448            if {[string compare [lindex $varctok($v) $ka] $tok] > 0} {
 449                set ki $k
 450                set tok [lindex $varctok($v) $ka]
 451            }
 452        }
 453        if {$tok ne {}} {
 454            set ka $varcid($v,$ki)
 455            set i [lsearch -exact $parents($v,$ki) $id]
 456            set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
 457            append tok [strrep $j]
 458            set oldtok [lindex $varctok($v) $a]
 459            if {$tok eq $oldtok} continue
 460            lset varctok($v) $a $tok
 461        } else {
 462            set ka 0
 463        }
 464        set b [lindex $vupptr($v) $a]
 465        if {$b != $ka} {
 466            if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
 467                modify_arc $v $ka
 468            }
 469            if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
 470                modify_arc $v $b
 471            }
 472            set c [lindex $vdownptr($v) $b]
 473            if {$c == $a} {
 474                lset vdownptr($v) $b [lindex $vleftptr($v) $a]
 475            } else {
 476                set b $c
 477                while {$b != 0 && [lindex $vleftptr($v) $b] != $a} {
 478                    set b [lindex $vleftptr($v) $b]
 479                }
 480                if {$b != 0} {
 481                    lset vleftptr($v) $b [lindex $vleftptr($v) $a]
 482                } else {
 483                    puts "oops couldn't find $a in chain for [lindex $vupptr($v) $a]"
 484                }
 485            }
 486            lset vupptr($v) $a $ka
 487            set rsib 0
 488            while {[incr i] < [llength $parents($v,$ki)]} {
 489                set bi [lindex $parents($v,$ki) $i]
 490                if {[info exists varcid($v,$bi)]} {
 491                    set b $varcid($v,$bi)
 492                    if {[lindex $vupptr($v) $b] == $ka} {
 493                        set rsib $b
 494                        lset vleftptr($v) $a [lindex $vleftptr($v) $b]
 495                        lset vleftptr($v) $b $a
 496                        break
 497                    }
 498                }
 499            }
 500            if {$rsib == 0} {
 501                lset vleftptr($v) $a [lindex $vdownptr($v) $ka]
 502                lset vdownptr($v) $ka $a
 503            }
 504        }
 505    }
 506    set t2 [clock clicks -milliseconds]
 507    #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
 508}
 509
 510proc fix_reversal {p a v} {
 511    global varcid varcstart varctok vupptr vseeds
 512
 513    set pa $varcid($v,$p)
 514    if {$p ne [lindex $varcstart($v) $pa]} {
 515        splitvarc $p $v
 516        set pa $varcid($v,$p)
 517    }
 518    # seeds always need to be renumbered (and taken out of the seeds list)
 519    if {[lindex $vupptr($v) $pa] == 0} {
 520        set i [lsearch -exact $vseeds($v) $p]
 521        if {$i >= 0} {
 522            set vseeds($v) [lreplace $vseeds($v) $i $i]
 523        } else {
 524            puts "oops couldn't find [shortids $p] in seeds"
 525        }
 526        renumbervarc $pa $v
 527    } elseif {[string compare [lindex $varctok($v) $a] \
 528                   [lindex $varctok($v) $pa]] > 0} {
 529        renumbervarc $pa $v
 530    }
 531}
 532
 533proc insertrow {id p v} {
 534    global varcid varccommits parents children cmitlisted
 535    global commitidx varctok vtokmod
 536
 537    set a $varcid($v,$p)
 538    set i [lsearch -exact $varccommits($v,$a) $p]
 539    if {$i < 0} {
 540        puts "oops: insertrow can't find [shortids $p] on arc $a"
 541        return
 542    }
 543    set children($v,$id) {}
 544    set parents($v,$id) [list $p]
 545    set varcid($v,$id) $a
 546    lappend children($v,$p) $id
 547    set cmitlisted($v,$id) 1
 548    incr commitidx($v)
 549    # note we deliberately don't update varcstart($v) even if $i == 0
 550    set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
 551    if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
 552        modify_arc $v $a $i
 553    }
 554    drawvisible
 555}
 556
 557proc removerow {id v} {
 558    global varcid varccommits parents children commitidx
 559    global varctok vtokmod
 560
 561    if {[llength $parents($v,$id)] != 1} {
 562        puts "oops: removerow [shortids $id] has [llength $parents($v,$id)] parents"
 563        return
 564    }
 565    set p [lindex $parents($v,$id) 0]
 566    set a $varcid($v,$id)
 567    set i [lsearch -exact $varccommits($v,$a) $id]
 568    if {$i < 0} {
 569        puts "oops: removerow can't find [shortids $id] on arc $a"
 570        return
 571    }
 572    unset varcid($v,$id)
 573    set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
 574    unset parents($v,$id)
 575    unset children($v,$id)
 576    unset cmitlisted($v,$id)
 577    incr commitidx($v) -1
 578    set j [lsearch -exact $children($v,$p) $id]
 579    if {$j >= 0} {
 580        set children($v,$p) [lreplace $children($v,$p) $j $j]
 581    }
 582    set tok [lindex $varctok($v) $a]
 583    if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
 584        modify_arc $v $a $i
 585    }
 586    drawvisible
 587}
 588
 589proc vtokcmp {v a b} {
 590    global varctok varcid
 591
 592    return [string compare [lindex $varctok($v) $varcid($v,$a)] \
 593                [lindex $varctok($v) $varcid($v,$b)]]
 594}
 595
 596proc modify_arc {v a {lim {}}} {
 597    global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
 598
 599    set vtokmod($v) [lindex $varctok($v) $a]
 600    set varcmod($v) $a
 601    if {$v == $curview} {
 602        while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
 603            set a [lindex $vupptr($v) $a]
 604            set lim {}
 605        }
 606        set r 0
 607        if {$a != 0} {
 608            if {$lim eq {}} {
 609                set lim [llength $varccommits($v,$a)]
 610            }
 611            set r [expr {[lindex $varcrow($v) $a] + $lim}]
 612        }
 613        set vrowmod($v) $r
 614        undolayout $r
 615    }
 616}
 617
 618proc update_arcrows {v} {
 619    global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
 620    global varcid vseeds vrownum varcorder varcix varccommits
 621    global vupptr vdownptr vleftptr varctok
 622    global uat displayorder parentlist curview cached_commitrow
 623
 624    set t1 [clock clicks -milliseconds]
 625    set narctot [expr {[llength $varctok($v)] - 1}]
 626    set a $varcmod($v)
 627    while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
 628        # go up the tree until we find something that has a row number,
 629        # or we get to a seed
 630        set a [lindex $vupptr($v) $a]
 631    }
 632    if {$a == 0} {
 633        set a [lindex $vdownptr($v) 0]
 634        if {$a == 0} return
 635        set vrownum($v) {0}
 636        set varcorder($v) [list $a]
 637        lset varcix($v) $a 0
 638        lset varcrow($v) $a 0
 639        set arcn 0
 640        set row 0
 641    } else {
 642        set arcn [lindex $varcix($v) $a]
 643        # see if a is the last arc; if so, nothing to do
 644        if {$arcn == $narctot - 1} {
 645            return
 646        }
 647        if {[llength $vrownum($v)] > $arcn + 1} {
 648            set vrownum($v) [lrange $vrownum($v) 0 $arcn]
 649            set varcorder($v) [lrange $varcorder($v) 0 $arcn]
 650        }
 651        set row [lindex $varcrow($v) $a]
 652    }
 653    if {$v == $curview} {
 654        if {[llength $displayorder] > $vrowmod($v)} {
 655            set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
 656            set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
 657        }
 658        catch {unset cached_commitrow}
 659    }
 660    while {1} {
 661        set p $a
 662        incr row [llength $varccommits($v,$a)]
 663        # go down if possible
 664        set b [lindex $vdownptr($v) $a]
 665        if {$b == 0} {
 666            # if not, go left, or go up until we can go left
 667            while {$a != 0} {
 668                set b [lindex $vleftptr($v) $a]
 669                if {$b != 0} break
 670                set a [lindex $vupptr($v) $a]
 671            }
 672            if {$a == 0} break
 673        }
 674        set a $b
 675        incr arcn
 676        lappend vrownum($v) $row
 677        lappend varcorder($v) $a
 678        lset varcix($v) $a $arcn
 679        lset varcrow($v) $a $row
 680    }
 681    set vtokmod($v) [lindex $varctok($v) $p]
 682    set varcmod($v) $p
 683    set vrowmod($v) $row
 684    if {[info exists currentid]} {
 685        set selectedline [rowofcommit $currentid]
 686    }
 687    set t2 [clock clicks -milliseconds]
 688    incr uat [expr {$t2-$t1}]
 689}
 690
 691# Test whether view $v contains commit $id
 692proc commitinview {id v} {
 693    global varcid
 694
 695    return [info exists varcid($v,$id)]
 696}
 697
 698# Return the row number for commit $id in the current view
 699proc rowofcommit {id} {
 700    global varcid varccommits varcrow curview cached_commitrow
 701    global varctok vtokmod
 702
 703    if {[info exists cached_commitrow($id)]} {
 704        return $cached_commitrow($id)
 705    }
 706    set v $curview
 707    if {![info exists varcid($v,$id)]} {
 708        puts "oops rowofcommit no arc for [shortids $id]"
 709        return {}
 710    }
 711    set a $varcid($v,$id)
 712    if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] > 0} {
 713        update_arcrows $v
 714    }
 715    set i [lsearch -exact $varccommits($v,$a) $id]
 716    if {$i < 0} {
 717        puts "oops didn't find commit [shortids $id] in arc $a"
 718        return {}
 719    }
 720    incr i [lindex $varcrow($v) $a]
 721    set cached_commitrow($id) $i
 722    return $i
 723}
 724
 725proc bsearch {l elt} {
 726    if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
 727        return 0
 728    }
 729    set lo 0
 730    set hi [llength $l]
 731    while {$hi - $lo > 1} {
 732        set mid [expr {int(($lo + $hi) / 2)}]
 733        set t [lindex $l $mid]
 734        if {$elt < $t} {
 735            set hi $mid
 736        } elseif {$elt > $t} {
 737            set lo $mid
 738        } else {
 739            return $mid
 740        }
 741    }
 742    return $lo
 743}
 744
 745# Make sure rows $start..$end-1 are valid in displayorder and parentlist
 746proc make_disporder {start end} {
 747    global vrownum curview commitidx displayorder parentlist
 748    global varccommits varcorder parents vrowmod varcrow
 749    global d_valid_start d_valid_end
 750
 751    if {$end > $vrowmod($curview)} {
 752        update_arcrows $curview
 753    }
 754    set ai [bsearch $vrownum($curview) $start]
 755    set start [lindex $vrownum($curview) $ai]
 756    set narc [llength $vrownum($curview)]
 757    for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
 758        set a [lindex $varcorder($curview) $ai]
 759        set l [llength $displayorder]
 760        set al [llength $varccommits($curview,$a)]
 761        if {$l < $r + $al} {
 762            if {$l < $r} {
 763                set pad [ntimes [expr {$r - $l}] {}]
 764                set displayorder [concat $displayorder $pad]
 765                set parentlist [concat $parentlist $pad]
 766            } elseif {$l > $r} {
 767                set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
 768                set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
 769            }
 770            foreach id $varccommits($curview,$a) {
 771                lappend displayorder $id
 772                lappend parentlist $parents($curview,$id)
 773            }
 774        } elseif {[lindex $displayorder $r] eq {}} {
 775            set i $r
 776            foreach id $varccommits($curview,$a) {
 777                lset displayorder $i $id
 778                lset parentlist $i $parents($curview,$id)
 779                incr i
 780            }
 781        }
 782        incr r $al
 783    }
 784}
 785
 786proc commitonrow {row} {
 787    global displayorder
 788
 789    set id [lindex $displayorder $row]
 790    if {$id eq {}} {
 791        make_disporder $row [expr {$row + 1}]
 792        set id [lindex $displayorder $row]
 793    }
 794    return $id
 795}
 796
 797proc closevarcs {v} {
 798    global varctok varccommits varcid parents children
 799    global cmitlisted commitidx commitinterest vtokmod
 800
 801    set missing_parents 0
 802    set scripts {}
 803    set narcs [llength $varctok($v)]
 804    for {set a 1} {$a < $narcs} {incr a} {
 805        set id [lindex $varccommits($v,$a) end]
 806        foreach p $parents($v,$id) {
 807            if {[info exists varcid($v,$p)]} continue
 808            # add p as a new commit
 809            incr missing_parents
 810            set cmitlisted($v,$p) 0
 811            set parents($v,$p) {}
 812            if {[llength $children($v,$p)] == 1 &&
 813                [llength $parents($v,$id)] == 1} {
 814                set b $a
 815            } else {
 816                set b [newvarc $v $p]
 817            }
 818            set varcid($v,$p) $b
 819            if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
 820                modify_arc $v $b
 821            }
 822            lappend varccommits($v,$b) $p
 823            incr commitidx($v)
 824            if {[info exists commitinterest($p)]} {
 825                foreach script $commitinterest($p) {
 826                    lappend scripts [string map [list "%I" $p] $script]
 827                }
 828                unset commitinterest($id)
 829            }
 830        }
 831    }
 832    if {$missing_parents > 0} {
 833        foreach s $scripts {
 834            eval $s
 835        }
 836    }
 837}
 838
 839proc getcommitlines {fd inst view}  {
 840    global cmitlisted commitinterest leftover getdbg
 841    global commitidx commitdata
 842    global parents children curview hlview
 843    global vnextroot idpending ordertok
 844    global varccommits varcid varctok vtokmod
 845
 846    set stuff [read $fd 500000]
 847    # git log doesn't terminate the last commit with a null...
 848    if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
 849        set stuff "\0"
 850    }
 851    if {$stuff == {}} {
 852        if {![eof $fd]} {
 853            return 1
 854        }
 855        global commfd viewcomplete viewactive viewname progresscoords
 856        global viewinstances
 857        unset commfd($inst)
 858        set i [lsearch -exact $viewinstances($view) $inst]
 859        if {$i >= 0} {
 860            set viewinstances($view) [lreplace $viewinstances($view) $i $i]
 861        }
 862        # set it blocking so we wait for the process to terminate
 863        fconfigure $fd -blocking 1
 864        if {[catch {close $fd} err]} {
 865            set fv {}
 866            if {$view != $curview} {
 867                set fv " for the \"$viewname($view)\" view"
 868            }
 869            if {[string range $err 0 4] == "usage"} {
 870                set err "Gitk: error reading commits$fv:\
 871                        bad arguments to git rev-list."
 872                if {$viewname($view) eq "Command line"} {
 873                    append err \
 874                        "  (Note: arguments to gitk are passed to git rev-list\
 875                         to allow selection of commits to be displayed.)"
 876                }
 877            } else {
 878                set err "Error reading commits$fv: $err"
 879            }
 880            error_popup $err
 881        }
 882        if {[incr viewactive($view) -1] <= 0} {
 883            set viewcomplete($view) 1
 884            # Check if we have seen any ids listed as parents that haven't
 885            # appeared in the list
 886            closevarcs $view
 887            notbusy $view
 888            set progresscoords {0 0}
 889            adjustprogress
 890        }
 891        if {$view == $curview} {
 892            run chewcommits $view
 893        }
 894        return 0
 895    }
 896    set start 0
 897    set gotsome 0
 898    set scripts {}
 899    while 1 {
 900        set i [string first "\0" $stuff $start]
 901        if {$i < 0} {
 902            append leftover($inst) [string range $stuff $start end]
 903            break
 904        }
 905        if {$start == 0} {
 906            set cmit $leftover($inst)
 907            append cmit [string range $stuff 0 [expr {$i - 1}]]
 908            set leftover($inst) {}
 909        } else {
 910            set cmit [string range $stuff $start [expr {$i - 1}]]
 911        }
 912        set start [expr {$i + 1}]
 913        set j [string first "\n" $cmit]
 914        set ok 0
 915        set listed 1
 916        if {$j >= 0 && [string match "commit *" $cmit]} {
 917            set ids [string range $cmit 7 [expr {$j - 1}]]
 918            if {[string match {[-<>]*} $ids]} {
 919                switch -- [string index $ids 0] {
 920                    "-" {set listed 0}
 921                    "<" {set listed 2}
 922                    ">" {set listed 3}
 923                }
 924                set ids [string range $ids 1 end]
 925            }
 926            set ok 1
 927            foreach id $ids {
 928                if {[string length $id] != 40} {
 929                    set ok 0
 930                    break
 931                }
 932            }
 933        }
 934        if {!$ok} {
 935            set shortcmit $cmit
 936            if {[string length $shortcmit] > 80} {
 937                set shortcmit "[string range $shortcmit 0 80]..."
 938            }
 939            error_popup "Can't parse git log output: {$shortcmit}"
 940            exit 1
 941        }
 942        set id [lindex $ids 0]
 943        set vid $view,$id
 944        if {!$listed && [info exists parents($vid)]} continue
 945        if {$listed} {
 946            set olds [lrange $ids 1 end]
 947        } else {
 948            set olds {}
 949        }
 950        set commitdata($id) [string range $cmit [expr {$j + 1}] end]
 951        set cmitlisted($vid) $listed
 952        set parents($vid) $olds
 953        set a 0
 954        if {![info exists children($vid)]} {
 955            set children($vid) {}
 956        } else {
 957            if {[llength $children($vid)] == 1} {
 958                set k [lindex $children($vid) 0]
 959                if {[llength $parents($view,$k)] == 1} {
 960                    set a $varcid($view,$k)
 961                }
 962            }
 963        }
 964        if {$a == 0} {
 965            # new arc
 966            set a [newvarc $view $id]
 967        }
 968        set varcid($vid) $a
 969        if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
 970            modify_arc $view $a
 971        }
 972        lappend varccommits($view,$a) $id
 973
 974        set i 0
 975        foreach p $olds {
 976            if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
 977                set vp $view,$p
 978                if {[llength [lappend children($vp) $id]] > 1 &&
 979                    [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
 980                    set children($vp) [lsort -command [list vtokcmp $view] \
 981                                           $children($vp)]
 982                    catch {unset ordertok}
 983                }
 984            }
 985            if {[info exists varcid($view,$p)]} {
 986                fix_reversal $p $a $view
 987            }
 988            incr i
 989        }
 990
 991        incr commitidx($view)
 992        if {[info exists commitinterest($id)]} {
 993            foreach script $commitinterest($id) {
 994                lappend scripts [string map [list "%I" $id] $script]
 995            }
 996            unset commitinterest($id)
 997        }
 998        set gotsome 1
 999    }
1000    if {$gotsome} {
1001        run chewcommits $view
1002        foreach s $scripts {
1003            eval $s
1004        }
1005        if {$view == $curview} {
1006            # update progress bar
1007            global progressdirn progresscoords proglastnc
1008            set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
1009            set proglastnc $commitidx($view)
1010            set l [lindex $progresscoords 0]
1011            set r [lindex $progresscoords 1]
1012            if {$progressdirn} {
1013                set r [expr {$r + $inc}]
1014                if {$r >= 1.0} {
1015                    set r 1.0
1016                    set progressdirn 0
1017                }
1018                if {$r > 0.2} {
1019                    set l [expr {$r - 0.2}]
1020                }
1021            } else {
1022                set l [expr {$l - $inc}]
1023                if {$l <= 0.0} {
1024                    set l 0.0
1025                    set progressdirn 1
1026                }
1027                set r [expr {$l + 0.2}]
1028            }
1029            set progresscoords [list $l $r]
1030            adjustprogress
1031        }
1032    }
1033    return 2
1034}
1035
1036proc chewcommits {view} {
1037    global curview hlview viewcomplete
1038    global pending_select
1039
1040    if {$view == $curview} {
1041        layoutmore
1042        if {$viewcomplete($view)} {
1043            global commitidx
1044            global numcommits startmsecs
1045            global mainheadid commitinfo nullid
1046
1047            if {[info exists pending_select]} {
1048                set row [first_real_row]
1049                selectline $row 1
1050            }
1051            if {$commitidx($curview) > 0} {
1052                #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1053                #puts "overall $ms ms for $numcommits commits"
1054                #global uat
1055                #puts "${uat}ms in update_arcrows"
1056            } else {
1057                show_status "No commits selected"
1058            }
1059            notbusy layout
1060        }
1061    }
1062    if {[info exists hlview] && $view == $hlview} {
1063        vhighlightmore
1064    }
1065    return 0
1066}
1067
1068proc readcommit {id} {
1069    if {[catch {set contents [exec git cat-file commit $id]}]} return
1070    parsecommit $id $contents 0
1071}
1072
1073proc parsecommit {id contents listed} {
1074    global commitinfo cdate
1075
1076    set inhdr 1
1077    set comment {}
1078    set headline {}
1079    set auname {}
1080    set audate {}
1081    set comname {}
1082    set comdate {}
1083    set hdrend [string first "\n\n" $contents]
1084    if {$hdrend < 0} {
1085        # should never happen...
1086        set hdrend [string length $contents]
1087    }
1088    set header [string range $contents 0 [expr {$hdrend - 1}]]
1089    set comment [string range $contents [expr {$hdrend + 2}] end]
1090    foreach line [split $header "\n"] {
1091        set tag [lindex $line 0]
1092        if {$tag == "author"} {
1093            set audate [lindex $line end-1]
1094            set auname [lrange $line 1 end-2]
1095        } elseif {$tag == "committer"} {
1096            set comdate [lindex $line end-1]
1097            set comname [lrange $line 1 end-2]
1098        }
1099    }
1100    set headline {}
1101    # take the first non-blank line of the comment as the headline
1102    set headline [string trimleft $comment]
1103    set i [string first "\n" $headline]
1104    if {$i >= 0} {
1105        set headline [string range $headline 0 $i]
1106    }
1107    set headline [string trimright $headline]
1108    set i [string first "\r" $headline]
1109    if {$i >= 0} {
1110        set headline [string trimright [string range $headline 0 $i]]
1111    }
1112    if {!$listed} {
1113        # git rev-list indents the comment by 4 spaces;
1114        # if we got this via git cat-file, add the indentation
1115        set newcomment {}
1116        foreach line [split $comment "\n"] {
1117            append newcomment "    "
1118            append newcomment $line
1119            append newcomment "\n"
1120        }
1121        set comment $newcomment
1122    }
1123    if {$comdate != {}} {
1124        set cdate($id) $comdate
1125    }
1126    set commitinfo($id) [list $headline $auname $audate \
1127                             $comname $comdate $comment]
1128}
1129
1130proc getcommit {id} {
1131    global commitdata commitinfo
1132
1133    if {[info exists commitdata($id)]} {
1134        parsecommit $id $commitdata($id) 1
1135    } else {
1136        readcommit $id
1137        if {![info exists commitinfo($id)]} {
1138            set commitinfo($id) {"No commit information available"}
1139        }
1140    }
1141    return 1
1142}
1143
1144proc readrefs {} {
1145    global tagids idtags headids idheads tagobjid
1146    global otherrefids idotherrefs mainhead mainheadid
1147
1148    foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1149        catch {unset $v}
1150    }
1151    set refd [open [list | git show-ref -d] r]
1152    while {[gets $refd line] >= 0} {
1153        if {[string index $line 40] ne " "} continue
1154        set id [string range $line 0 39]
1155        set ref [string range $line 41 end]
1156        if {![string match "refs/*" $ref]} continue
1157        set name [string range $ref 5 end]
1158        if {[string match "remotes/*" $name]} {
1159            if {![string match "*/HEAD" $name]} {
1160                set headids($name) $id
1161                lappend idheads($id) $name
1162            }
1163        } elseif {[string match "heads/*" $name]} {
1164            set name [string range $name 6 end]
1165            set headids($name) $id
1166            lappend idheads($id) $name
1167        } elseif {[string match "tags/*" $name]} {
1168            # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1169            # which is what we want since the former is the commit ID
1170            set name [string range $name 5 end]
1171            if {[string match "*^{}" $name]} {
1172                set name [string range $name 0 end-3]
1173            } else {
1174                set tagobjid($name) $id
1175            }
1176            set tagids($name) $id
1177            lappend idtags($id) $name
1178        } else {
1179            set otherrefids($name) $id
1180            lappend idotherrefs($id) $name
1181        }
1182    }
1183    catch {close $refd}
1184    set mainhead {}
1185    set mainheadid {}
1186    catch {
1187        set thehead [exec git symbolic-ref HEAD]
1188        if {[string match "refs/heads/*" $thehead]} {
1189            set mainhead [string range $thehead 11 end]
1190            if {[info exists headids($mainhead)]} {
1191                set mainheadid $headids($mainhead)
1192            }
1193        }
1194    }
1195}
1196
1197# skip over fake commits
1198proc first_real_row {} {
1199    global nullid nullid2 numcommits
1200
1201    for {set row 0} {$row < $numcommits} {incr row} {
1202        set id [commitonrow $row]
1203        if {$id ne $nullid && $id ne $nullid2} {
1204            break
1205        }
1206    }
1207    return $row
1208}
1209
1210# update things for a head moved to a child of its previous location
1211proc movehead {id name} {
1212    global headids idheads
1213
1214    removehead $headids($name) $name
1215    set headids($name) $id
1216    lappend idheads($id) $name
1217}
1218
1219# update things when a head has been removed
1220proc removehead {id name} {
1221    global headids idheads
1222
1223    if {$idheads($id) eq $name} {
1224        unset idheads($id)
1225    } else {
1226        set i [lsearch -exact $idheads($id) $name]
1227        if {$i >= 0} {
1228            set idheads($id) [lreplace $idheads($id) $i $i]
1229        }
1230    }
1231    unset headids($name)
1232}
1233
1234proc show_error {w top msg} {
1235    message $w.m -text $msg -justify center -aspect 400
1236    pack $w.m -side top -fill x -padx 20 -pady 20
1237    button $w.ok -text OK -command "destroy $top"
1238    pack $w.ok -side bottom -fill x
1239    bind $top <Visibility> "grab $top; focus $top"
1240    bind $top <Key-Return> "destroy $top"
1241    tkwait window $top
1242}
1243
1244proc error_popup msg {
1245    set w .error
1246    toplevel $w
1247    wm transient $w .
1248    show_error $w $w $msg
1249}
1250
1251proc confirm_popup msg {
1252    global confirm_ok
1253    set confirm_ok 0
1254    set w .confirm
1255    toplevel $w
1256    wm transient $w .
1257    message $w.m -text $msg -justify center -aspect 400
1258    pack $w.m -side top -fill x -padx 20 -pady 20
1259    button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
1260    pack $w.ok -side left -fill x
1261    button $w.cancel -text Cancel -command "destroy $w"
1262    pack $w.cancel -side right -fill x
1263    bind $w <Visibility> "grab $w; focus $w"
1264    tkwait window $w
1265    return $confirm_ok
1266}
1267
1268proc makewindow {} {
1269    global canv canv2 canv3 linespc charspc ctext cflist
1270    global tabstop
1271    global findtype findtypemenu findloc findstring fstring geometry
1272    global entries sha1entry sha1string sha1but
1273    global diffcontextstring diffcontext
1274    global maincursor textcursor curtextcursor
1275    global rowctxmenu fakerowmenu mergemax wrapcomment
1276    global highlight_files gdttype
1277    global searchstring sstring
1278    global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
1279    global headctxmenu progresscanv progressitem progresscoords statusw
1280    global fprogitem fprogcoord lastprogupdate progupdatepending
1281    global rprogitem rprogcoord
1282    global have_tk85
1283
1284    menu .bar
1285    .bar add cascade -label "File" -menu .bar.file
1286    .bar configure -font uifont
1287    menu .bar.file
1288    .bar.file add command -label "Update" -command updatecommits
1289    .bar.file add command -label "Reload" -command reloadcommits
1290    .bar.file add command -label "Reread references" -command rereadrefs
1291    .bar.file add command -label "List references" -command showrefs
1292    .bar.file add command -label "Quit" -command doquit
1293    .bar.file configure -font uifont
1294    menu .bar.edit
1295    .bar add cascade -label "Edit" -menu .bar.edit
1296    .bar.edit add command -label "Preferences" -command doprefs
1297    .bar.edit configure -font uifont
1298
1299    menu .bar.view -font uifont
1300    .bar add cascade -label "View" -menu .bar.view
1301    .bar.view add command -label "New view..." -command {newview 0}
1302    .bar.view add command -label "Edit view..." -command editview \
1303        -state disabled
1304    .bar.view add command -label "Delete view" -command delview -state disabled
1305    .bar.view add separator
1306    .bar.view add radiobutton -label "All files" -command {showview 0} \
1307        -variable selectedview -value 0
1308
1309    menu .bar.help
1310    .bar add cascade -label "Help" -menu .bar.help
1311    .bar.help add command -label "About gitk" -command about
1312    .bar.help add command -label "Key bindings" -command keys
1313    .bar.help configure -font uifont
1314    . configure -menu .bar
1315
1316    # the gui has upper and lower half, parts of a paned window.
1317    panedwindow .ctop -orient vertical
1318
1319    # possibly use assumed geometry
1320    if {![info exists geometry(pwsash0)]} {
1321        set geometry(topheight) [expr {15 * $linespc}]
1322        set geometry(topwidth) [expr {80 * $charspc}]
1323        set geometry(botheight) [expr {15 * $linespc}]
1324        set geometry(botwidth) [expr {50 * $charspc}]
1325        set geometry(pwsash0) "[expr {40 * $charspc}] 2"
1326        set geometry(pwsash1) "[expr {60 * $charspc}] 2"
1327    }
1328
1329    # the upper half will have a paned window, a scroll bar to the right, and some stuff below
1330    frame .tf -height $geometry(topheight) -width $geometry(topwidth)
1331    frame .tf.histframe
1332    panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
1333
1334    # create three canvases
1335    set cscroll .tf.histframe.csb
1336    set canv .tf.histframe.pwclist.canv
1337    canvas $canv \
1338        -selectbackground $selectbgcolor \
1339        -background $bgcolor -bd 0 \
1340        -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
1341    .tf.histframe.pwclist add $canv
1342    set canv2 .tf.histframe.pwclist.canv2
1343    canvas $canv2 \
1344        -selectbackground $selectbgcolor \
1345        -background $bgcolor -bd 0 -yscrollincr $linespc
1346    .tf.histframe.pwclist add $canv2
1347    set canv3 .tf.histframe.pwclist.canv3
1348    canvas $canv3 \
1349        -selectbackground $selectbgcolor \
1350        -background $bgcolor -bd 0 -yscrollincr $linespc
1351    .tf.histframe.pwclist add $canv3
1352    eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
1353    eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
1354
1355    # a scroll bar to rule them
1356    scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
1357    pack $cscroll -side right -fill y
1358    bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
1359    lappend bglist $canv $canv2 $canv3
1360    pack .tf.histframe.pwclist -fill both -expand 1 -side left
1361
1362    # we have two button bars at bottom of top frame. Bar 1
1363    frame .tf.bar
1364    frame .tf.lbar -height 15
1365
1366    set sha1entry .tf.bar.sha1
1367    set entries $sha1entry
1368    set sha1but .tf.bar.sha1label
1369    button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
1370        -command gotocommit -width 8 -font uifont
1371    $sha1but conf -disabledforeground [$sha1but cget -foreground]
1372    pack .tf.bar.sha1label -side left
1373    entry $sha1entry -width 40 -font textfont -textvariable sha1string
1374    trace add variable sha1string write sha1change
1375    pack $sha1entry -side left -pady 2
1376
1377    image create bitmap bm-left -data {
1378        #define left_width 16
1379        #define left_height 16
1380        static unsigned char left_bits[] = {
1381        0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
1382        0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
1383        0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
1384    }
1385    image create bitmap bm-right -data {
1386        #define right_width 16
1387        #define right_height 16
1388        static unsigned char right_bits[] = {
1389        0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
1390        0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
1391        0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
1392    }
1393    button .tf.bar.leftbut -image bm-left -command goback \
1394        -state disabled -width 26
1395    pack .tf.bar.leftbut -side left -fill y
1396    button .tf.bar.rightbut -image bm-right -command goforw \
1397        -state disabled -width 26
1398    pack .tf.bar.rightbut -side left -fill y
1399
1400    # Status label and progress bar
1401    set statusw .tf.bar.status
1402    label $statusw -width 15 -relief sunken -font uifont
1403    pack $statusw -side left -padx 5
1404    set h [expr {[font metrics uifont -linespace] + 2}]
1405    set progresscanv .tf.bar.progress
1406    canvas $progresscanv -relief sunken -height $h -borderwidth 2
1407    set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
1408    set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
1409    set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
1410    pack $progresscanv -side right -expand 1 -fill x
1411    set progresscoords {0 0}
1412    set fprogcoord 0
1413    set rprogcoord 0
1414    bind $progresscanv <Configure> adjustprogress
1415    set lastprogupdate [clock clicks -milliseconds]
1416    set progupdatepending 0
1417
1418    # build up the bottom bar of upper window
1419    label .tf.lbar.flabel -text "Find " -font uifont
1420    button .tf.lbar.fnext -text "next" -command {dofind 1 1} -font uifont
1421    button .tf.lbar.fprev -text "prev" -command {dofind -1 1} -font uifont
1422    label .tf.lbar.flab2 -text " commit " -font uifont
1423    pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
1424        -side left -fill y
1425    set gdttype "containing:"
1426    set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
1427                "containing:" \
1428                "touching paths:" \
1429                "adding/removing string:"]
1430    trace add variable gdttype write gdttype_change
1431    $gm conf -font uifont
1432    .tf.lbar.gdttype conf -font uifont
1433    pack .tf.lbar.gdttype -side left -fill y
1434
1435    set findstring {}
1436    set fstring .tf.lbar.findstring
1437    lappend entries $fstring
1438    entry $fstring -width 30 -font textfont -textvariable findstring
1439    trace add variable findstring write find_change
1440    set findtype Exact
1441    set findtypemenu [tk_optionMenu .tf.lbar.findtype \
1442                      findtype Exact IgnCase Regexp]
1443    trace add variable findtype write findcom_change
1444    .tf.lbar.findtype configure -font uifont
1445    .tf.lbar.findtype.menu configure -font uifont
1446    set findloc "All fields"
1447    tk_optionMenu .tf.lbar.findloc findloc "All fields" Headline \
1448        Comments Author Committer
1449    trace add variable findloc write find_change
1450    .tf.lbar.findloc configure -font uifont
1451    .tf.lbar.findloc.menu configure -font uifont
1452    pack .tf.lbar.findloc -side right
1453    pack .tf.lbar.findtype -side right
1454    pack $fstring -side left -expand 1 -fill x
1455
1456    # Finish putting the upper half of the viewer together
1457    pack .tf.lbar -in .tf -side bottom -fill x
1458    pack .tf.bar -in .tf -side bottom -fill x
1459    pack .tf.histframe -fill both -side top -expand 1
1460    .ctop add .tf
1461    .ctop paneconfigure .tf -height $geometry(topheight)
1462    .ctop paneconfigure .tf -width $geometry(topwidth)
1463
1464    # now build up the bottom
1465    panedwindow .pwbottom -orient horizontal
1466
1467    # lower left, a text box over search bar, scroll bar to the right
1468    # if we know window height, then that will set the lower text height, otherwise
1469    # we set lower text height which will drive window height
1470    if {[info exists geometry(main)]} {
1471        frame .bleft -width $geometry(botwidth)
1472    } else {
1473        frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
1474    }
1475    frame .bleft.top
1476    frame .bleft.mid
1477
1478    button .bleft.top.search -text "Search" -command dosearch \
1479        -font uifont
1480    pack .bleft.top.search -side left -padx 5
1481    set sstring .bleft.top.sstring
1482    entry $sstring -width 20 -font textfont -textvariable searchstring
1483    lappend entries $sstring
1484    trace add variable searchstring write incrsearch
1485    pack $sstring -side left -expand 1 -fill x
1486    radiobutton .bleft.mid.diff -text "Diff" -font uifont \
1487        -command changediffdisp -variable diffelide -value {0 0}
1488    radiobutton .bleft.mid.old -text "Old version" -font uifont \
1489        -command changediffdisp -variable diffelide -value {0 1}
1490    radiobutton .bleft.mid.new -text "New version" -font uifont \
1491        -command changediffdisp -variable diffelide -value {1 0}
1492    label .bleft.mid.labeldiffcontext -text "      Lines of context: " \
1493        -font uifont
1494    pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
1495    spinbox .bleft.mid.diffcontext -width 5 -font textfont \
1496        -from 1 -increment 1 -to 10000000 \
1497        -validate all -validatecommand "diffcontextvalidate %P" \
1498        -textvariable diffcontextstring
1499    .bleft.mid.diffcontext set $diffcontext
1500    trace add variable diffcontextstring write diffcontextchange
1501    lappend entries .bleft.mid.diffcontext
1502    pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
1503    set ctext .bleft.ctext
1504    text $ctext -background $bgcolor -foreground $fgcolor \
1505        -state disabled -font textfont \
1506        -yscrollcommand scrolltext -wrap none
1507    if {$have_tk85} {
1508        $ctext conf -tabstyle wordprocessor
1509    }
1510    scrollbar .bleft.sb -command "$ctext yview"
1511    pack .bleft.top -side top -fill x
1512    pack .bleft.mid -side top -fill x
1513    pack .bleft.sb -side right -fill y
1514    pack $ctext -side left -fill both -expand 1
1515    lappend bglist $ctext
1516    lappend fglist $ctext
1517
1518    $ctext tag conf comment -wrap $wrapcomment
1519    $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
1520    $ctext tag conf hunksep -fore [lindex $diffcolors 2]
1521    $ctext tag conf d0 -fore [lindex $diffcolors 0]
1522    $ctext tag conf d1 -fore [lindex $diffcolors 1]
1523    $ctext tag conf m0 -fore red
1524    $ctext tag conf m1 -fore blue
1525    $ctext tag conf m2 -fore green
1526    $ctext tag conf m3 -fore purple
1527    $ctext tag conf m4 -fore brown
1528    $ctext tag conf m5 -fore "#009090"
1529    $ctext tag conf m6 -fore magenta
1530    $ctext tag conf m7 -fore "#808000"
1531    $ctext tag conf m8 -fore "#009000"
1532    $ctext tag conf m9 -fore "#ff0080"
1533    $ctext tag conf m10 -fore cyan
1534    $ctext tag conf m11 -fore "#b07070"
1535    $ctext tag conf m12 -fore "#70b0f0"
1536    $ctext tag conf m13 -fore "#70f0b0"
1537    $ctext tag conf m14 -fore "#f0b070"
1538    $ctext tag conf m15 -fore "#ff70b0"
1539    $ctext tag conf mmax -fore darkgrey
1540    set mergemax 16
1541    $ctext tag conf mresult -font textfontbold
1542    $ctext tag conf msep -font textfontbold
1543    $ctext tag conf found -back yellow
1544
1545    .pwbottom add .bleft
1546    .pwbottom paneconfigure .bleft -width $geometry(botwidth)
1547
1548    # lower right
1549    frame .bright
1550    frame .bright.mode
1551    radiobutton .bright.mode.patch -text "Patch" \
1552        -command reselectline -variable cmitmode -value "patch"
1553    .bright.mode.patch configure -font uifont
1554    radiobutton .bright.mode.tree -text "Tree" \
1555        -command reselectline -variable cmitmode -value "tree"
1556    .bright.mode.tree configure -font uifont
1557    grid .bright.mode.patch .bright.mode.tree -sticky ew
1558    pack .bright.mode -side top -fill x
1559    set cflist .bright.cfiles
1560    set indent [font measure mainfont "nn"]
1561    text $cflist \
1562        -selectbackground $selectbgcolor \
1563        -background $bgcolor -foreground $fgcolor \
1564        -font mainfont \
1565        -tabs [list $indent [expr {2 * $indent}]] \
1566        -yscrollcommand ".bright.sb set" \
1567        -cursor [. cget -cursor] \
1568        -spacing1 1 -spacing3 1
1569    lappend bglist $cflist
1570    lappend fglist $cflist
1571    scrollbar .bright.sb -command "$cflist yview"
1572    pack .bright.sb -side right -fill y
1573    pack $cflist -side left -fill both -expand 1
1574    $cflist tag configure highlight \
1575        -background [$cflist cget -selectbackground]
1576    $cflist tag configure bold -font mainfontbold
1577
1578    .pwbottom add .bright
1579    .ctop add .pwbottom
1580
1581    # restore window position if known
1582    if {[info exists geometry(main)]} {
1583        wm geometry . "$geometry(main)"
1584    }
1585
1586    if {[tk windowingsystem] eq {aqua}} {
1587        set M1B M1
1588    } else {
1589        set M1B Control
1590    }
1591
1592    bind .pwbottom <Configure> {resizecdetpanes %W %w}
1593    pack .ctop -fill both -expand 1
1594    bindall <1> {selcanvline %W %x %y}
1595    #bindall <B1-Motion> {selcanvline %W %x %y}
1596    if {[tk windowingsystem] == "win32"} {
1597        bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
1598        bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
1599    } else {
1600        bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
1601        bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
1602        if {[tk windowingsystem] eq "aqua"} {
1603            bindall <MouseWheel> {
1604                set delta [expr {- (%D)}]
1605                allcanvs yview scroll $delta units
1606            }
1607        }
1608    }
1609    bindall <2> "canvscan mark %W %x %y"
1610    bindall <B2-Motion> "canvscan dragto %W %x %y"
1611    bindkey <Home> selfirstline
1612    bindkey <End> sellastline
1613    bind . <Key-Up> "selnextline -1"
1614    bind . <Key-Down> "selnextline 1"
1615    bind . <Shift-Key-Up> "dofind -1 0"
1616    bind . <Shift-Key-Down> "dofind 1 0"
1617    bindkey <Key-Right> "goforw"
1618    bindkey <Key-Left> "goback"
1619    bind . <Key-Prior> "selnextpage -1"
1620    bind . <Key-Next> "selnextpage 1"
1621    bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1622    bind . <$M1B-End> "allcanvs yview moveto 1.0"
1623    bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1624    bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1625    bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1626    bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1627    bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1628    bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1629    bindkey <Key-space> "$ctext yview scroll 1 pages"
1630    bindkey p "selnextline -1"
1631    bindkey n "selnextline 1"
1632    bindkey z "goback"
1633    bindkey x "goforw"
1634    bindkey i "selnextline -1"
1635    bindkey k "selnextline 1"
1636    bindkey j "goback"
1637    bindkey l "goforw"
1638    bindkey b "$ctext yview scroll -1 pages"
1639    bindkey d "$ctext yview scroll 18 units"
1640    bindkey u "$ctext yview scroll -18 units"
1641    bindkey / {dofind 1 1}
1642    bindkey <Key-Return> {dofind 1 1}
1643    bindkey ? {dofind -1 1}
1644    bindkey f nextfile
1645    bindkey <F5> updatecommits
1646    bind . <$M1B-q> doquit
1647    bind . <$M1B-f> {dofind 1 1}
1648    bind . <$M1B-g> {dofind 1 0}
1649    bind . <$M1B-r> dosearchback
1650    bind . <$M1B-s> dosearch
1651    bind . <$M1B-equal> {incrfont 1}
1652    bind . <$M1B-KP_Add> {incrfont 1}
1653    bind . <$M1B-minus> {incrfont -1}
1654    bind . <$M1B-KP_Subtract> {incrfont -1}
1655    wm protocol . WM_DELETE_WINDOW doquit
1656    bind . <Button-1> "click %W"
1657    bind $fstring <Key-Return> {dofind 1 1}
1658    bind $sha1entry <Key-Return> gotocommit
1659    bind $sha1entry <<PasteSelection>> clearsha1
1660    bind $cflist <1> {sel_flist %W %x %y; break}
1661    bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1662    bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1663    bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1664
1665    set maincursor [. cget -cursor]
1666    set textcursor [$ctext cget -cursor]
1667    set curtextcursor $textcursor
1668
1669    set rowctxmenu .rowctxmenu
1670    menu $rowctxmenu -tearoff 0
1671    $rowctxmenu add command -label "Diff this -> selected" \
1672        -command {diffvssel 0}
1673    $rowctxmenu add command -label "Diff selected -> this" \
1674        -command {diffvssel 1}
1675    $rowctxmenu add command -label "Make patch" -command mkpatch
1676    $rowctxmenu add command -label "Create tag" -command mktag
1677    $rowctxmenu add command -label "Write commit to file" -command writecommit
1678    $rowctxmenu add command -label "Create new branch" -command mkbranch
1679    $rowctxmenu add command -label "Cherry-pick this commit" \
1680        -command cherrypick
1681    $rowctxmenu add command -label "Reset HEAD branch to here" \
1682        -command resethead
1683
1684    set fakerowmenu .fakerowmenu
1685    menu $fakerowmenu -tearoff 0
1686    $fakerowmenu add command -label "Diff this -> selected" \
1687        -command {diffvssel 0}
1688    $fakerowmenu add command -label "Diff selected -> this" \
1689        -command {diffvssel 1}
1690    $fakerowmenu add command -label "Make patch" -command mkpatch
1691#    $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1692#    $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1693#    $fakerowmenu add command -label "Revert local changes" -command revertlocal
1694
1695    set headctxmenu .headctxmenu
1696    menu $headctxmenu -tearoff 0
1697    $headctxmenu add command -label "Check out this branch" \
1698        -command cobranch
1699    $headctxmenu add command -label "Remove this branch" \
1700        -command rmbranch
1701
1702    global flist_menu
1703    set flist_menu .flistctxmenu
1704    menu $flist_menu -tearoff 0
1705    $flist_menu add command -label "Highlight this too" \
1706        -command {flist_hl 0}
1707    $flist_menu add command -label "Highlight this only" \
1708        -command {flist_hl 1}
1709}
1710
1711# Windows sends all mouse wheel events to the current focused window, not
1712# the one where the mouse hovers, so bind those events here and redirect
1713# to the correct window
1714proc windows_mousewheel_redirector {W X Y D} {
1715    global canv canv2 canv3
1716    set w [winfo containing -displayof $W $X $Y]
1717    if {$w ne ""} {
1718        set u [expr {$D < 0 ? 5 : -5}]
1719        if {$w == $canv || $w == $canv2 || $w == $canv3} {
1720            allcanvs yview scroll $u units
1721        } else {
1722            catch {
1723                $w yview scroll $u units
1724            }
1725        }
1726    }
1727}
1728
1729# mouse-2 makes all windows scan vertically, but only the one
1730# the cursor is in scans horizontally
1731proc canvscan {op w x y} {
1732    global canv canv2 canv3
1733    foreach c [list $canv $canv2 $canv3] {
1734        if {$c == $w} {
1735            $c scan $op $x $y
1736        } else {
1737            $c scan $op 0 $y
1738        }
1739    }
1740}
1741
1742proc scrollcanv {cscroll f0 f1} {
1743    $cscroll set $f0 $f1
1744    drawfrac $f0 $f1
1745    flushhighlights
1746}
1747
1748# when we make a key binding for the toplevel, make sure
1749# it doesn't get triggered when that key is pressed in the
1750# find string entry widget.
1751proc bindkey {ev script} {
1752    global entries
1753    bind . $ev $script
1754    set escript [bind Entry $ev]
1755    if {$escript == {}} {
1756        set escript [bind Entry <Key>]
1757    }
1758    foreach e $entries {
1759        bind $e $ev "$escript; break"
1760    }
1761}
1762
1763# set the focus back to the toplevel for any click outside
1764# the entry widgets
1765proc click {w} {
1766    global ctext entries
1767    foreach e [concat $entries $ctext] {
1768        if {$w == $e} return
1769    }
1770    focus .
1771}
1772
1773# Adjust the progress bar for a change in requested extent or canvas size
1774proc adjustprogress {} {
1775    global progresscanv progressitem progresscoords
1776    global fprogitem fprogcoord lastprogupdate progupdatepending
1777    global rprogitem rprogcoord
1778
1779    set w [expr {[winfo width $progresscanv] - 4}]
1780    set x0 [expr {$w * [lindex $progresscoords 0]}]
1781    set x1 [expr {$w * [lindex $progresscoords 1]}]
1782    set h [winfo height $progresscanv]
1783    $progresscanv coords $progressitem $x0 0 $x1 $h
1784    $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1785    $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1786    set now [clock clicks -milliseconds]
1787    if {$now >= $lastprogupdate + 100} {
1788        set progupdatepending 0
1789        update
1790    } elseif {!$progupdatepending} {
1791        set progupdatepending 1
1792        after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1793    }
1794}
1795
1796proc doprogupdate {} {
1797    global lastprogupdate progupdatepending
1798
1799    if {$progupdatepending} {
1800        set progupdatepending 0
1801        set lastprogupdate [clock clicks -milliseconds]
1802        update
1803    }
1804}
1805
1806proc savestuff {w} {
1807    global canv canv2 canv3 mainfont textfont uifont tabstop
1808    global stuffsaved findmergefiles maxgraphpct
1809    global maxwidth showneartags showlocalchanges
1810    global viewname viewfiles viewargs viewperm nextviewnum
1811    global cmitmode wrapcomment datetimeformat limitdiffs
1812    global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1813
1814    if {$stuffsaved} return
1815    if {![winfo viewable .]} return
1816    catch {
1817        set f [open "~/.gitk-new" w]
1818        puts $f [list set mainfont $mainfont]
1819        puts $f [list set textfont $textfont]
1820        puts $f [list set uifont $uifont]
1821        puts $f [list set tabstop $tabstop]
1822        puts $f [list set findmergefiles $findmergefiles]
1823        puts $f [list set maxgraphpct $maxgraphpct]
1824        puts $f [list set maxwidth $maxwidth]
1825        puts $f [list set cmitmode $cmitmode]
1826        puts $f [list set wrapcomment $wrapcomment]
1827        puts $f [list set showneartags $showneartags]
1828        puts $f [list set showlocalchanges $showlocalchanges]
1829        puts $f [list set datetimeformat $datetimeformat]
1830        puts $f [list set limitdiffs $limitdiffs]
1831        puts $f [list set bgcolor $bgcolor]
1832        puts $f [list set fgcolor $fgcolor]
1833        puts $f [list set colors $colors]
1834        puts $f [list set diffcolors $diffcolors]
1835        puts $f [list set diffcontext $diffcontext]
1836        puts $f [list set selectbgcolor $selectbgcolor]
1837
1838        puts $f "set geometry(main) [wm geometry .]"
1839        puts $f "set geometry(topwidth) [winfo width .tf]"
1840        puts $f "set geometry(topheight) [winfo height .tf]"
1841        puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1842        puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1843        puts $f "set geometry(botwidth) [winfo width .bleft]"
1844        puts $f "set geometry(botheight) [winfo height .bleft]"
1845
1846        puts -nonewline $f "set permviews {"
1847        for {set v 0} {$v < $nextviewnum} {incr v} {
1848            if {$viewperm($v)} {
1849                puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1850            }
1851        }
1852        puts $f "}"
1853        close $f
1854        file rename -force "~/.gitk-new" "~/.gitk"
1855    }
1856    set stuffsaved 1
1857}
1858
1859proc resizeclistpanes {win w} {
1860    global oldwidth
1861    if {[info exists oldwidth($win)]} {
1862        set s0 [$win sash coord 0]
1863        set s1 [$win sash coord 1]
1864        if {$w < 60} {
1865            set sash0 [expr {int($w/2 - 2)}]
1866            set sash1 [expr {int($w*5/6 - 2)}]
1867        } else {
1868            set factor [expr {1.0 * $w / $oldwidth($win)}]
1869            set sash0 [expr {int($factor * [lindex $s0 0])}]
1870            set sash1 [expr {int($factor * [lindex $s1 0])}]
1871            if {$sash0 < 30} {
1872                set sash0 30
1873            }
1874            if {$sash1 < $sash0 + 20} {
1875                set sash1 [expr {$sash0 + 20}]
1876            }
1877            if {$sash1 > $w - 10} {
1878                set sash1 [expr {$w - 10}]
1879                if {$sash0 > $sash1 - 20} {
1880                    set sash0 [expr {$sash1 - 20}]
1881                }
1882            }
1883        }
1884        $win sash place 0 $sash0 [lindex $s0 1]
1885        $win sash place 1 $sash1 [lindex $s1 1]
1886    }
1887    set oldwidth($win) $w
1888}
1889
1890proc resizecdetpanes {win w} {
1891    global oldwidth
1892    if {[info exists oldwidth($win)]} {
1893        set s0 [$win sash coord 0]
1894        if {$w < 60} {
1895            set sash0 [expr {int($w*3/4 - 2)}]
1896        } else {
1897            set factor [expr {1.0 * $w / $oldwidth($win)}]
1898            set sash0 [expr {int($factor * [lindex $s0 0])}]
1899            if {$sash0 < 45} {
1900                set sash0 45
1901            }
1902            if {$sash0 > $w - 15} {
1903                set sash0 [expr {$w - 15}]
1904            }
1905        }
1906        $win sash place 0 $sash0 [lindex $s0 1]
1907    }
1908    set oldwidth($win) $w
1909}
1910
1911proc allcanvs args {
1912    global canv canv2 canv3
1913    eval $canv $args
1914    eval $canv2 $args
1915    eval $canv3 $args
1916}
1917
1918proc bindall {event action} {
1919    global canv canv2 canv3
1920    bind $canv $event $action
1921    bind $canv2 $event $action
1922    bind $canv3 $event $action
1923}
1924
1925proc about {} {
1926    global uifont
1927    set w .about
1928    if {[winfo exists $w]} {
1929        raise $w
1930        return
1931    }
1932    toplevel $w
1933    wm title $w "About gitk"
1934    message $w.m -text {
1935Gitk - a commit viewer for git
1936
1937Copyright © 2005-2007 Paul Mackerras
1938
1939Use and redistribute under the terms of the GNU General Public License} \
1940            -justify center -aspect 400 -border 2 -bg white -relief groove
1941    pack $w.m -side top -fill x -padx 2 -pady 2
1942    $w.m configure -font uifont
1943    button $w.ok -text Close -command "destroy $w" -default active
1944    pack $w.ok -side bottom
1945    $w.ok configure -font uifont
1946    bind $w <Visibility> "focus $w.ok"
1947    bind $w <Key-Escape> "destroy $w"
1948    bind $w <Key-Return> "destroy $w"
1949}
1950
1951proc keys {} {
1952    global uifont
1953    set w .keys
1954    if {[winfo exists $w]} {
1955        raise $w
1956        return
1957    }
1958    if {[tk windowingsystem] eq {aqua}} {
1959        set M1T Cmd
1960    } else {
1961        set M1T Ctrl
1962    }
1963    toplevel $w
1964    wm title $w "Gitk key bindings"
1965    message $w.m -text "
1966Gitk key bindings:
1967
1968<$M1T-Q>                Quit
1969<Home>          Move to first commit
1970<End>           Move to last commit
1971<Up>, p, i      Move up one commit
1972<Down>, n, k    Move down one commit
1973<Left>, z, j    Go back in history list
1974<Right>, x, l   Go forward in history list
1975<PageUp>        Move up one page in commit list
1976<PageDown>      Move down one page in commit list
1977<$M1T-Home>     Scroll to top of commit list
1978<$M1T-End>      Scroll to bottom of commit list
1979<$M1T-Up>       Scroll commit list up one line
1980<$M1T-Down>     Scroll commit list down one line
1981<$M1T-PageUp>   Scroll commit list up one page
1982<$M1T-PageDown> Scroll commit list down one page
1983<Shift-Up>      Find backwards (upwards, later commits)
1984<Shift-Down>    Find forwards (downwards, earlier commits)
1985<Delete>, b     Scroll diff view up one page
1986<Backspace>     Scroll diff view up one page
1987<Space>         Scroll diff view down one page
1988u               Scroll diff view up 18 lines
1989d               Scroll diff view down 18 lines
1990<$M1T-F>                Find
1991<$M1T-G>                Move to next find hit
1992<Return>        Move to next find hit
1993/               Move to next find hit, or redo find
1994?               Move to previous find hit
1995f               Scroll diff view to next file
1996<$M1T-S>                Search for next hit in diff view
1997<$M1T-R>                Search for previous hit in diff view
1998<$M1T-KP+>      Increase font size
1999<$M1T-plus>     Increase font size
2000<$M1T-KP->      Decrease font size
2001<$M1T-minus>    Decrease font size
2002<F5>            Update
2003" \
2004            -justify left -bg white -border 2 -relief groove
2005    pack $w.m -side top -fill both -padx 2 -pady 2
2006    $w.m configure -font uifont
2007    button $w.ok -text Close -command "destroy $w" -default active
2008    pack $w.ok -side bottom
2009    $w.ok configure -font uifont
2010    bind $w <Visibility> "focus $w.ok"
2011    bind $w <Key-Escape> "destroy $w"
2012    bind $w <Key-Return> "destroy $w"
2013}
2014
2015# Procedures for manipulating the file list window at the
2016# bottom right of the overall window.
2017
2018proc treeview {w l openlevs} {
2019    global treecontents treediropen treeheight treeparent treeindex
2020
2021    set ix 0
2022    set treeindex() 0
2023    set lev 0
2024    set prefix {}
2025    set prefixend -1
2026    set prefendstack {}
2027    set htstack {}
2028    set ht 0
2029    set treecontents() {}
2030    $w conf -state normal
2031    foreach f $l {
2032        while {[string range $f 0 $prefixend] ne $prefix} {
2033            if {$lev <= $openlevs} {
2034                $w mark set e:$treeindex($prefix) "end -1c"
2035                $w mark gravity e:$treeindex($prefix) left
2036            }
2037            set treeheight($prefix) $ht
2038            incr ht [lindex $htstack end]
2039            set htstack [lreplace $htstack end end]
2040            set prefixend [lindex $prefendstack end]
2041            set prefendstack [lreplace $prefendstack end end]
2042            set prefix [string range $prefix 0 $prefixend]
2043            incr lev -1
2044        }
2045        set tail [string range $f [expr {$prefixend+1}] end]
2046        while {[set slash [string first "/" $tail]] >= 0} {
2047            lappend htstack $ht
2048            set ht 0
2049            lappend prefendstack $prefixend
2050            incr prefixend [expr {$slash + 1}]
2051            set d [string range $tail 0 $slash]
2052            lappend treecontents($prefix) $d
2053            set oldprefix $prefix
2054            append prefix $d
2055            set treecontents($prefix) {}
2056            set treeindex($prefix) [incr ix]
2057            set treeparent($prefix) $oldprefix
2058            set tail [string range $tail [expr {$slash+1}] end]
2059            if {$lev <= $openlevs} {
2060                set ht 1
2061                set treediropen($prefix) [expr {$lev < $openlevs}]
2062                set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
2063                $w mark set d:$ix "end -1c"
2064                $w mark gravity d:$ix left
2065                set str "\n"
2066                for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2067                $w insert end $str
2068                $w image create end -align center -image $bm -padx 1 \
2069                    -name a:$ix
2070                $w insert end $d [highlight_tag $prefix]
2071                $w mark set s:$ix "end -1c"
2072                $w mark gravity s:$ix left
2073            }
2074            incr lev
2075        }
2076        if {$tail ne {}} {
2077            if {$lev <= $openlevs} {
2078                incr ht
2079                set str "\n"
2080                for {set i 0} {$i < $lev} {incr i} {append str "\t"}
2081                $w insert end $str
2082                $w insert end $tail [highlight_tag $f]
2083            }
2084            lappend treecontents($prefix) $tail
2085        }
2086    }
2087    while {$htstack ne {}} {
2088        set treeheight($prefix) $ht
2089        incr ht [lindex $htstack end]
2090        set htstack [lreplace $htstack end end]
2091        set prefixend [lindex $prefendstack end]
2092        set prefendstack [lreplace $prefendstack end end]
2093        set prefix [string range $prefix 0 $prefixend]
2094    }
2095    $w conf -state disabled
2096}
2097
2098proc linetoelt {l} {
2099    global treeheight treecontents
2100
2101    set y 2
2102    set prefix {}
2103    while {1} {
2104        foreach e $treecontents($prefix) {
2105            if {$y == $l} {
2106                return "$prefix$e"
2107            }
2108            set n 1
2109            if {[string index $e end] eq "/"} {
2110                set n $treeheight($prefix$e)
2111                if {$y + $n > $l} {
2112                    append prefix $e
2113                    incr y
2114                    break
2115                }
2116            }
2117            incr y $n
2118        }
2119    }
2120}
2121
2122proc highlight_tree {y prefix} {
2123    global treeheight treecontents cflist
2124
2125    foreach e $treecontents($prefix) {
2126        set path $prefix$e
2127        if {[highlight_tag $path] ne {}} {
2128            $cflist tag add bold $y.0 "$y.0 lineend"
2129        }
2130        incr y
2131        if {[string index $e end] eq "/" && $treeheight($path) > 1} {
2132            set y [highlight_tree $y $path]
2133        }
2134    }
2135    return $y
2136}
2137
2138proc treeclosedir {w dir} {
2139    global treediropen treeheight treeparent treeindex
2140
2141    set ix $treeindex($dir)
2142    $w conf -state normal
2143    $w delete s:$ix e:$ix
2144    set treediropen($dir) 0
2145    $w image configure a:$ix -image tri-rt
2146    $w conf -state disabled
2147    set n [expr {1 - $treeheight($dir)}]
2148    while {$dir ne {}} {
2149        incr treeheight($dir) $n
2150        set dir $treeparent($dir)
2151    }
2152}
2153
2154proc treeopendir {w dir} {
2155    global treediropen treeheight treeparent treecontents treeindex
2156
2157    set ix $treeindex($dir)
2158    $w conf -state normal
2159    $w image configure a:$ix -image tri-dn
2160    $w mark set e:$ix s:$ix
2161    $w mark gravity e:$ix right
2162    set lev 0
2163    set str "\n"
2164    set n [llength $treecontents($dir)]
2165    for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
2166        incr lev
2167        append str "\t"
2168        incr treeheight($x) $n
2169    }
2170    foreach e $treecontents($dir) {
2171        set de $dir$e
2172        if {[string index $e end] eq "/"} {
2173            set iy $treeindex($de)
2174            $w mark set d:$iy e:$ix
2175            $w mark gravity d:$iy left
2176            $w insert e:$ix $str
2177            set treediropen($de) 0
2178            $w image create e:$ix -align center -image tri-rt -padx 1 \
2179                -name a:$iy
2180            $w insert e:$ix $e [highlight_tag $de]
2181            $w mark set s:$iy e:$ix
2182            $w mark gravity s:$iy left
2183            set treeheight($de) 1
2184        } else {
2185            $w insert e:$ix $str
2186            $w insert e:$ix $e [highlight_tag $de]
2187        }
2188    }
2189    $w mark gravity e:$ix left
2190    $w conf -state disabled
2191    set treediropen($dir) 1
2192    set top [lindex [split [$w index @0,0] .] 0]
2193    set ht [$w cget -height]
2194    set l [lindex [split [$w index s:$ix] .] 0]
2195    if {$l < $top} {
2196        $w yview $l.0
2197    } elseif {$l + $n + 1 > $top + $ht} {
2198        set top [expr {$l + $n + 2 - $ht}]
2199        if {$l < $top} {
2200            set top $l
2201        }
2202        $w yview $top.0
2203    }
2204}
2205
2206proc treeclick {w x y} {
2207    global treediropen cmitmode ctext cflist cflist_top
2208
2209    if {$cmitmode ne "tree"} return
2210    if {![info exists cflist_top]} return
2211    set l [lindex [split [$w index "@$x,$y"] "."] 0]
2212    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2213    $cflist tag add highlight $l.0 "$l.0 lineend"
2214    set cflist_top $l
2215    if {$l == 1} {
2216        $ctext yview 1.0
2217        return
2218    }
2219    set e [linetoelt $l]
2220    if {[string index $e end] ne "/"} {
2221        showfile $e
2222    } elseif {$treediropen($e)} {
2223        treeclosedir $w $e
2224    } else {
2225        treeopendir $w $e
2226    }
2227}
2228
2229proc setfilelist {id} {
2230    global treefilelist cflist
2231
2232    treeview $cflist $treefilelist($id) 0
2233}
2234
2235image create bitmap tri-rt -background black -foreground blue -data {
2236    #define tri-rt_width 13
2237    #define tri-rt_height 13
2238    static unsigned char tri-rt_bits[] = {
2239       0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
2240       0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
2241       0x00, 0x00};
2242} -maskdata {
2243    #define tri-rt-mask_width 13
2244    #define tri-rt-mask_height 13
2245    static unsigned char tri-rt-mask_bits[] = {
2246       0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
2247       0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
2248       0x08, 0x00};
2249}
2250image create bitmap tri-dn -background black -foreground blue -data {
2251    #define tri-dn_width 13
2252    #define tri-dn_height 13
2253    static unsigned char tri-dn_bits[] = {
2254       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
2255       0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
2256       0x00, 0x00};
2257} -maskdata {
2258    #define tri-dn-mask_width 13
2259    #define tri-dn-mask_height 13
2260    static unsigned char tri-dn-mask_bits[] = {
2261       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
2262       0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
2263       0x00, 0x00};
2264}
2265
2266image create bitmap reficon-T -background black -foreground yellow -data {
2267    #define tagicon_width 13
2268    #define tagicon_height 9
2269    static unsigned char tagicon_bits[] = {
2270       0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
2271       0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
2272} -maskdata {
2273    #define tagicon-mask_width 13
2274    #define tagicon-mask_height 9
2275    static unsigned char tagicon-mask_bits[] = {
2276       0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
2277       0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
2278}
2279set rectdata {
2280    #define headicon_width 13
2281    #define headicon_height 9
2282    static unsigned char headicon_bits[] = {
2283       0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
2284       0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
2285}
2286set rectmask {
2287    #define headicon-mask_width 13
2288    #define headicon-mask_height 9
2289    static unsigned char headicon-mask_bits[] = {
2290       0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
2291       0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
2292}
2293image create bitmap reficon-H -background black -foreground green \
2294    -data $rectdata -maskdata $rectmask
2295image create bitmap reficon-o -background black -foreground "#ddddff" \
2296    -data $rectdata -maskdata $rectmask
2297
2298proc init_flist {first} {
2299    global cflist cflist_top difffilestart
2300
2301    $cflist conf -state normal
2302    $cflist delete 0.0 end
2303    if {$first ne {}} {
2304        $cflist insert end $first
2305        set cflist_top 1
2306        $cflist tag add highlight 1.0 "1.0 lineend"
2307    } else {
2308        catch {unset cflist_top}
2309    }
2310    $cflist conf -state disabled
2311    set difffilestart {}
2312}
2313
2314proc highlight_tag {f} {
2315    global highlight_paths
2316
2317    foreach p $highlight_paths {
2318        if {[string match $p $f]} {
2319            return "bold"
2320        }
2321    }
2322    return {}
2323}
2324
2325proc highlight_filelist {} {
2326    global cmitmode cflist
2327
2328    $cflist conf -state normal
2329    if {$cmitmode ne "tree"} {
2330        set end [lindex [split [$cflist index end] .] 0]
2331        for {set l 2} {$l < $end} {incr l} {
2332            set line [$cflist get $l.0 "$l.0 lineend"]
2333            if {[highlight_tag $line] ne {}} {
2334                $cflist tag add bold $l.0 "$l.0 lineend"
2335            }
2336        }
2337    } else {
2338        highlight_tree 2 {}
2339    }
2340    $cflist conf -state disabled
2341}
2342
2343proc unhighlight_filelist {} {
2344    global cflist
2345
2346    $cflist conf -state normal
2347    $cflist tag remove bold 1.0 end
2348    $cflist conf -state disabled
2349}
2350
2351proc add_flist {fl} {
2352    global cflist
2353
2354    $cflist conf -state normal
2355    foreach f $fl {
2356        $cflist insert end "\n"
2357        $cflist insert end $f [highlight_tag $f]
2358    }
2359    $cflist conf -state disabled
2360}
2361
2362proc sel_flist {w x y} {
2363    global ctext difffilestart cflist cflist_top cmitmode
2364
2365    if {$cmitmode eq "tree"} return
2366    if {![info exists cflist_top]} return
2367    set l [lindex [split [$w index "@$x,$y"] "."] 0]
2368    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
2369    $cflist tag add highlight $l.0 "$l.0 lineend"
2370    set cflist_top $l
2371    if {$l == 1} {
2372        $ctext yview 1.0
2373    } else {
2374        catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
2375    }
2376}
2377
2378proc pop_flist_menu {w X Y x y} {
2379    global ctext cflist cmitmode flist_menu flist_menu_file
2380    global treediffs diffids
2381
2382    stopfinding
2383    set l [lindex [split [$w index "@$x,$y"] "."] 0]
2384    if {$l <= 1} return
2385    if {$cmitmode eq "tree"} {
2386        set e [linetoelt $l]
2387        if {[string index $e end] eq "/"} return
2388    } else {
2389        set e [lindex $treediffs($diffids) [expr {$l-2}]]
2390    }
2391    set flist_menu_file $e
2392    tk_popup $flist_menu $X $Y
2393}
2394
2395proc flist_hl {only} {
2396    global flist_menu_file findstring gdttype
2397
2398    set x [shellquote $flist_menu_file]
2399    if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
2400        set findstring $x
2401    } else {
2402        append findstring " " $x
2403    }
2404    set gdttype "touching paths:"
2405}
2406
2407# Functions for adding and removing shell-type quoting
2408
2409proc shellquote {str} {
2410    if {![string match "*\['\"\\ \t]*" $str]} {
2411        return $str
2412    }
2413    if {![string match "*\['\"\\]*" $str]} {
2414        return "\"$str\""
2415    }
2416    if {![string match "*'*" $str]} {
2417        return "'$str'"
2418    }
2419    return "\"[string map {\" \\\" \\ \\\\} $str]\""
2420}
2421
2422proc shellarglist {l} {
2423    set str {}
2424    foreach a $l {
2425        if {$str ne {}} {
2426            append str " "
2427        }
2428        append str [shellquote $a]
2429    }
2430    return $str
2431}
2432
2433proc shelldequote {str} {
2434    set ret {}
2435    set used -1
2436    while {1} {
2437        incr used
2438        if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
2439            append ret [string range $str $used end]
2440            set used [string length $str]
2441            break
2442        }
2443        set first [lindex $first 0]
2444        set ch [string index $str $first]
2445        if {$first > $used} {
2446            append ret [string range $str $used [expr {$first - 1}]]
2447            set used $first
2448        }
2449        if {$ch eq " " || $ch eq "\t"} break
2450        incr used
2451        if {$ch eq "'"} {
2452            set first [string first "'" $str $used]
2453            if {$first < 0} {
2454                error "unmatched single-quote"
2455            }
2456            append ret [string range $str $used [expr {$first - 1}]]
2457            set used $first
2458            continue
2459        }
2460        if {$ch eq "\\"} {
2461            if {$used >= [string length $str]} {
2462                error "trailing backslash"
2463            }
2464            append ret [string index $str $used]
2465            continue
2466        }
2467        # here ch == "\""
2468        while {1} {
2469            if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
2470                error "unmatched double-quote"
2471            }
2472            set first [lindex $first 0]
2473            set ch [string index $str $first]
2474            if {$first > $used} {
2475                append ret [string range $str $used [expr {$first - 1}]]
2476                set used $first
2477            }
2478            if {$ch eq "\""} break
2479            incr used
2480            append ret [string index $str $used]
2481            incr used
2482        }
2483    }
2484    return [list $used $ret]
2485}
2486
2487proc shellsplit {str} {
2488    set l {}
2489    while {1} {
2490        set str [string trimleft $str]
2491        if {$str eq {}} break
2492        set dq [shelldequote $str]
2493        set n [lindex $dq 0]
2494        set word [lindex $dq 1]
2495        set str [string range $str $n end]
2496        lappend l $word
2497    }
2498    return $l
2499}
2500
2501# Code to implement multiple views
2502
2503proc newview {ishighlight} {
2504    global nextviewnum newviewname newviewperm uifont newishighlight
2505    global newviewargs revtreeargs
2506
2507    set newishighlight $ishighlight
2508    set top .gitkview
2509    if {[winfo exists $top]} {
2510        raise $top
2511        return
2512    }
2513    set newviewname($nextviewnum) "View $nextviewnum"
2514    set newviewperm($nextviewnum) 0
2515    set newviewargs($nextviewnum) [shellarglist $revtreeargs]
2516    vieweditor $top $nextviewnum "Gitk view definition"
2517}
2518
2519proc editview {} {
2520    global curview
2521    global viewname viewperm newviewname newviewperm
2522    global viewargs newviewargs
2523
2524    set top .gitkvedit-$curview
2525    if {[winfo exists $top]} {
2526        raise $top
2527        return
2528    }
2529    set newviewname($curview) $viewname($curview)
2530    set newviewperm($curview) $viewperm($curview)
2531    set newviewargs($curview) [shellarglist $viewargs($curview)]
2532    vieweditor $top $curview "Gitk: edit view $viewname($curview)"
2533}
2534
2535proc vieweditor {top n title} {
2536    global newviewname newviewperm viewfiles
2537    global uifont
2538
2539    toplevel $top
2540    wm title $top $title
2541    label $top.nl -text "Name" -font uifont
2542    entry $top.name -width 20 -textvariable newviewname($n) -font uifont
2543    grid $top.nl $top.name -sticky w -pady 5
2544    checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
2545        -font uifont
2546    grid $top.perm - -pady 5 -sticky w
2547    message $top.al -aspect 1000 -font uifont \
2548        -text "Commits to include (arguments to git rev-list):"
2549    grid $top.al - -sticky w -pady 5
2550    entry $top.args -width 50 -textvariable newviewargs($n) \
2551        -background white -font uifont
2552    grid $top.args - -sticky ew -padx 5
2553    message $top.l -aspect 1000 -font uifont \
2554        -text "Enter files and directories to include, one per line:"
2555    grid $top.l - -sticky w
2556    text $top.t -width 40 -height 10 -background white -font uifont
2557    if {[info exists viewfiles($n)]} {
2558        foreach f $viewfiles($n) {
2559            $top.t insert end $f
2560            $top.t insert end "\n"
2561        }
2562        $top.t delete {end - 1c} end
2563        $top.t mark set insert 0.0
2564    }
2565    grid $top.t - -sticky ew -padx 5
2566    frame $top.buts
2567    button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
2568        -font uifont
2569    button $top.buts.can -text "Cancel" -command [list destroy $top] \
2570        -font uifont
2571    grid $top.buts.ok $top.buts.can
2572    grid columnconfigure $top.buts 0 -weight 1 -uniform a
2573    grid columnconfigure $top.buts 1 -weight 1 -uniform a
2574    grid $top.buts - -pady 10 -sticky ew
2575    focus $top.t
2576}
2577
2578proc doviewmenu {m first cmd op argv} {
2579    set nmenu [$m index end]
2580    for {set i $first} {$i <= $nmenu} {incr i} {
2581        if {[$m entrycget $i -command] eq $cmd} {
2582            eval $m $op $i $argv
2583            break
2584        }
2585    }
2586}
2587
2588proc allviewmenus {n op args} {
2589    # global viewhlmenu
2590
2591    doviewmenu .bar.view 5 [list showview $n] $op $args
2592    # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2593}
2594
2595proc newviewok {top n} {
2596    global nextviewnum newviewperm newviewname newishighlight
2597    global viewname viewfiles viewperm selectedview curview
2598    global viewargs newviewargs viewhlmenu
2599
2600    if {[catch {
2601        set newargs [shellsplit $newviewargs($n)]
2602    } err]} {
2603        error_popup "Error in commit selection arguments: $err"
2604        wm raise $top
2605        focus $top
2606        return
2607    }
2608    set files {}
2609    foreach f [split [$top.t get 0.0 end] "\n"] {
2610        set ft [string trim $f]
2611        if {$ft ne {}} {
2612            lappend files $ft
2613        }
2614    }
2615    if {![info exists viewfiles($n)]} {
2616        # creating a new view
2617        incr nextviewnum
2618        set viewname($n) $newviewname($n)
2619        set viewperm($n) $newviewperm($n)
2620        set viewfiles($n) $files
2621        set viewargs($n) $newargs
2622        addviewmenu $n
2623        if {!$newishighlight} {
2624            run showview $n
2625        } else {
2626            run addvhighlight $n
2627        }
2628    } else {
2629        # editing an existing view
2630        set viewperm($n) $newviewperm($n)
2631        if {$newviewname($n) ne $viewname($n)} {
2632            set viewname($n) $newviewname($n)
2633            doviewmenu .bar.view 5 [list showview $n] \
2634                entryconf [list -label $viewname($n)]
2635            # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2636                # entryconf [list -label $viewname($n) -value $viewname($n)]
2637        }
2638        if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
2639            set viewfiles($n) $files
2640            set viewargs($n) $newargs
2641            if {$curview == $n} {
2642                run reloadcommits
2643            }
2644        }
2645    }
2646    catch {destroy $top}
2647}
2648
2649proc delview {} {
2650    global curview viewperm hlview selectedhlview
2651
2652    if {$curview == 0} return
2653    if {[info exists hlview] && $hlview == $curview} {
2654        set selectedhlview None
2655        unset hlview
2656    }
2657    allviewmenus $curview delete
2658    set viewperm($curview) 0
2659    showview 0
2660}
2661
2662proc addviewmenu {n} {
2663    global viewname viewhlmenu
2664
2665    .bar.view add radiobutton -label $viewname($n) \
2666        -command [list showview $n] -variable selectedview -value $n
2667    #$viewhlmenu add radiobutton -label $viewname($n) \
2668    #   -command [list addvhighlight $n] -variable selectedhlview
2669}
2670
2671proc showview {n} {
2672    global curview viewfiles cached_commitrow ordertok
2673    global displayorder parentlist rowidlist rowisopt rowfinal
2674    global colormap rowtextx nextcolor canvxmax
2675    global numcommits viewcomplete
2676    global selectedline currentid canv canvy0
2677    global treediffs
2678    global pending_select
2679    global commitidx
2680    global selectedview selectfirst
2681    global hlview selectedhlview commitinterest
2682
2683    if {$n == $curview} return
2684    set selid {}
2685    set ymax [lindex [$canv cget -scrollregion] 3]
2686    set span [$canv yview]
2687    set ytop [expr {[lindex $span 0] * $ymax}]
2688    set ybot [expr {[lindex $span 1] * $ymax}]
2689    set yscreen [expr {($ybot - $ytop) / 2}]
2690    if {[info exists selectedline]} {
2691        set selid $currentid
2692        set y [yc $selectedline]
2693        if {$ytop < $y && $y < $ybot} {
2694            set yscreen [expr {$y - $ytop}]
2695        }
2696    } elseif {[info exists pending_select]} {
2697        set selid $pending_select
2698        unset pending_select
2699    }
2700    unselectline
2701    normalline
2702    catch {unset treediffs}
2703    clear_display
2704    if {[info exists hlview] && $hlview == $n} {
2705        unset hlview
2706        set selectedhlview None
2707    }
2708    catch {unset commitinterest}
2709    catch {unset cached_commitrow}
2710    catch {unset ordertok}
2711
2712    set curview $n
2713    set selectedview $n
2714    .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2715    .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2716
2717    run refill_reflist
2718    if {![info exists viewcomplete($n)]} {
2719        if {$selid ne {}} {
2720            set pending_select $selid
2721        }
2722        getcommits
2723        return
2724    }
2725
2726    set displayorder {}
2727    set parentlist {}
2728    set rowidlist {}
2729    set rowisopt {}
2730    set rowfinal {}
2731    set numcommits $commitidx($n)
2732
2733    catch {unset colormap}
2734    catch {unset rowtextx}
2735    set nextcolor 0
2736    set canvxmax [$canv cget -width]
2737    set curview $n
2738    set row 0
2739    setcanvscroll
2740    set yf 0
2741    set row {}
2742    set selectfirst 0
2743    if {$selid ne {} && [commitinview $selid $n]} {
2744        set row [rowofcommit $selid]
2745        # try to get the selected row in the same position on the screen
2746        set ymax [lindex [$canv cget -scrollregion] 3]
2747        set ytop [expr {[yc $row] - $yscreen}]
2748        if {$ytop < 0} {
2749            set ytop 0
2750        }
2751        set yf [expr {$ytop * 1.0 / $ymax}]
2752    }
2753    allcanvs yview moveto $yf
2754    drawvisible
2755    if {$row ne {}} {
2756        selectline $row 0
2757    } elseif {$selid ne {}} {
2758        set pending_select $selid
2759    } else {
2760        set row [first_real_row]
2761        if {$row < $numcommits} {
2762            selectline $row 0
2763        } else {
2764            set selectfirst 1
2765        }
2766    }
2767    if {!$viewcomplete($n)} {
2768        if {$numcommits == 0} {
2769            show_status "Reading commits..."
2770        } else {
2771            run chewcommits $n
2772        }
2773    } elseif {$numcommits == 0} {
2774        show_status "No commits selected"
2775    }
2776}
2777
2778# Stuff relating to the highlighting facility
2779
2780proc ishighlighted {row} {
2781    global vhighlights fhighlights nhighlights rhighlights
2782
2783    if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2784        return $nhighlights($row)
2785    }
2786    if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2787        return $vhighlights($row)
2788    }
2789    if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2790        return $fhighlights($row)
2791    }
2792    if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2793        return $rhighlights($row)
2794    }
2795    return 0
2796}
2797
2798proc bolden {row font} {
2799    global canv linehtag selectedline boldrows
2800
2801    lappend boldrows $row
2802    $canv itemconf $linehtag($row) -font $font
2803    if {[info exists selectedline] && $row == $selectedline} {
2804        $canv delete secsel
2805        set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2806                   -outline {{}} -tags secsel \
2807                   -fill [$canv cget -selectbackground]]
2808        $canv lower $t
2809    }
2810}
2811
2812proc bolden_name {row font} {
2813    global canv2 linentag selectedline boldnamerows
2814
2815    lappend boldnamerows $row
2816    $canv2 itemconf $linentag($row) -font $font
2817    if {[info exists selectedline] && $row == $selectedline} {
2818        $canv2 delete secsel
2819        set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2820                   -outline {{}} -tags secsel \
2821                   -fill [$canv2 cget -selectbackground]]
2822        $canv2 lower $t
2823    }
2824}
2825
2826proc unbolden {} {
2827    global boldrows
2828
2829    set stillbold {}
2830    foreach row $boldrows {
2831        if {![ishighlighted $row]} {
2832            bolden $row mainfont
2833        } else {
2834            lappend stillbold $row
2835        }
2836    }
2837    set boldrows $stillbold
2838}
2839
2840proc addvhighlight {n} {
2841    global hlview viewcomplete curview vhl_done vhighlights commitidx
2842
2843    if {[info exists hlview]} {
2844        delvhighlight
2845    }
2846    set hlview $n
2847    if {$n != $curview && ![info exists viewcomplete($n)]} {
2848        start_rev_list $n
2849    }
2850    set vhl_done $commitidx($hlview)
2851    if {$vhl_done > 0} {
2852        drawvisible
2853    }
2854}
2855
2856proc delvhighlight {} {
2857    global hlview vhighlights
2858
2859    if {![info exists hlview]} return
2860    unset hlview
2861    catch {unset vhighlights}
2862    unbolden
2863}
2864
2865proc vhighlightmore {} {
2866    global hlview vhl_done commitidx vhighlights curview
2867
2868    set max $commitidx($hlview)
2869    set vr [visiblerows]
2870    set r0 [lindex $vr 0]
2871    set r1 [lindex $vr 1]
2872    for {set i $vhl_done} {$i < $max} {incr i} {
2873        set id [commitonrow $i $hlview]
2874        if {[commitinview $id $curview]} {
2875            set row [rowofcommit $id]
2876            if {$r0 <= $row && $row <= $r1} {
2877                if {![highlighted $row]} {
2878                    bolden $row mainfontbold
2879                }
2880                set vhighlights($row) 1
2881            }
2882        }
2883    }
2884    set vhl_done $max
2885}
2886
2887proc askvhighlight {row id} {
2888    global hlview vhighlights iddrawn
2889
2890    if {[commitinview $id $hlview]} {
2891        if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2892            bolden $row mainfontbold
2893        }
2894        set vhighlights($row) 1
2895    } else {
2896        set vhighlights($row) 0
2897    }
2898}
2899
2900proc hfiles_change {} {
2901    global highlight_files filehighlight fhighlights fh_serial
2902    global highlight_paths gdttype
2903
2904    if {[info exists filehighlight]} {
2905        # delete previous highlights
2906        catch {close $filehighlight}
2907        unset filehighlight
2908        catch {unset fhighlights}
2909        unbolden
2910        unhighlight_filelist
2911    }
2912    set highlight_paths {}
2913    after cancel do_file_hl $fh_serial
2914    incr fh_serial
2915    if {$highlight_files ne {}} {
2916        after 300 do_file_hl $fh_serial
2917    }
2918}
2919
2920proc gdttype_change {name ix op} {
2921    global gdttype highlight_files findstring findpattern
2922
2923    stopfinding
2924    if {$findstring ne {}} {
2925        if {$gdttype eq "containing:"} {
2926            if {$highlight_files ne {}} {
2927                set highlight_files {}
2928                hfiles_change
2929            }
2930            findcom_change
2931        } else {
2932            if {$findpattern ne {}} {
2933                set findpattern {}
2934                findcom_change
2935            }
2936            set highlight_files $findstring
2937            hfiles_change
2938        }
2939        drawvisible
2940    }
2941    # enable/disable findtype/findloc menus too
2942}
2943
2944proc find_change {name ix op} {
2945    global gdttype findstring highlight_files
2946
2947    stopfinding
2948    if {$gdttype eq "containing:"} {
2949        findcom_change
2950    } else {
2951        if {$highlight_files ne $findstring} {
2952            set highlight_files $findstring
2953            hfiles_change
2954        }
2955    }
2956    drawvisible
2957}
2958
2959proc findcom_change args {
2960    global nhighlights boldnamerows
2961    global findpattern findtype findstring gdttype
2962
2963    stopfinding
2964    # delete previous highlights, if any
2965    foreach row $boldnamerows {
2966        bolden_name $row mainfont
2967    }
2968    set boldnamerows {}
2969    catch {unset nhighlights}
2970    unbolden
2971    unmarkmatches
2972    if {$gdttype ne "containing:" || $findstring eq {}} {
2973        set findpattern {}
2974    } elseif {$findtype eq "Regexp"} {
2975        set findpattern $findstring
2976    } else {
2977        set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2978                   $findstring]
2979        set findpattern "*$e*"
2980    }
2981}
2982
2983proc makepatterns {l} {
2984    set ret {}
2985    foreach e $l {
2986        set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2987        if {[string index $ee end] eq "/"} {
2988            lappend ret "$ee*"
2989        } else {
2990            lappend ret $ee
2991            lappend ret "$ee/*"
2992        }
2993    }
2994    return $ret
2995}
2996
2997proc do_file_hl {serial} {
2998    global highlight_files filehighlight highlight_paths gdttype fhl_list
2999
3000    if {$gdttype eq "touching paths:"} {
3001        if {[catch {set paths [shellsplit $highlight_files]}]} return
3002        set highlight_paths [makepatterns $paths]
3003        highlight_filelist
3004        set gdtargs [concat -- $paths]
3005    } elseif {$gdttype eq "adding/removing string:"} {
3006        set gdtargs [list "-S$highlight_files"]
3007    } else {
3008        # must be "containing:", i.e. we're searching commit info
3009        return
3010    }
3011    set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
3012    set filehighlight [open $cmd r+]
3013    fconfigure $filehighlight -blocking 0
3014    filerun $filehighlight readfhighlight
3015    set fhl_list {}
3016    drawvisible
3017    flushhighlights
3018}
3019
3020proc flushhighlights {} {
3021    global filehighlight fhl_list
3022
3023    if {[info exists filehighlight]} {
3024        lappend fhl_list {}
3025        puts $filehighlight ""
3026        flush $filehighlight
3027    }
3028}
3029
3030proc askfilehighlight {row id} {
3031    global filehighlight fhighlights fhl_list
3032
3033    lappend fhl_list $id
3034    set fhighlights($row) -1
3035    puts $filehighlight $id
3036}
3037
3038proc readfhighlight {} {
3039    global filehighlight fhighlights curview iddrawn
3040    global fhl_list find_dirn
3041
3042    if {![info exists filehighlight]} {
3043        return 0
3044    }
3045    set nr 0
3046    while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
3047        set line [string trim $line]
3048        set i [lsearch -exact $fhl_list $line]
3049        if {$i < 0} continue
3050        for {set j 0} {$j < $i} {incr j} {
3051            set id [lindex $fhl_list $j]
3052            if {[commitinview $id $curview]} {
3053                set fhighlights([rowofcommit $id]) 0
3054            }
3055        }
3056        set fhl_list [lrange $fhl_list [expr {$i+1}] end]
3057        if {$line eq {}} continue
3058        if {![commitinview $line $curview]} continue
3059        set row [rowofcommit $line]
3060        if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
3061            bolden $row mainfontbold
3062        }
3063        set fhighlights($row) 1
3064    }
3065    if {[eof $filehighlight]} {
3066        # strange...
3067        puts "oops, git diff-tree died"
3068        catch {close $filehighlight}
3069        unset filehighlight
3070        return 0
3071    }
3072    if {[info exists find_dirn]} {
3073        run findmore
3074    }
3075    return 1
3076}
3077
3078proc doesmatch {f} {
3079    global findtype findpattern
3080
3081    if {$findtype eq "Regexp"} {
3082        return [regexp $findpattern $f]
3083    } elseif {$findtype eq "IgnCase"} {
3084        return [string match -nocase $findpattern $f]
3085    } else {
3086        return [string match $findpattern $f]
3087    }
3088}
3089
3090proc askfindhighlight {row id} {
3091    global nhighlights commitinfo iddrawn
3092    global findloc
3093    global markingmatches
3094
3095    if {![info exists commitinfo($id)]} {
3096        getcommit $id
3097    }
3098    set info $commitinfo($id)
3099    set isbold 0
3100    set fldtypes {Headline Author Date Committer CDate Comments}
3101    foreach f $info ty $fldtypes {
3102        if {($findloc eq "All fields" || $findloc eq $ty) &&
3103            [doesmatch $f]} {
3104            if {$ty eq "Author"} {
3105                set isbold 2
3106                break
3107            }
3108            set isbold 1
3109        }
3110    }
3111    if {$isbold && [info exists iddrawn($id)]} {
3112        if {![ishighlighted $row]} {
3113            bolden $row mainfontbold
3114            if {$isbold > 1} {
3115                bolden_name $row mainfontbold
3116            }
3117        }
3118        if {$markingmatches} {
3119            markrowmatches $row $id
3120        }
3121    }
3122    set nhighlights($row) $isbold
3123}
3124
3125proc markrowmatches {row id} {
3126    global canv canv2 linehtag linentag commitinfo findloc
3127
3128    set headline [lindex $commitinfo($id) 0]
3129    set author [lindex $commitinfo($id) 1]
3130    $canv delete match$row
3131    $canv2 delete match$row
3132    if {$findloc eq "All fields" || $findloc eq "Headline"} {
3133        set m [findmatches $headline]
3134        if {$m ne {}} {
3135            markmatches $canv $row $headline $linehtag($row) $m \
3136                [$canv itemcget $linehtag($row) -font] $row
3137        }
3138    }
3139    if {$findloc eq "All fields" || $findloc eq "Author"} {
3140        set m [findmatches $author]
3141        if {$m ne {}} {
3142            markmatches $canv2 $row $author $linentag($row) $m \
3143                [$canv2 itemcget $linentag($row) -font] $row
3144        }
3145    }
3146}
3147
3148proc vrel_change {name ix op} {
3149    global highlight_related
3150
3151    rhighlight_none
3152    if {$highlight_related ne "None"} {
3153        run drawvisible
3154    }
3155}
3156
3157# prepare for testing whether commits are descendents or ancestors of a
3158proc rhighlight_sel {a} {
3159    global descendent desc_todo ancestor anc_todo
3160    global highlight_related rhighlights
3161
3162    catch {unset descendent}
3163    set desc_todo [list $a]
3164    catch {unset ancestor}
3165    set anc_todo [list $a]
3166    if {$highlight_related ne "None"} {
3167        rhighlight_none
3168        run drawvisible
3169    }
3170}
3171
3172proc rhighlight_none {} {
3173    global rhighlights
3174
3175    catch {unset rhighlights}
3176    unbolden
3177}
3178
3179proc is_descendent {a} {
3180    global curview children descendent desc_todo
3181
3182    set v $curview
3183    set la [rowofcommit $a]
3184    set todo $desc_todo
3185    set leftover {}
3186    set done 0
3187    for {set i 0} {$i < [llength $todo]} {incr i} {
3188        set do [lindex $todo $i]
3189        if {[rowofcommit $do] < $la} {
3190            lappend leftover $do
3191            continue
3192        }
3193        foreach nk $children($v,$do) {
3194            if {![info exists descendent($nk)]} {
3195                set descendent($nk) 1
3196                lappend todo $nk
3197                if {$nk eq $a} {
3198                    set done 1
3199                }
3200            }
3201        }
3202        if {$done} {
3203            set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3204            return
3205        }
3206    }
3207    set descendent($a) 0
3208    set desc_todo $leftover
3209}
3210
3211proc is_ancestor {a} {
3212    global curview parents ancestor anc_todo
3213
3214    set v $curview
3215    set la [rowofcommit $a]
3216    set todo $anc_todo
3217    set leftover {}
3218    set done 0
3219    for {set i 0} {$i < [llength $todo]} {incr i} {
3220        set do [lindex $todo $i]
3221        if {![commitinview $do $v] || [rowofcommit $do] > $la} {
3222            lappend leftover $do
3223            continue
3224        }
3225        foreach np $parents($v,$do) {
3226            if {![info exists ancestor($np)]} {
3227                set ancestor($np) 1
3228                lappend todo $np
3229                if {$np eq $a} {
3230                    set done 1
3231                }
3232            }
3233        }
3234        if {$done} {
3235            set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
3236            return
3237        }
3238    }
3239    set ancestor($a) 0
3240    set anc_todo $leftover
3241}
3242
3243proc askrelhighlight {row id} {
3244    global descendent highlight_related iddrawn rhighlights
3245    global selectedline ancestor
3246
3247    if {![info exists selectedline]} return
3248    set isbold 0
3249    if {$highlight_related eq "Descendent" ||
3250        $highlight_related eq "Not descendent"} {
3251        if {![info exists descendent($id)]} {
3252            is_descendent $id
3253        }
3254        if {$descendent($id) == ($highlight_related eq "Descendent")} {
3255            set isbold 1
3256        }
3257    } elseif {$highlight_related eq "Ancestor" ||
3258              $highlight_related eq "Not ancestor"} {
3259        if {![info exists ancestor($id)]} {
3260            is_ancestor $id
3261        }
3262        if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
3263            set isbold 1
3264        }
3265    }
3266    if {[info exists iddrawn($id)]} {
3267        if {$isbold && ![ishighlighted $row]} {
3268            bolden $row mainfontbold
3269        }
3270    }
3271    set rhighlights($row) $isbold
3272}
3273
3274# Graph layout functions
3275
3276proc shortids {ids} {
3277    set res {}
3278    foreach id $ids {
3279        if {[llength $id] > 1} {
3280            lappend res [shortids $id]
3281        } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
3282            lappend res [string range $id 0 7]
3283        } else {
3284            lappend res $id
3285        }
3286    }
3287    return $res
3288}
3289
3290proc ntimes {n o} {
3291    set ret {}
3292    set o [list $o]
3293    for {set mask 1} {$mask <= $n} {incr mask $mask} {
3294        if {($n & $mask) != 0} {
3295            set ret [concat $ret $o]
3296        }
3297        set o [concat $o $o]
3298    }
3299    return $ret
3300}
3301
3302proc ordertoken {id} {
3303    global ordertok curview varcid varcstart varctok curview parents children
3304    global nullid nullid2
3305
3306    if {[info exists ordertok($id)]} {
3307        return $ordertok($id)
3308    }
3309    set origid $id
3310    set todo {}
3311    while {1} {
3312        if {[info exists varcid($curview,$id)]} {
3313            set a $varcid($curview,$id)
3314            set p [lindex $varcstart($curview) $a]
3315        } else {
3316            set p [lindex $children($curview,$id) 0]
3317        }
3318        if {[info exists ordertok($p)]} {
3319            set tok $ordertok($p)
3320            break
3321        }
3322        if {[llength $children($curview,$p)] == 0} {
3323            # it's a root
3324            set tok [lindex $varctok($curview) $a]
3325            break
3326        }
3327        set id [lindex $children($curview,$p) 0]
3328        if {$id eq $nullid || $id eq $nullid2} {
3329            # XXX treat it as a root
3330            set tok [lindex $varctok($curview) $a]
3331            break
3332        }
3333        if {[llength $parents($curview,$id)] == 1} {
3334            lappend todo [list $p {}]
3335        } else {
3336            set j [lsearch -exact $parents($curview,$id) $p]
3337            if {$j < 0} {
3338                puts "oops didn't find [shortids $p] in parents of [shortids $id]"
3339            }
3340            lappend todo [list $p [strrep $j]]
3341        }
3342    }
3343    for {set i [llength $todo]} {[incr i -1] >= 0} {} {
3344        set p [lindex $todo $i 0]
3345        append tok [lindex $todo $i 1]
3346        set ordertok($p) $tok
3347    }
3348    set ordertok($origid) $tok
3349    return $tok
3350}
3351
3352# Work out where id should go in idlist so that order-token
3353# values increase from left to right
3354proc idcol {idlist id {i 0}} {
3355    set t [ordertoken $id]
3356    if {$i < 0} {
3357        set i 0
3358    }
3359    if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
3360        if {$i > [llength $idlist]} {
3361            set i [llength $idlist]
3362        }
3363        while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
3364        incr i
3365    } else {
3366        if {$t > [ordertoken [lindex $idlist $i]]} {
3367            while {[incr i] < [llength $idlist] &&
3368                   $t >= [ordertoken [lindex $idlist $i]]} {}
3369        }
3370    }
3371    return $i
3372}
3373
3374proc initlayout {} {
3375    global rowidlist rowisopt rowfinal displayorder parentlist
3376    global numcommits canvxmax canv
3377    global nextcolor
3378    global colormap rowtextx
3379    global selectfirst
3380
3381    set numcommits 0
3382    set displayorder {}
3383    set parentlist {}
3384    set nextcolor 0
3385    set rowidlist {}
3386    set rowisopt {}
3387    set rowfinal {}
3388    set canvxmax [$canv cget -width]
3389    catch {unset colormap}
3390    catch {unset rowtextx}
3391    set selectfirst 1
3392}
3393
3394proc setcanvscroll {} {
3395    global canv canv2 canv3 numcommits linespc canvxmax canvy0
3396
3397    set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
3398    $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
3399    $canv2 conf -scrollregion [list 0 0 0 $ymax]
3400    $canv3 conf -scrollregion [list 0 0 0 $ymax]
3401}
3402
3403proc visiblerows {} {
3404    global canv numcommits linespc
3405
3406    set ymax [lindex [$canv cget -scrollregion] 3]
3407    if {$ymax eq {} || $ymax == 0} return
3408    set f [$canv yview]
3409    set y0 [expr {int([lindex $f 0] * $ymax)}]
3410    set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
3411    if {$r0 < 0} {
3412        set r0 0
3413    }
3414    set y1 [expr {int([lindex $f 1] * $ymax)}]
3415    set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
3416    if {$r1 >= $numcommits} {
3417        set r1 [expr {$numcommits - 1}]
3418    }
3419    return [list $r0 $r1]
3420}
3421
3422proc layoutmore {} {
3423    global commitidx viewcomplete curview
3424    global numcommits pending_select selectedline curview
3425    global selectfirst lastscrollset commitinterest
3426
3427    set canshow $commitidx($curview)
3428    if {$canshow <= $numcommits && !$viewcomplete($curview)} return
3429    if {$numcommits == 0} {
3430        allcanvs delete all
3431    }
3432    set r0 $numcommits
3433    set prev $numcommits
3434    set numcommits $canshow
3435    set t [clock clicks -milliseconds]
3436    if {$prev < 100 || $viewcomplete($curview) || $t - $lastscrollset > 500} {
3437        set lastscrollset $t
3438        setcanvscroll
3439    }
3440    set rows [visiblerows]
3441    set r1 [lindex $rows 1]
3442    if {$r1 >= $canshow} {
3443        set r1 [expr {$canshow - 1}]
3444    }
3445    if {$r0 <= $r1} {
3446        drawcommits $r0 $r1
3447    }
3448    if {[info exists pending_select] &&
3449        [commitinview $pending_select $curview]} {
3450        selectline [rowofcommit $pending_select] 1
3451    }
3452    if {$selectfirst} {
3453        if {[info exists selectedline] || [info exists pending_select]} {
3454            set selectfirst 0
3455        } else {
3456            set l [first_real_row]
3457            selectline $l 1
3458            set selectfirst 0
3459        }
3460    }
3461}
3462
3463proc doshowlocalchanges {} {
3464    global curview mainheadid
3465
3466    if {[commitinview $mainheadid $curview]} {
3467        dodiffindex
3468    } else {
3469        lappend commitinterest($mainheadid) {dodiffindex}
3470    }
3471}
3472
3473proc dohidelocalchanges {} {
3474    global nullid nullid2 lserial curview
3475
3476    if {[commitinview $nullid $curview]} {
3477        removerow $nullid $curview
3478    }
3479    if {[commitinview $nullid2 $curview]} {
3480        removerow $nullid2 $curview
3481    }
3482    incr lserial
3483}
3484
3485# spawn off a process to do git diff-index --cached HEAD
3486proc dodiffindex {} {
3487    global lserial showlocalchanges
3488
3489    if {!$showlocalchanges} return
3490    incr lserial
3491    set fd [open "|git diff-index --cached HEAD" r]
3492    fconfigure $fd -blocking 0
3493    filerun $fd [list readdiffindex $fd $lserial]
3494}
3495
3496proc readdiffindex {fd serial} {
3497    global mainheadid nullid2 curview commitinfo commitdata lserial
3498
3499    set isdiff 1
3500    if {[gets $fd line] < 0} {
3501        if {![eof $fd]} {
3502            return 1
3503        }
3504        set isdiff 0
3505    }
3506    # we only need to see one line and we don't really care what it says...
3507    close $fd
3508
3509    # now see if there are any local changes not checked in to the index
3510    if {$serial == $lserial} {
3511        set fd [open "|git diff-files" r]
3512        fconfigure $fd -blocking 0
3513        filerun $fd [list readdifffiles $fd $serial]
3514    }
3515
3516    if {$isdiff && $serial == $lserial && ![commitinview $nullid2 $curview]} {
3517        # add the line for the changes in the index to the graph
3518        set hl "Local changes checked in to index but not committed"
3519        set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
3520        set commitdata($nullid2) "\n    $hl\n"
3521        insertrow $nullid2 $mainheadid $curview
3522    }
3523    return 0
3524}
3525
3526proc readdifffiles {fd serial} {
3527    global mainheadid nullid nullid2 curview
3528    global commitinfo commitdata lserial
3529
3530    set isdiff 1
3531    if {[gets $fd line] < 0} {
3532        if {![eof $fd]} {
3533            return 1
3534        }
3535        set isdiff 0
3536    }
3537    # we only need to see one line and we don't really care what it says...
3538    close $fd
3539
3540    if {$isdiff && $serial == $lserial && ![commitinview $nullid $curview]} {
3541        # add the line for the local diff to the graph
3542        set hl "Local uncommitted changes, not checked in to index"
3543        set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
3544        set commitdata($nullid) "\n    $hl\n"
3545        if {[commitinview $nullid2 $curview]} {
3546            set p $nullid2
3547        } else {
3548            set p $mainheadid
3549        }
3550        insertrow $nullid $p $curview
3551    }
3552    return 0
3553}
3554
3555proc nextuse {id row} {
3556    global curview children
3557
3558    if {[info exists children($curview,$id)]} {
3559        foreach kid $children($curview,$id) {
3560            if {![commitinview $kid $curview]} {
3561                return -1
3562            }
3563            if {[rowofcommit $kid] > $row} {
3564                return [rowofcommit $kid]
3565            }
3566        }
3567    }
3568    if {[commitinview $id $curview]} {
3569        return [rowofcommit $id]
3570    }
3571    return -1
3572}
3573
3574proc prevuse {id row} {
3575    global curview children
3576
3577    set ret -1
3578    if {[info exists children($curview,$id)]} {
3579        foreach kid $children($curview,$id) {
3580            if {![commitinview $kid $curview]} break
3581            if {[rowofcommit $kid] < $row} {
3582                set ret [rowofcommit $kid]
3583            }
3584        }
3585    }
3586    return $ret
3587}
3588
3589proc make_idlist {row} {
3590    global displayorder parentlist uparrowlen downarrowlen mingaplen
3591    global commitidx curview children
3592
3593    set r [expr {$row - $mingaplen - $downarrowlen - 1}]
3594    if {$r < 0} {
3595        set r 0
3596    }
3597    set ra [expr {$row - $downarrowlen}]
3598    if {$ra < 0} {
3599        set ra 0
3600    }
3601    set rb [expr {$row + $uparrowlen}]
3602    if {$rb > $commitidx($curview)} {
3603        set rb $commitidx($curview)
3604    }
3605    make_disporder $r [expr {$rb + 1}]
3606    set ids {}
3607    for {} {$r < $ra} {incr r} {
3608        set nextid [lindex $displayorder [expr {$r + 1}]]
3609        foreach p [lindex $parentlist $r] {
3610            if {$p eq $nextid} continue
3611            set rn [nextuse $p $r]
3612            if {$rn >= $row &&
3613                $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3614                lappend ids [list [ordertoken $p] $p]
3615            }
3616        }
3617    }
3618    for {} {$r < $row} {incr r} {
3619        set nextid [lindex $displayorder [expr {$r + 1}]]
3620        foreach p [lindex $parentlist $r] {
3621            if {$p eq $nextid} continue
3622            set rn [nextuse $p $r]
3623            if {$rn < 0 || $rn >= $row} {
3624                lappend ids [list [ordertoken $p] $p]
3625            }
3626        }
3627    }
3628    set id [lindex $displayorder $row]
3629    lappend ids [list [ordertoken $id] $id]
3630    while {$r < $rb} {
3631        foreach p [lindex $parentlist $r] {
3632            set firstkid [lindex $children($curview,$p) 0]
3633            if {[rowofcommit $firstkid] < $row} {
3634                lappend ids [list [ordertoken $p] $p]
3635            }
3636        }
3637        incr r
3638        set id [lindex $displayorder $r]
3639        if {$id ne {}} {
3640            set firstkid [lindex $children($curview,$id) 0]
3641            if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
3642                lappend ids [list [ordertoken $id] $id]
3643            }
3644        }
3645    }
3646    set idlist {}
3647    foreach idx [lsort -unique $ids] {
3648        lappend idlist [lindex $idx 1]
3649    }
3650    return $idlist
3651}
3652
3653proc rowsequal {a b} {
3654    while {[set i [lsearch -exact $a {}]] >= 0} {
3655        set a [lreplace $a $i $i]
3656    }
3657    while {[set i [lsearch -exact $b {}]] >= 0} {
3658        set b [lreplace $b $i $i]
3659    }
3660    return [expr {$a eq $b}]
3661}
3662
3663proc makeupline {id row rend col} {
3664    global rowidlist uparrowlen downarrowlen mingaplen
3665
3666    for {set r $rend} {1} {set r $rstart} {
3667        set rstart [prevuse $id $r]
3668        if {$rstart < 0} return
3669        if {$rstart < $row} break
3670    }
3671    if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3672        set rstart [expr {$rend - $uparrowlen - 1}]
3673    }
3674    for {set r $rstart} {[incr r] <= $row} {} {
3675        set idlist [lindex $rowidlist $r]
3676        if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3677            set col [idcol $idlist $id $col]
3678            lset rowidlist $r [linsert $idlist $col $id]
3679            changedrow $r
3680        }
3681    }
3682}
3683
3684proc layoutrows {row endrow} {
3685    global rowidlist rowisopt rowfinal displayorder
3686    global uparrowlen downarrowlen maxwidth mingaplen
3687    global children parentlist
3688    global commitidx viewcomplete curview
3689
3690    make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
3691    set idlist {}
3692    if {$row > 0} {
3693        set rm1 [expr {$row - 1}]
3694        foreach id [lindex $rowidlist $rm1] {
3695            if {$id ne {}} {
3696                lappend idlist $id
3697            }
3698        }
3699        set final [lindex $rowfinal $rm1]
3700    }
3701    for {} {$row < $endrow} {incr row} {
3702        set rm1 [expr {$row - 1}]
3703        if {$rm1 < 0 || $idlist eq {}} {
3704            set idlist [make_idlist $row]
3705            set final 1
3706        } else {
3707            set id [lindex $displayorder $rm1]
3708            set col [lsearch -exact $idlist $id]
3709            set idlist [lreplace $idlist $col $col]
3710            foreach p [lindex $parentlist $rm1] {
3711                if {[lsearch -exact $idlist $p] < 0} {
3712                    set col [idcol $idlist $p $col]
3713                    set idlist [linsert $idlist $col $p]
3714                    # if not the first child, we have to insert a line going up
3715                    if {$id ne [lindex $children($curview,$p) 0]} {
3716                        makeupline $p $rm1 $row $col
3717                    }
3718                }
3719            }
3720            set id [lindex $displayorder $row]
3721            if {$row > $downarrowlen} {
3722                set termrow [expr {$row - $downarrowlen - 1}]
3723                foreach p [lindex $parentlist $termrow] {
3724                    set i [lsearch -exact $idlist $p]
3725                    if {$i < 0} continue
3726                    set nr [nextuse $p $termrow]
3727                    if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3728                        set idlist [lreplace $idlist $i $i]
3729                    }
3730                }
3731            }
3732            set col [lsearch -exact $idlist $id]
3733            if {$col < 0} {
3734                set col [idcol $idlist $id]
3735                set idlist [linsert $idlist $col $id]
3736                if {$children($curview,$id) ne {}} {
3737                    makeupline $id $rm1 $row $col
3738                }
3739            }
3740            set r [expr {$row + $uparrowlen - 1}]
3741            if {$r < $commitidx($curview)} {
3742                set x $col
3743                foreach p [lindex $parentlist $r] {
3744                    if {[lsearch -exact $idlist $p] >= 0} continue
3745                    set fk [lindex $children($curview,$p) 0]
3746                    if {[rowofcommit $fk] < $row} {
3747                        set x [idcol $idlist $p $x]
3748                        set idlist [linsert $idlist $x $p]
3749                    }
3750                }
3751                if {[incr r] < $commitidx($curview)} {
3752                    set p [lindex $displayorder $r]
3753                    if {[lsearch -exact $idlist $p] < 0} {
3754                        set fk [lindex $children($curview,$p) 0]
3755                        if {$fk ne {} && [rowofcommit $fk] < $row} {
3756                            set x [idcol $idlist $p $x]
3757                            set idlist [linsert $idlist $x $p]
3758                        }
3759                    }
3760                }
3761            }
3762        }
3763        if {$final && !$viewcomplete($curview) &&
3764            $row + $uparrowlen + $mingaplen + $downarrowlen
3765                >= $commitidx($curview)} {
3766            set final 0
3767        }
3768        set l [llength $rowidlist]
3769        if {$row == $l} {
3770            lappend rowidlist $idlist
3771            lappend rowisopt 0
3772            lappend rowfinal $final
3773        } elseif {$row < $l} {
3774            if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3775                lset rowidlist $row $idlist
3776                changedrow $row
3777            }
3778            lset rowfinal $row $final
3779        } else {
3780            set pad [ntimes [expr {$row - $l}] {}]
3781            set rowidlist [concat $rowidlist $pad]
3782            lappend rowidlist $idlist
3783            set rowfinal [concat $rowfinal $pad]
3784            lappend rowfinal $final
3785            set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3786        }
3787    }
3788    return $row
3789}
3790
3791proc changedrow {row} {
3792    global displayorder iddrawn rowisopt need_redisplay
3793
3794    set l [llength $rowisopt]
3795    if {$row < $l} {
3796        lset rowisopt $row 0
3797        if {$row + 1 < $l} {
3798            lset rowisopt [expr {$row + 1}] 0
3799            if {$row + 2 < $l} {
3800                lset rowisopt [expr {$row + 2}] 0
3801            }
3802        }
3803    }
3804    set id [lindex $displayorder $row]
3805    if {[info exists iddrawn($id)]} {
3806        set need_redisplay 1
3807    }
3808}
3809
3810proc insert_pad {row col npad} {
3811    global rowidlist
3812
3813    set pad [ntimes $npad {}]
3814    set idlist [lindex $rowidlist $row]
3815    set bef [lrange $idlist 0 [expr {$col - 1}]]
3816    set aft [lrange $idlist $col end]
3817    set i [lsearch -exact $aft {}]
3818    if {$i > 0} {
3819        set aft [lreplace $aft $i $i]
3820    }
3821    lset rowidlist $row [concat $bef $pad $aft]
3822    changedrow $row
3823}
3824
3825proc optimize_rows {row col endrow} {
3826    global rowidlist rowisopt displayorder curview children
3827
3828    if {$row < 1} {
3829        set row 1
3830    }
3831    for {} {$row < $endrow} {incr row; set col 0} {
3832        if {[lindex $rowisopt $row]} continue
3833        set haspad 0
3834        set y0 [expr {$row - 1}]
3835        set ym [expr {$row - 2}]
3836        set idlist [lindex $rowidlist $row]
3837        set previdlist [lindex $rowidlist $y0]
3838        if {$idlist eq {} || $previdlist eq {}} continue
3839        if {$ym >= 0} {
3840            set pprevidlist [lindex $rowidlist $ym]
3841            if {$pprevidlist eq {}} continue
3842        } else {
3843            set pprevidlist {}
3844        }
3845        set x0 -1
3846        set xm -1
3847        for {} {$col < [llength $idlist]} {incr col} {
3848            set id [lindex $idlist $col]
3849            if {[lindex $previdlist $col] eq $id} continue
3850            if {$id eq {}} {
3851                set haspad 1
3852                continue
3853            }
3854            set x0 [lsearch -exact $previdlist $id]
3855            if {$x0 < 0} continue
3856            set z [expr {$x0 - $col}]
3857            set isarrow 0
3858            set z0 {}
3859            if {$ym >= 0} {
3860                set xm [lsearch -exact $pprevidlist $id]
3861                if {$xm >= 0} {
3862                    set z0 [expr {$xm - $x0}]
3863                }
3864            }
3865            if {$z0 eq {}} {
3866                # if row y0 is the first child of $id then it's not an arrow
3867                if {[lindex $children($curview,$id) 0] ne
3868                    [lindex $displayorder $y0]} {
3869                    set isarrow 1
3870                }
3871            }
3872            if {!$isarrow && $id ne [lindex $displayorder $row] &&
3873                [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3874                set isarrow 1
3875            }
3876            # Looking at lines from this row to the previous row,
3877            # make them go straight up if they end in an arrow on
3878            # the previous row; otherwise make them go straight up
3879            # or at 45 degrees.
3880            if {$z < -1 || ($z < 0 && $isarrow)} {
3881                # Line currently goes left too much;
3882                # insert pads in the previous row, then optimize it
3883                set npad [expr {-1 - $z + $isarrow}]
3884                insert_pad $y0 $x0 $npad
3885                if {$y0 > 0} {
3886                    optimize_rows $y0 $x0 $row
3887                }
3888                set previdlist [lindex $rowidlist $y0]
3889                set x0 [lsearch -exact $previdlist $id]
3890                set z [expr {$x0 - $col}]
3891                if {$z0 ne {}} {
3892                    set pprevidlist [lindex $rowidlist $ym]
3893                    set xm [lsearch -exact $pprevidlist $id]
3894                    set z0 [expr {$xm - $x0}]
3895                }
3896            } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3897                # Line currently goes right too much;
3898                # insert pads in this line
3899                set npad [expr {$z - 1 + $isarrow}]
3900                insert_pad $row $col $npad
3901                set idlist [lindex $rowidlist $row]
3902                incr col $npad
3903                set z [expr {$x0 - $col}]
3904                set haspad 1
3905            }
3906            if {$z0 eq {} && !$isarrow && $ym >= 0} {
3907                # this line links to its first child on row $row-2
3908                set id [lindex $displayorder $ym]
3909                set xc [lsearch -exact $pprevidlist $id]
3910                if {$xc >= 0} {
3911                    set z0 [expr {$xc - $x0}]
3912                }
3913            }
3914            # avoid lines jigging left then immediately right
3915            if {$z0 ne {} && $z < 0 && $z0 > 0} {
3916                insert_pad $y0 $x0 1
3917                incr x0
3918                optimize_rows $y0 $x0 $row
3919                set previdlist [lindex $rowidlist $y0]
3920            }
3921        }
3922        if {!$haspad} {
3923            # Find the first column that doesn't have a line going right
3924            for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3925                set id [lindex $idlist $col]
3926                if {$id eq {}} break
3927                set x0 [lsearch -exact $previdlist $id]
3928                if {$x0 < 0} {
3929                    # check if this is the link to the first child
3930                    set kid [lindex $displayorder $y0]
3931                    if {[lindex $children($curview,$id) 0] eq $kid} {
3932                        # it is, work out offset to child
3933                        set x0 [lsearch -exact $previdlist $kid]
3934                    }
3935                }
3936                if {$x0 <= $col} break
3937            }
3938            # Insert a pad at that column as long as it has a line and
3939            # isn't the last column
3940            if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3941                set idlist [linsert $idlist $col {}]
3942                lset rowidlist $row $idlist
3943                changedrow $row
3944            }
3945        }
3946    }
3947}
3948
3949proc xc {row col} {
3950    global canvx0 linespc
3951    return [expr {$canvx0 + $col * $linespc}]
3952}
3953
3954proc yc {row} {
3955    global canvy0 linespc
3956    return [expr {$canvy0 + $row * $linespc}]
3957}
3958
3959proc linewidth {id} {
3960    global thickerline lthickness
3961
3962    set wid $lthickness
3963    if {[info exists thickerline] && $id eq $thickerline} {
3964        set wid [expr {2 * $lthickness}]
3965    }
3966    return $wid
3967}
3968
3969proc rowranges {id} {
3970    global curview children uparrowlen downarrowlen
3971    global rowidlist
3972
3973    set kids $children($curview,$id)
3974    if {$kids eq {}} {
3975        return {}
3976    }
3977    set ret {}
3978    lappend kids $id
3979    foreach child $kids {
3980        if {![commitinview $child $curview]} break
3981        set row [rowofcommit $child]
3982        if {![info exists prev]} {
3983            lappend ret [expr {$row + 1}]
3984        } else {
3985            if {$row <= $prevrow} {
3986                puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
3987            }
3988            # see if the line extends the whole way from prevrow to row
3989            if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3990                [lsearch -exact [lindex $rowidlist \
3991                            [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3992                # it doesn't, see where it ends
3993                set r [expr {$prevrow + $downarrowlen}]
3994                if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3995                    while {[incr r -1] > $prevrow &&
3996                           [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3997                } else {
3998                    while {[incr r] <= $row &&
3999                           [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4000                    incr r -1
4001                }
4002                lappend ret $r
4003                # see where it starts up again
4004                set r [expr {$row - $uparrowlen}]
4005                if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
4006                    while {[incr r] < $row &&
4007                           [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
4008                } else {
4009                    while {[incr r -1] >= $prevrow &&
4010                           [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
4011                    incr r
4012                }
4013                lappend ret $r
4014            }
4015        }
4016        if {$child eq $id} {
4017            lappend ret $row
4018        }
4019        set prev $child
4020        set prevrow $row
4021    }
4022    return $ret
4023}
4024
4025proc drawlineseg {id row endrow arrowlow} {
4026    global rowidlist displayorder iddrawn linesegs
4027    global canv colormap linespc curview maxlinelen parentlist
4028
4029    set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
4030    set le [expr {$row + 1}]
4031    set arrowhigh 1
4032    while {1} {
4033        set c [lsearch -exact [lindex $rowidlist $le] $id]
4034        if {$c < 0} {
4035            incr le -1
4036            break
4037        }
4038        lappend cols $c
4039        set x [lindex $displayorder $le]
4040        if {$x eq $id} {
4041            set arrowhigh 0
4042            break
4043        }
4044        if {[info exists iddrawn($x)] || $le == $endrow} {
4045            set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
4046            if {$c >= 0} {
4047                lappend cols $c
4048                set arrowhigh 0
4049            }
4050            break
4051        }
4052        incr le
4053    }
4054    if {$le <= $row} {
4055        return $row
4056    }
4057
4058    set lines {}
4059    set i 0
4060    set joinhigh 0
4061    if {[info exists linesegs($id)]} {
4062        set lines $linesegs($id)
4063        foreach li $lines {
4064            set r0 [lindex $li 0]
4065            if {$r0 > $row} {
4066                if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
4067                    set joinhigh 1
4068                }
4069                break
4070            }
4071            incr i
4072        }
4073    }
4074    set joinlow 0
4075    if {$i > 0} {
4076        set li [lindex $lines [expr {$i-1}]]
4077        set r1 [lindex $li 1]
4078        if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
4079            set joinlow 1
4080        }
4081    }
4082
4083    set x [lindex $cols [expr {$le - $row}]]
4084    set xp [lindex $cols [expr {$le - 1 - $row}]]
4085    set dir [expr {$xp - $x}]
4086    if {$joinhigh} {
4087        set ith [lindex $lines $i 2]
4088        set coords [$canv coords $ith]
4089        set ah [$canv itemcget $ith -arrow]
4090        set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
4091        set x2 [lindex $cols [expr {$le + 1 - $row}]]
4092        if {$x2 ne {} && $x - $x2 == $dir} {
4093            set coords [lrange $coords 0 end-2]
4094        }
4095    } else {
4096        set coords [list [xc $le $x] [yc $le]]
4097    }
4098    if {$joinlow} {
4099        set itl [lindex $lines [expr {$i-1}] 2]
4100        set al [$canv itemcget $itl -arrow]
4101        set arrowlow [expr {$al eq "last" || $al eq "both"}]
4102    } elseif {$arrowlow} {
4103        if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
4104            [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
4105            set arrowlow 0
4106        }
4107    }
4108    set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
4109    for {set y $le} {[incr y -1] > $row} {} {
4110        set x $xp
4111        set xp [lindex $cols [expr {$y - 1 - $row}]]
4112        set ndir [expr {$xp - $x}]
4113        if {$dir != $ndir || $xp < 0} {
4114            lappend coords [xc $y $x] [yc $y]
4115        }
4116        set dir $ndir
4117    }
4118    if {!$joinlow} {
4119        if {$xp < 0} {
4120            # join parent line to first child
4121            set ch [lindex $displayorder $row]
4122            set xc [lsearch -exact [lindex $rowidlist $row] $ch]
4123            if {$xc < 0} {
4124                puts "oops: drawlineseg: child $ch not on row $row"
4125            } elseif {$xc != $x} {
4126                if {($arrowhigh && $le == $row + 1) || $dir == 0} {
4127                    set d [expr {int(0.5 * $linespc)}]
4128                    set x1 [xc $row $x]
4129                    if {$xc < $x} {
4130                        set x2 [expr {$x1 - $d}]
4131                    } else {
4132                        set x2 [expr {$x1 + $d}]
4133                    }
4134                    set y2 [yc $row]
4135                    set y1 [expr {$y2 + $d}]
4136                    lappend coords $x1 $y1 $x2 $y2
4137                } elseif {$xc < $x - 1} {
4138                    lappend coords [xc $row [expr {$x-1}]] [yc $row]
4139                } elseif {$xc > $x + 1} {
4140                    lappend coords [xc $row [expr {$x+1}]] [yc $row]
4141                }
4142                set x $xc
4143            }
4144            lappend coords [xc $row $x] [yc $row]
4145        } else {
4146            set xn [xc $row $xp]
4147            set yn [yc $row]
4148            lappend coords $xn $yn
4149        }
4150        if {!$joinhigh} {
4151            assigncolor $id
4152            set t [$canv create line $coords -width [linewidth $id] \
4153                       -fill $colormap($id) -tags lines.$id -arrow $arrow]
4154            $canv lower $t
4155            bindline $t $id
4156            set lines [linsert $lines $i [list $row $le $t]]
4157        } else {
4158            $canv coords $ith $coords
4159            if {$arrow ne $ah} {
4160                $canv itemconf $ith -arrow $arrow
4161            }
4162            lset lines $i 0 $row
4163        }
4164    } else {
4165        set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
4166        set ndir [expr {$xo - $xp}]
4167        set clow [$canv coords $itl]
4168        if {$dir == $ndir} {
4169            set clow [lrange $clow 2 end]
4170        }
4171        set coords [concat $coords $clow]
4172        if {!$joinhigh} {
4173            lset lines [expr {$i-1}] 1 $le
4174        } else {
4175            # coalesce two pieces
4176            $canv delete $ith
4177            set b [lindex $lines [expr {$i-1}] 0]
4178            set e [lindex $lines $i 1]
4179            set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
4180        }
4181        $canv coords $itl $coords
4182        if {$arrow ne $al} {
4183            $canv itemconf $itl -arrow $arrow
4184        }
4185    }
4186
4187    set linesegs($id) $lines
4188    return $le
4189}
4190
4191proc drawparentlinks {id row} {
4192    global rowidlist canv colormap curview parentlist
4193    global idpos linespc
4194
4195    set rowids [lindex $rowidlist $row]
4196    set col [lsearch -exact $rowids $id]
4197    if {$col < 0} return
4198    set olds [lindex $parentlist $row]
4199    set row2 [expr {$row + 1}]
4200    set x [xc $row $col]
4201    set y [yc $row]
4202    set y2 [yc $row2]
4203    set d [expr {int(0.5 * $linespc)}]
4204    set ymid [expr {$y + $d}]
4205    set ids [lindex $rowidlist $row2]
4206    # rmx = right-most X coord used
4207    set rmx 0
4208    foreach p $olds {
4209        set i [lsearch -exact $ids $p]
4210        if {$i < 0} {
4211            puts "oops, parent $p of $id not in list"
4212            continue
4213        }
4214        set x2 [xc $row2 $i]
4215        if {$x2 > $rmx} {
4216            set rmx $x2
4217        }
4218        set j [lsearch -exact $rowids $p]
4219        if {$j < 0} {
4220            # drawlineseg will do this one for us
4221            continue
4222        }
4223        assigncolor $p
4224        # should handle duplicated parents here...
4225        set coords [list $x $y]
4226        if {$i != $col} {
4227            # if attaching to a vertical segment, draw a smaller
4228            # slant for visual distinctness
4229            if {$i == $j} {
4230                if {$i < $col} {
4231                    lappend coords [expr {$x2 + $d}] $y $x2 $ymid
4232                } else {
4233                    lappend coords [expr {$x2 - $d}] $y $x2 $ymid
4234                }
4235            } elseif {$i < $col && $i < $j} {
4236                # segment slants towards us already
4237                lappend coords [xc $row $j] $y
4238            } else {
4239                if {$i < $col - 1} {
4240                    lappend coords [expr {$x2 + $linespc}] $y
4241                } elseif {$i > $col + 1} {
4242                    lappend coords [expr {$x2 - $linespc}] $y
4243                }
4244                lappend coords $x2 $y2
4245            }
4246        } else {
4247            lappend coords $x2 $y2
4248        }
4249        set t [$canv create line $coords -width [linewidth $p] \
4250                   -fill $colormap($p) -tags lines.$p]
4251        $canv lower $t
4252        bindline $t $p
4253    }
4254    if {$rmx > [lindex $idpos($id) 1]} {
4255        lset idpos($id) 1 $rmx
4256        redrawtags $id
4257    }
4258}
4259
4260proc drawlines {id} {
4261    global canv
4262
4263    $canv itemconf lines.$id -width [linewidth $id]
4264}
4265
4266proc drawcmittext {id row col} {
4267    global linespc canv canv2 canv3 fgcolor curview
4268    global cmitlisted commitinfo rowidlist parentlist
4269    global rowtextx idpos idtags idheads idotherrefs
4270    global linehtag linentag linedtag selectedline
4271    global canvxmax boldrows boldnamerows fgcolor nullid nullid2
4272
4273    # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
4274    set listed $cmitlisted($curview,$id)
4275    if {$id eq $nullid} {
4276        set ofill red
4277    } elseif {$id eq $nullid2} {
4278        set ofill green
4279    } else {
4280        set ofill [expr {$listed != 0? "blue": "white"}]
4281    }
4282    set x [xc $row $col]
4283    set y [yc $row]
4284    set orad [expr {$linespc / 3}]
4285    if {$listed <= 1} {
4286        set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
4287                   [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4288                   -fill $ofill -outline $fgcolor -width 1 -tags circle]
4289    } elseif {$listed == 2} {
4290        # triangle pointing left for left-side commits
4291        set t [$canv create polygon \
4292                   [expr {$x - $orad}] $y \
4293                   [expr {$x + $orad - 1}] [expr {$y - $orad}] \
4294                   [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
4295                   -fill $ofill -outline $fgcolor -width 1 -tags circle]
4296    } else {
4297        # triangle pointing right for right-side commits
4298        set t [$canv create polygon \
4299                   [expr {$x + $orad - 1}] $y \
4300                   [expr {$x - $orad}] [expr {$y - $orad}] \
4301                   [expr {$x - $orad}] [expr {$y + $orad - 1}] \
4302                   -fill $ofill -outline $fgcolor -width 1 -tags circle]
4303    }
4304    $canv raise $t
4305    $canv bind $t <1> {selcanvline {} %x %y}
4306    set rmx [llength [lindex $rowidlist $row]]
4307    set olds [lindex $parentlist $row]
4308    if {$olds ne {}} {
4309        set nextids [lindex $rowidlist [expr {$row + 1}]]
4310        foreach p $olds {
4311            set i [lsearch -exact $nextids $p]
4312            if {$i > $rmx} {
4313                set rmx $i
4314            }
4315        }
4316    }
4317    set xt [xc $row $rmx]
4318    set rowtextx($row) $xt
4319    set idpos($id) [list $x $xt $y]
4320    if {[info exists idtags($id)] || [info exists idheads($id)]
4321        || [info exists idotherrefs($id)]} {
4322        set xt [drawtags $id $x $xt $y]
4323    }
4324    set headline [lindex $commitinfo($id) 0]
4325    set name [lindex $commitinfo($id) 1]
4326    set date [lindex $commitinfo($id) 2]
4327    set date [formatdate $date]
4328    set font mainfont
4329    set nfont mainfont
4330    set isbold [ishighlighted $row]
4331    if {$isbold > 0} {
4332        lappend boldrows $row
4333        set font mainfontbold
4334        if {$isbold > 1} {
4335            lappend boldnamerows $row
4336            set nfont mainfontbold
4337        }
4338    }
4339    set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
4340                            -text $headline -font $font -tags text]
4341    $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
4342    set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
4343                            -text $name -font $nfont -tags text]
4344    set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
4345                            -text $date -font mainfont -tags text]
4346    if {[info exists selectedline] && $selectedline == $row} {
4347        make_secsel $row
4348    }
4349    set xr [expr {$xt + [font measure $font $headline]}]
4350    if {$xr > $canvxmax} {
4351        set canvxmax $xr
4352        setcanvscroll
4353    }
4354}
4355
4356proc drawcmitrow {row} {
4357    global displayorder rowidlist nrows_drawn
4358    global iddrawn markingmatches
4359    global commitinfo numcommits
4360    global filehighlight fhighlights findpattern nhighlights
4361    global hlview vhighlights
4362    global highlight_related rhighlights
4363
4364    if {$row >= $numcommits} return
4365
4366    set id [lindex $displayorder $row]
4367    if {[info exists hlview] && ![info exists vhighlights($row)]} {
4368        askvhighlight $row $id
4369    }
4370    if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
4371        askfilehighlight $row $id
4372    }
4373    if {$findpattern ne {} && ![info exists nhighlights($row)]} {
4374        askfindhighlight $row $id
4375    }
4376    if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
4377        askrelhighlight $row $id
4378    }
4379    if {![info exists iddrawn($id)]} {
4380        set col [lsearch -exact [lindex $rowidlist $row] $id]
4381        if {$col < 0} {
4382            puts "oops, row $row id $id not in list"
4383            return
4384        }
4385        if {![info exists commitinfo($id)]} {
4386            getcommit $id
4387        }
4388        assigncolor $id
4389        drawcmittext $id $row $col
4390        set iddrawn($id) 1
4391        incr nrows_drawn
4392    }
4393    if {$markingmatches} {
4394        markrowmatches $row $id
4395    }
4396}
4397
4398proc drawcommits {row {endrow {}}} {
4399    global numcommits iddrawn displayorder curview need_redisplay
4400    global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
4401
4402    if {$row < 0} {
4403        set row 0
4404    }
4405    if {$endrow eq {}} {
4406        set endrow $row
4407    }
4408    if {$endrow >= $numcommits} {
4409        set endrow [expr {$numcommits - 1}]
4410    }
4411
4412    set rl1 [expr {$row - $downarrowlen - 3}]
4413    if {$rl1 < 0} {
4414        set rl1 0
4415    }
4416    set ro1 [expr {$row - 3}]
4417    if {$ro1 < 0} {
4418        set ro1 0
4419    }
4420    set r2 [expr {$endrow + $uparrowlen + 3}]
4421    if {$r2 > $numcommits} {
4422        set r2 $numcommits
4423    }
4424    for {set r $rl1} {$r < $r2} {incr r} {
4425        if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
4426            if {$rl1 < $r} {
4427                layoutrows $rl1 $r
4428            }
4429            set rl1 [expr {$r + 1}]
4430        }
4431    }
4432    if {$rl1 < $r} {
4433        layoutrows $rl1 $r
4434    }
4435    optimize_rows $ro1 0 $r2
4436    if {$need_redisplay || $nrows_drawn > 2000} {
4437        clear_display
4438        drawvisible
4439    }
4440
4441    # make the lines join to already-drawn rows either side
4442    set r [expr {$row - 1}]
4443    if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
4444        set r $row
4445    }
4446    set er [expr {$endrow + 1}]
4447    if {$er >= $numcommits ||
4448        ![info exists iddrawn([lindex $displayorder $er])]} {
4449        set er $endrow
4450    }
4451    for {} {$r <= $er} {incr r} {
4452        set id [lindex $displayorder $r]
4453        set wasdrawn [info exists iddrawn($id)]
4454        drawcmitrow $r
4455        if {$r == $er} break
4456        set nextid [lindex $displayorder [expr {$r + 1}]]
4457        if {$wasdrawn && [info exists iddrawn($nextid)]} continue
4458        drawparentlinks $id $r
4459
4460        set rowids [lindex $rowidlist $r]
4461        foreach lid $rowids {
4462            if {$lid eq {}} continue
4463            if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
4464            if {$lid eq $id} {
4465                # see if this is the first child of any of its parents
4466                foreach p [lindex $parentlist $r] {
4467                    if {[lsearch -exact $rowids $p] < 0} {
4468                        # make this line extend up to the child
4469                        set lineend($p) [drawlineseg $p $r $er 0]
4470                    }
4471                }
4472            } else {
4473                set lineend($lid) [drawlineseg $lid $r $er 1]
4474            }
4475        }
4476    }
4477}
4478
4479proc undolayout {row} {
4480    global uparrowlen mingaplen downarrowlen
4481    global rowidlist rowisopt rowfinal need_redisplay
4482
4483    set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
4484    if {$r < 0} {
4485        set r 0
4486    }
4487    if {[llength $rowidlist] > $r} {
4488        incr r -1
4489        set rowidlist [lrange $rowidlist 0 $r]
4490        set rowfinal [lrange $rowfinal 0 $r]
4491        set rowisopt [lrange $rowisopt 0 $r]
4492        set need_redisplay 1
4493        run drawvisible
4494    }
4495}
4496
4497proc drawfrac {f0 f1} {
4498    global canv linespc
4499
4500    set ymax [lindex [$canv cget -scrollregion] 3]
4501    if {$ymax eq {} || $ymax == 0} return
4502    set y0 [expr {int($f0 * $ymax)}]
4503    set row [expr {int(($y0 - 3) / $linespc) - 1}]
4504    set y1 [expr {int($f1 * $ymax)}]
4505    set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
4506    drawcommits $row $endrow
4507}
4508
4509proc drawvisible {} {
4510    global canv
4511    eval drawfrac [$canv yview]
4512}
4513
4514proc clear_display {} {
4515    global iddrawn linesegs need_redisplay nrows_drawn
4516    global vhighlights fhighlights nhighlights rhighlights
4517
4518    allcanvs delete all
4519    catch {unset iddrawn}
4520    catch {unset linesegs}
4521    catch {unset vhighlights}
4522    catch {unset fhighlights}
4523    catch {unset nhighlights}
4524    catch {unset rhighlights}
4525    set need_redisplay 0
4526    set nrows_drawn 0
4527}
4528
4529proc findcrossings {id} {
4530    global rowidlist parentlist numcommits displayorder
4531
4532    set cross {}
4533    set ccross {}
4534    foreach {s e} [rowranges $id] {
4535        if {$e >= $numcommits} {
4536            set e [expr {$numcommits - 1}]
4537        }
4538        if {$e <= $s} continue
4539        for {set row $e} {[incr row -1] >= $s} {} {
4540            set x [lsearch -exact [lindex $rowidlist $row] $id]
4541            if {$x < 0} break
4542            set olds [lindex $parentlist $row]
4543            set kid [lindex $displayorder $row]
4544            set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
4545            if {$kidx < 0} continue
4546            set nextrow [lindex $rowidlist [expr {$row + 1}]]
4547            foreach p $olds {
4548                set px [lsearch -exact $nextrow $p]
4549                if {$px < 0} continue
4550                if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
4551                    if {[lsearch -exact $ccross $p] >= 0} continue
4552                    if {$x == $px + ($kidx < $px? -1: 1)} {
4553                        lappend ccross $p
4554                    } elseif {[lsearch -exact $cross $p] < 0} {
4555                        lappend cross $p
4556                    }
4557                }
4558            }
4559        }
4560    }
4561    return [concat $ccross {{}} $cross]
4562}
4563
4564proc assigncolor {id} {
4565    global colormap colors nextcolor
4566    global parents children children curview
4567
4568    if {[info exists colormap($id)]} return
4569    set ncolors [llength $colors]
4570    if {[info exists children($curview,$id)]} {
4571        set kids $children($curview,$id)
4572    } else {
4573        set kids {}
4574    }
4575    if {[llength $kids] == 1} {
4576        set child [lindex $kids 0]
4577        if {[info exists colormap($child)]
4578            && [llength $parents($curview,$child)] == 1} {
4579            set colormap($id) $colormap($child)
4580            return
4581        }
4582    }
4583    set badcolors {}
4584    set origbad {}
4585    foreach x [findcrossings $id] {
4586        if {$x eq {}} {
4587            # delimiter between corner crossings and other crossings
4588            if {[llength $badcolors] >= $ncolors - 1} break
4589            set origbad $badcolors
4590        }
4591        if {[info exists colormap($x)]
4592            && [lsearch -exact $badcolors $colormap($x)] < 0} {
4593            lappend badcolors $colormap($x)
4594        }
4595    }
4596    if {[llength $badcolors] >= $ncolors} {
4597        set badcolors $origbad
4598    }
4599    set origbad $badcolors
4600    if {[llength $badcolors] < $ncolors - 1} {
4601        foreach child $kids {
4602            if {[info exists colormap($child)]
4603                && [lsearch -exact $badcolors $colormap($child)] < 0} {
4604                lappend badcolors $colormap($child)
4605            }
4606            foreach p $parents($curview,$child) {
4607                if {[info exists colormap($p)]
4608                    && [lsearch -exact $badcolors $colormap($p)] < 0} {
4609                    lappend badcolors $colormap($p)
4610                }
4611            }
4612        }
4613        if {[llength $badcolors] >= $ncolors} {
4614            set badcolors $origbad
4615        }
4616    }
4617    for {set i 0} {$i <= $ncolors} {incr i} {
4618        set c [lindex $colors $nextcolor]
4619        if {[incr nextcolor] >= $ncolors} {
4620            set nextcolor 0
4621        }
4622        if {[lsearch -exact $badcolors $c]} break
4623    }
4624    set colormap($id) $c
4625}
4626
4627proc bindline {t id} {
4628    global canv
4629
4630    $canv bind $t <Enter> "lineenter %x %y $id"
4631    $canv bind $t <Motion> "linemotion %x %y $id"
4632    $canv bind $t <Leave> "lineleave $id"
4633    $canv bind $t <Button-1> "lineclick %x %y $id 1"
4634}
4635
4636proc drawtags {id x xt y1} {
4637    global idtags idheads idotherrefs mainhead
4638    global linespc lthickness
4639    global canv rowtextx curview fgcolor bgcolor
4640
4641    set marks {}
4642    set ntags 0
4643    set nheads 0
4644    if {[info exists idtags($id)]} {
4645        set marks $idtags($id)
4646        set ntags [llength $marks]
4647    }
4648    if {[info exists idheads($id)]} {
4649        set marks [concat $marks $idheads($id)]
4650        set nheads [llength $idheads($id)]
4651    }
4652    if {[info exists idotherrefs($id)]} {
4653        set marks [concat $marks $idotherrefs($id)]
4654    }
4655    if {$marks eq {}} {
4656        return $xt
4657    }
4658
4659    set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4660    set yt [expr {$y1 - 0.5 * $linespc}]
4661    set yb [expr {$yt + $linespc - 1}]
4662    set xvals {}
4663    set wvals {}
4664    set i -1
4665    foreach tag $marks {
4666        incr i
4667        if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4668            set wid [font measure mainfontbold $tag]
4669        } else {
4670            set wid [font measure mainfont $tag]
4671        }
4672        lappend xvals $xt
4673        lappend wvals $wid
4674        set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4675    }
4676    set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4677               -width $lthickness -fill black -tags tag.$id]
4678    $canv lower $t
4679    foreach tag $marks x $xvals wid $wvals {
4680        set xl [expr {$x + $delta}]
4681        set xr [expr {$x + $delta + $wid + $lthickness}]
4682        set font mainfont
4683        if {[incr ntags -1] >= 0} {
4684            # draw a tag
4685            set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4686                       $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4687                       -width 1 -outline black -fill yellow -tags tag.$id]
4688            $canv bind $t <1> [list showtag $tag 1]
4689            set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
4690        } else {
4691            # draw a head or other ref
4692            if {[incr nheads -1] >= 0} {
4693                set col green
4694                if {$tag eq $mainhead} {
4695                    set font mainfontbold
4696                }
4697            } else {
4698                set col "#ddddff"
4699            }
4700            set xl [expr {$xl - $delta/2}]
4701            $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4702                -width 1 -outline black -fill $col -tags tag.$id
4703            if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4704                set rwid [font measure mainfont $remoteprefix]
4705                set xi [expr {$x + 1}]
4706                set yti [expr {$yt + 1}]
4707                set xri [expr {$x + $rwid}]
4708                $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4709                        -width 0 -fill "#ffddaa" -tags tag.$id
4710            }
4711        }
4712        set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4713                   -font $font -tags [list tag.$id text]]
4714        if {$ntags >= 0} {
4715            $canv bind $t <1> [list showtag $tag 1]
4716        } elseif {$nheads >= 0} {
4717            $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4718        }
4719    }
4720    return $xt
4721}
4722
4723proc xcoord {i level ln} {
4724    global canvx0 xspc1 xspc2
4725
4726    set x [expr {$canvx0 + $i * $xspc1($ln)}]
4727    if {$i > 0 && $i == $level} {
4728        set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4729    } elseif {$i > $level} {
4730        set x [expr {$x + $xspc2 - $xspc1($ln)}]
4731    }
4732    return $x
4733}
4734
4735proc show_status {msg} {
4736    global canv fgcolor
4737
4738    clear_display
4739    $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4740        -tags text -fill $fgcolor
4741}
4742
4743# Don't change the text pane cursor if it is currently the hand cursor,
4744# showing that we are over a sha1 ID link.
4745proc settextcursor {c} {
4746    global ctext curtextcursor
4747
4748    if {[$ctext cget -cursor] == $curtextcursor} {
4749        $ctext config -cursor $c
4750    }
4751    set curtextcursor $c
4752}
4753
4754proc nowbusy {what {name {}}} {
4755    global isbusy busyname statusw
4756
4757    if {[array names isbusy] eq {}} {
4758        . config -cursor watch
4759        settextcursor watch
4760    }
4761    set isbusy($what) 1
4762    set busyname($what) $name
4763    if {$name ne {}} {
4764        $statusw conf -text $name
4765    }
4766}
4767
4768proc notbusy {what} {
4769    global isbusy maincursor textcursor busyname statusw
4770
4771    catch {
4772        unset isbusy($what)
4773        if {$busyname($what) ne {} &&
4774            [$statusw cget -text] eq $busyname($what)} {
4775            $statusw conf -text {}
4776        }
4777    }
4778    if {[array names isbusy] eq {}} {
4779        . config -cursor $maincursor
4780        settextcursor $textcursor
4781    }
4782}
4783
4784proc findmatches {f} {
4785    global findtype findstring
4786    if {$findtype == "Regexp"} {
4787        set matches [regexp -indices -all -inline $findstring $f]
4788    } else {
4789        set fs $findstring
4790        if {$findtype == "IgnCase"} {
4791            set f [string tolower $f]
4792            set fs [string tolower $fs]
4793        }
4794        set matches {}
4795        set i 0
4796        set l [string length $fs]
4797        while {[set j [string first $fs $f $i]] >= 0} {
4798            lappend matches [list $j [expr {$j+$l-1}]]
4799            set i [expr {$j + $l}]
4800        }
4801    }
4802    return $matches
4803}
4804
4805proc dofind {{dirn 1} {wrap 1}} {
4806    global findstring findstartline findcurline selectedline numcommits
4807    global gdttype filehighlight fh_serial find_dirn findallowwrap
4808
4809    if {[info exists find_dirn]} {
4810        if {$find_dirn == $dirn} return
4811        stopfinding
4812    }
4813    focus .
4814    if {$findstring eq {} || $numcommits == 0} return
4815    if {![info exists selectedline]} {
4816        set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4817    } else {
4818        set findstartline $selectedline
4819    }
4820    set findcurline $findstartline
4821    nowbusy finding "Searching"
4822    if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4823        after cancel do_file_hl $fh_serial
4824        do_file_hl $fh_serial
4825    }
4826    set find_dirn $dirn
4827    set findallowwrap $wrap
4828    run findmore
4829}
4830
4831proc stopfinding {} {
4832    global find_dirn findcurline fprogcoord
4833
4834    if {[info exists find_dirn]} {
4835        unset find_dirn
4836        unset findcurline
4837        notbusy finding
4838        set fprogcoord 0
4839        adjustprogress
4840    }
4841}
4842
4843proc findmore {} {
4844    global commitdata commitinfo numcommits findpattern findloc
4845    global findstartline findcurline findallowwrap
4846    global find_dirn gdttype fhighlights fprogcoord
4847    global curview varcorder vrownum varccommits
4848
4849    if {![info exists find_dirn]} {
4850        return 0
4851    }
4852    set fldtypes {Headline Author Date Committer CDate Comments}
4853    set l $findcurline
4854    set moretodo 0
4855    if {$find_dirn > 0} {
4856        incr l
4857        if {$l >= $numcommits} {
4858            set l 0
4859        }
4860        if {$l <= $findstartline} {
4861            set lim [expr {$findstartline + 1}]
4862        } else {
4863            set lim $numcommits
4864            set moretodo $findallowwrap
4865        }
4866    } else {
4867        if {$l == 0} {
4868            set l $numcommits
4869        }
4870        incr l -1
4871        if {$l >= $findstartline} {
4872            set lim [expr {$findstartline - 1}]
4873        } else {
4874            set lim -1
4875            set moretodo $findallowwrap
4876        }
4877    }
4878    set n [expr {($lim - $l) * $find_dirn}]
4879    if {$n > 500} {
4880        set n 500
4881        set moretodo 1
4882    }
4883    set found 0
4884    set domore 1
4885    set ai [bsearch $vrownum($curview) $l]
4886    set a [lindex $varcorder($curview) $ai]
4887    set arow [lindex $vrownum($curview) $ai]
4888    set ids [lindex $varccommits($curview,$a)]
4889    set arowend [expr {$arow + [llength $ids]}]
4890    if {$gdttype eq "containing:"} {
4891        for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4892            if {$l < $arow || $l >= $arowend} {
4893                incr ai $find_dirn
4894                set a [lindex $varcorder($curview) $ai]
4895                set arow [lindex $vrownum($curview) $ai]
4896                set ids [lindex $varccommits($curview,$a)]
4897                set arowend [expr {$arow + [llength $ids]}]
4898            }
4899            set id [lindex $ids [expr {$l - $arow}]]
4900            # shouldn't happen unless git log doesn't give all the commits...
4901            if {![info exists commitdata($id)] ||
4902                ![doesmatch $commitdata($id)]} {
4903                continue
4904            }
4905            if {![info exists commitinfo($id)]} {
4906                getcommit $id
4907            }
4908            set info $commitinfo($id)
4909            foreach f $info ty $fldtypes {
4910                if {($findloc eq "All fields" || $findloc eq $ty) &&
4911                    [doesmatch $f]} {
4912                    set found 1
4913                    break
4914                }
4915            }
4916            if {$found} break
4917        }
4918    } else {
4919        for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4920            if {$l < $arow || $l >= $arowend} {
4921                incr ai $find_dirn
4922                set a [lindex $varcorder($curview) $ai]
4923                set arow [lindex $vrownum($curview) $ai]
4924                set ids [lindex $varccommits($curview,$a)]
4925                set arowend [expr {$arow + [llength $ids]}]
4926            }
4927            set id [lindex $ids [expr {$l - $arow}]]
4928            if {![info exists fhighlights($l)]} {
4929                askfilehighlight $l $id
4930                if {$domore} {
4931                    set domore 0
4932                    set findcurline [expr {$l - $find_dirn}]
4933                }
4934            } elseif {$fhighlights($l)} {
4935                set found $domore
4936                break
4937            }
4938        }
4939    }
4940    if {$found || ($domore && !$moretodo)} {
4941        unset findcurline
4942        unset find_dirn
4943        notbusy finding
4944        set fprogcoord 0
4945        adjustprogress
4946        if {$found} {
4947            findselectline $l
4948        } else {
4949            bell
4950        }
4951        return 0
4952    }
4953    if {!$domore} {
4954        flushhighlights
4955    } else {
4956        set findcurline [expr {$l - $find_dirn}]
4957    }
4958    set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
4959    if {$n < 0} {
4960        incr n $numcommits
4961    }
4962    set fprogcoord [expr {$n * 1.0 / $numcommits}]
4963    adjustprogress
4964    return $domore
4965}
4966
4967proc findselectline {l} {
4968    global findloc commentend ctext findcurline markingmatches gdttype
4969
4970    set markingmatches 1
4971    set findcurline $l
4972    selectline $l 1
4973    if {$findloc == "All fields" || $findloc == "Comments"} {
4974        # highlight the matches in the comments
4975        set f [$ctext get 1.0 $commentend]
4976        set matches [findmatches $f]
4977        foreach match $matches {
4978            set start [lindex $match 0]
4979            set end [expr {[lindex $match 1] + 1}]
4980            $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4981        }
4982    }
4983    drawvisible
4984}
4985
4986# mark the bits of a headline or author that match a find string
4987proc markmatches {canv l str tag matches font row} {
4988    global selectedline
4989
4990    set bbox [$canv bbox $tag]
4991    set x0 [lindex $bbox 0]
4992    set y0 [lindex $bbox 1]
4993    set y1 [lindex $bbox 3]
4994    foreach match $matches {
4995        set start [lindex $match 0]
4996        set end [lindex $match 1]
4997        if {$start > $end} continue
4998        set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4999        set xlen [font measure $font [string range $str 0 [expr {$end}]]]
5000        set t [$canv create rect [expr {$x0+$xoff}] $y0 \
5001                   [expr {$x0+$xlen+2}] $y1 \
5002                   -outline {} -tags [list match$l matches] -fill yellow]
5003        $canv lower $t
5004        if {[info exists selectedline] && $row == $selectedline} {
5005            $canv raise $t secsel
5006        }
5007    }
5008}
5009
5010proc unmarkmatches {} {
5011    global markingmatches
5012
5013    allcanvs delete matches
5014    set markingmatches 0
5015    stopfinding
5016}
5017
5018proc selcanvline {w x y} {
5019    global canv canvy0 ctext linespc
5020    global rowtextx
5021    set ymax [lindex [$canv cget -scrollregion] 3]
5022    if {$ymax == {}} return
5023    set yfrac [lindex [$canv yview] 0]
5024    set y [expr {$y + $yfrac * $ymax}]
5025    set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
5026    if {$l < 0} {
5027        set l 0
5028    }
5029    if {$w eq $canv} {
5030        if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
5031    }
5032    unmarkmatches
5033    selectline $l 1
5034}
5035
5036proc commit_descriptor {p} {
5037    global commitinfo
5038    if {![info exists commitinfo($p)]} {
5039        getcommit $p
5040    }
5041    set l "..."
5042    if {[llength $commitinfo($p)] > 1} {
5043        set l [lindex $commitinfo($p) 0]
5044    }
5045    return "$p ($l)\n"
5046}
5047
5048# append some text to the ctext widget, and make any SHA1 ID
5049# that we know about be a clickable link.
5050proc appendwithlinks {text tags} {
5051    global ctext linknum curview pendinglinks
5052
5053    set start [$ctext index "end - 1c"]
5054    $ctext insert end $text $tags
5055    set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
5056    foreach l $links {
5057        set s [lindex $l 0]
5058        set e [lindex $l 1]
5059        set linkid [string range $text $s $e]
5060        incr e
5061        $ctext tag delete link$linknum
5062        $ctext tag add link$linknum "$start + $s c" "$start + $e c"
5063        setlink $linkid link$linknum
5064        incr linknum
5065    }
5066}
5067
5068proc setlink {id lk} {
5069    global curview ctext pendinglinks commitinterest
5070
5071    if {[commitinview $id $curview]} {
5072        $ctext tag conf $lk -foreground blue -underline 1
5073        $ctext tag bind $lk <1> [list selectline [rowofcommit $id] 1]
5074        $ctext tag bind $lk <Enter> {linkcursor %W 1}
5075        $ctext tag bind $lk <Leave> {linkcursor %W -1}
5076    } else {
5077        lappend pendinglinks($id) $lk
5078        lappend commitinterest($id) {makelink %I}
5079    }
5080}
5081
5082proc makelink {id} {
5083    global pendinglinks
5084
5085    if {![info exists pendinglinks($id)]} return
5086    foreach lk $pendinglinks($id) {
5087        setlink $id $lk
5088    }
5089    unset pendinglinks($id)
5090}
5091
5092proc linkcursor {w inc} {
5093    global linkentercount curtextcursor
5094
5095    if {[incr linkentercount $inc] > 0} {
5096        $w configure -cursor hand2
5097    } else {
5098        $w configure -cursor $curtextcursor
5099        if {$linkentercount < 0} {
5100            set linkentercount 0
5101        }
5102    }
5103}
5104
5105proc viewnextline {dir} {
5106    global canv linespc
5107
5108    $canv delete hover
5109    set ymax [lindex [$canv cget -scrollregion] 3]
5110    set wnow [$canv yview]
5111    set wtop [expr {[lindex $wnow 0] * $ymax}]
5112    set newtop [expr {$wtop + $dir * $linespc}]
5113    if {$newtop < 0} {
5114        set newtop 0
5115    } elseif {$newtop > $ymax} {
5116        set newtop $ymax
5117    }
5118    allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5119}
5120
5121# add a list of tag or branch names at position pos
5122# returns the number of names inserted
5123proc appendrefs {pos ids var} {
5124    global ctext linknum curview $var maxrefs
5125
5126    if {[catch {$ctext index $pos}]} {
5127        return 0
5128    }
5129    $ctext conf -state normal
5130    $ctext delete $pos "$pos lineend"
5131    set tags {}
5132    foreach id $ids {
5133        foreach tag [set $var\($id\)] {
5134            lappend tags [list $tag $id]
5135        }
5136    }
5137    if {[llength $tags] > $maxrefs} {
5138        $ctext insert $pos "many ([llength $tags])"
5139    } else {
5140        set tags [lsort -index 0 -decreasing $tags]
5141        set sep {}
5142        foreach ti $tags {
5143            set id [lindex $ti 1]
5144            set lk link$linknum
5145            incr linknum
5146            $ctext tag delete $lk
5147            $ctext insert $pos $sep
5148            $ctext insert $pos [lindex $ti 0] $lk
5149            setlink $id $lk
5150            set sep ", "
5151        }
5152    }
5153    $ctext conf -state disabled
5154    return [llength $tags]
5155}
5156
5157# called when we have finished computing the nearby tags
5158proc dispneartags {delay} {
5159    global selectedline currentid showneartags tagphase
5160
5161    if {![info exists selectedline] || !$showneartags} return
5162    after cancel dispnexttag
5163    if {$delay} {
5164        after 200 dispnexttag
5165        set tagphase -1
5166    } else {
5167        after idle dispnexttag
5168        set tagphase 0
5169    }
5170}
5171
5172proc dispnexttag {} {
5173    global selectedline currentid showneartags tagphase ctext
5174
5175    if {![info exists selectedline] || !$showneartags} return
5176    switch -- $tagphase {
5177        0 {
5178            set dtags [desctags $currentid]
5179            if {$dtags ne {}} {
5180                appendrefs precedes $dtags idtags
5181            }
5182        }
5183        1 {
5184            set atags [anctags $currentid]
5185            if {$atags ne {}} {
5186                appendrefs follows $atags idtags
5187            }
5188        }
5189        2 {
5190            set dheads [descheads $currentid]
5191            if {$dheads ne {}} {
5192                if {[appendrefs branch $dheads idheads] > 1
5193                    && [$ctext get "branch -3c"] eq "h"} {
5194                    # turn "Branch" into "Branches"
5195                    $ctext conf -state normal
5196                    $ctext insert "branch -2c" "es"
5197                    $ctext conf -state disabled
5198                }
5199            }
5200        }
5201    }
5202    if {[incr tagphase] <= 2} {
5203        after idle dispnexttag
5204    }
5205}
5206
5207proc make_secsel {l} {
5208    global linehtag linentag linedtag canv canv2 canv3
5209
5210    if {![info exists linehtag($l)]} return
5211    $canv delete secsel
5212    set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
5213               -tags secsel -fill [$canv cget -selectbackground]]
5214    $canv lower $t
5215    $canv2 delete secsel
5216    set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
5217               -tags secsel -fill [$canv2 cget -selectbackground]]
5218    $canv2 lower $t
5219    $canv3 delete secsel
5220    set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
5221               -tags secsel -fill [$canv3 cget -selectbackground]]
5222    $canv3 lower $t
5223}
5224
5225proc selectline {l isnew} {
5226    global canv ctext commitinfo selectedline
5227    global canvy0 linespc parents children curview
5228    global currentid sha1entry
5229    global commentend idtags linknum
5230    global mergemax numcommits pending_select
5231    global cmitmode showneartags allcommits
5232
5233    catch {unset pending_select}
5234    $canv delete hover
5235    normalline
5236    unsel_reflist
5237    stopfinding
5238    if {$l < 0 || $l >= $numcommits} return
5239    set y [expr {$canvy0 + $l * $linespc}]
5240    set ymax [lindex [$canv cget -scrollregion] 3]
5241    set ytop [expr {$y - $linespc - 1}]
5242    set ybot [expr {$y + $linespc + 1}]
5243    set wnow [$canv yview]
5244    set wtop [expr {[lindex $wnow 0] * $ymax}]
5245    set wbot [expr {[lindex $wnow 1] * $ymax}]
5246    set wh [expr {$wbot - $wtop}]
5247    set newtop $wtop
5248    if {$ytop < $wtop} {
5249        if {$ybot < $wtop} {
5250            set newtop [expr {$y - $wh / 2.0}]
5251        } else {
5252            set newtop $ytop
5253            if {$newtop > $wtop - $linespc} {
5254                set newtop [expr {$wtop - $linespc}]
5255            }
5256        }
5257    } elseif {$ybot > $wbot} {
5258        if {$ytop > $wbot} {
5259            set newtop [expr {$y - $wh / 2.0}]
5260        } else {
5261            set newtop [expr {$ybot - $wh}]
5262            if {$newtop < $wtop + $linespc} {
5263                set newtop [expr {$wtop + $linespc}]
5264            }
5265        }
5266    }
5267    if {$newtop != $wtop} {
5268        if {$newtop < 0} {
5269            set newtop 0
5270        }
5271        allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
5272        drawvisible
5273    }
5274
5275    make_secsel $l
5276
5277    if {$isnew} {
5278        addtohistory [list selectline $l 0]
5279    }
5280
5281    set selectedline $l
5282
5283    set id [commitonrow $l]
5284    set currentid $id
5285    $sha1entry delete 0 end
5286    $sha1entry insert 0 $id
5287    $sha1entry selection from 0
5288    $sha1entry selection to end
5289    rhighlight_sel $id
5290
5291    $ctext conf -state normal
5292    clear_ctext
5293    set linknum 0
5294    set info $commitinfo($id)
5295    set date [formatdate [lindex $info 2]]
5296    $ctext insert end "Author: [lindex $info 1]  $date\n"
5297    set date [formatdate [lindex $info 4]]
5298    $ctext insert end "Committer: [lindex $info 3]  $date\n"
5299    if {[info exists idtags($id)]} {
5300        $ctext insert end "Tags:"
5301        foreach tag $idtags($id) {
5302            $ctext insert end " $tag"
5303        }
5304        $ctext insert end "\n"
5305    }
5306
5307    set headers {}
5308    set olds $parents($curview,$id)
5309    if {[llength $olds] > 1} {
5310        set np 0
5311        foreach p $olds {
5312            if {$np >= $mergemax} {
5313                set tag mmax
5314            } else {
5315                set tag m$np
5316            }
5317            $ctext insert end "Parent: " $tag
5318            appendwithlinks [commit_descriptor $p] {}
5319            incr np
5320        }
5321    } else {
5322        foreach p $olds {
5323            append headers "Parent: [commit_descriptor $p]"
5324        }
5325    }
5326
5327    foreach c $children($curview,$id) {
5328        append headers "Child:  [commit_descriptor $c]"
5329    }
5330
5331    # make anything that looks like a SHA1 ID be a clickable link
5332    appendwithlinks $headers {}
5333    if {$showneartags} {
5334        if {![info exists allcommits]} {
5335            getallcommits
5336        }
5337        $ctext insert end "Branch: "
5338        $ctext mark set branch "end -1c"
5339        $ctext mark gravity branch left
5340        $ctext insert end "\nFollows: "
5341        $ctext mark set follows "end -1c"
5342        $ctext mark gravity follows left
5343        $ctext insert end "\nPrecedes: "
5344        $ctext mark set precedes "end -1c"
5345        $ctext mark gravity precedes left
5346        $ctext insert end "\n"
5347        dispneartags 1
5348    }
5349    $ctext insert end "\n"
5350    set comment [lindex $info 5]
5351    if {[string first "\r" $comment] >= 0} {
5352        set comment [string map {"\r" "\n    "} $comment]
5353    }
5354    appendwithlinks $comment {comment}
5355
5356    $ctext tag remove found 1.0 end
5357    $ctext conf -state disabled
5358    set commentend [$ctext index "end - 1c"]
5359
5360    init_flist "Comments"
5361    if {$cmitmode eq "tree"} {
5362        gettree $id
5363    } elseif {[llength $olds] <= 1} {
5364        startdiff $id
5365    } else {
5366        mergediff $id
5367    }
5368}
5369
5370proc selfirstline {} {
5371    unmarkmatches
5372    selectline 0 1
5373}
5374
5375proc sellastline {} {
5376    global numcommits
5377    unmarkmatches
5378    set l [expr {$numcommits - 1}]
5379    selectline $l 1
5380}
5381
5382proc selnextline {dir} {
5383    global selectedline
5384    focus .
5385    if {![info exists selectedline]} return
5386    set l [expr {$selectedline + $dir}]
5387    unmarkmatches
5388    selectline $l 1
5389}
5390
5391proc selnextpage {dir} {
5392    global canv linespc selectedline numcommits
5393
5394    set lpp [expr {([winfo height $canv] - 2) / $linespc}]
5395    if {$lpp < 1} {
5396        set lpp 1
5397    }
5398    allcanvs yview scroll [expr {$dir * $lpp}] units
5399    drawvisible
5400    if {![info exists selectedline]} return
5401    set l [expr {$selectedline + $dir * $lpp}]
5402    if {$l < 0} {
5403        set l 0
5404    } elseif {$l >= $numcommits} {
5405        set l [expr $numcommits - 1]
5406    }
5407    unmarkmatches
5408    selectline $l 1
5409}
5410
5411proc unselectline {} {
5412    global selectedline currentid
5413
5414    catch {unset selectedline}
5415    catch {unset currentid}
5416    allcanvs delete secsel
5417    rhighlight_none
5418}
5419
5420proc reselectline {} {
5421    global selectedline
5422
5423    if {[info exists selectedline]} {
5424        selectline $selectedline 0
5425    }
5426}
5427
5428proc addtohistory {cmd} {
5429    global history historyindex curview
5430
5431    set elt [list $curview $cmd]
5432    if {$historyindex > 0
5433        && [lindex $history [expr {$historyindex - 1}]] == $elt} {
5434        return
5435    }
5436
5437    if {$historyindex < [llength $history]} {
5438        set history [lreplace $history $historyindex end $elt]
5439    } else {
5440        lappend history $elt
5441    }
5442    incr historyindex
5443    if {$historyindex > 1} {
5444        .tf.bar.leftbut conf -state normal
5445    } else {
5446        .tf.bar.leftbut conf -state disabled
5447    }
5448    .tf.bar.rightbut conf -state disabled
5449}
5450
5451proc godo {elt} {
5452    global curview
5453
5454    set view [lindex $elt 0]
5455    set cmd [lindex $elt 1]
5456    if {$curview != $view} {
5457        showview $view
5458    }
5459    eval $cmd
5460}
5461
5462proc goback {} {
5463    global history historyindex
5464    focus .
5465
5466    if {$historyindex > 1} {
5467        incr historyindex -1
5468        godo [lindex $history [expr {$historyindex - 1}]]
5469        .tf.bar.rightbut conf -state normal
5470    }
5471    if {$historyindex <= 1} {
5472        .tf.bar.leftbut conf -state disabled
5473    }
5474}
5475
5476proc goforw {} {
5477    global history historyindex
5478    focus .
5479
5480    if {$historyindex < [llength $history]} {
5481        set cmd [lindex $history $historyindex]
5482        incr historyindex
5483        godo $cmd
5484        .tf.bar.leftbut conf -state normal
5485    }
5486    if {$historyindex >= [llength $history]} {
5487        .tf.bar.rightbut conf -state disabled
5488    }
5489}
5490
5491proc gettree {id} {
5492    global treefilelist treeidlist diffids diffmergeid treepending
5493    global nullid nullid2
5494
5495    set diffids $id
5496    catch {unset diffmergeid}
5497    if {![info exists treefilelist($id)]} {
5498        if {![info exists treepending]} {
5499            if {$id eq $nullid} {
5500                set cmd [list | git ls-files]
5501            } elseif {$id eq $nullid2} {
5502                set cmd [list | git ls-files --stage -t]
5503            } else {
5504                set cmd [list | git ls-tree -r $id]
5505            }
5506            if {[catch {set gtf [open $cmd r]}]} {
5507                return
5508            }
5509            set treepending $id
5510            set treefilelist($id) {}
5511            set treeidlist($id) {}
5512            fconfigure $gtf -blocking 0
5513            filerun $gtf [list gettreeline $gtf $id]
5514        }
5515    } else {
5516        setfilelist $id
5517    }
5518}
5519
5520proc gettreeline {gtf id} {
5521    global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5522
5523    set nl 0
5524    while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5525        if {$diffids eq $nullid} {
5526            set fname $line
5527        } else {
5528            if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5529            set i [string first "\t" $line]
5530            if {$i < 0} continue
5531            set sha1 [lindex $line 2]
5532            set fname [string range $line [expr {$i+1}] end]
5533            if {[string index $fname 0] eq "\""} {
5534                set fname [lindex $fname 0]
5535            }
5536            lappend treeidlist($id) $sha1
5537        }
5538        lappend treefilelist($id) $fname
5539    }
5540    if {![eof $gtf]} {
5541        return [expr {$nl >= 1000? 2: 1}]
5542    }
5543    close $gtf
5544    unset treepending
5545    if {$cmitmode ne "tree"} {
5546        if {![info exists diffmergeid]} {
5547            gettreediffs $diffids
5548        }
5549    } elseif {$id ne $diffids} {
5550        gettree $diffids
5551    } else {
5552        setfilelist $id
5553    }
5554    return 0
5555}
5556
5557proc showfile {f} {
5558    global treefilelist treeidlist diffids nullid nullid2
5559    global ctext commentend
5560
5561    set i [lsearch -exact $treefilelist($diffids) $f]
5562    if {$i < 0} {
5563        puts "oops, $f not in list for id $diffids"
5564        return
5565    }
5566    if {$diffids eq $nullid} {
5567        if {[catch {set bf [open $f r]} err]} {
5568            puts "oops, can't read $f: $err"
5569            return
5570        }
5571    } else {
5572        set blob [lindex $treeidlist($diffids) $i]
5573        if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5574            puts "oops, error reading blob $blob: $err"
5575            return
5576        }
5577    }
5578    fconfigure $bf -blocking 0
5579    filerun $bf [list getblobline $bf $diffids]
5580    $ctext config -state normal
5581    clear_ctext $commentend
5582    $ctext insert end "\n"
5583    $ctext insert end "$f\n" filesep
5584    $ctext config -state disabled
5585    $ctext yview $commentend
5586    settabs 0
5587}
5588
5589proc getblobline {bf id} {
5590    global diffids cmitmode ctext
5591
5592    if {$id ne $diffids || $cmitmode ne "tree"} {
5593        catch {close $bf}
5594        return 0
5595    }
5596    $ctext config -state normal
5597    set nl 0
5598    while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5599        $ctext insert end "$line\n"
5600    }
5601    if {[eof $bf]} {
5602        # delete last newline
5603        $ctext delete "end - 2c" "end - 1c"
5604        close $bf
5605        return 0
5606    }
5607    $ctext config -state disabled
5608    return [expr {$nl >= 1000? 2: 1}]
5609}
5610
5611proc mergediff {id} {
5612    global diffmergeid mdifffd
5613    global diffids
5614    global parents
5615    global limitdiffs viewfiles curview
5616
5617    set diffmergeid $id
5618    set diffids $id
5619    # this doesn't seem to actually affect anything...
5620    set cmd [concat | git diff-tree --no-commit-id --cc $id]
5621    if {$limitdiffs && $viewfiles($curview) ne {}} {
5622        set cmd [concat $cmd -- $viewfiles($curview)]
5623    }
5624    if {[catch {set mdf [open $cmd r]} err]} {
5625        error_popup "Error getting merge diffs: $err"
5626        return
5627    }
5628    fconfigure $mdf -blocking 0
5629    set mdifffd($id) $mdf
5630    set np [llength $parents($curview,$id)]
5631    settabs $np
5632    filerun $mdf [list getmergediffline $mdf $id $np]
5633}
5634
5635proc getmergediffline {mdf id np} {
5636    global diffmergeid ctext cflist mergemax
5637    global difffilestart mdifffd
5638
5639    $ctext conf -state normal
5640    set nr 0
5641    while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5642        if {![info exists diffmergeid] || $id != $diffmergeid
5643            || $mdf != $mdifffd($id)} {
5644            close $mdf
5645            return 0
5646        }
5647        if {[regexp {^diff --cc (.*)} $line match fname]} {
5648            # start of a new file
5649            $ctext insert end "\n"
5650            set here [$ctext index "end - 1c"]
5651            lappend difffilestart $here
5652            add_flist [list $fname]
5653            set l [expr {(78 - [string length $fname]) / 2}]
5654            set pad [string range "----------------------------------------" 1 $l]
5655            $ctext insert end "$pad $fname $pad\n" filesep
5656        } elseif {[regexp {^@@} $line]} {
5657            $ctext insert end "$line\n" hunksep
5658        } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5659            # do nothing
5660        } else {
5661            # parse the prefix - one ' ', '-' or '+' for each parent
5662            set spaces {}
5663            set minuses {}
5664            set pluses {}
5665            set isbad 0
5666            for {set j 0} {$j < $np} {incr j} {
5667                set c [string range $line $j $j]
5668                if {$c == " "} {
5669                    lappend spaces $j
5670                } elseif {$c == "-"} {
5671                    lappend minuses $j
5672                } elseif {$c == "+"} {
5673                    lappend pluses $j
5674                } else {
5675                    set isbad 1
5676                    break
5677                }
5678            }
5679            set tags {}
5680            set num {}
5681            if {!$isbad && $minuses ne {} && $pluses eq {}} {
5682                # line doesn't appear in result, parents in $minuses have the line
5683                set num [lindex $minuses 0]
5684            } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5685                # line appears in result, parents in $pluses don't have the line
5686                lappend tags mresult
5687                set num [lindex $spaces 0]
5688            }
5689            if {$num ne {}} {
5690                if {$num >= $mergemax} {
5691                    set num "max"
5692                }
5693                lappend tags m$num
5694            }
5695            $ctext insert end "$line\n" $tags
5696        }
5697    }
5698    $ctext conf -state disabled
5699    if {[eof $mdf]} {
5700        close $mdf
5701        return 0
5702    }
5703    return [expr {$nr >= 1000? 2: 1}]
5704}
5705
5706proc startdiff {ids} {
5707    global treediffs diffids treepending diffmergeid nullid nullid2
5708
5709    settabs 1
5710    set diffids $ids
5711    catch {unset diffmergeid}
5712    if {![info exists treediffs($ids)] ||
5713        [lsearch -exact $ids $nullid] >= 0 ||
5714        [lsearch -exact $ids $nullid2] >= 0} {
5715        if {![info exists treepending]} {
5716            gettreediffs $ids
5717        }
5718    } else {
5719        addtocflist $ids
5720    }
5721}
5722
5723proc path_filter {filter name} {
5724    foreach p $filter {
5725        set l [string length $p]
5726        if {[string index $p end] eq "/"} {
5727            if {[string compare -length $l $p $name] == 0} {
5728                return 1
5729            }
5730        } else {
5731            if {[string compare -length $l $p $name] == 0 &&
5732                ([string length $name] == $l ||
5733                 [string index $name $l] eq "/")} {
5734                return 1
5735            }
5736        }
5737    }
5738    return 0
5739}
5740
5741proc addtocflist {ids} {
5742    global treediffs
5743
5744    add_flist $treediffs($ids)
5745    getblobdiffs $ids
5746}
5747
5748proc diffcmd {ids flags} {
5749    global nullid nullid2
5750
5751    set i [lsearch -exact $ids $nullid]
5752    set j [lsearch -exact $ids $nullid2]
5753    if {$i >= 0} {
5754        if {[llength $ids] > 1 && $j < 0} {
5755            # comparing working directory with some specific revision
5756            set cmd [concat | git diff-index $flags]
5757            if {$i == 0} {
5758                lappend cmd -R [lindex $ids 1]
5759            } else {
5760                lappend cmd [lindex $ids 0]
5761            }
5762        } else {
5763            # comparing working directory with index
5764            set cmd [concat | git diff-files $flags]
5765            if {$j == 1} {
5766                lappend cmd -R
5767            }
5768        }
5769    } elseif {$j >= 0} {
5770        set cmd [concat | git diff-index --cached $flags]
5771        if {[llength $ids] > 1} {
5772            # comparing index with specific revision
5773            if {$i == 0} {
5774                lappend cmd -R [lindex $ids 1]
5775            } else {
5776                lappend cmd [lindex $ids 0]
5777            }
5778        } else {
5779            # comparing index with HEAD
5780            lappend cmd HEAD
5781        }
5782    } else {
5783        set cmd [concat | git diff-tree -r $flags $ids]
5784    }
5785    return $cmd
5786}
5787
5788proc gettreediffs {ids} {
5789    global treediff treepending
5790
5791    set treepending $ids
5792    set treediff {}
5793    if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5794    fconfigure $gdtf -blocking 0
5795    filerun $gdtf [list gettreediffline $gdtf $ids]
5796}
5797
5798proc gettreediffline {gdtf ids} {
5799    global treediff treediffs treepending diffids diffmergeid
5800    global cmitmode viewfiles curview limitdiffs
5801
5802    set nr 0
5803    while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5804        set i [string first "\t" $line]
5805        if {$i >= 0} {
5806            set file [string range $line [expr {$i+1}] end]
5807            if {[string index $file 0] eq "\""} {
5808                set file [lindex $file 0]
5809            }
5810            lappend treediff $file
5811        }
5812    }
5813    if {![eof $gdtf]} {
5814        return [expr {$nr >= 1000? 2: 1}]
5815    }
5816    close $gdtf
5817    if {$limitdiffs && $viewfiles($curview) ne {}} {
5818        set flist {}
5819        foreach f $treediff {
5820            if {[path_filter $viewfiles($curview) $f]} {
5821                lappend flist $f
5822            }
5823        }
5824        set treediffs($ids) $flist
5825    } else {
5826        set treediffs($ids) $treediff
5827    }
5828    unset treepending
5829    if {$cmitmode eq "tree"} {
5830        gettree $diffids
5831    } elseif {$ids != $diffids} {
5832        if {![info exists diffmergeid]} {
5833            gettreediffs $diffids
5834        }
5835    } else {
5836        addtocflist $ids
5837    }
5838    return 0
5839}
5840
5841# empty string or positive integer
5842proc diffcontextvalidate {v} {
5843    return [regexp {^(|[1-9][0-9]*)$} $v]
5844}
5845
5846proc diffcontextchange {n1 n2 op} {
5847    global diffcontextstring diffcontext
5848
5849    if {[string is integer -strict $diffcontextstring]} {
5850        if {$diffcontextstring > 0} {
5851            set diffcontext $diffcontextstring
5852            reselectline
5853        }
5854    }
5855}
5856
5857proc getblobdiffs {ids} {
5858    global blobdifffd diffids env
5859    global diffinhdr treediffs
5860    global diffcontext
5861    global limitdiffs viewfiles curview
5862
5863    set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5864    if {$limitdiffs && $viewfiles($curview) ne {}} {
5865        set cmd [concat $cmd -- $viewfiles($curview)]
5866    }
5867    if {[catch {set bdf [open $cmd r]} err]} {
5868        puts "error getting diffs: $err"
5869        return
5870    }
5871    set diffinhdr 0
5872    fconfigure $bdf -blocking 0
5873    set blobdifffd($ids) $bdf
5874    filerun $bdf [list getblobdiffline $bdf $diffids]
5875}
5876
5877proc setinlist {var i val} {
5878    global $var
5879
5880    while {[llength [set $var]] < $i} {
5881        lappend $var {}
5882    }
5883    if {[llength [set $var]] == $i} {
5884        lappend $var $val
5885    } else {
5886        lset $var $i $val
5887    }
5888}
5889
5890proc makediffhdr {fname ids} {
5891    global ctext curdiffstart treediffs
5892
5893    set i [lsearch -exact $treediffs($ids) $fname]
5894    if {$i >= 0} {
5895        setinlist difffilestart $i $curdiffstart
5896    }
5897    set l [expr {(78 - [string length $fname]) / 2}]
5898    set pad [string range "----------------------------------------" 1 $l]
5899    $ctext insert $curdiffstart "$pad $fname $pad" filesep
5900}
5901
5902proc getblobdiffline {bdf ids} {
5903    global diffids blobdifffd ctext curdiffstart
5904    global diffnexthead diffnextnote difffilestart
5905    global diffinhdr treediffs
5906
5907    set nr 0
5908    $ctext conf -state normal
5909    while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5910        if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5911            close $bdf
5912            return 0
5913        }
5914        if {![string compare -length 11 "diff --git " $line]} {
5915            # trim off "diff --git "
5916            set line [string range $line 11 end]
5917            set diffinhdr 1
5918            # start of a new file
5919            $ctext insert end "\n"
5920            set curdiffstart [$ctext index "end - 1c"]
5921            $ctext insert end "\n" filesep
5922            # If the name hasn't changed the length will be odd,
5923            # the middle char will be a space, and the two bits either
5924            # side will be a/name and b/name, or "a/name" and "b/name".
5925            # If the name has changed we'll get "rename from" and
5926            # "rename to" or "copy from" and "copy to" lines following this,
5927            # and we'll use them to get the filenames.
5928            # This complexity is necessary because spaces in the filename(s)
5929            # don't get escaped.
5930            set l [string length $line]
5931            set i [expr {$l / 2}]
5932            if {!(($l & 1) && [string index $line $i] eq " " &&
5933                  [string range $line 2 [expr {$i - 1}]] eq \
5934                      [string range $line [expr {$i + 3}] end])} {
5935                continue
5936            }
5937            # unescape if quoted and chop off the a/ from the front
5938            if {[string index $line 0] eq "\""} {
5939                set fname [string range [lindex $line 0] 2 end]
5940            } else {
5941                set fname [string range $line 2 [expr {$i - 1}]]
5942            }
5943            makediffhdr $fname $ids
5944
5945        } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5946                       $line match f1l f1c f2l f2c rest]} {
5947            $ctext insert end "$line\n" hunksep
5948            set diffinhdr 0
5949
5950        } elseif {$diffinhdr} {
5951            if {![string compare -length 12 "rename from " $line]} {
5952                set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5953                if {[string index $fname 0] eq "\""} {
5954                    set fname [lindex $fname 0]
5955                }
5956                set i [lsearch -exact $treediffs($ids) $fname]
5957                if {$i >= 0} {
5958                    setinlist difffilestart $i $curdiffstart
5959                }
5960            } elseif {![string compare -length 10 $line "rename to "] ||
5961                      ![string compare -length 8 $line "copy to "]} {
5962                set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5963                if {[string index $fname 0] eq "\""} {
5964                    set fname [lindex $fname 0]
5965                }
5966                makediffhdr $fname $ids
5967            } elseif {[string compare -length 3 $line "---"] == 0} {
5968                # do nothing
5969                continue
5970            } elseif {[string compare -length 3 $line "+++"] == 0} {
5971                set diffinhdr 0
5972                continue
5973            }
5974            $ctext insert end "$line\n" filesep
5975
5976        } else {
5977            set x [string range $line 0 0]
5978            if {$x == "-" || $x == "+"} {
5979                set tag [expr {$x == "+"}]
5980                $ctext insert end "$line\n" d$tag
5981            } elseif {$x == " "} {
5982                $ctext insert end "$line\n"
5983            } else {
5984                # "\ No newline at end of file",
5985                # or something else we don't recognize
5986                $ctext insert end "$line\n" hunksep
5987            }
5988        }
5989    }
5990    $ctext conf -state disabled
5991    if {[eof $bdf]} {
5992        close $bdf
5993        return 0
5994    }
5995    return [expr {$nr >= 1000? 2: 1}]
5996}
5997
5998proc changediffdisp {} {
5999    global ctext diffelide
6000
6001    $ctext tag conf d0 -elide [lindex $diffelide 0]
6002    $ctext tag conf d1 -elide [lindex $diffelide 1]
6003}
6004
6005proc prevfile {} {
6006    global difffilestart ctext
6007    set prev [lindex $difffilestart 0]
6008    set here [$ctext index @0,0]
6009    foreach loc $difffilestart {
6010        if {[$ctext compare $loc >= $here]} {
6011            $ctext yview $prev
6012            return
6013        }
6014        set prev $loc
6015    }
6016    $ctext yview $prev
6017}
6018
6019proc nextfile {} {
6020    global difffilestart ctext
6021    set here [$ctext index @0,0]
6022    foreach loc $difffilestart {
6023        if {[$ctext compare $loc > $here]} {
6024            $ctext yview $loc
6025            return
6026        }
6027    }
6028}
6029
6030proc clear_ctext {{first 1.0}} {
6031    global ctext smarktop smarkbot
6032    global pendinglinks
6033
6034    set l [lindex [split $first .] 0]
6035    if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
6036        set smarktop $l
6037    }
6038    if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
6039        set smarkbot $l
6040    }
6041    $ctext delete $first end
6042    if {$first eq "1.0"} {
6043        catch {unset pendinglinks}
6044    }
6045}
6046
6047proc settabs {{firstab {}}} {
6048    global firsttabstop tabstop ctext have_tk85
6049
6050    if {$firstab ne {} && $have_tk85} {
6051        set firsttabstop $firstab
6052    }
6053    set w [font measure textfont "0"]
6054    if {$firsttabstop != 0} {
6055        $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
6056                               [expr {($firsttabstop + 2 * $tabstop) * $w}]]
6057    } elseif {$have_tk85 || $tabstop != 8} {
6058        $ctext conf -tabs [expr {$tabstop * $w}]
6059    } else {
6060        $ctext conf -tabs {}
6061    }
6062}
6063
6064proc incrsearch {name ix op} {
6065    global ctext searchstring searchdirn
6066
6067    $ctext tag remove found 1.0 end
6068    if {[catch {$ctext index anchor}]} {
6069        # no anchor set, use start of selection, or of visible area
6070        set sel [$ctext tag ranges sel]
6071        if {$sel ne {}} {
6072            $ctext mark set anchor [lindex $sel 0]
6073        } elseif {$searchdirn eq "-forwards"} {
6074            $ctext mark set anchor @0,0
6075        } else {
6076            $ctext mark set anchor @0,[winfo height $ctext]
6077        }
6078    }
6079    if {$searchstring ne {}} {
6080        set here [$ctext search $searchdirn -- $searchstring anchor]
6081        if {$here ne {}} {
6082            $ctext see $here
6083        }
6084        searchmarkvisible 1
6085    }
6086}
6087
6088proc dosearch {} {
6089    global sstring ctext searchstring searchdirn
6090
6091    focus $sstring
6092    $sstring icursor end
6093    set searchdirn -forwards
6094    if {$searchstring ne {}} {
6095        set sel [$ctext tag ranges sel]
6096        if {$sel ne {}} {
6097            set start "[lindex $sel 0] + 1c"
6098        } elseif {[catch {set start [$ctext index anchor]}]} {
6099            set start "@0,0"
6100        }
6101        set match [$ctext search -count mlen -- $searchstring $start]
6102        $ctext tag remove sel 1.0 end
6103        if {$match eq {}} {
6104            bell
6105            return
6106        }
6107        $ctext see $match
6108        set mend "$match + $mlen c"
6109        $ctext tag add sel $match $mend
6110        $ctext mark unset anchor
6111    }
6112}
6113
6114proc dosearchback {} {
6115    global sstring ctext searchstring searchdirn
6116
6117    focus $sstring
6118    $sstring icursor end
6119    set searchdirn -backwards
6120    if {$searchstring ne {}} {
6121        set sel [$ctext tag ranges sel]
6122        if {$sel ne {}} {
6123            set start [lindex $sel 0]
6124        } elseif {[catch {set start [$ctext index anchor]}]} {
6125            set start @0,[winfo height $ctext]
6126        }
6127        set match [$ctext search -backwards -count ml -- $searchstring $start]
6128        $ctext tag remove sel 1.0 end
6129        if {$match eq {}} {
6130            bell
6131            return
6132        }
6133        $ctext see $match
6134        set mend "$match + $ml c"
6135        $ctext tag add sel $match $mend
6136        $ctext mark unset anchor
6137    }
6138}
6139
6140proc searchmark {first last} {
6141    global ctext searchstring
6142
6143    set mend $first.0
6144    while {1} {
6145        set match [$ctext search -count mlen -- $searchstring $mend $last.end]
6146        if {$match eq {}} break
6147        set mend "$match + $mlen c"
6148        $ctext tag add found $match $mend
6149    }
6150}
6151
6152proc searchmarkvisible {doall} {
6153    global ctext smarktop smarkbot
6154
6155    set topline [lindex [split [$ctext index @0,0] .] 0]
6156    set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
6157    if {$doall || $botline < $smarktop || $topline > $smarkbot} {
6158        # no overlap with previous
6159        searchmark $topline $botline
6160        set smarktop $topline
6161        set smarkbot $botline
6162    } else {
6163        if {$topline < $smarktop} {
6164            searchmark $topline [expr {$smarktop-1}]
6165            set smarktop $topline
6166        }
6167        if {$botline > $smarkbot} {
6168            searchmark [expr {$smarkbot+1}] $botline
6169            set smarkbot $botline
6170        }
6171    }
6172}
6173
6174proc scrolltext {f0 f1} {
6175    global searchstring
6176
6177    .bleft.sb set $f0 $f1
6178    if {$searchstring ne {}} {
6179        searchmarkvisible 0
6180    }
6181}
6182
6183proc setcoords {} {
6184    global linespc charspc canvx0 canvy0
6185    global xspc1 xspc2 lthickness
6186
6187    set linespc [font metrics mainfont -linespace]
6188    set charspc [font measure mainfont "m"]
6189    set canvy0 [expr {int(3 + 0.5 * $linespc)}]
6190    set canvx0 [expr {int(3 + 0.5 * $linespc)}]
6191    set lthickness [expr {int($linespc / 9) + 1}]
6192    set xspc1(0) $linespc
6193    set xspc2 $linespc
6194}
6195
6196proc redisplay {} {
6197    global canv
6198    global selectedline
6199
6200    set ymax [lindex [$canv cget -scrollregion] 3]
6201    if {$ymax eq {} || $ymax == 0} return
6202    set span [$canv yview]
6203    clear_display
6204    setcanvscroll
6205    allcanvs yview moveto [lindex $span 0]
6206    drawvisible
6207    if {[info exists selectedline]} {
6208        selectline $selectedline 0
6209        allcanvs yview moveto [lindex $span 0]
6210    }
6211}
6212
6213proc parsefont {f n} {
6214    global fontattr
6215
6216    set fontattr($f,family) [lindex $n 0]
6217    set s [lindex $n 1]
6218    if {$s eq {} || $s == 0} {
6219        set s 10
6220    } elseif {$s < 0} {
6221        set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
6222    }
6223    set fontattr($f,size) $s
6224    set fontattr($f,weight) normal
6225    set fontattr($f,slant) roman
6226    foreach style [lrange $n 2 end] {
6227        switch -- $style {
6228            "normal" -
6229            "bold"   {set fontattr($f,weight) $style}
6230            "roman" -
6231            "italic" {set fontattr($f,slant) $style}
6232        }
6233    }
6234}
6235
6236proc fontflags {f {isbold 0}} {
6237    global fontattr
6238
6239    return [list -family $fontattr($f,family) -size $fontattr($f,size) \
6240                -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
6241                -slant $fontattr($f,slant)]
6242}
6243
6244proc fontname {f} {
6245    global fontattr
6246
6247    set n [list $fontattr($f,family) $fontattr($f,size)]
6248    if {$fontattr($f,weight) eq "bold"} {
6249        lappend n "bold"
6250    }
6251    if {$fontattr($f,slant) eq "italic"} {
6252        lappend n "italic"
6253    }
6254    return $n
6255}
6256
6257proc incrfont {inc} {
6258    global mainfont textfont ctext canv cflist showrefstop
6259    global stopped entries fontattr
6260
6261    unmarkmatches
6262    set s $fontattr(mainfont,size)
6263    incr s $inc
6264    if {$s < 1} {
6265        set s 1
6266    }
6267    set fontattr(mainfont,size) $s
6268    font config mainfont -size $s
6269    font config mainfontbold -size $s
6270    set mainfont [fontname mainfont]
6271    set s $fontattr(textfont,size)
6272    incr s $inc
6273    if {$s < 1} {
6274        set s 1
6275    }
6276    set fontattr(textfont,size) $s
6277    font config textfont -size $s
6278    font config textfontbold -size $s
6279    set textfont [fontname textfont]
6280    setcoords
6281    settabs
6282    redisplay
6283}
6284
6285proc clearsha1 {} {
6286    global sha1entry sha1string
6287    if {[string length $sha1string] == 40} {
6288        $sha1entry delete 0 end
6289    }
6290}
6291
6292proc sha1change {n1 n2 op} {
6293    global sha1string currentid sha1but
6294    if {$sha1string == {}
6295        || ([info exists currentid] && $sha1string == $currentid)} {
6296        set state disabled
6297    } else {
6298        set state normal
6299    }
6300    if {[$sha1but cget -state] == $state} return
6301    if {$state == "normal"} {
6302        $sha1but conf -state normal -relief raised -text "Goto: "
6303    } else {
6304        $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
6305    }
6306}
6307
6308proc gotocommit {} {
6309    global sha1string tagids headids curview varcid
6310
6311    if {$sha1string == {}
6312        || ([info exists currentid] && $sha1string == $currentid)} return
6313    if {[info exists tagids($sha1string)]} {
6314        set id $tagids($sha1string)
6315    } elseif {[info exists headids($sha1string)]} {
6316        set id $headids($sha1string)
6317    } else {
6318        set id [string tolower $sha1string]
6319        if {[regexp {^[0-9a-f]{4,39}$} $id]} {
6320            set matches [array names varcid "$curview,$id*"]
6321            if {$matches ne {}} {
6322                if {[llength $matches] > 1} {
6323                    error_popup "Short SHA1 id $id is ambiguous"
6324                    return
6325                }
6326                set id [lindex [split [lindex $matches 0] ","] 1]
6327            }
6328        }
6329    }
6330    if {[commitinview $id $curview]} {
6331        selectline [rowofcommit $id] 1
6332        return
6333    }
6334    if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
6335        set type "SHA1 id"
6336    } else {
6337        set type "Tag/Head"
6338    }
6339    error_popup "$type $sha1string is not known"
6340}
6341
6342proc lineenter {x y id} {
6343    global hoverx hovery hoverid hovertimer
6344    global commitinfo canv
6345
6346    if {![info exists commitinfo($id)] && ![getcommit $id]} return
6347    set hoverx $x
6348    set hovery $y
6349    set hoverid $id
6350    if {[info exists hovertimer]} {
6351        after cancel $hovertimer
6352    }
6353    set hovertimer [after 500 linehover]
6354    $canv delete hover
6355}
6356
6357proc linemotion {x y id} {
6358    global hoverx hovery hoverid hovertimer
6359
6360    if {[info exists hoverid] && $id == $hoverid} {
6361        set hoverx $x
6362        set hovery $y
6363        if {[info exists hovertimer]} {
6364            after cancel $hovertimer
6365        }
6366        set hovertimer [after 500 linehover]
6367    }
6368}
6369
6370proc lineleave {id} {
6371    global hoverid hovertimer canv
6372
6373    if {[info exists hoverid] && $id == $hoverid} {
6374        $canv delete hover
6375        if {[info exists hovertimer]} {
6376            after cancel $hovertimer
6377            unset hovertimer
6378        }
6379        unset hoverid
6380    }
6381}
6382
6383proc linehover {} {
6384    global hoverx hovery hoverid hovertimer
6385    global canv linespc lthickness
6386    global commitinfo
6387
6388    set text [lindex $commitinfo($hoverid) 0]
6389    set ymax [lindex [$canv cget -scrollregion] 3]
6390    if {$ymax == {}} return
6391    set yfrac [lindex [$canv yview] 0]
6392    set x [expr {$hoverx + 2 * $linespc}]
6393    set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6394    set x0 [expr {$x - 2 * $lthickness}]
6395    set y0 [expr {$y - 2 * $lthickness}]
6396    set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
6397    set y1 [expr {$y + $linespc + 2 * $lthickness}]
6398    set t [$canv create rectangle $x0 $y0 $x1 $y1 \
6399               -fill \#ffff80 -outline black -width 1 -tags hover]
6400    $canv raise $t
6401    set t [$canv create text $x $y -anchor nw -text $text -tags hover \
6402               -font mainfont]
6403    $canv raise $t
6404}
6405
6406proc clickisonarrow {id y} {
6407    global lthickness
6408
6409    set ranges [rowranges $id]
6410    set thresh [expr {2 * $lthickness + 6}]
6411    set n [expr {[llength $ranges] - 1}]
6412    for {set i 1} {$i < $n} {incr i} {
6413        set row [lindex $ranges $i]
6414        if {abs([yc $row] - $y) < $thresh} {
6415            return $i
6416        }
6417    }
6418    return {}
6419}
6420
6421proc arrowjump {id n y} {
6422    global canv
6423
6424    # 1 <-> 2, 3 <-> 4, etc...
6425    set n [expr {(($n - 1) ^ 1) + 1}]
6426    set row [lindex [rowranges $id] $n]
6427    set yt [yc $row]
6428    set ymax [lindex [$canv cget -scrollregion] 3]
6429    if {$ymax eq {} || $ymax <= 0} return
6430    set view [$canv yview]
6431    set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
6432    set yfrac [expr {$yt / $ymax - $yspan / 2}]
6433    if {$yfrac < 0} {
6434        set yfrac 0
6435    }
6436    allcanvs yview moveto $yfrac
6437}
6438
6439proc lineclick {x y id isnew} {
6440    global ctext commitinfo children canv thickerline curview
6441
6442    if {![info exists commitinfo($id)] && ![getcommit $id]} return
6443    unmarkmatches
6444    unselectline
6445    normalline
6446    $canv delete hover
6447    # draw this line thicker than normal
6448    set thickerline $id
6449    drawlines $id
6450    if {$isnew} {
6451        set ymax [lindex [$canv cget -scrollregion] 3]
6452        if {$ymax eq {}} return
6453        set yfrac [lindex [$canv yview] 0]
6454        set y [expr {$y + $yfrac * $ymax}]
6455    }
6456    set dirn [clickisonarrow $id $y]
6457    if {$dirn ne {}} {
6458        arrowjump $id $dirn $y
6459        return
6460    }
6461
6462    if {$isnew} {
6463        addtohistory [list lineclick $x $y $id 0]
6464    }
6465    # fill the details pane with info about this line
6466    $ctext conf -state normal
6467    clear_ctext
6468    settabs 0
6469    $ctext insert end "Parent:\t"
6470    $ctext insert end $id link0
6471    setlink $id link0
6472    set info $commitinfo($id)
6473    $ctext insert end "\n\t[lindex $info 0]\n"
6474    $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
6475    set date [formatdate [lindex $info 2]]
6476    $ctext insert end "\tDate:\t$date\n"
6477    set kids $children($curview,$id)
6478    if {$kids ne {}} {
6479        $ctext insert end "\nChildren:"
6480        set i 0
6481        foreach child $kids {
6482            incr i
6483            if {![info exists commitinfo($child)] && ![getcommit $child]} continue
6484            set info $commitinfo($child)
6485            $ctext insert end "\n\t"
6486            $ctext insert end $child link$i
6487            setlink $child link$i
6488            $ctext insert end "\n\t[lindex $info 0]"
6489            $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
6490            set date [formatdate [lindex $info 2]]
6491            $ctext insert end "\n\tDate:\t$date\n"
6492        }
6493    }
6494    $ctext conf -state disabled
6495    init_flist {}
6496}
6497
6498proc normalline {} {
6499    global thickerline
6500    if {[info exists thickerline]} {
6501        set id $thickerline
6502        unset thickerline
6503        drawlines $id
6504    }
6505}
6506
6507proc selbyid {id} {
6508    global curview
6509    if {[commitinview $id $curview]} {
6510        selectline [rowofcommit $id] 1
6511    }
6512}
6513
6514proc mstime {} {
6515    global startmstime
6516    if {![info exists startmstime]} {
6517        set startmstime [clock clicks -milliseconds]
6518    }
6519    return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6520}
6521
6522proc rowmenu {x y id} {
6523    global rowctxmenu selectedline rowmenuid curview
6524    global nullid nullid2 fakerowmenu mainhead
6525
6526    stopfinding
6527    set rowmenuid $id
6528    if {![info exists selectedline]
6529        || [rowofcommit $id] eq $selectedline} {
6530        set state disabled
6531    } else {
6532        set state normal
6533    }
6534    if {$id ne $nullid && $id ne $nullid2} {
6535        set menu $rowctxmenu
6536        $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6537    } else {
6538        set menu $fakerowmenu
6539    }
6540    $menu entryconfigure "Diff this*" -state $state
6541    $menu entryconfigure "Diff selected*" -state $state
6542    $menu entryconfigure "Make patch" -state $state
6543    tk_popup $menu $x $y
6544}
6545
6546proc diffvssel {dirn} {
6547    global rowmenuid selectedline
6548
6549    if {![info exists selectedline]} return
6550    if {$dirn} {
6551        set oldid [commitonrow $selectedline]
6552        set newid $rowmenuid
6553    } else {
6554        set oldid $rowmenuid
6555        set newid [commitonrow $selectedline]
6556    }
6557    addtohistory [list doseldiff $oldid $newid]
6558    doseldiff $oldid $newid
6559}
6560
6561proc doseldiff {oldid newid} {
6562    global ctext
6563    global commitinfo
6564
6565    $ctext conf -state normal
6566    clear_ctext
6567    init_flist "Top"
6568    $ctext insert end "From "
6569    $ctext insert end $oldid link0
6570    setlink $oldid link0
6571    $ctext insert end "\n     "
6572    $ctext insert end [lindex $commitinfo($oldid) 0]
6573    $ctext insert end "\n\nTo   "
6574    $ctext insert end $newid link1
6575    setlink $newid link1
6576    $ctext insert end "\n     "
6577    $ctext insert end [lindex $commitinfo($newid) 0]
6578    $ctext insert end "\n"
6579    $ctext conf -state disabled
6580    $ctext tag remove found 1.0 end
6581    startdiff [list $oldid $newid]
6582}
6583
6584proc mkpatch {} {
6585    global rowmenuid currentid commitinfo patchtop patchnum
6586
6587    if {![info exists currentid]} return
6588    set oldid $currentid
6589    set oldhead [lindex $commitinfo($oldid) 0]
6590    set newid $rowmenuid
6591    set newhead [lindex $commitinfo($newid) 0]
6592    set top .patch
6593    set patchtop $top
6594    catch {destroy $top}
6595    toplevel $top
6596    label $top.title -text "Generate patch"
6597    grid $top.title - -pady 10
6598    label $top.from -text "From:"
6599    entry $top.fromsha1 -width 40 -relief flat
6600    $top.fromsha1 insert 0 $oldid
6601    $top.fromsha1 conf -state readonly
6602    grid $top.from $top.fromsha1 -sticky w
6603    entry $top.fromhead -width 60 -relief flat
6604    $top.fromhead insert 0 $oldhead
6605    $top.fromhead conf -state readonly
6606    grid x $top.fromhead -sticky w
6607    label $top.to -text "To:"
6608    entry $top.tosha1 -width 40 -relief flat
6609    $top.tosha1 insert 0 $newid
6610    $top.tosha1 conf -state readonly
6611    grid $top.to $top.tosha1 -sticky w
6612    entry $top.tohead -width 60 -relief flat
6613    $top.tohead insert 0 $newhead
6614    $top.tohead conf -state readonly
6615    grid x $top.tohead -sticky w
6616    button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6617    grid $top.rev x -pady 10
6618    label $top.flab -text "Output file:"
6619    entry $top.fname -width 60
6620    $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6621    incr patchnum
6622    grid $top.flab $top.fname -sticky w
6623    frame $top.buts
6624    button $top.buts.gen -text "Generate" -command mkpatchgo
6625    button $top.buts.can -text "Cancel" -command mkpatchcan
6626    grid $top.buts.gen $top.buts.can
6627    grid columnconfigure $top.buts 0 -weight 1 -uniform a
6628    grid columnconfigure $top.buts 1 -weight 1 -uniform a
6629    grid $top.buts - -pady 10 -sticky ew
6630    focus $top.fname
6631}
6632
6633proc mkpatchrev {} {
6634    global patchtop
6635
6636    set oldid [$patchtop.fromsha1 get]
6637    set oldhead [$patchtop.fromhead get]
6638    set newid [$patchtop.tosha1 get]
6639    set newhead [$patchtop.tohead get]
6640    foreach e [list fromsha1 fromhead tosha1 tohead] \
6641            v [list $newid $newhead $oldid $oldhead] {
6642        $patchtop.$e conf -state normal
6643        $patchtop.$e delete 0 end
6644        $patchtop.$e insert 0 $v
6645        $patchtop.$e conf -state readonly
6646    }
6647}
6648
6649proc mkpatchgo {} {
6650    global patchtop nullid nullid2
6651
6652    set oldid [$patchtop.fromsha1 get]
6653    set newid [$patchtop.tosha1 get]
6654    set fname [$patchtop.fname get]
6655    set cmd [diffcmd [list $oldid $newid] -p]
6656    # trim off the initial "|"
6657    set cmd [lrange $cmd 1 end]
6658    lappend cmd >$fname &
6659    if {[catch {eval exec $cmd} err]} {
6660        error_popup "Error creating patch: $err"
6661    }
6662    catch {destroy $patchtop}
6663    unset patchtop
6664}
6665
6666proc mkpatchcan {} {
6667    global patchtop
6668
6669    catch {destroy $patchtop}
6670    unset patchtop
6671}
6672
6673proc mktag {} {
6674    global rowmenuid mktagtop commitinfo
6675
6676    set top .maketag
6677    set mktagtop $top
6678    catch {destroy $top}
6679    toplevel $top
6680    label $top.title -text "Create tag"
6681    grid $top.title - -pady 10
6682    label $top.id -text "ID:"
6683    entry $top.sha1 -width 40 -relief flat
6684    $top.sha1 insert 0 $rowmenuid
6685    $top.sha1 conf -state readonly
6686    grid $top.id $top.sha1 -sticky w
6687    entry $top.head -width 60 -relief flat
6688    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6689    $top.head conf -state readonly
6690    grid x $top.head -sticky w
6691    label $top.tlab -text "Tag name:"
6692    entry $top.tag -width 60
6693    grid $top.tlab $top.tag -sticky w
6694    frame $top.buts
6695    button $top.buts.gen -text "Create" -command mktaggo
6696    button $top.buts.can -text "Cancel" -command mktagcan
6697    grid $top.buts.gen $top.buts.can
6698    grid columnconfigure $top.buts 0 -weight 1 -uniform a
6699    grid columnconfigure $top.buts 1 -weight 1 -uniform a
6700    grid $top.buts - -pady 10 -sticky ew
6701    focus $top.tag
6702}
6703
6704proc domktag {} {
6705    global mktagtop env tagids idtags
6706
6707    set id [$mktagtop.sha1 get]
6708    set tag [$mktagtop.tag get]
6709    if {$tag == {}} {
6710        error_popup "No tag name specified"
6711        return
6712    }
6713    if {[info exists tagids($tag)]} {
6714        error_popup "Tag \"$tag\" already exists"
6715        return
6716    }
6717    if {[catch {
6718        set dir [gitdir]
6719        set fname [file join $dir "refs/tags" $tag]
6720        set f [open $fname w]
6721        puts $f $id
6722        close $f
6723    } err]} {
6724        error_popup "Error creating tag: $err"
6725        return
6726    }
6727
6728    set tagids($tag) $id
6729    lappend idtags($id) $tag
6730    redrawtags $id
6731    addedtag $id
6732    dispneartags 0
6733    run refill_reflist
6734}
6735
6736proc redrawtags {id} {
6737    global canv linehtag idpos selectedline curview
6738    global canvxmax iddrawn
6739
6740    if {![commitinview $id $curview]} return
6741    if {![info exists iddrawn($id)]} return
6742    drawcommits [rowofcommit $id]
6743    $canv delete tag.$id
6744    set xt [eval drawtags $id $idpos($id)]
6745    $canv coords $linehtag([rowofcommit $id]) $xt [lindex $idpos($id) 2]
6746    set text [$canv itemcget $linehtag([rowofcommit $id]) -text]
6747    set xr [expr {$xt + [font measure mainfont $text]}]
6748    if {$xr > $canvxmax} {
6749        set canvxmax $xr
6750        setcanvscroll
6751    }
6752    if {[info exists selectedline]
6753        && $selectedline == [rowofcommit $id]} {
6754        selectline $selectedline 0
6755    }
6756}
6757
6758proc mktagcan {} {
6759    global mktagtop
6760
6761    catch {destroy $mktagtop}
6762    unset mktagtop
6763}
6764
6765proc mktaggo {} {
6766    domktag
6767    mktagcan
6768}
6769
6770proc writecommit {} {
6771    global rowmenuid wrcomtop commitinfo wrcomcmd
6772
6773    set top .writecommit
6774    set wrcomtop $top
6775    catch {destroy $top}
6776    toplevel $top
6777    label $top.title -text "Write commit to file"
6778    grid $top.title - -pady 10
6779    label $top.id -text "ID:"
6780    entry $top.sha1 -width 40 -relief flat
6781    $top.sha1 insert 0 $rowmenuid
6782    $top.sha1 conf -state readonly
6783    grid $top.id $top.sha1 -sticky w
6784    entry $top.head -width 60 -relief flat
6785    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6786    $top.head conf -state readonly
6787    grid x $top.head -sticky w
6788    label $top.clab -text "Command:"
6789    entry $top.cmd -width 60 -textvariable wrcomcmd
6790    grid $top.clab $top.cmd -sticky w -pady 10
6791    label $top.flab -text "Output file:"
6792    entry $top.fname -width 60
6793    $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6794    grid $top.flab $top.fname -sticky w
6795    frame $top.buts
6796    button $top.buts.gen -text "Write" -command wrcomgo
6797    button $top.buts.can -text "Cancel" -command wrcomcan
6798    grid $top.buts.gen $top.buts.can
6799    grid columnconfigure $top.buts 0 -weight 1 -uniform a
6800    grid columnconfigure $top.buts 1 -weight 1 -uniform a
6801    grid $top.buts - -pady 10 -sticky ew
6802    focus $top.fname
6803}
6804
6805proc wrcomgo {} {
6806    global wrcomtop
6807
6808    set id [$wrcomtop.sha1 get]
6809    set cmd "echo $id | [$wrcomtop.cmd get]"
6810    set fname [$wrcomtop.fname get]
6811    if {[catch {exec sh -c $cmd >$fname &} err]} {
6812        error_popup "Error writing commit: $err"
6813    }
6814    catch {destroy $wrcomtop}
6815    unset wrcomtop
6816}
6817
6818proc wrcomcan {} {
6819    global wrcomtop
6820
6821    catch {destroy $wrcomtop}
6822    unset wrcomtop
6823}
6824
6825proc mkbranch {} {
6826    global rowmenuid mkbrtop
6827
6828    set top .makebranch
6829    catch {destroy $top}
6830    toplevel $top
6831    label $top.title -text "Create new branch"
6832    grid $top.title - -pady 10
6833    label $top.id -text "ID:"
6834    entry $top.sha1 -width 40 -relief flat
6835    $top.sha1 insert 0 $rowmenuid
6836    $top.sha1 conf -state readonly
6837    grid $top.id $top.sha1 -sticky w
6838    label $top.nlab -text "Name:"
6839    entry $top.name -width 40
6840    grid $top.nlab $top.name -sticky w
6841    frame $top.buts
6842    button $top.buts.go -text "Create" -command [list mkbrgo $top]
6843    button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6844    grid $top.buts.go $top.buts.can
6845    grid columnconfigure $top.buts 0 -weight 1 -uniform a
6846    grid columnconfigure $top.buts 1 -weight 1 -uniform a
6847    grid $top.buts - -pady 10 -sticky ew
6848    focus $top.name
6849}
6850
6851proc mkbrgo {top} {
6852    global headids idheads
6853
6854    set name [$top.name get]
6855    set id [$top.sha1 get]
6856    if {$name eq {}} {
6857        error_popup "Please specify a name for the new branch"
6858        return
6859    }
6860    catch {destroy $top}
6861    nowbusy newbranch
6862    update
6863    if {[catch {
6864        exec git branch $name $id
6865    } err]} {
6866        notbusy newbranch
6867        error_popup $err
6868    } else {
6869        set headids($name) $id
6870        lappend idheads($id) $name
6871        addedhead $id $name
6872        notbusy newbranch
6873        redrawtags $id
6874        dispneartags 0
6875        run refill_reflist
6876    }
6877}
6878
6879proc cherrypick {} {
6880    global rowmenuid curview
6881    global mainhead
6882
6883    set oldhead [exec git rev-parse HEAD]
6884    set dheads [descheads $rowmenuid]
6885    if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6886        set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6887                        included in branch $mainhead -- really re-apply it?"]
6888        if {!$ok} return
6889    }
6890    nowbusy cherrypick "Cherry-picking"
6891    update
6892    # Unfortunately git-cherry-pick writes stuff to stderr even when
6893    # no error occurs, and exec takes that as an indication of error...
6894    if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6895        notbusy cherrypick
6896        error_popup $err
6897        return
6898    }
6899    set newhead [exec git rev-parse HEAD]
6900    if {$newhead eq $oldhead} {
6901        notbusy cherrypick
6902        error_popup "No changes committed"
6903        return
6904    }
6905    addnewchild $newhead $oldhead
6906    if {[commitinview $oldhead $curview]} {
6907        insertrow $newhead $oldhead $curview
6908        if {$mainhead ne {}} {
6909            movehead $newhead $mainhead
6910            movedhead $newhead $mainhead
6911        }
6912        redrawtags $oldhead
6913        redrawtags $newhead
6914    }
6915    notbusy cherrypick
6916}
6917
6918proc resethead {} {
6919    global mainheadid mainhead rowmenuid confirm_ok resettype
6920
6921    set confirm_ok 0
6922    set w ".confirmreset"
6923    toplevel $w
6924    wm transient $w .
6925    wm title $w "Confirm reset"
6926    message $w.m -text \
6927        "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6928        -justify center -aspect 1000
6929    pack $w.m -side top -fill x -padx 20 -pady 20
6930    frame $w.f -relief sunken -border 2
6931    message $w.f.rt -text "Reset type:" -aspect 1000
6932    grid $w.f.rt -sticky w
6933    set resettype mixed
6934    radiobutton $w.f.soft -value soft -variable resettype -justify left \
6935        -text "Soft: Leave working tree and index untouched"
6936    grid $w.f.soft -sticky w
6937    radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6938        -text "Mixed: Leave working tree untouched, reset index"
6939    grid $w.f.mixed -sticky w
6940    radiobutton $w.f.hard -value hard -variable resettype -justify left \
6941        -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6942    grid $w.f.hard -sticky w
6943    pack $w.f -side top -fill x
6944    button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6945    pack $w.ok -side left -fill x -padx 20 -pady 20
6946    button $w.cancel -text Cancel -command "destroy $w"
6947    pack $w.cancel -side right -fill x -padx 20 -pady 20
6948    bind $w <Visibility> "grab $w; focus $w"
6949    tkwait window $w
6950    if {!$confirm_ok} return
6951    if {[catch {set fd [open \
6952            [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6953        error_popup $err
6954    } else {
6955        dohidelocalchanges
6956        filerun $fd [list readresetstat $fd]
6957        nowbusy reset "Resetting"
6958    }
6959}
6960
6961proc readresetstat {fd} {
6962    global mainhead mainheadid showlocalchanges rprogcoord
6963
6964    if {[gets $fd line] >= 0} {
6965        if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6966            set rprogcoord [expr {1.0 * $m / $n}]
6967            adjustprogress
6968        }
6969        return 1
6970    }
6971    set rprogcoord 0
6972    adjustprogress
6973    notbusy reset
6974    if {[catch {close $fd} err]} {
6975        error_popup $err
6976    }
6977    set oldhead $mainheadid
6978    set newhead [exec git rev-parse HEAD]
6979    if {$newhead ne $oldhead} {
6980        movehead $newhead $mainhead
6981        movedhead $newhead $mainhead
6982        set mainheadid $newhead
6983        redrawtags $oldhead
6984        redrawtags $newhead
6985    }
6986    if {$showlocalchanges} {
6987        doshowlocalchanges
6988    }
6989    return 0
6990}
6991
6992# context menu for a head
6993proc headmenu {x y id head} {
6994    global headmenuid headmenuhead headctxmenu mainhead
6995
6996    stopfinding
6997    set headmenuid $id
6998    set headmenuhead $head
6999    set state normal
7000    if {$head eq $mainhead} {
7001        set state disabled
7002    }
7003    $headctxmenu entryconfigure 0 -state $state
7004    $headctxmenu entryconfigure 1 -state $state
7005    tk_popup $headctxmenu $x $y
7006}
7007
7008proc cobranch {} {
7009    global headmenuid headmenuhead mainhead headids
7010    global showlocalchanges mainheadid
7011
7012    # check the tree is clean first??
7013    set oldmainhead $mainhead
7014    nowbusy checkout "Checking out"
7015    update
7016    dohidelocalchanges
7017    if {[catch {
7018        exec git checkout -q $headmenuhead
7019    } err]} {
7020        notbusy checkout
7021        error_popup $err
7022    } else {
7023        notbusy checkout
7024        set mainhead $headmenuhead
7025        set mainheadid $headmenuid
7026        if {[info exists headids($oldmainhead)]} {
7027            redrawtags $headids($oldmainhead)
7028        }
7029        redrawtags $headmenuid
7030    }
7031    if {$showlocalchanges} {
7032        dodiffindex
7033    }
7034}
7035
7036proc rmbranch {} {
7037    global headmenuid headmenuhead mainhead
7038    global idheads
7039
7040    set head $headmenuhead
7041    set id $headmenuid
7042    # this check shouldn't be needed any more...
7043    if {$head eq $mainhead} {
7044        error_popup "Cannot delete the currently checked-out branch"
7045        return
7046    }
7047    set dheads [descheads $id]
7048    if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
7049        # the stuff on this branch isn't on any other branch
7050        if {![confirm_popup "The commits on branch $head aren't on any other\
7051                        branch.\nReally delete branch $head?"]} return
7052    }
7053    nowbusy rmbranch
7054    update
7055    if {[catch {exec git branch -D $head} err]} {
7056        notbusy rmbranch
7057        error_popup $err
7058        return
7059    }
7060    removehead $id $head
7061    removedhead $id $head
7062    redrawtags $id
7063    notbusy rmbranch
7064    dispneartags 0
7065    run refill_reflist
7066}
7067
7068# Display a list of tags and heads
7069proc showrefs {} {
7070    global showrefstop bgcolor fgcolor selectbgcolor
7071    global bglist fglist reflistfilter reflist maincursor
7072
7073    set top .showrefs
7074    set showrefstop $top
7075    if {[winfo exists $top]} {
7076        raise $top
7077        refill_reflist
7078        return
7079    }
7080    toplevel $top
7081    wm title $top "Tags and heads: [file tail [pwd]]"
7082    text $top.list -background $bgcolor -foreground $fgcolor \
7083        -selectbackground $selectbgcolor -font mainfont \
7084        -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
7085        -width 30 -height 20 -cursor $maincursor \
7086        -spacing1 1 -spacing3 1 -state disabled
7087    $top.list tag configure highlight -background $selectbgcolor
7088    lappend bglist $top.list
7089    lappend fglist $top.list
7090    scrollbar $top.ysb -command "$top.list yview" -orient vertical
7091    scrollbar $top.xsb -command "$top.list xview" -orient horizontal
7092    grid $top.list $top.ysb -sticky nsew
7093    grid $top.xsb x -sticky ew
7094    frame $top.f
7095    label $top.f.l -text "Filter: " -font uifont
7096    entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
7097    set reflistfilter "*"
7098    trace add variable reflistfilter write reflistfilter_change
7099    pack $top.f.e -side right -fill x -expand 1
7100    pack $top.f.l -side left
7101    grid $top.f - -sticky ew -pady 2
7102    button $top.close -command [list destroy $top] -text "Close" \
7103        -font uifont
7104    grid $top.close -
7105    grid columnconfigure $top 0 -weight 1
7106    grid rowconfigure $top 0 -weight 1
7107    bind $top.list <1> {break}
7108    bind $top.list <B1-Motion> {break}
7109    bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
7110    set reflist {}
7111    refill_reflist
7112}
7113
7114proc sel_reflist {w x y} {
7115    global showrefstop reflist headids tagids otherrefids
7116
7117    if {![winfo exists $showrefstop]} return
7118    set l [lindex [split [$w index "@$x,$y"] "."] 0]
7119    set ref [lindex $reflist [expr {$l-1}]]
7120    set n [lindex $ref 0]
7121    switch -- [lindex $ref 1] {
7122        "H" {selbyid $headids($n)}
7123        "T" {selbyid $tagids($n)}
7124        "o" {selbyid $otherrefids($n)}
7125    }
7126    $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
7127}
7128
7129proc unsel_reflist {} {
7130    global showrefstop
7131
7132    if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7133    $showrefstop.list tag remove highlight 0.0 end
7134}
7135
7136proc reflistfilter_change {n1 n2 op} {
7137    global reflistfilter
7138
7139    after cancel refill_reflist
7140    after 200 refill_reflist
7141}
7142
7143proc refill_reflist {} {
7144    global reflist reflistfilter showrefstop headids tagids otherrefids
7145    global curview commitinterest
7146
7147    if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
7148    set refs {}
7149    foreach n [array names headids] {
7150        if {[string match $reflistfilter $n]} {
7151            if {[commitinview $headids($n) $curview]} {
7152                lappend refs [list $n H]
7153            } else {
7154                set commitinterest($headids($n)) {run refill_reflist}
7155            }
7156        }
7157    }
7158    foreach n [array names tagids] {
7159        if {[string match $reflistfilter $n]} {
7160            if {[commitinview $tagids($n) $curview]} {
7161                lappend refs [list $n T]
7162            } else {
7163                set commitinterest($tagids($n)) {run refill_reflist}
7164            }
7165        }
7166    }
7167    foreach n [array names otherrefids] {
7168        if {[string match $reflistfilter $n]} {
7169            if {[commitinview $otherrefids($n) $curview]} {
7170                lappend refs [list $n o]
7171            } else {
7172                set commitinterest($otherrefids($n)) {run refill_reflist}
7173            }
7174        }
7175    }
7176    set refs [lsort -index 0 $refs]
7177    if {$refs eq $reflist} return
7178
7179    # Update the contents of $showrefstop.list according to the
7180    # differences between $reflist (old) and $refs (new)
7181    $showrefstop.list conf -state normal
7182    $showrefstop.list insert end "\n"
7183    set i 0
7184    set j 0
7185    while {$i < [llength $reflist] || $j < [llength $refs]} {
7186        if {$i < [llength $reflist]} {
7187            if {$j < [llength $refs]} {
7188                set cmp [string compare [lindex $reflist $i 0] \
7189                             [lindex $refs $j 0]]
7190                if {$cmp == 0} {
7191                    set cmp [string compare [lindex $reflist $i 1] \
7192                                 [lindex $refs $j 1]]
7193                }
7194            } else {
7195                set cmp -1
7196            }
7197        } else {
7198            set cmp 1
7199        }
7200        switch -- $cmp {
7201            -1 {
7202                $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
7203                incr i
7204            }
7205            0 {
7206                incr i
7207                incr j
7208            }
7209            1 {
7210                set l [expr {$j + 1}]
7211                $showrefstop.list image create $l.0 -align baseline \
7212                    -image reficon-[lindex $refs $j 1] -padx 2
7213                $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
7214                incr j
7215            }
7216        }
7217    }
7218    set reflist $refs
7219    # delete last newline
7220    $showrefstop.list delete end-2c end-1c
7221    $showrefstop.list conf -state disabled
7222}
7223
7224# Stuff for finding nearby tags
7225proc getallcommits {} {
7226    global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
7227    global idheads idtags idotherrefs allparents tagobjid
7228
7229    if {![info exists allcommits]} {
7230        set nextarc 0
7231        set allcommits 0
7232        set seeds {}
7233        set allcwait 0
7234        set cachedarcs 0
7235        set allccache [file join [gitdir] "gitk.cache"]
7236        if {![catch {
7237            set f [open $allccache r]
7238            set allcwait 1
7239            getcache $f
7240        }]} return
7241    }
7242
7243    if {$allcwait} {
7244        return
7245    }
7246    set cmd [list | git rev-list --parents]
7247    set allcupdate [expr {$seeds ne {}}]
7248    if {!$allcupdate} {
7249        set ids "--all"
7250    } else {
7251        set refs [concat [array names idheads] [array names idtags] \
7252                      [array names idotherrefs]]
7253        set ids {}
7254        set tagobjs {}
7255        foreach name [array names tagobjid] {
7256            lappend tagobjs $tagobjid($name)
7257        }
7258        foreach id [lsort -unique $refs] {
7259            if {![info exists allparents($id)] &&
7260                [lsearch -exact $tagobjs $id] < 0} {
7261                lappend ids $id
7262            }
7263        }
7264        if {$ids ne {}} {
7265            foreach id $seeds {
7266                lappend ids "^$id"
7267            }
7268        }
7269    }
7270    if {$ids ne {}} {
7271        set fd [open [concat $cmd $ids] r]
7272        fconfigure $fd -blocking 0
7273        incr allcommits
7274        nowbusy allcommits
7275        filerun $fd [list getallclines $fd]
7276    } else {
7277        dispneartags 0
7278    }
7279}
7280
7281# Since most commits have 1 parent and 1 child, we group strings of
7282# such commits into "arcs" joining branch/merge points (BMPs), which
7283# are commits that either don't have 1 parent or don't have 1 child.
7284#
7285# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
7286# arcout(id) - outgoing arcs for BMP
7287# arcids(a) - list of IDs on arc including end but not start
7288# arcstart(a) - BMP ID at start of arc
7289# arcend(a) - BMP ID at end of arc
7290# growing(a) - arc a is still growing
7291# arctags(a) - IDs out of arcids (excluding end) that have tags
7292# archeads(a) - IDs out of arcids (excluding end) that have heads
7293# The start of an arc is at the descendent end, so "incoming" means
7294# coming from descendents, and "outgoing" means going towards ancestors.
7295
7296proc getallclines {fd} {
7297    global allparents allchildren idtags idheads nextarc
7298    global arcnos arcids arctags arcout arcend arcstart archeads growing
7299    global seeds allcommits cachedarcs allcupdate
7300    
7301    set nid 0
7302    while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
7303        set id [lindex $line 0]
7304        if {[info exists allparents($id)]} {
7305            # seen it already
7306            continue
7307        }
7308        set cachedarcs 0
7309        set olds [lrange $line 1 end]
7310        set allparents($id) $olds
7311        if {![info exists allchildren($id)]} {
7312            set allchildren($id) {}
7313            set arcnos($id) {}
7314            lappend seeds $id
7315        } else {
7316            set a $arcnos($id)
7317            if {[llength $olds] == 1 && [llength $a] == 1} {
7318                lappend arcids($a) $id
7319                if {[info exists idtags($id)]} {
7320                    lappend arctags($a) $id
7321                }
7322                if {[info exists idheads($id)]} {
7323                    lappend archeads($a) $id
7324                }
7325                if {[info exists allparents($olds)]} {
7326                    # seen parent already
7327                    if {![info exists arcout($olds)]} {
7328                        splitarc $olds
7329                    }
7330                    lappend arcids($a) $olds
7331                    set arcend($a) $olds
7332                    unset growing($a)
7333                }
7334                lappend allchildren($olds) $id
7335                lappend arcnos($olds) $a
7336                continue
7337            }
7338        }
7339        foreach a $arcnos($id) {
7340            lappend arcids($a) $id
7341            set arcend($a) $id
7342            unset growing($a)
7343        }
7344
7345        set ao {}
7346        foreach p $olds {
7347            lappend allchildren($p) $id
7348            set a [incr nextarc]
7349            set arcstart($a) $id
7350            set archeads($a) {}
7351            set arctags($a) {}
7352            set archeads($a) {}
7353            set arcids($a) {}
7354            lappend ao $a
7355            set growing($a) 1
7356            if {[info exists allparents($p)]} {
7357                # seen it already, may need to make a new branch
7358                if {![info exists arcout($p)]} {
7359                    splitarc $p
7360                }
7361                lappend arcids($a) $p
7362                set arcend($a) $p
7363                unset growing($a)
7364            }
7365            lappend arcnos($p) $a
7366        }
7367        set arcout($id) $ao
7368    }
7369    if {$nid > 0} {
7370        global cached_dheads cached_dtags cached_atags
7371        catch {unset cached_dheads}
7372        catch {unset cached_dtags}
7373        catch {unset cached_atags}
7374    }
7375    if {![eof $fd]} {
7376        return [expr {$nid >= 1000? 2: 1}]
7377    }
7378    set cacheok 1
7379    if {[catch {
7380        fconfigure $fd -blocking 1
7381        close $fd
7382    } err]} {
7383        # got an error reading the list of commits
7384        # if we were updating, try rereading the whole thing again
7385        if {$allcupdate} {
7386            incr allcommits -1
7387            dropcache $err
7388            return
7389        }
7390        error_popup "Error reading commit topology information;\
7391                branch and preceding/following tag information\
7392                will be incomplete.\n($err)"
7393        set cacheok 0
7394    }
7395    if {[incr allcommits -1] == 0} {
7396        notbusy allcommits
7397        if {$cacheok} {
7398            run savecache
7399        }
7400    }
7401    dispneartags 0
7402    return 0
7403}
7404
7405proc recalcarc {a} {
7406    global arctags archeads arcids idtags idheads
7407
7408    set at {}
7409    set ah {}
7410    foreach id [lrange $arcids($a) 0 end-1] {
7411        if {[info exists idtags($id)]} {
7412            lappend at $id
7413        }
7414        if {[info exists idheads($id)]} {
7415            lappend ah $id
7416        }
7417    }
7418    set arctags($a) $at
7419    set archeads($a) $ah
7420}
7421
7422proc splitarc {p} {
7423    global arcnos arcids nextarc arctags archeads idtags idheads
7424    global arcstart arcend arcout allparents growing
7425
7426    set a $arcnos($p)
7427    if {[llength $a] != 1} {
7428        puts "oops splitarc called but [llength $a] arcs already"
7429        return
7430    }
7431    set a [lindex $a 0]
7432    set i [lsearch -exact $arcids($a) $p]
7433    if {$i < 0} {
7434        puts "oops splitarc $p not in arc $a"
7435        return
7436    }
7437    set na [incr nextarc]
7438    if {[info exists arcend($a)]} {
7439        set arcend($na) $arcend($a)
7440    } else {
7441        set l [lindex $allparents([lindex $arcids($a) end]) 0]
7442        set j [lsearch -exact $arcnos($l) $a]
7443        set arcnos($l) [lreplace $arcnos($l) $j $j $na]
7444    }
7445    set tail [lrange $arcids($a) [expr {$i+1}] end]
7446    set arcids($a) [lrange $arcids($a) 0 $i]
7447    set arcend($a) $p
7448    set arcstart($na) $p
7449    set arcout($p) $na
7450    set arcids($na) $tail
7451    if {[info exists growing($a)]} {
7452        set growing($na) 1
7453        unset growing($a)
7454    }
7455
7456    foreach id $tail {
7457        if {[llength $arcnos($id)] == 1} {
7458            set arcnos($id) $na
7459        } else {
7460            set j [lsearch -exact $arcnos($id) $a]
7461            set arcnos($id) [lreplace $arcnos($id) $j $j $na]
7462        }
7463    }
7464
7465    # reconstruct tags and heads lists
7466    if {$arctags($a) ne {} || $archeads($a) ne {}} {
7467        recalcarc $a
7468        recalcarc $na
7469    } else {
7470        set arctags($na) {}
7471        set archeads($na) {}
7472    }
7473}
7474
7475# Update things for a new commit added that is a child of one
7476# existing commit.  Used when cherry-picking.
7477proc addnewchild {id p} {
7478    global allparents allchildren idtags nextarc
7479    global arcnos arcids arctags arcout arcend arcstart archeads growing
7480    global seeds allcommits
7481
7482    if {![info exists allcommits] || ![info exists arcnos($p)]} return
7483    set allparents($id) [list $p]
7484    set allchildren($id) {}
7485    set arcnos($id) {}
7486    lappend seeds $id
7487    lappend allchildren($p) $id
7488    set a [incr nextarc]
7489    set arcstart($a) $id
7490    set archeads($a) {}
7491    set arctags($a) {}
7492    set arcids($a) [list $p]
7493    set arcend($a) $p
7494    if {![info exists arcout($p)]} {
7495        splitarc $p
7496    }
7497    lappend arcnos($p) $a
7498    set arcout($id) [list $a]
7499}
7500
7501# This implements a cache for the topology information.
7502# The cache saves, for each arc, the start and end of the arc,
7503# the ids on the arc, and the outgoing arcs from the end.
7504proc readcache {f} {
7505    global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7506    global idtags idheads allparents cachedarcs possible_seeds seeds growing
7507    global allcwait
7508
7509    set a $nextarc
7510    set lim $cachedarcs
7511    if {$lim - $a > 500} {
7512        set lim [expr {$a + 500}]
7513    }
7514    if {[catch {
7515        if {$a == $lim} {
7516            # finish reading the cache and setting up arctags, etc.
7517            set line [gets $f]
7518            if {$line ne "1"} {error "bad final version"}
7519            close $f
7520            foreach id [array names idtags] {
7521                if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7522                    [llength $allparents($id)] == 1} {
7523                    set a [lindex $arcnos($id) 0]
7524                    if {$arctags($a) eq {}} {
7525                        recalcarc $a
7526                    }
7527                }
7528            }
7529            foreach id [array names idheads] {
7530                if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7531                    [llength $allparents($id)] == 1} {
7532                    set a [lindex $arcnos($id) 0]
7533                    if {$archeads($a) eq {}} {
7534                        recalcarc $a
7535                    }
7536                }
7537            }
7538            foreach id [lsort -unique $possible_seeds] {
7539                if {$arcnos($id) eq {}} {
7540                    lappend seeds $id
7541                }
7542            }
7543            set allcwait 0
7544        } else {
7545            while {[incr a] <= $lim} {
7546                set line [gets $f]
7547                if {[llength $line] != 3} {error "bad line"}
7548                set s [lindex $line 0]
7549                set arcstart($a) $s
7550                lappend arcout($s) $a
7551                if {![info exists arcnos($s)]} {
7552                    lappend possible_seeds $s
7553                    set arcnos($s) {}
7554                }
7555                set e [lindex $line 1]
7556                if {$e eq {}} {
7557                    set growing($a) 1
7558                } else {
7559                    set arcend($a) $e
7560                    if {![info exists arcout($e)]} {
7561                        set arcout($e) {}
7562                    }
7563                }
7564                set arcids($a) [lindex $line 2]
7565                foreach id $arcids($a) {
7566                    lappend allparents($s) $id
7567                    set s $id
7568                    lappend arcnos($id) $a
7569                }
7570                if {![info exists allparents($s)]} {
7571                    set allparents($s) {}
7572                }
7573                set arctags($a) {}
7574                set archeads($a) {}
7575            }
7576            set nextarc [expr {$a - 1}]
7577        }
7578    } err]} {
7579        dropcache $err
7580        return 0
7581    }
7582    if {!$allcwait} {
7583        getallcommits
7584    }
7585    return $allcwait
7586}
7587
7588proc getcache {f} {
7589    global nextarc cachedarcs possible_seeds
7590
7591    if {[catch {
7592        set line [gets $f]
7593        if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7594        # make sure it's an integer
7595        set cachedarcs [expr {int([lindex $line 1])}]
7596        if {$cachedarcs < 0} {error "bad number of arcs"}
7597        set nextarc 0
7598        set possible_seeds {}
7599        run readcache $f
7600    } err]} {
7601        dropcache $err
7602    }
7603    return 0
7604}
7605
7606proc dropcache {err} {
7607    global allcwait nextarc cachedarcs seeds
7608
7609    #puts "dropping cache ($err)"
7610    foreach v {arcnos arcout arcids arcstart arcend growing \
7611                   arctags archeads allparents allchildren} {
7612        global $v
7613        catch {unset $v}
7614    }
7615    set allcwait 0
7616    set nextarc 0
7617    set cachedarcs 0
7618    set seeds {}
7619    getallcommits
7620}
7621
7622proc writecache {f} {
7623    global cachearc cachedarcs allccache
7624    global arcstart arcend arcnos arcids arcout
7625
7626    set a $cachearc
7627    set lim $cachedarcs
7628    if {$lim - $a > 1000} {
7629        set lim [expr {$a + 1000}]
7630    }
7631    if {[catch {
7632        while {[incr a] <= $lim} {
7633            if {[info exists arcend($a)]} {
7634                puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7635            } else {
7636                puts $f [list $arcstart($a) {} $arcids($a)]
7637            }
7638        }
7639    } err]} {
7640        catch {close $f}
7641        catch {file delete $allccache}
7642        #puts "writing cache failed ($err)"
7643        return 0
7644    }
7645    set cachearc [expr {$a - 1}]
7646    if {$a > $cachedarcs} {
7647        puts $f "1"
7648        close $f
7649        return 0
7650    }
7651    return 1
7652}
7653
7654proc savecache {} {
7655    global nextarc cachedarcs cachearc allccache
7656
7657    if {$nextarc == $cachedarcs} return
7658    set cachearc 0
7659    set cachedarcs $nextarc
7660    catch {
7661        set f [open $allccache w]
7662        puts $f [list 1 $cachedarcs]
7663        run writecache $f
7664    }
7665}
7666
7667# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7668# or 0 if neither is true.
7669proc anc_or_desc {a b} {
7670    global arcout arcstart arcend arcnos cached_isanc
7671
7672    if {$arcnos($a) eq $arcnos($b)} {
7673        # Both are on the same arc(s); either both are the same BMP,
7674        # or if one is not a BMP, the other is also not a BMP or is
7675        # the BMP at end of the arc (and it only has 1 incoming arc).
7676        # Or both can be BMPs with no incoming arcs.
7677        if {$a eq $b || $arcnos($a) eq {}} {
7678            return 0
7679        }
7680        # assert {[llength $arcnos($a)] == 1}
7681        set arc [lindex $arcnos($a) 0]
7682        set i [lsearch -exact $arcids($arc) $a]
7683        set j [lsearch -exact $arcids($arc) $b]
7684        if {$i < 0 || $i > $j} {
7685            return 1
7686        } else {
7687            return -1
7688        }
7689    }
7690
7691    if {![info exists arcout($a)]} {
7692        set arc [lindex $arcnos($a) 0]
7693        if {[info exists arcend($arc)]} {
7694            set aend $arcend($arc)
7695        } else {
7696            set aend {}
7697        }
7698        set a $arcstart($arc)
7699    } else {
7700        set aend $a
7701    }
7702    if {![info exists arcout($b)]} {
7703        set arc [lindex $arcnos($b) 0]
7704        if {[info exists arcend($arc)]} {
7705            set bend $arcend($arc)
7706        } else {
7707            set bend {}
7708        }
7709        set b $arcstart($arc)
7710    } else {
7711        set bend $b
7712    }
7713    if {$a eq $bend} {
7714        return 1
7715    }
7716    if {$b eq $aend} {
7717        return -1
7718    }
7719    if {[info exists cached_isanc($a,$bend)]} {
7720        if {$cached_isanc($a,$bend)} {
7721            return 1
7722        }
7723    }
7724    if {[info exists cached_isanc($b,$aend)]} {
7725        if {$cached_isanc($b,$aend)} {
7726            return -1
7727        }
7728        if {[info exists cached_isanc($a,$bend)]} {
7729            return 0
7730        }
7731    }
7732
7733    set todo [list $a $b]
7734    set anc($a) a
7735    set anc($b) b
7736    for {set i 0} {$i < [llength $todo]} {incr i} {
7737        set x [lindex $todo $i]
7738        if {$anc($x) eq {}} {
7739            continue
7740        }
7741        foreach arc $arcnos($x) {
7742            set xd $arcstart($arc)
7743            if {$xd eq $bend} {
7744                set cached_isanc($a,$bend) 1
7745                set cached_isanc($b,$aend) 0
7746                return 1
7747            } elseif {$xd eq $aend} {
7748                set cached_isanc($b,$aend) 1
7749                set cached_isanc($a,$bend) 0
7750                return -1
7751            }
7752            if {![info exists anc($xd)]} {
7753                set anc($xd) $anc($x)
7754                lappend todo $xd
7755            } elseif {$anc($xd) ne $anc($x)} {
7756                set anc($xd) {}
7757            }
7758        }
7759    }
7760    set cached_isanc($a,$bend) 0
7761    set cached_isanc($b,$aend) 0
7762    return 0
7763}
7764
7765# This identifies whether $desc has an ancestor that is
7766# a growing tip of the graph and which is not an ancestor of $anc
7767# and returns 0 if so and 1 if not.
7768# If we subsequently discover a tag on such a growing tip, and that
7769# turns out to be a descendent of $anc (which it could, since we
7770# don't necessarily see children before parents), then $desc
7771# isn't a good choice to display as a descendent tag of
7772# $anc (since it is the descendent of another tag which is
7773# a descendent of $anc).  Similarly, $anc isn't a good choice to
7774# display as a ancestor tag of $desc.
7775#
7776proc is_certain {desc anc} {
7777    global arcnos arcout arcstart arcend growing problems
7778
7779    set certain {}
7780    if {[llength $arcnos($anc)] == 1} {
7781        # tags on the same arc are certain
7782        if {$arcnos($desc) eq $arcnos($anc)} {
7783            return 1
7784        }
7785        if {![info exists arcout($anc)]} {
7786            # if $anc is partway along an arc, use the start of the arc instead
7787            set a [lindex $arcnos($anc) 0]
7788            set anc $arcstart($a)
7789        }
7790    }
7791    if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7792        set x $desc
7793    } else {
7794        set a [lindex $arcnos($desc) 0]
7795        set x $arcend($a)
7796    }
7797    if {$x == $anc} {
7798        return 1
7799    }
7800    set anclist [list $x]
7801    set dl($x) 1
7802    set nnh 1
7803    set ngrowanc 0
7804    for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7805        set x [lindex $anclist $i]
7806        if {$dl($x)} {
7807            incr nnh -1
7808        }
7809        set done($x) 1
7810        foreach a $arcout($x) {
7811            if {[info exists growing($a)]} {
7812                if {![info exists growanc($x)] && $dl($x)} {
7813                    set growanc($x) 1
7814                    incr ngrowanc
7815                }
7816            } else {
7817                set y $arcend($a)
7818                if {[info exists dl($y)]} {
7819                    if {$dl($y)} {
7820                        if {!$dl($x)} {
7821                            set dl($y) 0
7822                            if {![info exists done($y)]} {
7823                                incr nnh -1
7824                            }
7825                            if {[info exists growanc($x)]} {
7826                                incr ngrowanc -1
7827                            }
7828                            set xl [list $y]
7829                            for {set k 0} {$k < [llength $xl]} {incr k} {
7830                                set z [lindex $xl $k]
7831                                foreach c $arcout($z) {
7832                                    if {[info exists arcend($c)]} {
7833                                        set v $arcend($c)
7834                                        if {[info exists dl($v)] && $dl($v)} {
7835                                            set dl($v) 0
7836                                            if {![info exists done($v)]} {
7837                                                incr nnh -1
7838                                            }
7839                                            if {[info exists growanc($v)]} {
7840                                                incr ngrowanc -1
7841                                            }
7842                                            lappend xl $v
7843                                        }
7844                                    }
7845                                }
7846                            }
7847                        }
7848                    }
7849                } elseif {$y eq $anc || !$dl($x)} {
7850                    set dl($y) 0
7851                    lappend anclist $y
7852                } else {
7853                    set dl($y) 1
7854                    lappend anclist $y
7855                    incr nnh
7856                }
7857            }
7858        }
7859    }
7860    foreach x [array names growanc] {
7861        if {$dl($x)} {
7862            return 0
7863        }
7864        return 0
7865    }
7866    return 1
7867}
7868
7869proc validate_arctags {a} {
7870    global arctags idtags
7871
7872    set i -1
7873    set na $arctags($a)
7874    foreach id $arctags($a) {
7875        incr i
7876        if {![info exists idtags($id)]} {
7877            set na [lreplace $na $i $i]
7878            incr i -1
7879        }
7880    }
7881    set arctags($a) $na
7882}
7883
7884proc validate_archeads {a} {
7885    global archeads idheads
7886
7887    set i -1
7888    set na $archeads($a)
7889    foreach id $archeads($a) {
7890        incr i
7891        if {![info exists idheads($id)]} {
7892            set na [lreplace $na $i $i]
7893            incr i -1
7894        }
7895    }
7896    set archeads($a) $na
7897}
7898
7899# Return the list of IDs that have tags that are descendents of id,
7900# ignoring IDs that are descendents of IDs already reported.
7901proc desctags {id} {
7902    global arcnos arcstart arcids arctags idtags allparents
7903    global growing cached_dtags
7904
7905    if {![info exists allparents($id)]} {
7906        return {}
7907    }
7908    set t1 [clock clicks -milliseconds]
7909    set argid $id
7910    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7911        # part-way along an arc; check that arc first
7912        set a [lindex $arcnos($id) 0]
7913        if {$arctags($a) ne {}} {
7914            validate_arctags $a
7915            set i [lsearch -exact $arcids($a) $id]
7916            set tid {}
7917            foreach t $arctags($a) {
7918                set j [lsearch -exact $arcids($a) $t]
7919                if {$j >= $i} break
7920                set tid $t
7921            }
7922            if {$tid ne {}} {
7923                return $tid
7924            }
7925        }
7926        set id $arcstart($a)
7927        if {[info exists idtags($id)]} {
7928            return $id
7929        }
7930    }
7931    if {[info exists cached_dtags($id)]} {
7932        return $cached_dtags($id)
7933    }
7934
7935    set origid $id
7936    set todo [list $id]
7937    set queued($id) 1
7938    set nc 1
7939    for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7940        set id [lindex $todo $i]
7941        set done($id) 1
7942        set ta [info exists hastaggedancestor($id)]
7943        if {!$ta} {
7944            incr nc -1
7945        }
7946        # ignore tags on starting node
7947        if {!$ta && $i > 0} {
7948            if {[info exists idtags($id)]} {
7949                set tagloc($id) $id
7950                set ta 1
7951            } elseif {[info exists cached_dtags($id)]} {
7952                set tagloc($id) $cached_dtags($id)
7953                set ta 1
7954            }
7955        }
7956        foreach a $arcnos($id) {
7957            set d $arcstart($a)
7958            if {!$ta && $arctags($a) ne {}} {
7959                validate_arctags $a
7960                if {$arctags($a) ne {}} {
7961                    lappend tagloc($id) [lindex $arctags($a) end]
7962                }
7963            }
7964            if {$ta || $arctags($a) ne {}} {
7965                set tomark [list $d]
7966                for {set j 0} {$j < [llength $tomark]} {incr j} {
7967                    set dd [lindex $tomark $j]
7968                    if {![info exists hastaggedancestor($dd)]} {
7969                        if {[info exists done($dd)]} {
7970                            foreach b $arcnos($dd) {
7971                                lappend tomark $arcstart($b)
7972                            }
7973                            if {[info exists tagloc($dd)]} {
7974                                unset tagloc($dd)
7975                            }
7976                        } elseif {[info exists queued($dd)]} {
7977                            incr nc -1
7978                        }
7979                        set hastaggedancestor($dd) 1
7980                    }
7981                }
7982            }
7983            if {![info exists queued($d)]} {
7984                lappend todo $d
7985                set queued($d) 1
7986                if {![info exists hastaggedancestor($d)]} {
7987                    incr nc
7988                }
7989            }
7990        }
7991    }
7992    set tags {}
7993    foreach id [array names tagloc] {
7994        if {![info exists hastaggedancestor($id)]} {
7995            foreach t $tagloc($id) {
7996                if {[lsearch -exact $tags $t] < 0} {
7997                    lappend tags $t
7998                }
7999            }
8000        }
8001    }
8002    set t2 [clock clicks -milliseconds]
8003    set loopix $i
8004
8005    # remove tags that are descendents of other tags
8006    for {set i 0} {$i < [llength $tags]} {incr i} {
8007        set a [lindex $tags $i]
8008        for {set j 0} {$j < $i} {incr j} {
8009            set b [lindex $tags $j]
8010            set r [anc_or_desc $a $b]
8011            if {$r == 1} {
8012                set tags [lreplace $tags $j $j]
8013                incr j -1
8014                incr i -1
8015            } elseif {$r == -1} {
8016                set tags [lreplace $tags $i $i]
8017                incr i -1
8018                break
8019            }
8020        }
8021    }
8022
8023    if {[array names growing] ne {}} {
8024        # graph isn't finished, need to check if any tag could get
8025        # eclipsed by another tag coming later.  Simply ignore any
8026        # tags that could later get eclipsed.
8027        set ctags {}
8028        foreach t $tags {
8029            if {[is_certain $t $origid]} {
8030                lappend ctags $t
8031            }
8032        }
8033        if {$tags eq $ctags} {
8034            set cached_dtags($origid) $tags
8035        } else {
8036            set tags $ctags
8037        }
8038    } else {
8039        set cached_dtags($origid) $tags
8040    }
8041    set t3 [clock clicks -milliseconds]
8042    if {0 && $t3 - $t1 >= 100} {
8043        puts "iterating descendents ($loopix/[llength $todo] nodes) took\
8044            [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8045    }
8046    return $tags
8047}
8048
8049proc anctags {id} {
8050    global arcnos arcids arcout arcend arctags idtags allparents
8051    global growing cached_atags
8052
8053    if {![info exists allparents($id)]} {
8054        return {}
8055    }
8056    set t1 [clock clicks -milliseconds]
8057    set argid $id
8058    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8059        # part-way along an arc; check that arc first
8060        set a [lindex $arcnos($id) 0]
8061        if {$arctags($a) ne {}} {
8062            validate_arctags $a
8063            set i [lsearch -exact $arcids($a) $id]
8064            foreach t $arctags($a) {
8065                set j [lsearch -exact $arcids($a) $t]
8066                if {$j > $i} {
8067                    return $t
8068                }
8069            }
8070        }
8071        if {![info exists arcend($a)]} {
8072            return {}
8073        }
8074        set id $arcend($a)
8075        if {[info exists idtags($id)]} {
8076            return $id
8077        }
8078    }
8079    if {[info exists cached_atags($id)]} {
8080        return $cached_atags($id)
8081    }
8082
8083    set origid $id
8084    set todo [list $id]
8085    set queued($id) 1
8086    set taglist {}
8087    set nc 1
8088    for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
8089        set id [lindex $todo $i]
8090        set done($id) 1
8091        set td [info exists hastaggeddescendent($id)]
8092        if {!$td} {
8093            incr nc -1
8094        }
8095        # ignore tags on starting node
8096        if {!$td && $i > 0} {
8097            if {[info exists idtags($id)]} {
8098                set tagloc($id) $id
8099                set td 1
8100            } elseif {[info exists cached_atags($id)]} {
8101                set tagloc($id) $cached_atags($id)
8102                set td 1
8103            }
8104        }
8105        foreach a $arcout($id) {
8106            if {!$td && $arctags($a) ne {}} {
8107                validate_arctags $a
8108                if {$arctags($a) ne {}} {
8109                    lappend tagloc($id) [lindex $arctags($a) 0]
8110                }
8111            }
8112            if {![info exists arcend($a)]} continue
8113            set d $arcend($a)
8114            if {$td || $arctags($a) ne {}} {
8115                set tomark [list $d]
8116                for {set j 0} {$j < [llength $tomark]} {incr j} {
8117                    set dd [lindex $tomark $j]
8118                    if {![info exists hastaggeddescendent($dd)]} {
8119                        if {[info exists done($dd)]} {
8120                            foreach b $arcout($dd) {
8121                                if {[info exists arcend($b)]} {
8122                                    lappend tomark $arcend($b)
8123                                }
8124                            }
8125                            if {[info exists tagloc($dd)]} {
8126                                unset tagloc($dd)
8127                            }
8128                        } elseif {[info exists queued($dd)]} {
8129                            incr nc -1
8130                        }
8131                        set hastaggeddescendent($dd) 1
8132                    }
8133                }
8134            }
8135            if {![info exists queued($d)]} {
8136                lappend todo $d
8137                set queued($d) 1
8138                if {![info exists hastaggeddescendent($d)]} {
8139                    incr nc
8140                }
8141            }
8142        }
8143    }
8144    set t2 [clock clicks -milliseconds]
8145    set loopix $i
8146    set tags {}
8147    foreach id [array names tagloc] {
8148        if {![info exists hastaggeddescendent($id)]} {
8149            foreach t $tagloc($id) {
8150                if {[lsearch -exact $tags $t] < 0} {
8151                    lappend tags $t
8152                }
8153            }
8154        }
8155    }
8156
8157    # remove tags that are ancestors of other tags
8158    for {set i 0} {$i < [llength $tags]} {incr i} {
8159        set a [lindex $tags $i]
8160        for {set j 0} {$j < $i} {incr j} {
8161            set b [lindex $tags $j]
8162            set r [anc_or_desc $a $b]
8163            if {$r == -1} {
8164                set tags [lreplace $tags $j $j]
8165                incr j -1
8166                incr i -1
8167            } elseif {$r == 1} {
8168                set tags [lreplace $tags $i $i]
8169                incr i -1
8170                break
8171            }
8172        }
8173    }
8174
8175    if {[array names growing] ne {}} {
8176        # graph isn't finished, need to check if any tag could get
8177        # eclipsed by another tag coming later.  Simply ignore any
8178        # tags that could later get eclipsed.
8179        set ctags {}
8180        foreach t $tags {
8181            if {[is_certain $origid $t]} {
8182                lappend ctags $t
8183            }
8184        }
8185        if {$tags eq $ctags} {
8186            set cached_atags($origid) $tags
8187        } else {
8188            set tags $ctags
8189        }
8190    } else {
8191        set cached_atags($origid) $tags
8192    }
8193    set t3 [clock clicks -milliseconds]
8194    if {0 && $t3 - $t1 >= 100} {
8195        puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
8196            [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
8197    }
8198    return $tags
8199}
8200
8201# Return the list of IDs that have heads that are descendents of id,
8202# including id itself if it has a head.
8203proc descheads {id} {
8204    global arcnos arcstart arcids archeads idheads cached_dheads
8205    global allparents
8206
8207    if {![info exists allparents($id)]} {
8208        return {}
8209    }
8210    set aret {}
8211    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
8212        # part-way along an arc; check it first
8213        set a [lindex $arcnos($id) 0]
8214        if {$archeads($a) ne {}} {
8215            validate_archeads $a
8216            set i [lsearch -exact $arcids($a) $id]
8217            foreach t $archeads($a) {
8218                set j [lsearch -exact $arcids($a) $t]
8219                if {$j > $i} break
8220                lappend aret $t
8221            }
8222        }
8223        set id $arcstart($a)
8224    }
8225    set origid $id
8226    set todo [list $id]
8227    set seen($id) 1
8228    set ret {}
8229    for {set i 0} {$i < [llength $todo]} {incr i} {
8230        set id [lindex $todo $i]
8231        if {[info exists cached_dheads($id)]} {
8232            set ret [concat $ret $cached_dheads($id)]
8233        } else {
8234            if {[info exists idheads($id)]} {
8235                lappend ret $id
8236            }
8237            foreach a $arcnos($id) {
8238                if {$archeads($a) ne {}} {
8239                    validate_archeads $a
8240                    if {$archeads($a) ne {}} {
8241                        set ret [concat $ret $archeads($a)]
8242                    }
8243                }
8244                set d $arcstart($a)
8245                if {![info exists seen($d)]} {
8246                    lappend todo $d
8247                    set seen($d) 1
8248                }
8249            }
8250        }
8251    }
8252    set ret [lsort -unique $ret]
8253    set cached_dheads($origid) $ret
8254    return [concat $ret $aret]
8255}
8256
8257proc addedtag {id} {
8258    global arcnos arcout cached_dtags cached_atags
8259
8260    if {![info exists arcnos($id)]} return
8261    if {![info exists arcout($id)]} {
8262        recalcarc [lindex $arcnos($id) 0]
8263    }
8264    catch {unset cached_dtags}
8265    catch {unset cached_atags}
8266}
8267
8268proc addedhead {hid head} {
8269    global arcnos arcout cached_dheads
8270
8271    if {![info exists arcnos($hid)]} return
8272    if {![info exists arcout($hid)]} {
8273        recalcarc [lindex $arcnos($hid) 0]
8274    }
8275    catch {unset cached_dheads}
8276}
8277
8278proc removedhead {hid head} {
8279    global cached_dheads
8280
8281    catch {unset cached_dheads}
8282}
8283
8284proc movedhead {hid head} {
8285    global arcnos arcout cached_dheads
8286
8287    if {![info exists arcnos($hid)]} return
8288    if {![info exists arcout($hid)]} {
8289        recalcarc [lindex $arcnos($hid) 0]
8290    }
8291    catch {unset cached_dheads}
8292}
8293
8294proc changedrefs {} {
8295    global cached_dheads cached_dtags cached_atags
8296    global arctags archeads arcnos arcout idheads idtags
8297
8298    foreach id [concat [array names idheads] [array names idtags]] {
8299        if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
8300            set a [lindex $arcnos($id) 0]
8301            if {![info exists donearc($a)]} {
8302                recalcarc $a
8303                set donearc($a) 1
8304            }
8305        }
8306    }
8307    catch {unset cached_dtags}
8308    catch {unset cached_atags}
8309    catch {unset cached_dheads}
8310}
8311
8312proc rereadrefs {} {
8313    global idtags idheads idotherrefs mainhead
8314
8315    set refids [concat [array names idtags] \
8316                    [array names idheads] [array names idotherrefs]]
8317    foreach id $refids {
8318        if {![info exists ref($id)]} {
8319            set ref($id) [listrefs $id]
8320        }
8321    }
8322    set oldmainhead $mainhead
8323    readrefs
8324    changedrefs
8325    set refids [lsort -unique [concat $refids [array names idtags] \
8326                        [array names idheads] [array names idotherrefs]]]
8327    foreach id $refids {
8328        set v [listrefs $id]
8329        if {![info exists ref($id)] || $ref($id) != $v ||
8330            ($id eq $oldmainhead && $id ne $mainhead) ||
8331            ($id eq $mainhead && $id ne $oldmainhead)} {
8332            redrawtags $id
8333        }
8334    }
8335    run refill_reflist
8336}
8337
8338proc listrefs {id} {
8339    global idtags idheads idotherrefs
8340
8341    set x {}
8342    if {[info exists idtags($id)]} {
8343        set x $idtags($id)
8344    }
8345    set y {}
8346    if {[info exists idheads($id)]} {
8347        set y $idheads($id)
8348    }
8349    set z {}
8350    if {[info exists idotherrefs($id)]} {
8351        set z $idotherrefs($id)
8352    }
8353    return [list $x $y $z]
8354}
8355
8356proc showtag {tag isnew} {
8357    global ctext tagcontents tagids linknum tagobjid
8358
8359    if {$isnew} {
8360        addtohistory [list showtag $tag 0]
8361    }
8362    $ctext conf -state normal
8363    clear_ctext
8364    settabs 0
8365    set linknum 0
8366    if {![info exists tagcontents($tag)]} {
8367        catch {
8368            set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
8369        }
8370    }
8371    if {[info exists tagcontents($tag)]} {
8372        set text $tagcontents($tag)
8373    } else {
8374        set text "Tag: $tag\nId:  $tagids($tag)"
8375    }
8376    appendwithlinks $text {}
8377    $ctext conf -state disabled
8378    init_flist {}
8379}
8380
8381proc doquit {} {
8382    global stopped
8383    set stopped 100
8384    savestuff .
8385    destroy .
8386}
8387
8388proc mkfontdisp {font top which} {
8389    global fontattr fontpref $font
8390
8391    set fontpref($font) [set $font]
8392    button $top.${font}but -text $which -font optionfont \
8393        -command [list choosefont $font $which]
8394    label $top.$font -relief flat -font $font \
8395        -text $fontattr($font,family) -justify left
8396    grid x $top.${font}but $top.$font -sticky w
8397}
8398
8399proc choosefont {font which} {
8400    global fontparam fontlist fonttop fontattr
8401
8402    set fontparam(which) $which
8403    set fontparam(font) $font
8404    set fontparam(family) [font actual $font -family]
8405    set fontparam(size) $fontattr($font,size)
8406    set fontparam(weight) $fontattr($font,weight)
8407    set fontparam(slant) $fontattr($font,slant)
8408    set top .gitkfont
8409    set fonttop $top
8410    if {![winfo exists $top]} {
8411        font create sample
8412        eval font config sample [font actual $font]
8413        toplevel $top
8414        wm title $top "Gitk font chooser"
8415        label $top.l -textvariable fontparam(which) -font uifont
8416        pack $top.l -side top
8417        set fontlist [lsort [font families]]
8418        frame $top.f
8419        listbox $top.f.fam -listvariable fontlist \
8420            -yscrollcommand [list $top.f.sb set]
8421        bind $top.f.fam <<ListboxSelect>> selfontfam
8422        scrollbar $top.f.sb -command [list $top.f.fam yview]
8423        pack $top.f.sb -side right -fill y
8424        pack $top.f.fam -side left -fill both -expand 1
8425        pack $top.f -side top -fill both -expand 1
8426        frame $top.g
8427        spinbox $top.g.size -from 4 -to 40 -width 4 \
8428            -textvariable fontparam(size) \
8429            -validatecommand {string is integer -strict %s}
8430        checkbutton $top.g.bold -padx 5 \
8431            -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
8432            -variable fontparam(weight) -onvalue bold -offvalue normal
8433        checkbutton $top.g.ital -padx 5 \
8434            -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0  \
8435            -variable fontparam(slant) -onvalue italic -offvalue roman
8436        pack $top.g.size $top.g.bold $top.g.ital -side left
8437        pack $top.g -side top
8438        canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8439            -background white
8440        $top.c create text 100 25 -anchor center -text $which -font sample \
8441            -fill black -tags text
8442        bind $top.c <Configure> [list centertext $top.c]
8443        pack $top.c -side top -fill x
8444        frame $top.buts
8445        button $top.buts.ok -text "OK" -command fontok -default active \
8446            -font uifont
8447        button $top.buts.can -text "Cancel" -command fontcan -default normal \
8448            -font uifont
8449        grid $top.buts.ok $top.buts.can
8450        grid columnconfigure $top.buts 0 -weight 1 -uniform a
8451        grid columnconfigure $top.buts 1 -weight 1 -uniform a
8452        pack $top.buts -side bottom -fill x
8453        trace add variable fontparam write chg_fontparam
8454    } else {
8455        raise $top
8456        $top.c itemconf text -text $which
8457    }
8458    set i [lsearch -exact $fontlist $fontparam(family)]
8459    if {$i >= 0} {
8460        $top.f.fam selection set $i
8461        $top.f.fam see $i
8462    }
8463}
8464
8465proc centertext {w} {
8466    $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8467}
8468
8469proc fontok {} {
8470    global fontparam fontpref prefstop
8471
8472    set f $fontparam(font)
8473    set fontpref($f) [list $fontparam(family) $fontparam(size)]
8474    if {$fontparam(weight) eq "bold"} {
8475        lappend fontpref($f) "bold"
8476    }
8477    if {$fontparam(slant) eq "italic"} {
8478        lappend fontpref($f) "italic"
8479    }
8480    set w $prefstop.$f
8481    $w conf -text $fontparam(family) -font $fontpref($f)
8482        
8483    fontcan
8484}
8485
8486proc fontcan {} {
8487    global fonttop fontparam
8488
8489    if {[info exists fonttop]} {
8490        catch {destroy $fonttop}
8491        catch {font delete sample}
8492        unset fonttop
8493        unset fontparam
8494    }
8495}
8496
8497proc selfontfam {} {
8498    global fonttop fontparam
8499
8500    set i [$fonttop.f.fam curselection]
8501    if {$i ne {}} {
8502        set fontparam(family) [$fonttop.f.fam get $i]
8503    }
8504}
8505
8506proc chg_fontparam {v sub op} {
8507    global fontparam
8508
8509    font config sample -$sub $fontparam($sub)
8510}
8511
8512proc doprefs {} {
8513    global maxwidth maxgraphpct
8514    global oldprefs prefstop showneartags showlocalchanges
8515    global bgcolor fgcolor ctext diffcolors selectbgcolor
8516    global uifont tabstop limitdiffs
8517
8518    set top .gitkprefs
8519    set prefstop $top
8520    if {[winfo exists $top]} {
8521        raise $top
8522        return
8523    }
8524    foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8525                   limitdiffs tabstop} {
8526        set oldprefs($v) [set $v]
8527    }
8528    toplevel $top
8529    wm title $top "Gitk preferences"
8530    label $top.ldisp -text "Commit list display options"
8531    $top.ldisp configure -font uifont
8532    grid $top.ldisp - -sticky w -pady 10
8533    label $top.spacer -text " "
8534    label $top.maxwidthl -text "Maximum graph width (lines)" \
8535        -font optionfont
8536    spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8537    grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8538    label $top.maxpctl -text "Maximum graph width (% of pane)" \
8539        -font optionfont
8540    spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8541    grid x $top.maxpctl $top.maxpct -sticky w
8542    frame $top.showlocal
8543    label $top.showlocal.l -text "Show local changes" -font optionfont
8544    checkbutton $top.showlocal.b -variable showlocalchanges
8545    pack $top.showlocal.b $top.showlocal.l -side left
8546    grid x $top.showlocal -sticky w
8547
8548    label $top.ddisp -text "Diff display options"
8549    $top.ddisp configure -font uifont
8550    grid $top.ddisp - -sticky w -pady 10
8551    label $top.tabstopl -text "Tab spacing" -font optionfont
8552    spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8553    grid x $top.tabstopl $top.tabstop -sticky w
8554    frame $top.ntag
8555    label $top.ntag.l -text "Display nearby tags" -font optionfont
8556    checkbutton $top.ntag.b -variable showneartags
8557    pack $top.ntag.b $top.ntag.l -side left
8558    grid x $top.ntag -sticky w
8559    frame $top.ldiff
8560    label $top.ldiff.l -text "Limit diffs to listed paths" -font optionfont
8561    checkbutton $top.ldiff.b -variable limitdiffs
8562    pack $top.ldiff.b $top.ldiff.l -side left
8563    grid x $top.ldiff -sticky w
8564
8565    label $top.cdisp -text "Colors: press to choose"
8566    $top.cdisp configure -font uifont
8567    grid $top.cdisp - -sticky w -pady 10
8568    label $top.bg -padx 40 -relief sunk -background $bgcolor
8569    button $top.bgbut -text "Background" -font optionfont \
8570        -command [list choosecolor bgcolor 0 $top.bg background setbg]
8571    grid x $top.bgbut $top.bg -sticky w
8572    label $top.fg -padx 40 -relief sunk -background $fgcolor
8573    button $top.fgbut -text "Foreground" -font optionfont \
8574        -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8575    grid x $top.fgbut $top.fg -sticky w
8576    label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8577    button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8578        -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8579                      [list $ctext tag conf d0 -foreground]]
8580    grid x $top.diffoldbut $top.diffold -sticky w
8581    label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8582    button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8583        -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8584                      [list $ctext tag conf d1 -foreground]]
8585    grid x $top.diffnewbut $top.diffnew -sticky w
8586    label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8587    button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8588        -command [list choosecolor diffcolors 2 $top.hunksep \
8589                      "diff hunk header" \
8590                      [list $ctext tag conf hunksep -foreground]]
8591    grid x $top.hunksepbut $top.hunksep -sticky w
8592    label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8593    button $top.selbgbut -text "Select bg" -font optionfont \
8594        -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8595    grid x $top.selbgbut $top.selbgsep -sticky w
8596
8597    label $top.cfont -text "Fonts: press to choose"
8598    $top.cfont configure -font uifont
8599    grid $top.cfont - -sticky w -pady 10
8600    mkfontdisp mainfont $top "Main font"
8601    mkfontdisp textfont $top "Diff display font"
8602    mkfontdisp uifont $top "User interface font"
8603
8604    frame $top.buts
8605    button $top.buts.ok -text "OK" -command prefsok -default active
8606    $top.buts.ok configure -font uifont
8607    button $top.buts.can -text "Cancel" -command prefscan -default normal
8608    $top.buts.can configure -font uifont
8609    grid $top.buts.ok $top.buts.can
8610    grid columnconfigure $top.buts 0 -weight 1 -uniform a
8611    grid columnconfigure $top.buts 1 -weight 1 -uniform a
8612    grid $top.buts - - -pady 10 -sticky ew
8613    bind $top <Visibility> "focus $top.buts.ok"
8614}
8615
8616proc choosecolor {v vi w x cmd} {
8617    global $v
8618
8619    set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8620               -title "Gitk: choose color for $x"]
8621    if {$c eq {}} return
8622    $w conf -background $c
8623    lset $v $vi $c
8624    eval $cmd $c
8625}
8626
8627proc setselbg {c} {
8628    global bglist cflist
8629    foreach w $bglist {
8630        $w configure -selectbackground $c
8631    }
8632    $cflist tag configure highlight \
8633        -background [$cflist cget -selectbackground]
8634    allcanvs itemconf secsel -fill $c
8635}
8636
8637proc setbg {c} {
8638    global bglist
8639
8640    foreach w $bglist {
8641        $w conf -background $c
8642    }
8643}
8644
8645proc setfg {c} {
8646    global fglist canv
8647
8648    foreach w $fglist {
8649        $w conf -foreground $c
8650    }
8651    allcanvs itemconf text -fill $c
8652    $canv itemconf circle -outline $c
8653}
8654
8655proc prefscan {} {
8656    global oldprefs prefstop
8657
8658    foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8659                   limitdiffs tabstop} {
8660        global $v
8661        set $v $oldprefs($v)
8662    }
8663    catch {destroy $prefstop}
8664    unset prefstop
8665    fontcan
8666}
8667
8668proc prefsok {} {
8669    global maxwidth maxgraphpct
8670    global oldprefs prefstop showneartags showlocalchanges
8671    global fontpref mainfont textfont uifont
8672    global limitdiffs treediffs
8673
8674    catch {destroy $prefstop}
8675    unset prefstop
8676    fontcan
8677    set fontchanged 0
8678    if {$mainfont ne $fontpref(mainfont)} {
8679        set mainfont $fontpref(mainfont)
8680        parsefont mainfont $mainfont
8681        eval font configure mainfont [fontflags mainfont]
8682        eval font configure mainfontbold [fontflags mainfont 1]
8683        setcoords
8684        set fontchanged 1
8685    }
8686    if {$textfont ne $fontpref(textfont)} {
8687        set textfont $fontpref(textfont)
8688        parsefont textfont $textfont
8689        eval font configure textfont [fontflags textfont]
8690        eval font configure textfontbold [fontflags textfont 1]
8691    }
8692    if {$uifont ne $fontpref(uifont)} {
8693        set uifont $fontpref(uifont)
8694        parsefont uifont $uifont
8695        eval font configure uifont [fontflags uifont]
8696    }
8697    settabs
8698    if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8699        if {$showlocalchanges} {
8700            doshowlocalchanges
8701        } else {
8702            dohidelocalchanges
8703        }
8704    }
8705    if {$limitdiffs != $oldprefs(limitdiffs)} {
8706        # treediffs elements are limited by path
8707        catch {unset treediffs}
8708    }
8709    if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8710        || $maxgraphpct != $oldprefs(maxgraphpct)} {
8711        redisplay
8712    } elseif {$showneartags != $oldprefs(showneartags) ||
8713          $limitdiffs != $oldprefs(limitdiffs)} {
8714        reselectline
8715    }
8716}
8717
8718proc formatdate {d} {
8719    global datetimeformat
8720    if {$d ne {}} {
8721        set d [clock format $d -format $datetimeformat]
8722    }
8723    return $d
8724}
8725
8726# This list of encoding names and aliases is distilled from
8727# http://www.iana.org/assignments/character-sets.
8728# Not all of them are supported by Tcl.
8729set encoding_aliases {
8730    { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8731      ISO646-US US-ASCII us IBM367 cp367 csASCII }
8732    { ISO-10646-UTF-1 csISO10646UTF1 }
8733    { ISO_646.basic:1983 ref csISO646basic1983 }
8734    { INVARIANT csINVARIANT }
8735    { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8736    { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8737    { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8738    { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8739    { NATS-DANO iso-ir-9-1 csNATSDANO }
8740    { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8741    { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8742    { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8743    { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8744    { ISO-2022-KR csISO2022KR }
8745    { EUC-KR csEUCKR }
8746    { ISO-2022-JP csISO2022JP }
8747    { ISO-2022-JP-2 csISO2022JP2 }
8748    { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8749      csISO13JISC6220jp }
8750    { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8751    { IT iso-ir-15 ISO646-IT csISO15Italian }
8752    { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8753    { ES iso-ir-17 ISO646-ES csISO17Spanish }
8754    { greek7-old iso-ir-18 csISO18Greek7Old }
8755    { latin-greek iso-ir-19 csISO19LatinGreek }
8756    { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8757    { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8758    { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8759    { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8760    { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8761    { BS_viewdata iso-ir-47 csISO47BSViewdata }
8762    { INIS iso-ir-49 csISO49INIS }
8763    { INIS-8 iso-ir-50 csISO50INIS8 }
8764    { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8765    { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8766    { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8767    { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8768    { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8769    { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8770      csISO60Norwegian1 }
8771    { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8772    { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8773    { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8774    { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8775    { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8776    { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8777    { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8778    { greek7 iso-ir-88 csISO88Greek7 }
8779    { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8780    { iso-ir-90 csISO90 }
8781    { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8782    { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8783      csISO92JISC62991984b }
8784    { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8785    { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8786    { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8787      csISO95JIS62291984handadd }
8788    { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8789    { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8790    { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8791    { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8792      CP819 csISOLatin1 }
8793    { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8794    { T.61-7bit iso-ir-102 csISO102T617bit }
8795    { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8796    { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8797    { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8798    { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8799    { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8800    { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8801    { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8802    { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8803      arabic csISOLatinArabic }
8804    { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8805    { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8806    { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8807      greek greek8 csISOLatinGreek }
8808    { T.101-G2 iso-ir-128 csISO128T101G2 }
8809    { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8810      csISOLatinHebrew }
8811    { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8812    { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8813    { CSN_369103 iso-ir-139 csISO139CSN369103 }
8814    { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8815    { ISO_6937-2-add iso-ir-142 csISOTextComm }
8816    { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8817    { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8818      csISOLatinCyrillic }
8819    { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8820    { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8821    { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8822    { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8823    { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8824    { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8825    { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8826    { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8827    { ISO_10367-box iso-ir-155 csISO10367Box }
8828    { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8829    { latin-lap lap iso-ir-158 csISO158Lap }
8830    { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8831    { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8832    { us-dk csUSDK }
8833    { dk-us csDKUS }
8834    { JIS_X0201 X0201 csHalfWidthKatakana }
8835    { KSC5636 ISO646-KR csKSC5636 }
8836    { ISO-10646-UCS-2 csUnicode }
8837    { ISO-10646-UCS-4 csUCS4 }
8838    { DEC-MCS dec csDECMCS }
8839    { hp-roman8 roman8 r8 csHPRoman8 }
8840    { macintosh mac csMacintosh }
8841    { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8842      csIBM037 }
8843    { IBM038 EBCDIC-INT cp038 csIBM038 }
8844    { IBM273 CP273 csIBM273 }
8845    { IBM274 EBCDIC-BE CP274 csIBM274 }
8846    { IBM275 EBCDIC-BR cp275 csIBM275 }
8847    { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8848    { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8849    { IBM280 CP280 ebcdic-cp-it csIBM280 }
8850    { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8851    { IBM284 CP284 ebcdic-cp-es csIBM284 }
8852    { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8853    { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8854    { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8855    { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8856    { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8857    { IBM424 cp424 ebcdic-cp-he csIBM424 }
8858    { IBM437 cp437 437 csPC8CodePage437 }
8859    { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8860    { IBM775 cp775 csPC775Baltic }
8861    { IBM850 cp850 850 csPC850Multilingual }
8862    { IBM851 cp851 851 csIBM851 }
8863    { IBM852 cp852 852 csPCp852 }
8864    { IBM855 cp855 855 csIBM855 }
8865    { IBM857 cp857 857 csIBM857 }
8866    { IBM860 cp860 860 csIBM860 }
8867    { IBM861 cp861 861 cp-is csIBM861 }
8868    { IBM862 cp862 862 csPC862LatinHebrew }
8869    { IBM863 cp863 863 csIBM863 }
8870    { IBM864 cp864 csIBM864 }
8871    { IBM865 cp865 865 csIBM865 }
8872    { IBM866 cp866 866 csIBM866 }
8873    { IBM868 CP868 cp-ar csIBM868 }
8874    { IBM869 cp869 869 cp-gr csIBM869 }
8875    { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8876    { IBM871 CP871 ebcdic-cp-is csIBM871 }
8877    { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8878    { IBM891 cp891 csIBM891 }
8879    { IBM903 cp903 csIBM903 }
8880    { IBM904 cp904 904 csIBBM904 }
8881    { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8882    { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8883    { IBM1026 CP1026 csIBM1026 }
8884    { EBCDIC-AT-DE csIBMEBCDICATDE }
8885    { EBCDIC-AT-DE-A csEBCDICATDEA }
8886    { EBCDIC-CA-FR csEBCDICCAFR }
8887    { EBCDIC-DK-NO csEBCDICDKNO }
8888    { EBCDIC-DK-NO-A csEBCDICDKNOA }
8889    { EBCDIC-FI-SE csEBCDICFISE }
8890    { EBCDIC-FI-SE-A csEBCDICFISEA }
8891    { EBCDIC-FR csEBCDICFR }
8892    { EBCDIC-IT csEBCDICIT }
8893    { EBCDIC-PT csEBCDICPT }
8894    { EBCDIC-ES csEBCDICES }
8895    { EBCDIC-ES-A csEBCDICESA }
8896    { EBCDIC-ES-S csEBCDICESS }
8897    { EBCDIC-UK csEBCDICUK }
8898    { EBCDIC-US csEBCDICUS }
8899    { UNKNOWN-8BIT csUnknown8BiT }
8900    { MNEMONIC csMnemonic }
8901    { MNEM csMnem }
8902    { VISCII csVISCII }
8903    { VIQR csVIQR }
8904    { KOI8-R csKOI8R }
8905    { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8906    { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8907    { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8908    { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8909    { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8910    { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8911    { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8912    { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8913    { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8914    { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8915    { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8916    { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8917    { IBM1047 IBM-1047 }
8918    { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8919    { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8920    { UNICODE-1-1 csUnicode11 }
8921    { CESU-8 csCESU-8 }
8922    { BOCU-1 csBOCU-1 }
8923    { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8924    { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8925      l8 }
8926    { ISO-8859-15 ISO_8859-15 Latin-9 }
8927    { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8928    { GBK CP936 MS936 windows-936 }
8929    { JIS_Encoding csJISEncoding }
8930    { Shift_JIS MS_Kanji csShiftJIS }
8931    { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8932      EUC-JP }
8933    { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8934    { ISO-10646-UCS-Basic csUnicodeASCII }
8935    { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8936    { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8937    { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8938    { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8939    { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8940    { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8941    { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8942    { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8943    { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8944    { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8945    { Adobe-Standard-Encoding csAdobeStandardEncoding }
8946    { Ventura-US csVenturaUS }
8947    { Ventura-International csVenturaInternational }
8948    { PC8-Danish-Norwegian csPC8DanishNorwegian }
8949    { PC8-Turkish csPC8Turkish }
8950    { IBM-Symbols csIBMSymbols }
8951    { IBM-Thai csIBMThai }
8952    { HP-Legal csHPLegal }
8953    { HP-Pi-font csHPPiFont }
8954    { HP-Math8 csHPMath8 }
8955    { Adobe-Symbol-Encoding csHPPSMath }
8956    { HP-DeskTop csHPDesktop }
8957    { Ventura-Math csVenturaMath }
8958    { Microsoft-Publishing csMicrosoftPublishing }
8959    { Windows-31J csWindows31J }
8960    { GB2312 csGB2312 }
8961    { Big5 csBig5 }
8962}
8963
8964proc tcl_encoding {enc} {
8965    global encoding_aliases
8966    set names [encoding names]
8967    set lcnames [string tolower $names]
8968    set enc [string tolower $enc]
8969    set i [lsearch -exact $lcnames $enc]
8970    if {$i < 0} {
8971        # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8972        if {[regsub {^iso[-_]} $enc iso encx]} {
8973            set i [lsearch -exact $lcnames $encx]
8974        }
8975    }
8976    if {$i < 0} {
8977        foreach l $encoding_aliases {
8978            set ll [string tolower $l]
8979            if {[lsearch -exact $ll $enc] < 0} continue
8980            # look through the aliases for one that tcl knows about
8981            foreach e $ll {
8982                set i [lsearch -exact $lcnames $e]
8983                if {$i < 0} {
8984                    if {[regsub {^iso[-_]} $e iso ex]} {
8985                        set i [lsearch -exact $lcnames $ex]
8986                    }
8987                }
8988                if {$i >= 0} break
8989            }
8990            break
8991        }
8992    }
8993    if {$i >= 0} {
8994        return [lindex $names $i]
8995    }
8996    return {}
8997}
8998
8999# First check that Tcl/Tk is recent enough
9000if {[catch {package require Tk 8.4} err]} {
9001    show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
9002                     Gitk requires at least Tcl/Tk 8.4."
9003    exit 1
9004}
9005
9006# defaults...
9007set datemode 0
9008set wrcomcmd "git diff-tree --stdin -p --pretty"
9009
9010set gitencoding {}
9011catch {
9012    set gitencoding [exec git config --get i18n.commitencoding]
9013}
9014if {$gitencoding == ""} {
9015    set gitencoding "utf-8"
9016}
9017set tclencoding [tcl_encoding $gitencoding]
9018if {$tclencoding == {}} {
9019    puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
9020}
9021
9022set mainfont {Helvetica 9}
9023set textfont {Courier 9}
9024set uifont {Helvetica 9 bold}
9025set tabstop 8
9026set findmergefiles 0
9027set maxgraphpct 50
9028set maxwidth 16
9029set revlistorder 0
9030set fastdate 0
9031set uparrowlen 5
9032set downarrowlen 5
9033set mingaplen 100
9034set cmitmode "patch"
9035set wrapcomment "none"
9036set showneartags 1
9037set maxrefs 20
9038set maxlinelen 200
9039set showlocalchanges 1
9040set limitdiffs 1
9041set datetimeformat "%Y-%m-%d %H:%M:%S"
9042
9043set colors {green red blue magenta darkgrey brown orange}
9044set bgcolor white
9045set fgcolor black
9046set diffcolors {red "#00a000" blue}
9047set diffcontext 3
9048set selectbgcolor gray85
9049
9050catch {source ~/.gitk}
9051
9052font create optionfont -family sans-serif -size -12
9053
9054parsefont mainfont $mainfont
9055eval font create mainfont [fontflags mainfont]
9056eval font create mainfontbold [fontflags mainfont 1]
9057
9058parsefont textfont $textfont
9059eval font create textfont [fontflags textfont]
9060eval font create textfontbold [fontflags textfont 1]
9061
9062parsefont uifont $uifont
9063eval font create uifont [fontflags uifont]
9064
9065# check that we can find a .git directory somewhere...
9066if {[catch {set gitdir [gitdir]}]} {
9067    show_error {} . "Cannot find a git repository here."
9068    exit 1
9069}
9070if {![file isdirectory $gitdir]} {
9071    show_error {} . "Cannot find the git directory \"$gitdir\"."
9072    exit 1
9073}
9074
9075set mergeonly 0
9076set revtreeargs {}
9077set cmdline_files {}
9078set i 0
9079foreach arg $argv {
9080    switch -- $arg {
9081        "" { }
9082        "-d" { set datemode 1 }
9083        "--merge" {
9084            set mergeonly 1
9085            lappend revtreeargs $arg
9086        }
9087        "--" {
9088            set cmdline_files [lrange $argv [expr {$i + 1}] end]
9089            break
9090        }
9091        default {
9092            lappend revtreeargs $arg
9093        }
9094    }
9095    incr i
9096}
9097
9098if {$i >= [llength $argv] && $revtreeargs ne {}} {
9099    # no -- on command line, but some arguments (other than -d)
9100    if {[catch {
9101        set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
9102        set cmdline_files [split $f "\n"]
9103        set n [llength $cmdline_files]
9104        set revtreeargs [lrange $revtreeargs 0 end-$n]
9105        # Unfortunately git rev-parse doesn't produce an error when
9106        # something is both a revision and a filename.  To be consistent
9107        # with git log and git rev-list, check revtreeargs for filenames.
9108        foreach arg $revtreeargs {
9109            if {[file exists $arg]} {
9110                show_error {} . "Ambiguous argument '$arg': both revision\
9111                                 and filename"
9112                exit 1
9113            }
9114        }
9115    } err]} {
9116        # unfortunately we get both stdout and stderr in $err,
9117        # so look for "fatal:".
9118        set i [string first "fatal:" $err]
9119        if {$i > 0} {
9120            set err [string range $err [expr {$i + 6}] end]
9121        }
9122        show_error {} . "Bad arguments to gitk:\n$err"
9123        exit 1
9124    }
9125}
9126
9127if {$mergeonly} {
9128    # find the list of unmerged files
9129    set mlist {}
9130    set nr_unmerged 0
9131    if {[catch {
9132        set fd [open "| git ls-files -u" r]
9133    } err]} {
9134        show_error {} . "Couldn't get list of unmerged files: $err"
9135        exit 1
9136    }
9137    while {[gets $fd line] >= 0} {
9138        set i [string first "\t" $line]
9139        if {$i < 0} continue
9140        set fname [string range $line [expr {$i+1}] end]
9141        if {[lsearch -exact $mlist $fname] >= 0} continue
9142        incr nr_unmerged
9143        if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
9144            lappend mlist $fname
9145        }
9146    }
9147    catch {close $fd}
9148    if {$mlist eq {}} {
9149        if {$nr_unmerged == 0} {
9150            show_error {} . "No files selected: --merge specified but\
9151                             no files are unmerged."
9152        } else {
9153            show_error {} . "No files selected: --merge specified but\
9154                             no unmerged files are within file limit."
9155        }
9156        exit 1
9157    }
9158    set cmdline_files $mlist
9159}
9160
9161set nullid "0000000000000000000000000000000000000000"
9162set nullid2 "0000000000000000000000000000000000000001"
9163
9164set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
9165
9166set runq {}
9167set history {}
9168set historyindex 0
9169set fh_serial 0
9170set nhl_names {}
9171set highlight_paths {}
9172set findpattern {}
9173set searchdirn -forwards
9174set boldrows {}
9175set boldnamerows {}
9176set diffelide {0 0}
9177set markingmatches 0
9178set linkentercount 0
9179set need_redisplay 0
9180set nrows_drawn 0
9181set firsttabstop 0
9182
9183set nextviewnum 1
9184set curview 0
9185set selectedview 0
9186set selectedhlview None
9187set highlight_related None
9188set highlight_files {}
9189set viewfiles(0) {}
9190set viewperm(0) 0
9191set viewargs(0) {}
9192
9193set loginstance 0
9194set getdbg 0
9195set cmdlineok 0
9196set stopped 0
9197set stuffsaved 0
9198set patchnum 0
9199set lserial 0
9200setcoords
9201makewindow
9202# wait for the window to become visible
9203tkwait visibility .
9204wm title . "[file tail $argv0]: [file tail [pwd]]"
9205readrefs
9206
9207if {$cmdline_files ne {} || $revtreeargs ne {}} {
9208    # create a view for the files/dirs specified on the command line
9209    set curview 1
9210    set selectedview 1
9211    set nextviewnum 2
9212    set viewname(1) "Command line"
9213    set viewfiles(1) $cmdline_files
9214    set viewargs(1) $revtreeargs
9215    set viewperm(1) 0
9216    addviewmenu 1
9217    .bar.view entryconf Edit* -state normal
9218    .bar.view entryconf Delete* -state normal
9219}
9220
9221if {[info exists permviews]} {
9222    foreach v $permviews {
9223        set n $nextviewnum
9224        incr nextviewnum
9225        set viewname($n) [lindex $v 0]
9226        set viewfiles($n) [lindex $v 1]
9227        set viewargs($n) [lindex $v 2]
9228        set viewperm($n) 1
9229        addviewmenu $n
9230    }
9231}
9232getcommits