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