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