gitk-git / gitkon commit Merge git://ozlabs.org/~paulus/gitk (ec418bc)
   1#!/bin/sh
   2# Tcl ignores the next line -*- tcl -*- \
   3exec wish "$0" -- "$@"
   4
   5# Copyright © 2005-2011 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
  10package require Tk
  11
  12proc hasworktree {} {
  13    return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
  14                  [exec git rev-parse --is-inside-git-dir] == "false"}]
  15}
  16
  17proc reponame {} {
  18    global gitdir
  19    set n [file normalize $gitdir]
  20    if {[string match "*/.git" $n]} {
  21        set n [string range $n 0 end-5]
  22    }
  23    return [file tail $n]
  24}
  25
  26proc gitworktree {} {
  27    variable _gitworktree
  28    if {[info exists _gitworktree]} {
  29        return $_gitworktree
  30    }
  31    # v1.7.0 introduced --show-toplevel to return the canonical work-tree
  32    if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
  33        # try to set work tree from environment, core.worktree or use
  34        # cdup to obtain a relative path to the top of the worktree. If
  35        # run from the top, the ./ prefix ensures normalize expands pwd.
  36        if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
  37            catch {set _gitworktree [exec git config --get core.worktree]}
  38            if {$_gitworktree eq ""} {
  39                set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
  40            }
  41        }
  42    }
  43    return $_gitworktree
  44}
  45
  46# A simple scheduler for compute-intensive stuff.
  47# The aim is to make sure that event handlers for GUI actions can
  48# run at least every 50-100 ms.  Unfortunately fileevent handlers are
  49# run before X event handlers, so reading from a fast source can
  50# make the GUI completely unresponsive.
  51proc run args {
  52    global isonrunq runq currunq
  53
  54    set script $args
  55    if {[info exists isonrunq($script)]} return
  56    if {$runq eq {} && ![info exists currunq]} {
  57        after idle dorunq
  58    }
  59    lappend runq [list {} $script]
  60    set isonrunq($script) 1
  61}
  62
  63proc filerun {fd script} {
  64    fileevent $fd readable [list filereadable $fd $script]
  65}
  66
  67proc filereadable {fd script} {
  68    global runq currunq
  69
  70    fileevent $fd readable {}
  71    if {$runq eq {} && ![info exists currunq]} {
  72        after idle dorunq
  73    }
  74    lappend runq [list $fd $script]
  75}
  76
  77proc nukefile {fd} {
  78    global runq
  79
  80    for {set i 0} {$i < [llength $runq]} {} {
  81        if {[lindex $runq $i 0] eq $fd} {
  82            set runq [lreplace $runq $i $i]
  83        } else {
  84            incr i
  85        }
  86    }
  87}
  88
  89proc dorunq {} {
  90    global isonrunq runq currunq
  91
  92    set tstart [clock clicks -milliseconds]
  93    set t0 $tstart
  94    while {[llength $runq] > 0} {
  95        set fd [lindex $runq 0 0]
  96        set script [lindex $runq 0 1]
  97        set currunq [lindex $runq 0]
  98        set runq [lrange $runq 1 end]
  99        set repeat [eval $script]
 100        unset currunq
 101        set t1 [clock clicks -milliseconds]
 102        set t [expr {$t1 - $t0}]
 103        if {$repeat ne {} && $repeat} {
 104            if {$fd eq {} || $repeat == 2} {
 105                # script returns 1 if it wants to be readded
 106                # file readers return 2 if they could do more straight away
 107                lappend runq [list $fd $script]
 108            } else {
 109                fileevent $fd readable [list filereadable $fd $script]
 110            }
 111        } elseif {$fd eq {}} {
 112            unset isonrunq($script)
 113        }
 114        set t0 $t1
 115        if {$t1 - $tstart >= 80} break
 116    }
 117    if {$runq ne {}} {
 118        after idle dorunq
 119    }
 120}
 121
 122proc reg_instance {fd} {
 123    global commfd leftover loginstance
 124
 125    set i [incr loginstance]
 126    set commfd($i) $fd
 127    set leftover($i) {}
 128    return $i
 129}
 130
 131proc unmerged_files {files} {
 132    global nr_unmerged
 133
 134    # find the list of unmerged files
 135    set mlist {}
 136    set nr_unmerged 0
 137    if {[catch {
 138        set fd [open "| git ls-files -u" r]
 139    } err]} {
 140        show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
 141        exit 1
 142    }
 143    while {[gets $fd line] >= 0} {
 144        set i [string first "\t" $line]
 145        if {$i < 0} continue
 146        set fname [string range $line [expr {$i+1}] end]
 147        if {[lsearch -exact $mlist $fname] >= 0} continue
 148        incr nr_unmerged
 149        if {$files eq {} || [path_filter $files $fname]} {
 150            lappend mlist $fname
 151        }
 152    }
 153    catch {close $fd}
 154    return $mlist
 155}
 156
 157proc parseviewargs {n arglist} {
 158    global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
 159    global vinlinediff
 160    global worddiff git_version
 161
 162    set vdatemode($n) 0
 163    set vmergeonly($n) 0
 164    set vinlinediff($n) 0
 165    set glflags {}
 166    set diffargs {}
 167    set nextisval 0
 168    set revargs {}
 169    set origargs $arglist
 170    set allknown 1
 171    set filtered 0
 172    set i -1
 173    foreach arg $arglist {
 174        incr i
 175        if {$nextisval} {
 176            lappend glflags $arg
 177            set nextisval 0
 178            continue
 179        }
 180        switch -glob -- $arg {
 181            "-d" -
 182            "--date-order" {
 183                set vdatemode($n) 1
 184                # remove from origargs in case we hit an unknown option
 185                set origargs [lreplace $origargs $i $i]
 186                incr i -1
 187            }
 188            "-[puabwcrRBMC]" -
 189            "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
 190            "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
 191            "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
 192            "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
 193            "--ignore-space-change" - "-U*" - "--unified=*" {
 194                # These request or affect diff output, which we don't want.
 195                # Some could be used to set our defaults for diff display.
 196                lappend diffargs $arg
 197            }
 198            "--raw" - "--patch-with-raw" - "--patch-with-stat" -
 199            "--name-only" - "--name-status" - "--color" -
 200            "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
 201            "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
 202            "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
 203            "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
 204            "--objects" - "--objects-edge" - "--reverse" {
 205                # These cause our parsing of git log's output to fail, or else
 206                # they're options we want to set ourselves, so ignore them.
 207            }
 208            "--color-words*" - "--word-diff=color" {
 209                # These trigger a word diff in the console interface,
 210                # so help the user by enabling our own support
 211                if {[package vcompare $git_version "1.7.2"] >= 0} {
 212                    set worddiff [mc "Color words"]
 213                }
 214            }
 215            "--word-diff*" {
 216                if {[package vcompare $git_version "1.7.2"] >= 0} {
 217                    set worddiff [mc "Markup words"]
 218                }
 219            }
 220            "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
 221            "--check" - "--exit-code" - "--quiet" - "--topo-order" -
 222            "--full-history" - "--dense" - "--sparse" -
 223            "--follow" - "--left-right" - "--encoding=*" {
 224                # These are harmless, and some are even useful
 225                lappend glflags $arg
 226            }
 227            "--diff-filter=*" - "--no-merges" - "--unpacked" -
 228            "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
 229            "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
 230            "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
 231            "--remove-empty" - "--first-parent" - "--cherry-pick" -
 232            "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
 233            "--simplify-by-decoration" {
 234                # These mean that we get a subset of the commits
 235                set filtered 1
 236                lappend glflags $arg
 237            }
 238            "-L*" {
 239                # Line-log with 'stuck' argument (unstuck form is
 240                # not supported)
 241                set filtered 1
 242                set vinlinediff($n) 1
 243                set allknown 0
 244                lappend glflags $arg
 245            }
 246            "-n" {
 247                # This appears to be the only one that has a value as a
 248                # separate word following it
 249                set filtered 1
 250                set nextisval 1
 251                lappend glflags $arg
 252            }
 253            "--not" - "--all" {
 254                lappend revargs $arg
 255            }
 256            "--merge" {
 257                set vmergeonly($n) 1
 258                # git rev-parse doesn't understand --merge
 259                lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
 260            }
 261            "--no-replace-objects" {
 262                set env(GIT_NO_REPLACE_OBJECTS) "1"
 263            }
 264            "-*" {
 265                # Other flag arguments including -<n>
 266                if {[string is digit -strict [string range $arg 1 end]]} {
 267                    set filtered 1
 268                } else {
 269                    # a flag argument that we don't recognize;
 270                    # that means we can't optimize
 271                    set allknown 0
 272                }
 273                lappend glflags $arg
 274            }
 275            default {
 276                # Non-flag arguments specify commits or ranges of commits
 277                if {[string match "*...*" $arg]} {
 278                    lappend revargs --gitk-symmetric-diff-marker
 279                }
 280                lappend revargs $arg
 281            }
 282        }
 283    }
 284    set vdflags($n) $diffargs
 285    set vflags($n) $glflags
 286    set vrevs($n) $revargs
 287    set vfiltered($n) $filtered
 288    set vorigargs($n) $origargs
 289    return $allknown
 290}
 291
 292proc parseviewrevs {view revs} {
 293    global vposids vnegids
 294
 295    if {$revs eq {}} {
 296        set revs HEAD
 297    }
 298    if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
 299        # we get stdout followed by stderr in $err
 300        # for an unknown rev, git rev-parse echoes it and then errors out
 301        set errlines [split $err "\n"]
 302        set badrev {}
 303        for {set l 0} {$l < [llength $errlines]} {incr l} {
 304            set line [lindex $errlines $l]
 305            if {!([string length $line] == 40 && [string is xdigit $line])} {
 306                if {[string match "fatal:*" $line]} {
 307                    if {[string match "fatal: ambiguous argument*" $line]
 308                        && $badrev ne {}} {
 309                        if {[llength $badrev] == 1} {
 310                            set err "unknown revision $badrev"
 311                        } else {
 312                            set err "unknown revisions: [join $badrev ", "]"
 313                        }
 314                    } else {
 315                        set err [join [lrange $errlines $l end] "\n"]
 316                    }
 317                    break
 318                }
 319                lappend badrev $line
 320            }
 321        }
 322        error_popup "[mc "Error parsing revisions:"] $err"
 323        return {}
 324    }
 325    set ret {}
 326    set pos {}
 327    set neg {}
 328    set sdm 0
 329    foreach id [split $ids "\n"] {
 330        if {$id eq "--gitk-symmetric-diff-marker"} {
 331            set sdm 4
 332        } elseif {[string match "^*" $id]} {
 333            if {$sdm != 1} {
 334                lappend ret $id
 335                if {$sdm == 3} {
 336                    set sdm 0
 337                }
 338            }
 339            lappend neg [string range $id 1 end]
 340        } else {
 341            if {$sdm != 2} {
 342                lappend ret $id
 343            } else {
 344                lset ret end $id...[lindex $ret end]
 345            }
 346            lappend pos $id
 347        }
 348        incr sdm -1
 349    }
 350    set vposids($view) $pos
 351    set vnegids($view) $neg
 352    return $ret
 353}
 354
 355# Start off a git log process and arrange to read its output
 356proc start_rev_list {view} {
 357    global startmsecs commitidx viewcomplete curview
 358    global tclencoding
 359    global viewargs viewargscmd viewfiles vfilelimit
 360    global showlocalchanges
 361    global viewactive viewinstances vmergeonly
 362    global mainheadid viewmainheadid viewmainheadid_orig
 363    global vcanopt vflags vrevs vorigargs
 364    global show_notes
 365
 366    set startmsecs [clock clicks -milliseconds]
 367    set commitidx($view) 0
 368    # these are set this way for the error exits
 369    set viewcomplete($view) 1
 370    set viewactive($view) 0
 371    varcinit $view
 372
 373    set args $viewargs($view)
 374    if {$viewargscmd($view) ne {}} {
 375        if {[catch {
 376            set str [exec sh -c $viewargscmd($view)]
 377        } err]} {
 378            error_popup "[mc "Error executing --argscmd command:"] $err"
 379            return 0
 380        }
 381        set args [concat $args [split $str "\n"]]
 382    }
 383    set vcanopt($view) [parseviewargs $view $args]
 384
 385    set files $viewfiles($view)
 386    if {$vmergeonly($view)} {
 387        set files [unmerged_files $files]
 388        if {$files eq {}} {
 389            global nr_unmerged
 390            if {$nr_unmerged == 0} {
 391                error_popup [mc "No files selected: --merge specified but\
 392                             no files are unmerged."]
 393            } else {
 394                error_popup [mc "No files selected: --merge specified but\
 395                             no unmerged files are within file limit."]
 396            }
 397            return 0
 398        }
 399    }
 400    set vfilelimit($view) $files
 401
 402    if {$vcanopt($view)} {
 403        set revs [parseviewrevs $view $vrevs($view)]
 404        if {$revs eq {}} {
 405            return 0
 406        }
 407        set args [concat $vflags($view) $revs]
 408    } else {
 409        set args $vorigargs($view)
 410    }
 411
 412    if {[catch {
 413        set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
 414                        --parents --boundary $args "--" $files] r]
 415    } err]} {
 416        error_popup "[mc "Error executing git log:"] $err"
 417        return 0
 418    }
 419    set i [reg_instance $fd]
 420    set viewinstances($view) [list $i]
 421    set viewmainheadid($view) $mainheadid
 422    set viewmainheadid_orig($view) $mainheadid
 423    if {$files ne {} && $mainheadid ne {}} {
 424        get_viewmainhead $view
 425    }
 426    if {$showlocalchanges && $viewmainheadid($view) ne {}} {
 427        interestedin $viewmainheadid($view) dodiffindex
 428    }
 429    fconfigure $fd -blocking 0 -translation lf -eofchar {}
 430    if {$tclencoding != {}} {
 431        fconfigure $fd -encoding $tclencoding
 432    }
 433    filerun $fd [list getcommitlines $fd $i $view 0]
 434    nowbusy $view [mc "Reading"]
 435    set viewcomplete($view) 0
 436    set viewactive($view) 1
 437    return 1
 438}
 439
 440proc stop_instance {inst} {
 441    global commfd leftover
 442
 443    set fd $commfd($inst)
 444    catch {
 445        set pid [pid $fd]
 446
 447        if {$::tcl_platform(platform) eq {windows}} {
 448            exec kill -f $pid
 449        } else {
 450            exec kill $pid
 451        }
 452    }
 453    catch {close $fd}
 454    nukefile $fd
 455    unset commfd($inst)
 456    unset leftover($inst)
 457}
 458
 459proc stop_backends {} {
 460    global commfd
 461
 462    foreach inst [array names commfd] {
 463        stop_instance $inst
 464    }
 465}
 466
 467proc stop_rev_list {view} {
 468    global viewinstances
 469
 470    foreach inst $viewinstances($view) {
 471        stop_instance $inst
 472    }
 473    set viewinstances($view) {}
 474}
 475
 476proc reset_pending_select {selid} {
 477    global pending_select mainheadid selectheadid
 478
 479    if {$selid ne {}} {
 480        set pending_select $selid
 481    } elseif {$selectheadid ne {}} {
 482        set pending_select $selectheadid
 483    } else {
 484        set pending_select $mainheadid
 485    }
 486}
 487
 488proc getcommits {selid} {
 489    global canv curview need_redisplay viewactive
 490
 491    initlayout
 492    if {[start_rev_list $curview]} {
 493        reset_pending_select $selid
 494        show_status [mc "Reading commits..."]
 495        set need_redisplay 1
 496    } else {
 497        show_status [mc "No commits selected"]
 498    }
 499}
 500
 501proc updatecommits {} {
 502    global curview vcanopt vorigargs vfilelimit viewinstances
 503    global viewactive viewcomplete tclencoding
 504    global startmsecs showneartags showlocalchanges
 505    global mainheadid viewmainheadid viewmainheadid_orig pending_select
 506    global hasworktree
 507    global varcid vposids vnegids vflags vrevs
 508    global show_notes
 509
 510    set hasworktree [hasworktree]
 511    rereadrefs
 512    set view $curview
 513    if {$mainheadid ne $viewmainheadid_orig($view)} {
 514        if {$showlocalchanges} {
 515            dohidelocalchanges
 516        }
 517        set viewmainheadid($view) $mainheadid
 518        set viewmainheadid_orig($view) $mainheadid
 519        if {$vfilelimit($view) ne {}} {
 520            get_viewmainhead $view
 521        }
 522    }
 523    if {$showlocalchanges} {
 524        doshowlocalchanges
 525    }
 526    if {$vcanopt($view)} {
 527        set oldpos $vposids($view)
 528        set oldneg $vnegids($view)
 529        set revs [parseviewrevs $view $vrevs($view)]
 530        if {$revs eq {}} {
 531            return
 532        }
 533        # note: getting the delta when negative refs change is hard,
 534        # and could require multiple git log invocations, so in that
 535        # case we ask git log for all the commits (not just the delta)
 536        if {$oldneg eq $vnegids($view)} {
 537            set newrevs {}
 538            set npos 0
 539            # take out positive refs that we asked for before or
 540            # that we have already seen
 541            foreach rev $revs {
 542                if {[string length $rev] == 40} {
 543                    if {[lsearch -exact $oldpos $rev] < 0
 544                        && ![info exists varcid($view,$rev)]} {
 545                        lappend newrevs $rev
 546                        incr npos
 547                    }
 548                } else {
 549                    lappend $newrevs $rev
 550                }
 551            }
 552            if {$npos == 0} return
 553            set revs $newrevs
 554            set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
 555        }
 556        set args [concat $vflags($view) $revs --not $oldpos]
 557    } else {
 558        set args $vorigargs($view)
 559    }
 560    if {[catch {
 561        set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
 562                        --parents --boundary $args "--" $vfilelimit($view)] r]
 563    } err]} {
 564        error_popup "[mc "Error executing git log:"] $err"
 565        return
 566    }
 567    if {$viewactive($view) == 0} {
 568        set startmsecs [clock clicks -milliseconds]
 569    }
 570    set i [reg_instance $fd]
 571    lappend viewinstances($view) $i
 572    fconfigure $fd -blocking 0 -translation lf -eofchar {}
 573    if {$tclencoding != {}} {
 574        fconfigure $fd -encoding $tclencoding
 575    }
 576    filerun $fd [list getcommitlines $fd $i $view 1]
 577    incr viewactive($view)
 578    set viewcomplete($view) 0
 579    reset_pending_select {}
 580    nowbusy $view [mc "Reading"]
 581    if {$showneartags} {
 582        getallcommits
 583    }
 584}
 585
 586proc reloadcommits {} {
 587    global curview viewcomplete selectedline currentid thickerline
 588    global showneartags treediffs commitinterest cached_commitrow
 589    global targetid
 590
 591    set selid {}
 592    if {$selectedline ne {}} {
 593        set selid $currentid
 594    }
 595
 596    if {!$viewcomplete($curview)} {
 597        stop_rev_list $curview
 598    }
 599    resetvarcs $curview
 600    set selectedline {}
 601    catch {unset currentid}
 602    catch {unset thickerline}
 603    catch {unset treediffs}
 604    readrefs
 605    changedrefs
 606    if {$showneartags} {
 607        getallcommits
 608    }
 609    clear_display
 610    catch {unset commitinterest}
 611    catch {unset cached_commitrow}
 612    catch {unset targetid}
 613    setcanvscroll
 614    getcommits $selid
 615    return 0
 616}
 617
 618# This makes a string representation of a positive integer which
 619# sorts as a string in numerical order
 620proc strrep {n} {
 621    if {$n < 16} {
 622        return [format "%x" $n]
 623    } elseif {$n < 256} {
 624        return [format "x%.2x" $n]
 625    } elseif {$n < 65536} {
 626        return [format "y%.4x" $n]
 627    }
 628    return [format "z%.8x" $n]
 629}
 630
 631# Procedures used in reordering commits from git log (without
 632# --topo-order) into the order for display.
 633
 634proc varcinit {view} {
 635    global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
 636    global vtokmod varcmod vrowmod varcix vlastins
 637
 638    set varcstart($view) {{}}
 639    set vupptr($view) {0}
 640    set vdownptr($view) {0}
 641    set vleftptr($view) {0}
 642    set vbackptr($view) {0}
 643    set varctok($view) {{}}
 644    set varcrow($view) {{}}
 645    set vtokmod($view) {}
 646    set varcmod($view) 0
 647    set vrowmod($view) 0
 648    set varcix($view) {{}}
 649    set vlastins($view) {0}
 650}
 651
 652proc resetvarcs {view} {
 653    global varcid varccommits parents children vseedcount ordertok
 654    global vshortids
 655
 656    foreach vid [array names varcid $view,*] {
 657        unset varcid($vid)
 658        unset children($vid)
 659        unset parents($vid)
 660    }
 661    foreach vid [array names vshortids $view,*] {
 662        unset vshortids($vid)
 663    }
 664    # some commits might have children but haven't been seen yet
 665    foreach vid [array names children $view,*] {
 666        unset children($vid)
 667    }
 668    foreach va [array names varccommits $view,*] {
 669        unset varccommits($va)
 670    }
 671    foreach vd [array names vseedcount $view,*] {
 672        unset vseedcount($vd)
 673    }
 674    catch {unset ordertok}
 675}
 676
 677# returns a list of the commits with no children
 678proc seeds {v} {
 679    global vdownptr vleftptr varcstart
 680
 681    set ret {}
 682    set a [lindex $vdownptr($v) 0]
 683    while {$a != 0} {
 684        lappend ret [lindex $varcstart($v) $a]
 685        set a [lindex $vleftptr($v) $a]
 686    }
 687    return $ret
 688}
 689
 690proc newvarc {view id} {
 691    global varcid varctok parents children vdatemode
 692    global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
 693    global commitdata commitinfo vseedcount varccommits vlastins
 694
 695    set a [llength $varctok($view)]
 696    set vid $view,$id
 697    if {[llength $children($vid)] == 0 || $vdatemode($view)} {
 698        if {![info exists commitinfo($id)]} {
 699            parsecommit $id $commitdata($id) 1
 700        }
 701        set cdate [lindex [lindex $commitinfo($id) 4] 0]
 702        if {![string is integer -strict $cdate]} {
 703            set cdate 0
 704        }
 705        if {![info exists vseedcount($view,$cdate)]} {
 706            set vseedcount($view,$cdate) -1
 707        }
 708        set c [incr vseedcount($view,$cdate)]
 709        set cdate [expr {$cdate ^ 0xffffffff}]
 710        set tok "s[strrep $cdate][strrep $c]"
 711    } else {
 712        set tok {}
 713    }
 714    set ka 0
 715    if {[llength $children($vid)] > 0} {
 716        set kid [lindex $children($vid) end]
 717        set k $varcid($view,$kid)
 718        if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
 719            set ki $kid
 720            set ka $k
 721            set tok [lindex $varctok($view) $k]
 722        }
 723    }
 724    if {$ka != 0} {
 725        set i [lsearch -exact $parents($view,$ki) $id]
 726        set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
 727        append tok [strrep $j]
 728    }
 729    set c [lindex $vlastins($view) $ka]
 730    if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
 731        set c $ka
 732        set b [lindex $vdownptr($view) $ka]
 733    } else {
 734        set b [lindex $vleftptr($view) $c]
 735    }
 736    while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
 737        set c $b
 738        set b [lindex $vleftptr($view) $c]
 739    }
 740    if {$c == $ka} {
 741        lset vdownptr($view) $ka $a
 742        lappend vbackptr($view) 0
 743    } else {
 744        lset vleftptr($view) $c $a
 745        lappend vbackptr($view) $c
 746    }
 747    lset vlastins($view) $ka $a
 748    lappend vupptr($view) $ka
 749    lappend vleftptr($view) $b
 750    if {$b != 0} {
 751        lset vbackptr($view) $b $a
 752    }
 753    lappend varctok($view) $tok
 754    lappend varcstart($view) $id
 755    lappend vdownptr($view) 0
 756    lappend varcrow($view) {}
 757    lappend varcix($view) {}
 758    set varccommits($view,$a) {}
 759    lappend vlastins($view) 0
 760    return $a
 761}
 762
 763proc splitvarc {p v} {
 764    global varcid varcstart varccommits varctok vtokmod
 765    global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
 766
 767    set oa $varcid($v,$p)
 768    set otok [lindex $varctok($v) $oa]
 769    set ac $varccommits($v,$oa)
 770    set i [lsearch -exact $varccommits($v,$oa) $p]
 771    if {$i <= 0} return
 772    set na [llength $varctok($v)]
 773    # "%" sorts before "0"...
 774    set tok "$otok%[strrep $i]"
 775    lappend varctok($v) $tok
 776    lappend varcrow($v) {}
 777    lappend varcix($v) {}
 778    set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
 779    set varccommits($v,$na) [lrange $ac $i end]
 780    lappend varcstart($v) $p
 781    foreach id $varccommits($v,$na) {
 782        set varcid($v,$id) $na
 783    }
 784    lappend vdownptr($v) [lindex $vdownptr($v) $oa]
 785    lappend vlastins($v) [lindex $vlastins($v) $oa]
 786    lset vdownptr($v) $oa $na
 787    lset vlastins($v) $oa 0
 788    lappend vupptr($v) $oa
 789    lappend vleftptr($v) 0
 790    lappend vbackptr($v) 0
 791    for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
 792        lset vupptr($v) $b $na
 793    }
 794    if {[string compare $otok $vtokmod($v)] <= 0} {
 795        modify_arc $v $oa
 796    }
 797}
 798
 799proc renumbervarc {a v} {
 800    global parents children varctok varcstart varccommits
 801    global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
 802
 803    set t1 [clock clicks -milliseconds]
 804    set todo {}
 805    set isrelated($a) 1
 806    set kidchanged($a) 1
 807    set ntot 0
 808    while {$a != 0} {
 809        if {[info exists isrelated($a)]} {
 810            lappend todo $a
 811            set id [lindex $varccommits($v,$a) end]
 812            foreach p $parents($v,$id) {
 813                if {[info exists varcid($v,$p)]} {
 814                    set isrelated($varcid($v,$p)) 1
 815                }
 816            }
 817        }
 818        incr ntot
 819        set b [lindex $vdownptr($v) $a]
 820        if {$b == 0} {
 821            while {$a != 0} {
 822                set b [lindex $vleftptr($v) $a]
 823                if {$b != 0} break
 824                set a [lindex $vupptr($v) $a]
 825            }
 826        }
 827        set a $b
 828    }
 829    foreach a $todo {
 830        if {![info exists kidchanged($a)]} continue
 831        set id [lindex $varcstart($v) $a]
 832        if {[llength $children($v,$id)] > 1} {
 833            set children($v,$id) [lsort -command [list vtokcmp $v] \
 834                                      $children($v,$id)]
 835        }
 836        set oldtok [lindex $varctok($v) $a]
 837        if {!$vdatemode($v)} {
 838            set tok {}
 839        } else {
 840            set tok $oldtok
 841        }
 842        set ka 0
 843        set kid [last_real_child $v,$id]
 844        if {$kid ne {}} {
 845            set k $varcid($v,$kid)
 846            if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
 847                set ki $kid
 848                set ka $k
 849                set tok [lindex $varctok($v) $k]
 850            }
 851        }
 852        if {$ka != 0} {
 853            set i [lsearch -exact $parents($v,$ki) $id]
 854            set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
 855            append tok [strrep $j]
 856        }
 857        if {$tok eq $oldtok} {
 858            continue
 859        }
 860        set id [lindex $varccommits($v,$a) end]
 861        foreach p $parents($v,$id) {
 862            if {[info exists varcid($v,$p)]} {
 863                set kidchanged($varcid($v,$p)) 1
 864            } else {
 865                set sortkids($p) 1
 866            }
 867        }
 868        lset varctok($v) $a $tok
 869        set b [lindex $vupptr($v) $a]
 870        if {$b != $ka} {
 871            if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
 872                modify_arc $v $ka
 873            }
 874            if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
 875                modify_arc $v $b
 876            }
 877            set c [lindex $vbackptr($v) $a]
 878            set d [lindex $vleftptr($v) $a]
 879            if {$c == 0} {
 880                lset vdownptr($v) $b $d
 881            } else {
 882                lset vleftptr($v) $c $d
 883            }
 884            if {$d != 0} {
 885                lset vbackptr($v) $d $c
 886            }
 887            if {[lindex $vlastins($v) $b] == $a} {
 888                lset vlastins($v) $b $c
 889            }
 890            lset vupptr($v) $a $ka
 891            set c [lindex $vlastins($v) $ka]
 892            if {$c == 0 || \
 893                    [string compare $tok [lindex $varctok($v) $c]] < 0} {
 894                set c $ka
 895                set b [lindex $vdownptr($v) $ka]
 896            } else {
 897                set b [lindex $vleftptr($v) $c]
 898            }
 899            while {$b != 0 && \
 900                      [string compare $tok [lindex $varctok($v) $b]] >= 0} {
 901                set c $b
 902                set b [lindex $vleftptr($v) $c]
 903            }
 904            if {$c == $ka} {
 905                lset vdownptr($v) $ka $a
 906                lset vbackptr($v) $a 0
 907            } else {
 908                lset vleftptr($v) $c $a
 909                lset vbackptr($v) $a $c
 910            }
 911            lset vleftptr($v) $a $b
 912            if {$b != 0} {
 913                lset vbackptr($v) $b $a
 914            }
 915            lset vlastins($v) $ka $a
 916        }
 917    }
 918    foreach id [array names sortkids] {
 919        if {[llength $children($v,$id)] > 1} {
 920            set children($v,$id) [lsort -command [list vtokcmp $v] \
 921                                      $children($v,$id)]
 922        }
 923    }
 924    set t2 [clock clicks -milliseconds]
 925    #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
 926}
 927
 928# Fix up the graph after we have found out that in view $v,
 929# $p (a commit that we have already seen) is actually the parent
 930# of the last commit in arc $a.
 931proc fix_reversal {p a v} {
 932    global varcid varcstart varctok vupptr
 933
 934    set pa $varcid($v,$p)
 935    if {$p ne [lindex $varcstart($v) $pa]} {
 936        splitvarc $p $v
 937        set pa $varcid($v,$p)
 938    }
 939    # seeds always need to be renumbered
 940    if {[lindex $vupptr($v) $pa] == 0 ||
 941        [string compare [lindex $varctok($v) $a] \
 942             [lindex $varctok($v) $pa]] > 0} {
 943        renumbervarc $pa $v
 944    }
 945}
 946
 947proc insertrow {id p v} {
 948    global cmitlisted children parents varcid varctok vtokmod
 949    global varccommits ordertok commitidx numcommits curview
 950    global targetid targetrow vshortids
 951
 952    readcommit $id
 953    set vid $v,$id
 954    set cmitlisted($vid) 1
 955    set children($vid) {}
 956    set parents($vid) [list $p]
 957    set a [newvarc $v $id]
 958    set varcid($vid) $a
 959    lappend vshortids($v,[string range $id 0 3]) $id
 960    if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
 961        modify_arc $v $a
 962    }
 963    lappend varccommits($v,$a) $id
 964    set vp $v,$p
 965    if {[llength [lappend children($vp) $id]] > 1} {
 966        set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
 967        catch {unset ordertok}
 968    }
 969    fix_reversal $p $a $v
 970    incr commitidx($v)
 971    if {$v == $curview} {
 972        set numcommits $commitidx($v)
 973        setcanvscroll
 974        if {[info exists targetid]} {
 975            if {![comes_before $targetid $p]} {
 976                incr targetrow
 977            }
 978        }
 979    }
 980}
 981
 982proc insertfakerow {id p} {
 983    global varcid varccommits parents children cmitlisted
 984    global commitidx varctok vtokmod targetid targetrow curview numcommits
 985
 986    set v $curview
 987    set a $varcid($v,$p)
 988    set i [lsearch -exact $varccommits($v,$a) $p]
 989    if {$i < 0} {
 990        puts "oops: insertfakerow can't find [shortids $p] on arc $a"
 991        return
 992    }
 993    set children($v,$id) {}
 994    set parents($v,$id) [list $p]
 995    set varcid($v,$id) $a
 996    lappend children($v,$p) $id
 997    set cmitlisted($v,$id) 1
 998    set numcommits [incr commitidx($v)]
 999    # note we deliberately don't update varcstart($v) even if $i == 0
1000    set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1001    modify_arc $v $a $i
1002    if {[info exists targetid]} {
1003        if {![comes_before $targetid $p]} {
1004            incr targetrow
1005        }
1006    }
1007    setcanvscroll
1008    drawvisible
1009}
1010
1011proc removefakerow {id} {
1012    global varcid varccommits parents children commitidx
1013    global varctok vtokmod cmitlisted currentid selectedline
1014    global targetid curview numcommits
1015
1016    set v $curview
1017    if {[llength $parents($v,$id)] != 1} {
1018        puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1019        return
1020    }
1021    set p [lindex $parents($v,$id) 0]
1022    set a $varcid($v,$id)
1023    set i [lsearch -exact $varccommits($v,$a) $id]
1024    if {$i < 0} {
1025        puts "oops: removefakerow can't find [shortids $id] on arc $a"
1026        return
1027    }
1028    unset varcid($v,$id)
1029    set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1030    unset parents($v,$id)
1031    unset children($v,$id)
1032    unset cmitlisted($v,$id)
1033    set numcommits [incr commitidx($v) -1]
1034    set j [lsearch -exact $children($v,$p) $id]
1035    if {$j >= 0} {
1036        set children($v,$p) [lreplace $children($v,$p) $j $j]
1037    }
1038    modify_arc $v $a $i
1039    if {[info exist currentid] && $id eq $currentid} {
1040        unset currentid
1041        set selectedline {}
1042    }
1043    if {[info exists targetid] && $targetid eq $id} {
1044        set targetid $p
1045    }
1046    setcanvscroll
1047    drawvisible
1048}
1049
1050proc real_children {vp} {
1051    global children nullid nullid2
1052
1053    set kids {}
1054    foreach id $children($vp) {
1055        if {$id ne $nullid && $id ne $nullid2} {
1056            lappend kids $id
1057        }
1058    }
1059    return $kids
1060}
1061
1062proc first_real_child {vp} {
1063    global children nullid nullid2
1064
1065    foreach id $children($vp) {
1066        if {$id ne $nullid && $id ne $nullid2} {
1067            return $id
1068        }
1069    }
1070    return {}
1071}
1072
1073proc last_real_child {vp} {
1074    global children nullid nullid2
1075
1076    set kids $children($vp)
1077    for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1078        set id [lindex $kids $i]
1079        if {$id ne $nullid && $id ne $nullid2} {
1080            return $id
1081        }
1082    }
1083    return {}
1084}
1085
1086proc vtokcmp {v a b} {
1087    global varctok varcid
1088
1089    return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1090                [lindex $varctok($v) $varcid($v,$b)]]
1091}
1092
1093# This assumes that if lim is not given, the caller has checked that
1094# arc a's token is less than $vtokmod($v)
1095proc modify_arc {v a {lim {}}} {
1096    global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1097
1098    if {$lim ne {}} {
1099        set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1100        if {$c > 0} return
1101        if {$c == 0} {
1102            set r [lindex $varcrow($v) $a]
1103            if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1104        }
1105    }
1106    set vtokmod($v) [lindex $varctok($v) $a]
1107    set varcmod($v) $a
1108    if {$v == $curview} {
1109        while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1110            set a [lindex $vupptr($v) $a]
1111            set lim {}
1112        }
1113        set r 0
1114        if {$a != 0} {
1115            if {$lim eq {}} {
1116                set lim [llength $varccommits($v,$a)]
1117            }
1118            set r [expr {[lindex $varcrow($v) $a] + $lim}]
1119        }
1120        set vrowmod($v) $r
1121        undolayout $r
1122    }
1123}
1124
1125proc update_arcrows {v} {
1126    global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1127    global varcid vrownum varcorder varcix varccommits
1128    global vupptr vdownptr vleftptr varctok
1129    global displayorder parentlist curview cached_commitrow
1130
1131    if {$vrowmod($v) == $commitidx($v)} return
1132    if {$v == $curview} {
1133        if {[llength $displayorder] > $vrowmod($v)} {
1134            set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1135            set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1136        }
1137        catch {unset cached_commitrow}
1138    }
1139    set narctot [expr {[llength $varctok($v)] - 1}]
1140    set a $varcmod($v)
1141    while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1142        # go up the tree until we find something that has a row number,
1143        # or we get to a seed
1144        set a [lindex $vupptr($v) $a]
1145    }
1146    if {$a == 0} {
1147        set a [lindex $vdownptr($v) 0]
1148        if {$a == 0} return
1149        set vrownum($v) {0}
1150        set varcorder($v) [list $a]
1151        lset varcix($v) $a 0
1152        lset varcrow($v) $a 0
1153        set arcn 0
1154        set row 0
1155    } else {
1156        set arcn [lindex $varcix($v) $a]
1157        if {[llength $vrownum($v)] > $arcn + 1} {
1158            set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1159            set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1160        }
1161        set row [lindex $varcrow($v) $a]
1162    }
1163    while {1} {
1164        set p $a
1165        incr row [llength $varccommits($v,$a)]
1166        # go down if possible
1167        set b [lindex $vdownptr($v) $a]
1168        if {$b == 0} {
1169            # if not, go left, or go up until we can go left
1170            while {$a != 0} {
1171                set b [lindex $vleftptr($v) $a]
1172                if {$b != 0} break
1173                set a [lindex $vupptr($v) $a]
1174            }
1175            if {$a == 0} break
1176        }
1177        set a $b
1178        incr arcn
1179        lappend vrownum($v) $row
1180        lappend varcorder($v) $a
1181        lset varcix($v) $a $arcn
1182        lset varcrow($v) $a $row
1183    }
1184    set vtokmod($v) [lindex $varctok($v) $p]
1185    set varcmod($v) $p
1186    set vrowmod($v) $row
1187    if {[info exists currentid]} {
1188        set selectedline [rowofcommit $currentid]
1189    }
1190}
1191
1192# Test whether view $v contains commit $id
1193proc commitinview {id v} {
1194    global varcid
1195
1196    return [info exists varcid($v,$id)]
1197}
1198
1199# Return the row number for commit $id in the current view
1200proc rowofcommit {id} {
1201    global varcid varccommits varcrow curview cached_commitrow
1202    global varctok vtokmod
1203
1204    set v $curview
1205    if {![info exists varcid($v,$id)]} {
1206        puts "oops rowofcommit no arc for [shortids $id]"
1207        return {}
1208    }
1209    set a $varcid($v,$id)
1210    if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1211        update_arcrows $v
1212    }
1213    if {[info exists cached_commitrow($id)]} {
1214        return $cached_commitrow($id)
1215    }
1216    set i [lsearch -exact $varccommits($v,$a) $id]
1217    if {$i < 0} {
1218        puts "oops didn't find commit [shortids $id] in arc $a"
1219        return {}
1220    }
1221    incr i [lindex $varcrow($v) $a]
1222    set cached_commitrow($id) $i
1223    return $i
1224}
1225
1226# Returns 1 if a is on an earlier row than b, otherwise 0
1227proc comes_before {a b} {
1228    global varcid varctok curview
1229
1230    set v $curview
1231    if {$a eq $b || ![info exists varcid($v,$a)] || \
1232            ![info exists varcid($v,$b)]} {
1233        return 0
1234    }
1235    if {$varcid($v,$a) != $varcid($v,$b)} {
1236        return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1237                           [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1238    }
1239    return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1240}
1241
1242proc bsearch {l elt} {
1243    if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1244        return 0
1245    }
1246    set lo 0
1247    set hi [llength $l]
1248    while {$hi - $lo > 1} {
1249        set mid [expr {int(($lo + $hi) / 2)}]
1250        set t [lindex $l $mid]
1251        if {$elt < $t} {
1252            set hi $mid
1253        } elseif {$elt > $t} {
1254            set lo $mid
1255        } else {
1256            return $mid
1257        }
1258    }
1259    return $lo
1260}
1261
1262# Make sure rows $start..$end-1 are valid in displayorder and parentlist
1263proc make_disporder {start end} {
1264    global vrownum curview commitidx displayorder parentlist
1265    global varccommits varcorder parents vrowmod varcrow
1266    global d_valid_start d_valid_end
1267
1268    if {$end > $vrowmod($curview)} {
1269        update_arcrows $curview
1270    }
1271    set ai [bsearch $vrownum($curview) $start]
1272    set start [lindex $vrownum($curview) $ai]
1273    set narc [llength $vrownum($curview)]
1274    for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1275        set a [lindex $varcorder($curview) $ai]
1276        set l [llength $displayorder]
1277        set al [llength $varccommits($curview,$a)]
1278        if {$l < $r + $al} {
1279            if {$l < $r} {
1280                set pad [ntimes [expr {$r - $l}] {}]
1281                set displayorder [concat $displayorder $pad]
1282                set parentlist [concat $parentlist $pad]
1283            } elseif {$l > $r} {
1284                set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1285                set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1286            }
1287            foreach id $varccommits($curview,$a) {
1288                lappend displayorder $id
1289                lappend parentlist $parents($curview,$id)
1290            }
1291        } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1292            set i $r
1293            foreach id $varccommits($curview,$a) {
1294                lset displayorder $i $id
1295                lset parentlist $i $parents($curview,$id)
1296                incr i
1297            }
1298        }
1299        incr r $al
1300    }
1301}
1302
1303proc commitonrow {row} {
1304    global displayorder
1305
1306    set id [lindex $displayorder $row]
1307    if {$id eq {}} {
1308        make_disporder $row [expr {$row + 1}]
1309        set id [lindex $displayorder $row]
1310    }
1311    return $id
1312}
1313
1314proc closevarcs {v} {
1315    global varctok varccommits varcid parents children
1316    global cmitlisted commitidx vtokmod
1317
1318    set missing_parents 0
1319    set scripts {}
1320    set narcs [llength $varctok($v)]
1321    for {set a 1} {$a < $narcs} {incr a} {
1322        set id [lindex $varccommits($v,$a) end]
1323        foreach p $parents($v,$id) {
1324            if {[info exists varcid($v,$p)]} continue
1325            # add p as a new commit
1326            incr missing_parents
1327            set cmitlisted($v,$p) 0
1328            set parents($v,$p) {}
1329            if {[llength $children($v,$p)] == 1 &&
1330                [llength $parents($v,$id)] == 1} {
1331                set b $a
1332            } else {
1333                set b [newvarc $v $p]
1334            }
1335            set varcid($v,$p) $b
1336            if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1337                modify_arc $v $b
1338            }
1339            lappend varccommits($v,$b) $p
1340            incr commitidx($v)
1341            set scripts [check_interest $p $scripts]
1342        }
1343    }
1344    if {$missing_parents > 0} {
1345        foreach s $scripts {
1346            eval $s
1347        }
1348    }
1349}
1350
1351# Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1352# Assumes we already have an arc for $rwid.
1353proc rewrite_commit {v id rwid} {
1354    global children parents varcid varctok vtokmod varccommits
1355
1356    foreach ch $children($v,$id) {
1357        # make $rwid be $ch's parent in place of $id
1358        set i [lsearch -exact $parents($v,$ch) $id]
1359        if {$i < 0} {
1360            puts "oops rewrite_commit didn't find $id in parent list for $ch"
1361        }
1362        set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1363        # add $ch to $rwid's children and sort the list if necessary
1364        if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1365            set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1366                                        $children($v,$rwid)]
1367        }
1368        # fix the graph after joining $id to $rwid
1369        set a $varcid($v,$ch)
1370        fix_reversal $rwid $a $v
1371        # parentlist is wrong for the last element of arc $a
1372        # even if displayorder is right, hence the 3rd arg here
1373        modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1374    }
1375}
1376
1377# Mechanism for registering a command to be executed when we come
1378# across a particular commit.  To handle the case when only the
1379# prefix of the commit is known, the commitinterest array is now
1380# indexed by the first 4 characters of the ID.  Each element is a
1381# list of id, cmd pairs.
1382proc interestedin {id cmd} {
1383    global commitinterest
1384
1385    lappend commitinterest([string range $id 0 3]) $id $cmd
1386}
1387
1388proc check_interest {id scripts} {
1389    global commitinterest
1390
1391    set prefix [string range $id 0 3]
1392    if {[info exists commitinterest($prefix)]} {
1393        set newlist {}
1394        foreach {i script} $commitinterest($prefix) {
1395            if {[string match "$i*" $id]} {
1396                lappend scripts [string map [list "%I" $id "%P" $i] $script]
1397            } else {
1398                lappend newlist $i $script
1399            }
1400        }
1401        if {$newlist ne {}} {
1402            set commitinterest($prefix) $newlist
1403        } else {
1404            unset commitinterest($prefix)
1405        }
1406    }
1407    return $scripts
1408}
1409
1410proc getcommitlines {fd inst view updating}  {
1411    global cmitlisted leftover
1412    global commitidx commitdata vdatemode
1413    global parents children curview hlview
1414    global idpending ordertok
1415    global varccommits varcid varctok vtokmod vfilelimit vshortids
1416
1417    set stuff [read $fd 500000]
1418    # git log doesn't terminate the last commit with a null...
1419    if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1420        set stuff "\0"
1421    }
1422    if {$stuff == {}} {
1423        if {![eof $fd]} {
1424            return 1
1425        }
1426        global commfd viewcomplete viewactive viewname
1427        global viewinstances
1428        unset commfd($inst)
1429        set i [lsearch -exact $viewinstances($view) $inst]
1430        if {$i >= 0} {
1431            set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1432        }
1433        # set it blocking so we wait for the process to terminate
1434        fconfigure $fd -blocking 1
1435        if {[catch {close $fd} err]} {
1436            set fv {}
1437            if {$view != $curview} {
1438                set fv " for the \"$viewname($view)\" view"
1439            }
1440            if {[string range $err 0 4] == "usage"} {
1441                set err "Gitk: error reading commits$fv:\
1442                        bad arguments to git log."
1443                if {$viewname($view) eq "Command line"} {
1444                    append err \
1445                        "  (Note: arguments to gitk are passed to git log\
1446                         to allow selection of commits to be displayed.)"
1447                }
1448            } else {
1449                set err "Error reading commits$fv: $err"
1450            }
1451            error_popup $err
1452        }
1453        if {[incr viewactive($view) -1] <= 0} {
1454            set viewcomplete($view) 1
1455            # Check if we have seen any ids listed as parents that haven't
1456            # appeared in the list
1457            closevarcs $view
1458            notbusy $view
1459        }
1460        if {$view == $curview} {
1461            run chewcommits
1462        }
1463        return 0
1464    }
1465    set start 0
1466    set gotsome 0
1467    set scripts {}
1468    while 1 {
1469        set i [string first "\0" $stuff $start]
1470        if {$i < 0} {
1471            append leftover($inst) [string range $stuff $start end]
1472            break
1473        }
1474        if {$start == 0} {
1475            set cmit $leftover($inst)
1476            append cmit [string range $stuff 0 [expr {$i - 1}]]
1477            set leftover($inst) {}
1478        } else {
1479            set cmit [string range $stuff $start [expr {$i - 1}]]
1480        }
1481        set start [expr {$i + 1}]
1482        set j [string first "\n" $cmit]
1483        set ok 0
1484        set listed 1
1485        if {$j >= 0 && [string match "commit *" $cmit]} {
1486            set ids [string range $cmit 7 [expr {$j - 1}]]
1487            if {[string match {[-^<>]*} $ids]} {
1488                switch -- [string index $ids 0] {
1489                    "-" {set listed 0}
1490                    "^" {set listed 2}
1491                    "<" {set listed 3}
1492                    ">" {set listed 4}
1493                }
1494                set ids [string range $ids 1 end]
1495            }
1496            set ok 1
1497            foreach id $ids {
1498                if {[string length $id] != 40} {
1499                    set ok 0
1500                    break
1501                }
1502            }
1503        }
1504        if {!$ok} {
1505            set shortcmit $cmit
1506            if {[string length $shortcmit] > 80} {
1507                set shortcmit "[string range $shortcmit 0 80]..."
1508            }
1509            error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1510            exit 1
1511        }
1512        set id [lindex $ids 0]
1513        set vid $view,$id
1514
1515        lappend vshortids($view,[string range $id 0 3]) $id
1516
1517        if {!$listed && $updating && ![info exists varcid($vid)] &&
1518            $vfilelimit($view) ne {}} {
1519            # git log doesn't rewrite parents for unlisted commits
1520            # when doing path limiting, so work around that here
1521            # by working out the rewritten parent with git rev-list
1522            # and if we already know about it, using the rewritten
1523            # parent as a substitute parent for $id's children.
1524            if {![catch {
1525                set rwid [exec git rev-list --first-parent --max-count=1 \
1526                              $id -- $vfilelimit($view)]
1527            }]} {
1528                if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1529                    # use $rwid in place of $id
1530                    rewrite_commit $view $id $rwid
1531                    continue
1532                }
1533            }
1534        }
1535
1536        set a 0
1537        if {[info exists varcid($vid)]} {
1538            if {$cmitlisted($vid) || !$listed} continue
1539            set a $varcid($vid)
1540        }
1541        if {$listed} {
1542            set olds [lrange $ids 1 end]
1543        } else {
1544            set olds {}
1545        }
1546        set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1547        set cmitlisted($vid) $listed
1548        set parents($vid) $olds
1549        if {![info exists children($vid)]} {
1550            set children($vid) {}
1551        } elseif {$a == 0 && [llength $children($vid)] == 1} {
1552            set k [lindex $children($vid) 0]
1553            if {[llength $parents($view,$k)] == 1 &&
1554                (!$vdatemode($view) ||
1555                 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1556                set a $varcid($view,$k)
1557            }
1558        }
1559        if {$a == 0} {
1560            # new arc
1561            set a [newvarc $view $id]
1562        }
1563        if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1564            modify_arc $view $a
1565        }
1566        if {![info exists varcid($vid)]} {
1567            set varcid($vid) $a
1568            lappend varccommits($view,$a) $id
1569            incr commitidx($view)
1570        }
1571
1572        set i 0
1573        foreach p $olds {
1574            if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1575                set vp $view,$p
1576                if {[llength [lappend children($vp) $id]] > 1 &&
1577                    [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1578                    set children($vp) [lsort -command [list vtokcmp $view] \
1579                                           $children($vp)]
1580                    catch {unset ordertok}
1581                }
1582                if {[info exists varcid($view,$p)]} {
1583                    fix_reversal $p $a $view
1584                }
1585            }
1586            incr i
1587        }
1588
1589        set scripts [check_interest $id $scripts]
1590        set gotsome 1
1591    }
1592    if {$gotsome} {
1593        global numcommits hlview
1594
1595        if {$view == $curview} {
1596            set numcommits $commitidx($view)
1597            run chewcommits
1598        }
1599        if {[info exists hlview] && $view == $hlview} {
1600            # we never actually get here...
1601            run vhighlightmore
1602        }
1603        foreach s $scripts {
1604            eval $s
1605        }
1606    }
1607    return 2
1608}
1609
1610proc chewcommits {} {
1611    global curview hlview viewcomplete
1612    global pending_select
1613
1614    layoutmore
1615    if {$viewcomplete($curview)} {
1616        global commitidx varctok
1617        global numcommits startmsecs
1618
1619        if {[info exists pending_select]} {
1620            update
1621            reset_pending_select {}
1622
1623            if {[commitinview $pending_select $curview]} {
1624                selectline [rowofcommit $pending_select] 1
1625            } else {
1626                set row [first_real_row]
1627                selectline $row 1
1628            }
1629        }
1630        if {$commitidx($curview) > 0} {
1631            #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1632            #puts "overall $ms ms for $numcommits commits"
1633            #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1634        } else {
1635            show_status [mc "No commits selected"]
1636        }
1637        notbusy layout
1638    }
1639    return 0
1640}
1641
1642proc do_readcommit {id} {
1643    global tclencoding
1644
1645    # Invoke git-log to handle automatic encoding conversion
1646    set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1647    # Read the results using i18n.logoutputencoding
1648    fconfigure $fd -translation lf -eofchar {}
1649    if {$tclencoding != {}} {
1650        fconfigure $fd -encoding $tclencoding
1651    }
1652    set contents [read $fd]
1653    close $fd
1654    # Remove the heading line
1655    regsub {^commit [0-9a-f]+\n} $contents {} contents
1656
1657    return $contents
1658}
1659
1660proc readcommit {id} {
1661    if {[catch {set contents [do_readcommit $id]}]} return
1662    parsecommit $id $contents 1
1663}
1664
1665proc parsecommit {id contents listed} {
1666    global commitinfo
1667
1668    set inhdr 1
1669    set comment {}
1670    set headline {}
1671    set auname {}
1672    set audate {}
1673    set comname {}
1674    set comdate {}
1675    set hdrend [string first "\n\n" $contents]
1676    if {$hdrend < 0} {
1677        # should never happen...
1678        set hdrend [string length $contents]
1679    }
1680    set header [string range $contents 0 [expr {$hdrend - 1}]]
1681    set comment [string range $contents [expr {$hdrend + 2}] end]
1682    foreach line [split $header "\n"] {
1683        set line [split $line " "]
1684        set tag [lindex $line 0]
1685        if {$tag == "author"} {
1686            set audate [lrange $line end-1 end]
1687            set auname [join [lrange $line 1 end-2] " "]
1688        } elseif {$tag == "committer"} {
1689            set comdate [lrange $line end-1 end]
1690            set comname [join [lrange $line 1 end-2] " "]
1691        }
1692    }
1693    set headline {}
1694    # take the first non-blank line of the comment as the headline
1695    set headline [string trimleft $comment]
1696    set i [string first "\n" $headline]
1697    if {$i >= 0} {
1698        set headline [string range $headline 0 $i]
1699    }
1700    set headline [string trimright $headline]
1701    set i [string first "\r" $headline]
1702    if {$i >= 0} {
1703        set headline [string trimright [string range $headline 0 $i]]
1704    }
1705    if {!$listed} {
1706        # git log indents the comment by 4 spaces;
1707        # if we got this via git cat-file, add the indentation
1708        set newcomment {}
1709        foreach line [split $comment "\n"] {
1710            append newcomment "    "
1711            append newcomment $line
1712            append newcomment "\n"
1713        }
1714        set comment $newcomment
1715    }
1716    set hasnote [string first "\nNotes:\n" $contents]
1717    set diff ""
1718    # If there is diff output shown in the git-log stream, split it
1719    # out.  But get rid of the empty line that always precedes the
1720    # diff.
1721    set i [string first "\n\ndiff" $comment]
1722    if {$i >= 0} {
1723        set diff [string range $comment $i+1 end]
1724        set comment [string range $comment 0 $i-1]
1725    }
1726    set commitinfo($id) [list $headline $auname $audate \
1727                             $comname $comdate $comment $hasnote $diff]
1728}
1729
1730proc getcommit {id} {
1731    global commitdata commitinfo
1732
1733    if {[info exists commitdata($id)]} {
1734        parsecommit $id $commitdata($id) 1
1735    } else {
1736        readcommit $id
1737        if {![info exists commitinfo($id)]} {
1738            set commitinfo($id) [list [mc "No commit information available"]]
1739        }
1740    }
1741    return 1
1742}
1743
1744# Expand an abbreviated commit ID to a list of full 40-char IDs that match
1745# and are present in the current view.
1746# This is fairly slow...
1747proc longid {prefix} {
1748    global varcid curview vshortids
1749
1750    set ids {}
1751    if {[string length $prefix] >= 4} {
1752        set vshortid $curview,[string range $prefix 0 3]
1753        if {[info exists vshortids($vshortid)]} {
1754            foreach id $vshortids($vshortid) {
1755                if {[string match "$prefix*" $id]} {
1756                    if {[lsearch -exact $ids $id] < 0} {
1757                        lappend ids $id
1758                        if {[llength $ids] >= 2} break
1759                    }
1760                }
1761            }
1762        }
1763    } else {
1764        foreach match [array names varcid "$curview,$prefix*"] {
1765            lappend ids [lindex [split $match ","] 1]
1766            if {[llength $ids] >= 2} break
1767        }
1768    }
1769    return $ids
1770}
1771
1772proc readrefs {} {
1773    global tagids idtags headids idheads tagobjid
1774    global otherrefids idotherrefs mainhead mainheadid
1775    global selecthead selectheadid
1776    global hideremotes
1777
1778    foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1779        catch {unset $v}
1780    }
1781    set refd [open [list | git show-ref -d] r]
1782    while {[gets $refd line] >= 0} {
1783        if {[string index $line 40] ne " "} continue
1784        set id [string range $line 0 39]
1785        set ref [string range $line 41 end]
1786        if {![string match "refs/*" $ref]} continue
1787        set name [string range $ref 5 end]
1788        if {[string match "remotes/*" $name]} {
1789            if {![string match "*/HEAD" $name] && !$hideremotes} {
1790                set headids($name) $id
1791                lappend idheads($id) $name
1792            }
1793        } elseif {[string match "heads/*" $name]} {
1794            set name [string range $name 6 end]
1795            set headids($name) $id
1796            lappend idheads($id) $name
1797        } elseif {[string match "tags/*" $name]} {
1798            # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1799            # which is what we want since the former is the commit ID
1800            set name [string range $name 5 end]
1801            if {[string match "*^{}" $name]} {
1802                set name [string range $name 0 end-3]
1803            } else {
1804                set tagobjid($name) $id
1805            }
1806            set tagids($name) $id
1807            lappend idtags($id) $name
1808        } else {
1809            set otherrefids($name) $id
1810            lappend idotherrefs($id) $name
1811        }
1812    }
1813    catch {close $refd}
1814    set mainhead {}
1815    set mainheadid {}
1816    catch {
1817        set mainheadid [exec git rev-parse HEAD]
1818        set thehead [exec git symbolic-ref HEAD]
1819        if {[string match "refs/heads/*" $thehead]} {
1820            set mainhead [string range $thehead 11 end]
1821        }
1822    }
1823    set selectheadid {}
1824    if {$selecthead ne {}} {
1825        catch {
1826            set selectheadid [exec git rev-parse --verify $selecthead]
1827        }
1828    }
1829}
1830
1831# skip over fake commits
1832proc first_real_row {} {
1833    global nullid nullid2 numcommits
1834
1835    for {set row 0} {$row < $numcommits} {incr row} {
1836        set id [commitonrow $row]
1837        if {$id ne $nullid && $id ne $nullid2} {
1838            break
1839        }
1840    }
1841    return $row
1842}
1843
1844# update things for a head moved to a child of its previous location
1845proc movehead {id name} {
1846    global headids idheads
1847
1848    removehead $headids($name) $name
1849    set headids($name) $id
1850    lappend idheads($id) $name
1851}
1852
1853# update things when a head has been removed
1854proc removehead {id name} {
1855    global headids idheads
1856
1857    if {$idheads($id) eq $name} {
1858        unset idheads($id)
1859    } else {
1860        set i [lsearch -exact $idheads($id) $name]
1861        if {$i >= 0} {
1862            set idheads($id) [lreplace $idheads($id) $i $i]
1863        }
1864    }
1865    unset headids($name)
1866}
1867
1868proc ttk_toplevel {w args} {
1869    global use_ttk
1870    eval [linsert $args 0 ::toplevel $w]
1871    if {$use_ttk} {
1872        place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1873    }
1874    return $w
1875}
1876
1877proc make_transient {window origin} {
1878    global have_tk85
1879
1880    # In MacOS Tk 8.4 transient appears to work by setting
1881    # overrideredirect, which is utterly useless, since the
1882    # windows get no border, and are not even kept above
1883    # the parent.
1884    if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1885
1886    wm transient $window $origin
1887
1888    # Windows fails to place transient windows normally, so
1889    # schedule a callback to center them on the parent.
1890    if {[tk windowingsystem] eq {win32}} {
1891        after idle [list tk::PlaceWindow $window widget $origin]
1892    }
1893}
1894
1895proc show_error {w top msg {mc mc}} {
1896    global NS
1897    if {![info exists NS]} {set NS ""}
1898    if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1899    message $w.m -text $msg -justify center -aspect 400
1900    pack $w.m -side top -fill x -padx 20 -pady 20
1901    ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1902    pack $w.ok -side bottom -fill x
1903    bind $top <Visibility> "grab $top; focus $top"
1904    bind $top <Key-Return> "destroy $top"
1905    bind $top <Key-space>  "destroy $top"
1906    bind $top <Key-Escape> "destroy $top"
1907    tkwait window $top
1908}
1909
1910proc error_popup {msg {owner .}} {
1911    if {[tk windowingsystem] eq "win32"} {
1912        tk_messageBox -icon error -type ok -title [wm title .] \
1913            -parent $owner -message $msg
1914    } else {
1915        set w .error
1916        ttk_toplevel $w
1917        make_transient $w $owner
1918        show_error $w $w $msg
1919    }
1920}
1921
1922proc confirm_popup {msg {owner .}} {
1923    global confirm_ok NS
1924    set confirm_ok 0
1925    set w .confirm
1926    ttk_toplevel $w
1927    make_transient $w $owner
1928    message $w.m -text $msg -justify center -aspect 400
1929    pack $w.m -side top -fill x -padx 20 -pady 20
1930    ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1931    pack $w.ok -side left -fill x
1932    ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1933    pack $w.cancel -side right -fill x
1934    bind $w <Visibility> "grab $w; focus $w"
1935    bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1936    bind $w <Key-space>  "set confirm_ok 1; destroy $w"
1937    bind $w <Key-Escape> "destroy $w"
1938    tk::PlaceWindow $w widget $owner
1939    tkwait window $w
1940    return $confirm_ok
1941}
1942
1943proc setoptions {} {
1944    if {[tk windowingsystem] ne "win32"} {
1945        option add *Panedwindow.showHandle 1 startupFile
1946        option add *Panedwindow.sashRelief raised startupFile
1947        if {[tk windowingsystem] ne "aqua"} {
1948            option add *Menu.font uifont startupFile
1949        }
1950    } else {
1951        option add *Menu.TearOff 0 startupFile
1952    }
1953    option add *Button.font uifont startupFile
1954    option add *Checkbutton.font uifont startupFile
1955    option add *Radiobutton.font uifont startupFile
1956    option add *Menubutton.font uifont startupFile
1957    option add *Label.font uifont startupFile
1958    option add *Message.font uifont startupFile
1959    option add *Entry.font textfont startupFile
1960    option add *Text.font textfont startupFile
1961    option add *Labelframe.font uifont startupFile
1962    option add *Spinbox.font textfont startupFile
1963    option add *Listbox.font mainfont startupFile
1964}
1965
1966# Make a menu and submenus.
1967# m is the window name for the menu, items is the list of menu items to add.
1968# Each item is a list {mc label type description options...}
1969# mc is ignored; it's so we can put mc there to alert xgettext
1970# label is the string that appears in the menu
1971# type is cascade, command or radiobutton (should add checkbutton)
1972# description depends on type; it's the sublist for cascade, the
1973# command to invoke for command, or {variable value} for radiobutton
1974proc makemenu {m items} {
1975    menu $m
1976    if {[tk windowingsystem] eq {aqua}} {
1977        set Meta1 Cmd
1978    } else {
1979        set Meta1 Ctrl
1980    }
1981    foreach i $items {
1982        set name [mc [lindex $i 1]]
1983        set type [lindex $i 2]
1984        set thing [lindex $i 3]
1985        set params [list $type]
1986        if {$name ne {}} {
1987            set u [string first "&" [string map {&& x} $name]]
1988            lappend params -label [string map {&& & & {}} $name]
1989            if {$u >= 0} {
1990                lappend params -underline $u
1991            }
1992        }
1993        switch -- $type {
1994            "cascade" {
1995                set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1996                lappend params -menu $m.$submenu
1997            }
1998            "command" {
1999                lappend params -command $thing
2000            }
2001            "radiobutton" {
2002                lappend params -variable [lindex $thing 0] \
2003                    -value [lindex $thing 1]
2004            }
2005        }
2006        set tail [lrange $i 4 end]
2007        regsub -all {\yMeta1\y} $tail $Meta1 tail
2008        eval $m add $params $tail
2009        if {$type eq "cascade"} {
2010            makemenu $m.$submenu $thing
2011        }
2012    }
2013}
2014
2015# translate string and remove ampersands
2016proc mca {str} {
2017    return [string map {&& & & {}} [mc $str]]
2018}
2019
2020proc cleardropsel {w} {
2021    $w selection clear
2022}
2023proc makedroplist {w varname args} {
2024    global use_ttk
2025    if {$use_ttk} {
2026        set width 0
2027        foreach label $args {
2028            set cx [string length $label]
2029            if {$cx > $width} {set width $cx}
2030        }
2031        set gm [ttk::combobox $w -width $width -state readonly\
2032                    -textvariable $varname -values $args \
2033                    -exportselection false]
2034        bind $gm <<ComboboxSelected>> [list $gm selection clear]
2035    } else {
2036        set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2037    }
2038    return $gm
2039}
2040
2041proc makewindow {} {
2042    global canv canv2 canv3 linespc charspc ctext cflist cscroll
2043    global tabstop
2044    global findtype findtypemenu findloc findstring fstring geometry
2045    global entries sha1entry sha1string sha1but
2046    global diffcontextstring diffcontext
2047    global ignorespace
2048    global maincursor textcursor curtextcursor
2049    global rowctxmenu fakerowmenu mergemax wrapcomment
2050    global highlight_files gdttype
2051    global searchstring sstring
2052    global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2053    global uifgcolor uifgdisabledcolor
2054    global filesepbgcolor filesepfgcolor
2055    global mergecolors foundbgcolor currentsearchhitbgcolor
2056    global headctxmenu progresscanv progressitem progresscoords statusw
2057    global fprogitem fprogcoord lastprogupdate progupdatepending
2058    global rprogitem rprogcoord rownumsel numcommits
2059    global have_tk85 use_ttk NS
2060    global git_version
2061    global worddiff
2062
2063    # The "mc" arguments here are purely so that xgettext
2064    # sees the following string as needing to be translated
2065    set file {
2066        mc "File" cascade {
2067            {mc "Update" command updatecommits -accelerator F5}
2068            {mc "Reload" command reloadcommits -accelerator Shift-F5}
2069            {mc "Reread references" command rereadrefs}
2070            {mc "List references" command showrefs -accelerator F2}
2071            {xx "" separator}
2072            {mc "Start git gui" command {exec git gui &}}
2073            {xx "" separator}
2074            {mc "Quit" command doquit -accelerator Meta1-Q}
2075        }}
2076    set edit {
2077        mc "Edit" cascade {
2078            {mc "Preferences" command doprefs}
2079        }}
2080    set view {
2081        mc "View" cascade {
2082            {mc "New view..." command {newview 0} -accelerator Shift-F4}
2083            {mc "Edit view..." command editview -state disabled -accelerator F4}
2084            {mc "Delete view" command delview -state disabled}
2085            {xx "" separator}
2086            {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2087        }}
2088    if {[tk windowingsystem] ne "aqua"} {
2089        set help {
2090        mc "Help" cascade {
2091            {mc "About gitk" command about}
2092            {mc "Key bindings" command keys}
2093        }}
2094        set bar [list $file $edit $view $help]
2095    } else {
2096        proc ::tk::mac::ShowPreferences {} {doprefs}
2097        proc ::tk::mac::Quit {} {doquit}
2098        lset file end [lreplace [lindex $file end] end-1 end]
2099        set apple {
2100        xx "Apple" cascade {
2101            {mc "About gitk" command about}
2102            {xx "" separator}
2103        }}
2104        set help {
2105        mc "Help" cascade {
2106            {mc "Key bindings" command keys}
2107        }}
2108        set bar [list $apple $file $view $help]
2109    }
2110    makemenu .bar $bar
2111    . configure -menu .bar
2112
2113    if {$use_ttk} {
2114        # cover the non-themed toplevel with a themed frame.
2115        place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2116    }
2117
2118    # the gui has upper and lower half, parts of a paned window.
2119    ${NS}::panedwindow .ctop -orient vertical
2120
2121    # possibly use assumed geometry
2122    if {![info exists geometry(pwsash0)]} {
2123        set geometry(topheight) [expr {15 * $linespc}]
2124        set geometry(topwidth) [expr {80 * $charspc}]
2125        set geometry(botheight) [expr {15 * $linespc}]
2126        set geometry(botwidth) [expr {50 * $charspc}]
2127        set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2128        set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2129    }
2130
2131    # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2132    ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2133    ${NS}::frame .tf.histframe
2134    ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2135    if {!$use_ttk} {
2136        .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2137    }
2138
2139    # create three canvases
2140    set cscroll .tf.histframe.csb
2141    set canv .tf.histframe.pwclist.canv
2142    canvas $canv \
2143        -selectbackground $selectbgcolor \
2144        -background $bgcolor -bd 0 \
2145        -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2146    .tf.histframe.pwclist add $canv
2147    set canv2 .tf.histframe.pwclist.canv2
2148    canvas $canv2 \
2149        -selectbackground $selectbgcolor \
2150        -background $bgcolor -bd 0 -yscrollincr $linespc
2151    .tf.histframe.pwclist add $canv2
2152    set canv3 .tf.histframe.pwclist.canv3
2153    canvas $canv3 \
2154        -selectbackground $selectbgcolor \
2155        -background $bgcolor -bd 0 -yscrollincr $linespc
2156    .tf.histframe.pwclist add $canv3
2157    if {$use_ttk} {
2158        bind .tf.histframe.pwclist <Map> {
2159            bind %W <Map> {}
2160            .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2161            .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2162        }
2163    } else {
2164        eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2165        eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2166    }
2167
2168    # a scroll bar to rule them
2169    ${NS}::scrollbar $cscroll -command {allcanvs yview}
2170    if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2171    pack $cscroll -side right -fill y
2172    bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2173    lappend bglist $canv $canv2 $canv3
2174    pack .tf.histframe.pwclist -fill both -expand 1 -side left
2175
2176    # we have two button bars at bottom of top frame. Bar 1
2177    ${NS}::frame .tf.bar
2178    ${NS}::frame .tf.lbar -height 15
2179
2180    set sha1entry .tf.bar.sha1
2181    set entries $sha1entry
2182    set sha1but .tf.bar.sha1label
2183    button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2184        -command gotocommit -width 8
2185    $sha1but conf -disabledforeground [$sha1but cget -foreground]
2186    pack .tf.bar.sha1label -side left
2187    ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2188    trace add variable sha1string write sha1change
2189    pack $sha1entry -side left -pady 2
2190
2191    set bm_left_data {
2192        #define left_width 16
2193        #define left_height 16
2194        static unsigned char left_bits[] = {
2195        0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2196        0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2197        0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2198    }
2199    set bm_right_data {
2200        #define right_width 16
2201        #define right_height 16
2202        static unsigned char right_bits[] = {
2203        0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2204        0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2205        0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2206    }
2207    image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2208    image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2209    image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2210    image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2211
2212    ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2213    if {$use_ttk} {
2214        .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2215    } else {
2216        .tf.bar.leftbut configure -image bm-left
2217    }
2218    pack .tf.bar.leftbut -side left -fill y
2219    ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2220    if {$use_ttk} {
2221        .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2222    } else {
2223        .tf.bar.rightbut configure -image bm-right
2224    }
2225    pack .tf.bar.rightbut -side left -fill y
2226
2227    ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2228    set rownumsel {}
2229    ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2230        -relief sunken -anchor e
2231    ${NS}::label .tf.bar.rowlabel2 -text "/"
2232    ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2233        -relief sunken -anchor e
2234    pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2235        -side left
2236    if {!$use_ttk} {
2237        foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2238    }
2239    global selectedline
2240    trace add variable selectedline write selectedline_change
2241
2242    # Status label and progress bar
2243    set statusw .tf.bar.status
2244    ${NS}::label $statusw -width 15 -relief sunken
2245    pack $statusw -side left -padx 5
2246    if {$use_ttk} {
2247        set progresscanv [ttk::progressbar .tf.bar.progress]
2248    } else {
2249        set h [expr {[font metrics uifont -linespace] + 2}]
2250        set progresscanv .tf.bar.progress
2251        canvas $progresscanv -relief sunken -height $h -borderwidth 2
2252        set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2253        set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2254        set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2255    }
2256    pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2257    set progresscoords {0 0}
2258    set fprogcoord 0
2259    set rprogcoord 0
2260    bind $progresscanv <Configure> adjustprogress
2261    set lastprogupdate [clock clicks -milliseconds]
2262    set progupdatepending 0
2263
2264    # build up the bottom bar of upper window
2265    ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2266    ${NS}::button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
2267    ${NS}::button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
2268    ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2269    pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2270        -side left -fill y
2271    set gdttype [mc "containing:"]
2272    set gm [makedroplist .tf.lbar.gdttype gdttype \
2273                [mc "containing:"] \
2274                [mc "touching paths:"] \
2275                [mc "adding/removing string:"] \
2276                [mc "changing lines matching:"]]
2277    trace add variable gdttype write gdttype_change
2278    pack .tf.lbar.gdttype -side left -fill y
2279
2280    set findstring {}
2281    set fstring .tf.lbar.findstring
2282    lappend entries $fstring
2283    ${NS}::entry $fstring -width 30 -textvariable findstring
2284    trace add variable findstring write find_change
2285    set findtype [mc "Exact"]
2286    set findtypemenu [makedroplist .tf.lbar.findtype \
2287                          findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2288    trace add variable findtype write findcom_change
2289    set findloc [mc "All fields"]
2290    makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2291        [mc "Comments"] [mc "Author"] [mc "Committer"]
2292    trace add variable findloc write find_change
2293    pack .tf.lbar.findloc -side right
2294    pack .tf.lbar.findtype -side right
2295    pack $fstring -side left -expand 1 -fill x
2296
2297    # Finish putting the upper half of the viewer together
2298    pack .tf.lbar -in .tf -side bottom -fill x
2299    pack .tf.bar -in .tf -side bottom -fill x
2300    pack .tf.histframe -fill both -side top -expand 1
2301    .ctop add .tf
2302    if {!$use_ttk} {
2303        .ctop paneconfigure .tf -height $geometry(topheight)
2304        .ctop paneconfigure .tf -width $geometry(topwidth)
2305    }
2306
2307    # now build up the bottom
2308    ${NS}::panedwindow .pwbottom -orient horizontal
2309
2310    # lower left, a text box over search bar, scroll bar to the right
2311    # if we know window height, then that will set the lower text height, otherwise
2312    # we set lower text height which will drive window height
2313    if {[info exists geometry(main)]} {
2314        ${NS}::frame .bleft -width $geometry(botwidth)
2315    } else {
2316        ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2317    }
2318    ${NS}::frame .bleft.top
2319    ${NS}::frame .bleft.mid
2320    ${NS}::frame .bleft.bottom
2321
2322    ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2323    pack .bleft.top.search -side left -padx 5
2324    set sstring .bleft.top.sstring
2325    set searchstring ""
2326    ${NS}::entry $sstring -width 20 -textvariable searchstring
2327    lappend entries $sstring
2328    trace add variable searchstring write incrsearch
2329    pack $sstring -side left -expand 1 -fill x
2330    ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2331        -command changediffdisp -variable diffelide -value {0 0}
2332    ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2333        -command changediffdisp -variable diffelide -value {0 1}
2334    ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2335        -command changediffdisp -variable diffelide -value {1 0}
2336    ${NS}::label .bleft.mid.labeldiffcontext -text "      [mc "Lines of context"]: "
2337    pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2338    spinbox .bleft.mid.diffcontext -width 5 \
2339        -from 0 -increment 1 -to 10000000 \
2340        -validate all -validatecommand "diffcontextvalidate %P" \
2341        -textvariable diffcontextstring
2342    .bleft.mid.diffcontext set $diffcontext
2343    trace add variable diffcontextstring write diffcontextchange
2344    lappend entries .bleft.mid.diffcontext
2345    pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2346    ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2347        -command changeignorespace -variable ignorespace
2348    pack .bleft.mid.ignspace -side left -padx 5
2349
2350    set worddiff [mc "Line diff"]
2351    if {[package vcompare $git_version "1.7.2"] >= 0} {
2352        makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2353            [mc "Markup words"] [mc "Color words"]
2354        trace add variable worddiff write changeworddiff
2355        pack .bleft.mid.worddiff -side left -padx 5
2356    }
2357
2358    set ctext .bleft.bottom.ctext
2359    text $ctext -background $bgcolor -foreground $fgcolor \
2360        -state disabled -font textfont \
2361        -yscrollcommand scrolltext -wrap none \
2362        -xscrollcommand ".bleft.bottom.sbhorizontal set"
2363    if {$have_tk85} {
2364        $ctext conf -tabstyle wordprocessor
2365    }
2366    ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2367    ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2368    pack .bleft.top -side top -fill x
2369    pack .bleft.mid -side top -fill x
2370    grid $ctext .bleft.bottom.sb -sticky nsew
2371    grid .bleft.bottom.sbhorizontal -sticky ew
2372    grid columnconfigure .bleft.bottom 0 -weight 1
2373    grid rowconfigure .bleft.bottom 0 -weight 1
2374    grid rowconfigure .bleft.bottom 1 -weight 0
2375    pack .bleft.bottom -side top -fill both -expand 1
2376    lappend bglist $ctext
2377    lappend fglist $ctext
2378
2379    $ctext tag conf comment -wrap $wrapcomment
2380    $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2381    $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2382    $ctext tag conf d0 -fore [lindex $diffcolors 0]
2383    $ctext tag conf dresult -fore [lindex $diffcolors 1]
2384    $ctext tag conf m0 -fore [lindex $mergecolors 0]
2385    $ctext tag conf m1 -fore [lindex $mergecolors 1]
2386    $ctext tag conf m2 -fore [lindex $mergecolors 2]
2387    $ctext tag conf m3 -fore [lindex $mergecolors 3]
2388    $ctext tag conf m4 -fore [lindex $mergecolors 4]
2389    $ctext tag conf m5 -fore [lindex $mergecolors 5]
2390    $ctext tag conf m6 -fore [lindex $mergecolors 6]
2391    $ctext tag conf m7 -fore [lindex $mergecolors 7]
2392    $ctext tag conf m8 -fore [lindex $mergecolors 8]
2393    $ctext tag conf m9 -fore [lindex $mergecolors 9]
2394    $ctext tag conf m10 -fore [lindex $mergecolors 10]
2395    $ctext tag conf m11 -fore [lindex $mergecolors 11]
2396    $ctext tag conf m12 -fore [lindex $mergecolors 12]
2397    $ctext tag conf m13 -fore [lindex $mergecolors 13]
2398    $ctext tag conf m14 -fore [lindex $mergecolors 14]
2399    $ctext tag conf m15 -fore [lindex $mergecolors 15]
2400    $ctext tag conf mmax -fore darkgrey
2401    set mergemax 16
2402    $ctext tag conf mresult -font textfontbold
2403    $ctext tag conf msep -font textfontbold
2404    $ctext tag conf found -back $foundbgcolor
2405    $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2406    $ctext tag conf wwrap -wrap word
2407    $ctext tag conf bold -font textfontbold
2408
2409    .pwbottom add .bleft
2410    if {!$use_ttk} {
2411        .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2412    }
2413
2414    # lower right
2415    ${NS}::frame .bright
2416    ${NS}::frame .bright.mode
2417    ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2418        -command reselectline -variable cmitmode -value "patch"
2419    ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2420        -command reselectline -variable cmitmode -value "tree"
2421    grid .bright.mode.patch .bright.mode.tree -sticky ew
2422    pack .bright.mode -side top -fill x
2423    set cflist .bright.cfiles
2424    set indent [font measure mainfont "nn"]
2425    text $cflist \
2426        -selectbackground $selectbgcolor \
2427        -background $bgcolor -foreground $fgcolor \
2428        -font mainfont \
2429        -tabs [list $indent [expr {2 * $indent}]] \
2430        -yscrollcommand ".bright.sb set" \
2431        -cursor [. cget -cursor] \
2432        -spacing1 1 -spacing3 1
2433    lappend bglist $cflist
2434    lappend fglist $cflist
2435    ${NS}::scrollbar .bright.sb -command "$cflist yview"
2436    pack .bright.sb -side right -fill y
2437    pack $cflist -side left -fill both -expand 1
2438    $cflist tag configure highlight \
2439        -background [$cflist cget -selectbackground]
2440    $cflist tag configure bold -font mainfontbold
2441
2442    .pwbottom add .bright
2443    .ctop add .pwbottom
2444
2445    # restore window width & height if known
2446    if {[info exists geometry(main)]} {
2447        if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2448            if {$w > [winfo screenwidth .]} {
2449                set w [winfo screenwidth .]
2450            }
2451            if {$h > [winfo screenheight .]} {
2452                set h [winfo screenheight .]
2453            }
2454            wm geometry . "${w}x$h"
2455        }
2456    }
2457
2458    if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2459        wm state . $geometry(state)
2460    }
2461
2462    if {[tk windowingsystem] eq {aqua}} {
2463        set M1B M1
2464        set ::BM "3"
2465    } else {
2466        set M1B Control
2467        set ::BM "2"
2468    }
2469
2470    if {$use_ttk} {
2471        bind .ctop <Map> {
2472            bind %W <Map> {}
2473            %W sashpos 0 $::geometry(topheight)
2474        }
2475        bind .pwbottom <Map> {
2476            bind %W <Map> {}
2477            %W sashpos 0 $::geometry(botwidth)
2478        }
2479    }
2480
2481    bind .pwbottom <Configure> {resizecdetpanes %W %w}
2482    pack .ctop -fill both -expand 1
2483    bindall <1> {selcanvline %W %x %y}
2484    #bindall <B1-Motion> {selcanvline %W %x %y}
2485    if {[tk windowingsystem] == "win32"} {
2486        bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2487        bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2488    } else {
2489        bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2490        bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2491        if {[tk windowingsystem] eq "aqua"} {
2492            bindall <MouseWheel> {
2493                set delta [expr {- (%D)}]
2494                allcanvs yview scroll $delta units
2495            }
2496            bindall <Shift-MouseWheel> {
2497                set delta [expr {- (%D)}]
2498                $canv xview scroll $delta units
2499            }
2500        }
2501    }
2502    bindall <$::BM> "canvscan mark %W %x %y"
2503    bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2504    bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2505    bind . <$M1B-Key-w> doquit
2506    bindkey <Home> selfirstline
2507    bindkey <End> sellastline
2508    bind . <Key-Up> "selnextline -1"
2509    bind . <Key-Down> "selnextline 1"
2510    bind . <Shift-Key-Up> "dofind -1 0"
2511    bind . <Shift-Key-Down> "dofind 1 0"
2512    bindkey <Key-Right> "goforw"
2513    bindkey <Key-Left> "goback"
2514    bind . <Key-Prior> "selnextpage -1"
2515    bind . <Key-Next> "selnextpage 1"
2516    bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2517    bind . <$M1B-End> "allcanvs yview moveto 1.0"
2518    bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2519    bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2520    bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2521    bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2522    bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2523    bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2524    bindkey <Key-space> "$ctext yview scroll 1 pages"
2525    bindkey p "selnextline -1"
2526    bindkey n "selnextline 1"
2527    bindkey z "goback"
2528    bindkey x "goforw"
2529    bindkey k "selnextline -1"
2530    bindkey j "selnextline 1"
2531    bindkey h "goback"
2532    bindkey l "goforw"
2533    bindkey b prevfile
2534    bindkey d "$ctext yview scroll 18 units"
2535    bindkey u "$ctext yview scroll -18 units"
2536    bindkey / {focus $fstring}
2537    bindkey <Key-KP_Divide> {focus $fstring}
2538    bindkey <Key-Return> {dofind 1 1}
2539    bindkey ? {dofind -1 1}
2540    bindkey f nextfile
2541    bind . <F5> updatecommits
2542    bindmodfunctionkey Shift 5 reloadcommits
2543    bind . <F2> showrefs
2544    bindmodfunctionkey Shift 4 {newview 0}
2545    bind . <F4> edit_or_newview
2546    bind . <$M1B-q> doquit
2547    bind . <$M1B-f> {dofind 1 1}
2548    bind . <$M1B-g> {dofind 1 0}
2549    bind . <$M1B-r> dosearchback
2550    bind . <$M1B-s> dosearch
2551    bind . <$M1B-equal> {incrfont 1}
2552    bind . <$M1B-plus> {incrfont 1}
2553    bind . <$M1B-KP_Add> {incrfont 1}
2554    bind . <$M1B-minus> {incrfont -1}
2555    bind . <$M1B-KP_Subtract> {incrfont -1}
2556    wm protocol . WM_DELETE_WINDOW doquit
2557    bind . <Destroy> {stop_backends}
2558    bind . <Button-1> "click %W"
2559    bind $fstring <Key-Return> {dofind 1 1}
2560    bind $sha1entry <Key-Return> {gotocommit; break}
2561    bind $sha1entry <<PasteSelection>> clearsha1
2562    bind $cflist <1> {sel_flist %W %x %y; break}
2563    bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2564    bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2565    global ctxbut
2566    bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2567    bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2568    bind $ctext <Button-1> {focus %W}
2569    bind $ctext <<Selection>> rehighlight_search_results
2570
2571    set maincursor [. cget -cursor]
2572    set textcursor [$ctext cget -cursor]
2573    set curtextcursor $textcursor
2574
2575    set rowctxmenu .rowctxmenu
2576    makemenu $rowctxmenu {
2577        {mc "Diff this -> selected" command {diffvssel 0}}
2578        {mc "Diff selected -> this" command {diffvssel 1}}
2579        {mc "Make patch" command mkpatch}
2580        {mc "Create tag" command mktag}
2581        {mc "Write commit to file" command writecommit}
2582        {mc "Create new branch" command mkbranch}
2583        {mc "Cherry-pick this commit" command cherrypick}
2584        {mc "Reset HEAD branch to here" command resethead}
2585        {mc "Mark this commit" command markhere}
2586        {mc "Return to mark" command gotomark}
2587        {mc "Find descendant of this and mark" command find_common_desc}
2588        {mc "Compare with marked commit" command compare_commits}
2589        {mc "Diff this -> marked commit" command {diffvsmark 0}}
2590        {mc "Diff marked commit -> this" command {diffvsmark 1}}
2591        {mc "Revert this commit" command revert}
2592    }
2593    $rowctxmenu configure -tearoff 0
2594
2595    set fakerowmenu .fakerowmenu
2596    makemenu $fakerowmenu {
2597        {mc "Diff this -> selected" command {diffvssel 0}}
2598        {mc "Diff selected -> this" command {diffvssel 1}}
2599        {mc "Make patch" command mkpatch}
2600        {mc "Diff this -> marked commit" command {diffvsmark 0}}
2601        {mc "Diff marked commit -> this" command {diffvsmark 1}}
2602    }
2603    $fakerowmenu configure -tearoff 0
2604
2605    set headctxmenu .headctxmenu
2606    makemenu $headctxmenu {
2607        {mc "Check out this branch" command cobranch}
2608        {mc "Remove this branch" command rmbranch}
2609    }
2610    $headctxmenu configure -tearoff 0
2611
2612    global flist_menu
2613    set flist_menu .flistctxmenu
2614    makemenu $flist_menu {
2615        {mc "Highlight this too" command {flist_hl 0}}
2616        {mc "Highlight this only" command {flist_hl 1}}
2617        {mc "External diff" command {external_diff}}
2618        {mc "Blame parent commit" command {external_blame 1}}
2619    }
2620    $flist_menu configure -tearoff 0
2621
2622    global diff_menu
2623    set diff_menu .diffctxmenu
2624    makemenu $diff_menu {
2625        {mc "Show origin of this line" command show_line_source}
2626        {mc "Run git gui blame on this line" command {external_blame_diff}}
2627    }
2628    $diff_menu configure -tearoff 0
2629}
2630
2631# Windows sends all mouse wheel events to the current focused window, not
2632# the one where the mouse hovers, so bind those events here and redirect
2633# to the correct window
2634proc windows_mousewheel_redirector {W X Y D} {
2635    global canv canv2 canv3
2636    set w [winfo containing -displayof $W $X $Y]
2637    if {$w ne ""} {
2638        set u [expr {$D < 0 ? 5 : -5}]
2639        if {$w == $canv || $w == $canv2 || $w == $canv3} {
2640            allcanvs yview scroll $u units
2641        } else {
2642            catch {
2643                $w yview scroll $u units
2644            }
2645        }
2646    }
2647}
2648
2649# Update row number label when selectedline changes
2650proc selectedline_change {n1 n2 op} {
2651    global selectedline rownumsel
2652
2653    if {$selectedline eq {}} {
2654        set rownumsel {}
2655    } else {
2656        set rownumsel [expr {$selectedline + 1}]
2657    }
2658}
2659
2660# mouse-2 makes all windows scan vertically, but only the one
2661# the cursor is in scans horizontally
2662proc canvscan {op w x y} {
2663    global canv canv2 canv3
2664    foreach c [list $canv $canv2 $canv3] {
2665        if {$c == $w} {
2666            $c scan $op $x $y
2667        } else {
2668            $c scan $op 0 $y
2669        }
2670    }
2671}
2672
2673proc scrollcanv {cscroll f0 f1} {
2674    $cscroll set $f0 $f1
2675    drawvisible
2676    flushhighlights
2677}
2678
2679# when we make a key binding for the toplevel, make sure
2680# it doesn't get triggered when that key is pressed in the
2681# find string entry widget.
2682proc bindkey {ev script} {
2683    global entries
2684    bind . $ev $script
2685    set escript [bind Entry $ev]
2686    if {$escript == {}} {
2687        set escript [bind Entry <Key>]
2688    }
2689    foreach e $entries {
2690        bind $e $ev "$escript; break"
2691    }
2692}
2693
2694proc bindmodfunctionkey {mod n script} {
2695    bind . <$mod-F$n> $script
2696    catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2697}
2698
2699# set the focus back to the toplevel for any click outside
2700# the entry widgets
2701proc click {w} {
2702    global ctext entries
2703    foreach e [concat $entries $ctext] {
2704        if {$w == $e} return
2705    }
2706    focus .
2707}
2708
2709# Adjust the progress bar for a change in requested extent or canvas size
2710proc adjustprogress {} {
2711    global progresscanv progressitem progresscoords
2712    global fprogitem fprogcoord lastprogupdate progupdatepending
2713    global rprogitem rprogcoord use_ttk
2714
2715    if {$use_ttk} {
2716        $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2717        return
2718    }
2719
2720    set w [expr {[winfo width $progresscanv] - 4}]
2721    set x0 [expr {$w * [lindex $progresscoords 0]}]
2722    set x1 [expr {$w * [lindex $progresscoords 1]}]
2723    set h [winfo height $progresscanv]
2724    $progresscanv coords $progressitem $x0 0 $x1 $h
2725    $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2726    $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2727    set now [clock clicks -milliseconds]
2728    if {$now >= $lastprogupdate + 100} {
2729        set progupdatepending 0
2730        update
2731    } elseif {!$progupdatepending} {
2732        set progupdatepending 1
2733        after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2734    }
2735}
2736
2737proc doprogupdate {} {
2738    global lastprogupdate progupdatepending
2739
2740    if {$progupdatepending} {
2741        set progupdatepending 0
2742        set lastprogupdate [clock clicks -milliseconds]
2743        update
2744    }
2745}
2746
2747proc savestuff {w} {
2748    global canv canv2 canv3 mainfont textfont uifont tabstop
2749    global stuffsaved findmergefiles maxgraphpct
2750    global maxwidth showneartags showlocalchanges
2751    global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
2752    global cmitmode wrapcomment datetimeformat limitdiffs
2753    global colors uicolor bgcolor fgcolor diffcolors diffcontext selectbgcolor
2754    global uifgcolor uifgdisabledcolor
2755    global headbgcolor headfgcolor headoutlinecolor remotebgcolor
2756    global tagbgcolor tagfgcolor tagoutlinecolor
2757    global reflinecolor filesepbgcolor filesepfgcolor
2758    global mergecolors foundbgcolor currentsearchhitbgcolor
2759    global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor circlecolors
2760    global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
2761    global linkfgcolor circleoutlinecolor
2762    global autoselect autosellen extdifftool perfile_attrs markbgcolor use_ttk
2763    global hideremotes want_ttk maxrefs
2764
2765    if {$stuffsaved} return
2766    if {![winfo viewable .]} return
2767    catch {
2768        if {[file exists ~/.gitk-new]} {file delete -force ~/.gitk-new}
2769        set f [open "~/.gitk-new" w]
2770        if {$::tcl_platform(platform) eq {windows}} {
2771            file attributes "~/.gitk-new" -hidden true
2772        }
2773        puts $f [list set mainfont $mainfont]
2774        puts $f [list set textfont $textfont]
2775        puts $f [list set uifont $uifont]
2776        puts $f [list set tabstop $tabstop]
2777        puts $f [list set findmergefiles $findmergefiles]
2778        puts $f [list set maxgraphpct $maxgraphpct]
2779        puts $f [list set maxwidth $maxwidth]
2780        puts $f [list set cmitmode $cmitmode]
2781        puts $f [list set wrapcomment $wrapcomment]
2782        puts $f [list set autoselect $autoselect]
2783        puts $f [list set autosellen $autosellen]
2784        puts $f [list set showneartags $showneartags]
2785        puts $f [list set maxrefs $maxrefs]
2786        puts $f [list set hideremotes $hideremotes]
2787        puts $f [list set showlocalchanges $showlocalchanges]
2788        puts $f [list set datetimeformat $datetimeformat]
2789        puts $f [list set limitdiffs $limitdiffs]
2790        puts $f [list set uicolor $uicolor]
2791        puts $f [list set want_ttk $want_ttk]
2792        puts $f [list set bgcolor $bgcolor]
2793        puts $f [list set fgcolor $fgcolor]
2794        puts $f [list set uifgcolor $uifgcolor]
2795        puts $f [list set uifgdisabledcolor $uifgdisabledcolor]
2796        puts $f [list set colors $colors]
2797        puts $f [list set diffcolors $diffcolors]
2798        puts $f [list set mergecolors $mergecolors]
2799        puts $f [list set markbgcolor $markbgcolor]
2800        puts $f [list set diffcontext $diffcontext]
2801        puts $f [list set selectbgcolor $selectbgcolor]
2802        puts $f [list set foundbgcolor $foundbgcolor]
2803        puts $f [list set currentsearchhitbgcolor $currentsearchhitbgcolor]
2804        puts $f [list set extdifftool $extdifftool]
2805        puts $f [list set perfile_attrs $perfile_attrs]
2806        puts $f [list set headbgcolor $headbgcolor]
2807        puts $f [list set headfgcolor $headfgcolor]
2808        puts $f [list set headoutlinecolor $headoutlinecolor]
2809        puts $f [list set remotebgcolor $remotebgcolor]
2810        puts $f [list set tagbgcolor $tagbgcolor]
2811        puts $f [list set tagfgcolor $tagfgcolor]
2812        puts $f [list set tagoutlinecolor $tagoutlinecolor]
2813        puts $f [list set reflinecolor $reflinecolor]
2814        puts $f [list set filesepbgcolor $filesepbgcolor]
2815        puts $f [list set filesepfgcolor $filesepfgcolor]
2816        puts $f [list set linehoverbgcolor $linehoverbgcolor]
2817        puts $f [list set linehoverfgcolor $linehoverfgcolor]
2818        puts $f [list set linehoveroutlinecolor $linehoveroutlinecolor]
2819        puts $f [list set mainheadcirclecolor $mainheadcirclecolor]
2820        puts $f [list set workingfilescirclecolor $workingfilescirclecolor]
2821        puts $f [list set indexcirclecolor $indexcirclecolor]
2822        puts $f [list set circlecolors $circlecolors]
2823        puts $f [list set linkfgcolor $linkfgcolor]
2824        puts $f [list set circleoutlinecolor $circleoutlinecolor]
2825
2826        puts $f "set geometry(main) [wm geometry .]"
2827        puts $f "set geometry(state) [wm state .]"
2828        puts $f "set geometry(topwidth) [winfo width .tf]"
2829        puts $f "set geometry(topheight) [winfo height .tf]"
2830        if {$use_ttk} {
2831            puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2832            puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2833        } else {
2834            puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2835            puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2836        }
2837        puts $f "set geometry(botwidth) [winfo width .bleft]"
2838        puts $f "set geometry(botheight) [winfo height .bleft]"
2839
2840        puts -nonewline $f "set permviews {"
2841        for {set v 0} {$v < $nextviewnum} {incr v} {
2842            if {$viewperm($v)} {
2843                puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
2844            }
2845        }
2846        puts $f "}"
2847        close $f
2848        file rename -force "~/.gitk-new" "~/.gitk"
2849    }
2850    set stuffsaved 1
2851}
2852
2853proc resizeclistpanes {win w} {
2854    global oldwidth use_ttk
2855    if {[info exists oldwidth($win)]} {
2856        if {$use_ttk} {
2857            set s0 [$win sashpos 0]
2858            set s1 [$win sashpos 1]
2859        } else {
2860            set s0 [$win sash coord 0]
2861            set s1 [$win sash coord 1]
2862        }
2863        if {$w < 60} {
2864            set sash0 [expr {int($w/2 - 2)}]
2865            set sash1 [expr {int($w*5/6 - 2)}]
2866        } else {
2867            set factor [expr {1.0 * $w / $oldwidth($win)}]
2868            set sash0 [expr {int($factor * [lindex $s0 0])}]
2869            set sash1 [expr {int($factor * [lindex $s1 0])}]
2870            if {$sash0 < 30} {
2871                set sash0 30
2872            }
2873            if {$sash1 < $sash0 + 20} {
2874                set sash1 [expr {$sash0 + 20}]
2875            }
2876            if {$sash1 > $w - 10} {
2877                set sash1 [expr {$w - 10}]
2878                if {$sash0 > $sash1 - 20} {
2879                    set sash0 [expr {$sash1 - 20}]
2880                }
2881            }
2882        }
2883        if {$use_ttk} {
2884            $win sashpos 0 $sash0
2885            $win sashpos 1 $sash1
2886        } else {
2887            $win sash place 0 $sash0 [lindex $s0 1]
2888            $win sash place 1 $sash1 [lindex $s1 1]
2889        }
2890    }
2891    set oldwidth($win) $w
2892}
2893
2894proc resizecdetpanes {win w} {
2895    global oldwidth use_ttk
2896    if {[info exists oldwidth($win)]} {
2897        if {$use_ttk} {
2898            set s0 [$win sashpos 0]
2899        } else {
2900            set s0 [$win sash coord 0]
2901        }
2902        if {$w < 60} {
2903            set sash0 [expr {int($w*3/4 - 2)}]
2904        } else {
2905            set factor [expr {1.0 * $w / $oldwidth($win)}]
2906            set sash0 [expr {int($factor * [lindex $s0 0])}]
2907            if {$sash0 < 45} {
2908                set sash0 45
2909            }
2910            if {$sash0 > $w - 15} {
2911                set sash0 [expr {$w - 15}]
2912            }
2913        }
2914        if {$use_ttk} {
2915            $win sashpos 0 $sash0
2916        } else {
2917            $win sash place 0 $sash0 [lindex $s0 1]
2918        }
2919    }
2920    set oldwidth($win) $w
2921}
2922
2923proc allcanvs args {
2924    global canv canv2 canv3
2925    eval $canv $args
2926    eval $canv2 $args
2927    eval $canv3 $args
2928}
2929
2930proc bindall {event action} {
2931    global canv canv2 canv3
2932    bind $canv $event $action
2933    bind $canv2 $event $action
2934    bind $canv3 $event $action
2935}
2936
2937proc about {} {
2938    global uifont NS
2939    set w .about
2940    if {[winfo exists $w]} {
2941        raise $w
2942        return
2943    }
2944    ttk_toplevel $w
2945    wm title $w [mc "About gitk"]
2946    make_transient $w .
2947    message $w.m -text [mc "
2948Gitk - a commit viewer for git
2949
2950Copyright \u00a9 2005-2011 Paul Mackerras
2951
2952Use and redistribute under the terms of the GNU General Public License"] \
2953            -justify center -aspect 400 -border 2 -bg white -relief groove
2954    pack $w.m -side top -fill x -padx 2 -pady 2
2955    ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2956    pack $w.ok -side bottom
2957    bind $w <Visibility> "focus $w.ok"
2958    bind $w <Key-Escape> "destroy $w"
2959    bind $w <Key-Return> "destroy $w"
2960    tk::PlaceWindow $w widget .
2961}
2962
2963proc keys {} {
2964    global NS
2965    set w .keys
2966    if {[winfo exists $w]} {
2967        raise $w
2968        return
2969    }
2970    if {[tk windowingsystem] eq {aqua}} {
2971        set M1T Cmd
2972    } else {
2973        set M1T Ctrl
2974    }
2975    ttk_toplevel $w
2976    wm title $w [mc "Gitk key bindings"]
2977    make_transient $w .
2978    message $w.m -text "
2979[mc "Gitk key bindings:"]
2980
2981[mc "<%s-Q>             Quit" $M1T]
2982[mc "<%s-W>             Close window" $M1T]
2983[mc "<Home>             Move to first commit"]
2984[mc "<End>              Move to last commit"]
2985[mc "<Up>, p, k Move up one commit"]
2986[mc "<Down>, n, j       Move down one commit"]
2987[mc "<Left>, z, h       Go back in history list"]
2988[mc "<Right>, x, l      Go forward in history list"]
2989[mc "<PageUp>   Move up one page in commit list"]
2990[mc "<PageDown> Move down one page in commit list"]
2991[mc "<%s-Home>  Scroll to top of commit list" $M1T]
2992[mc "<%s-End>   Scroll to bottom of commit list" $M1T]
2993[mc "<%s-Up>    Scroll commit list up one line" $M1T]
2994[mc "<%s-Down>  Scroll commit list down one line" $M1T]
2995[mc "<%s-PageUp>        Scroll commit list up one page" $M1T]
2996[mc "<%s-PageDown>      Scroll commit list down one page" $M1T]
2997[mc "<Shift-Up> Find backwards (upwards, later commits)"]
2998[mc "<Shift-Down>       Find forwards (downwards, earlier commits)"]
2999[mc "<Delete>, b        Scroll diff view up one page"]
3000[mc "<Backspace>        Scroll diff view up one page"]
3001[mc "<Space>            Scroll diff view down one page"]
3002[mc "u          Scroll diff view up 18 lines"]
3003[mc "d          Scroll diff view down 18 lines"]
3004[mc "<%s-F>             Find" $M1T]
3005[mc "<%s-G>             Move to next find hit" $M1T]
3006[mc "<Return>   Move to next find hit"]
3007[mc "/          Focus the search box"]
3008[mc "?          Move to previous find hit"]
3009[mc "f          Scroll diff view to next file"]
3010[mc "<%s-S>             Search for next hit in diff view" $M1T]
3011[mc "<%s-R>             Search for previous hit in diff view" $M1T]
3012[mc "<%s-KP+>   Increase font size" $M1T]
3013[mc "<%s-plus>  Increase font size" $M1T]
3014[mc "<%s-KP->   Decrease font size" $M1T]
3015[mc "<%s-minus> Decrease font size" $M1T]
3016[mc "<F5>               Update"]
3017" \
3018            -justify left -bg white -border 2 -relief groove
3019    pack $w.m -side top -fill both -padx 2 -pady 2
3020    ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3021    bind $w <Key-Escape> [list destroy $w]
3022    pack $w.ok -side bottom
3023    bind $w <Visibility> "focus $w.ok"
3024    bind $w <Key-Escape> "destroy $w"
3025    bind $w <Key-Return> "destroy $w"
3026}
3027
3028# Procedures for manipulating the file list window at the
3029# bottom right of the overall window.
3030
3031proc treeview {w l openlevs} {
3032    global treecontents treediropen treeheight treeparent treeindex
3033
3034    set ix 0
3035    set treeindex() 0
3036    set lev 0
3037    set prefix {}
3038    set prefixend -1
3039    set prefendstack {}
3040    set htstack {}
3041    set ht 0
3042    set treecontents() {}
3043    $w conf -state normal
3044    foreach f $l {
3045        while {[string range $f 0 $prefixend] ne $prefix} {
3046            if {$lev <= $openlevs} {
3047                $w mark set e:$treeindex($prefix) "end -1c"
3048                $w mark gravity e:$treeindex($prefix) left
3049            }
3050            set treeheight($prefix) $ht
3051            incr ht [lindex $htstack end]
3052            set htstack [lreplace $htstack end end]
3053            set prefixend [lindex $prefendstack end]
3054            set prefendstack [lreplace $prefendstack end end]
3055            set prefix [string range $prefix 0 $prefixend]
3056            incr lev -1
3057        }
3058        set tail [string range $f [expr {$prefixend+1}] end]
3059        while {[set slash [string first "/" $tail]] >= 0} {
3060            lappend htstack $ht
3061            set ht 0
3062            lappend prefendstack $prefixend
3063            incr prefixend [expr {$slash + 1}]
3064            set d [string range $tail 0 $slash]
3065            lappend treecontents($prefix) $d
3066            set oldprefix $prefix
3067            append prefix $d
3068            set treecontents($prefix) {}
3069            set treeindex($prefix) [incr ix]
3070            set treeparent($prefix) $oldprefix
3071            set tail [string range $tail [expr {$slash+1}] end]
3072            if {$lev <= $openlevs} {
3073                set ht 1
3074                set treediropen($prefix) [expr {$lev < $openlevs}]
3075                set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3076                $w mark set d:$ix "end -1c"
3077                $w mark gravity d:$ix left
3078                set str "\n"
3079                for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3080                $w insert end $str
3081                $w image create end -align center -image $bm -padx 1 \
3082                    -name a:$ix
3083                $w insert end $d [highlight_tag $prefix]
3084                $w mark set s:$ix "end -1c"
3085                $w mark gravity s:$ix left
3086            }
3087            incr lev
3088        }
3089        if {$tail ne {}} {
3090            if {$lev <= $openlevs} {
3091                incr ht
3092                set str "\n"
3093                for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3094                $w insert end $str
3095                $w insert end $tail [highlight_tag $f]
3096            }
3097            lappend treecontents($prefix) $tail
3098        }
3099    }
3100    while {$htstack ne {}} {
3101        set treeheight($prefix) $ht
3102        incr ht [lindex $htstack end]
3103        set htstack [lreplace $htstack end end]
3104        set prefixend [lindex $prefendstack end]
3105        set prefendstack [lreplace $prefendstack end end]
3106        set prefix [string range $prefix 0 $prefixend]
3107    }
3108    $w conf -state disabled
3109}
3110
3111proc linetoelt {l} {
3112    global treeheight treecontents
3113
3114    set y 2
3115    set prefix {}
3116    while {1} {
3117        foreach e $treecontents($prefix) {
3118            if {$y == $l} {
3119                return "$prefix$e"
3120            }
3121            set n 1
3122            if {[string index $e end] eq "/"} {
3123                set n $treeheight($prefix$e)
3124                if {$y + $n > $l} {
3125                    append prefix $e
3126                    incr y
3127                    break
3128                }
3129            }
3130            incr y $n
3131        }
3132    }
3133}
3134
3135proc highlight_tree {y prefix} {
3136    global treeheight treecontents cflist
3137
3138    foreach e $treecontents($prefix) {
3139        set path $prefix$e
3140        if {[highlight_tag $path] ne {}} {
3141            $cflist tag add bold $y.0 "$y.0 lineend"
3142        }
3143        incr y
3144        if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3145            set y [highlight_tree $y $path]
3146        }
3147    }
3148    return $y
3149}
3150
3151proc treeclosedir {w dir} {
3152    global treediropen treeheight treeparent treeindex
3153
3154    set ix $treeindex($dir)
3155    $w conf -state normal
3156    $w delete s:$ix e:$ix
3157    set treediropen($dir) 0
3158    $w image configure a:$ix -image tri-rt
3159    $w conf -state disabled
3160    set n [expr {1 - $treeheight($dir)}]
3161    while {$dir ne {}} {
3162        incr treeheight($dir) $n
3163        set dir $treeparent($dir)
3164    }
3165}
3166
3167proc treeopendir {w dir} {
3168    global treediropen treeheight treeparent treecontents treeindex
3169
3170    set ix $treeindex($dir)
3171    $w conf -state normal
3172    $w image configure a:$ix -image tri-dn
3173    $w mark set e:$ix s:$ix
3174    $w mark gravity e:$ix right
3175    set lev 0
3176    set str "\n"
3177    set n [llength $treecontents($dir)]
3178    for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3179        incr lev
3180        append str "\t"
3181        incr treeheight($x) $n
3182    }
3183    foreach e $treecontents($dir) {
3184        set de $dir$e
3185        if {[string index $e end] eq "/"} {
3186            set iy $treeindex($de)
3187            $w mark set d:$iy e:$ix
3188            $w mark gravity d:$iy left
3189            $w insert e:$ix $str
3190            set treediropen($de) 0
3191            $w image create e:$ix -align center -image tri-rt -padx 1 \
3192                -name a:$iy
3193            $w insert e:$ix $e [highlight_tag $de]
3194            $w mark set s:$iy e:$ix
3195            $w mark gravity s:$iy left
3196            set treeheight($de) 1
3197        } else {
3198            $w insert e:$ix $str
3199            $w insert e:$ix $e [highlight_tag $de]
3200        }
3201    }
3202    $w mark gravity e:$ix right
3203    $w conf -state disabled
3204    set treediropen($dir) 1
3205    set top [lindex [split [$w index @0,0] .] 0]
3206    set ht [$w cget -height]
3207    set l [lindex [split [$w index s:$ix] .] 0]
3208    if {$l < $top} {
3209        $w yview $l.0
3210    } elseif {$l + $n + 1 > $top + $ht} {
3211        set top [expr {$l + $n + 2 - $ht}]
3212        if {$l < $top} {
3213            set top $l
3214        }
3215        $w yview $top.0
3216    }
3217}
3218
3219proc treeclick {w x y} {
3220    global treediropen cmitmode ctext cflist cflist_top
3221
3222    if {$cmitmode ne "tree"} return
3223    if {![info exists cflist_top]} return
3224    set l [lindex [split [$w index "@$x,$y"] "."] 0]
3225    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3226    $cflist tag add highlight $l.0 "$l.0 lineend"
3227    set cflist_top $l
3228    if {$l == 1} {
3229        $ctext yview 1.0
3230        return
3231    }
3232    set e [linetoelt $l]
3233    if {[string index $e end] ne "/"} {
3234        showfile $e
3235    } elseif {$treediropen($e)} {
3236        treeclosedir $w $e
3237    } else {
3238        treeopendir $w $e
3239    }
3240}
3241
3242proc setfilelist {id} {
3243    global treefilelist cflist jump_to_here
3244
3245    treeview $cflist $treefilelist($id) 0
3246    if {$jump_to_here ne {}} {
3247        set f [lindex $jump_to_here 0]
3248        if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3249            showfile $f
3250        }
3251    }
3252}
3253
3254image create bitmap tri-rt -background black -foreground blue -data {
3255    #define tri-rt_width 13
3256    #define tri-rt_height 13
3257    static unsigned char tri-rt_bits[] = {
3258       0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3259       0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3260       0x00, 0x00};
3261} -maskdata {
3262    #define tri-rt-mask_width 13
3263    #define tri-rt-mask_height 13
3264    static unsigned char tri-rt-mask_bits[] = {
3265       0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3266       0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3267       0x08, 0x00};
3268}
3269image create bitmap tri-dn -background black -foreground blue -data {
3270    #define tri-dn_width 13
3271    #define tri-dn_height 13
3272    static unsigned char tri-dn_bits[] = {
3273       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3274       0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3275       0x00, 0x00};
3276} -maskdata {
3277    #define tri-dn-mask_width 13
3278    #define tri-dn-mask_height 13
3279    static unsigned char tri-dn-mask_bits[] = {
3280       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3281       0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3282       0x00, 0x00};
3283}
3284
3285image create bitmap reficon-T -background black -foreground yellow -data {
3286    #define tagicon_width 13
3287    #define tagicon_height 9
3288    static unsigned char tagicon_bits[] = {
3289       0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3290       0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3291} -maskdata {
3292    #define tagicon-mask_width 13
3293    #define tagicon-mask_height 9
3294    static unsigned char tagicon-mask_bits[] = {
3295       0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3296       0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3297}
3298set rectdata {
3299    #define headicon_width 13
3300    #define headicon_height 9
3301    static unsigned char headicon_bits[] = {
3302       0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3303       0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3304}
3305set rectmask {
3306    #define headicon-mask_width 13
3307    #define headicon-mask_height 9
3308    static unsigned char headicon-mask_bits[] = {
3309       0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3310       0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3311}
3312image create bitmap reficon-H -background black -foreground green \
3313    -data $rectdata -maskdata $rectmask
3314image create bitmap reficon-o -background black -foreground "#ddddff" \
3315    -data $rectdata -maskdata $rectmask
3316
3317proc init_flist {first} {
3318    global cflist cflist_top difffilestart
3319
3320    $cflist conf -state normal
3321    $cflist delete 0.0 end
3322    if {$first ne {}} {
3323        $cflist insert end $first
3324        set cflist_top 1
3325        $cflist tag add highlight 1.0 "1.0 lineend"
3326    } else {
3327        catch {unset cflist_top}
3328    }
3329    $cflist conf -state disabled
3330    set difffilestart {}
3331}
3332
3333proc highlight_tag {f} {
3334    global highlight_paths
3335
3336    foreach p $highlight_paths {
3337        if {[string match $p $f]} {
3338            return "bold"
3339        }
3340    }
3341    return {}
3342}
3343
3344proc highlight_filelist {} {
3345    global cmitmode cflist
3346
3347    $cflist conf -state normal
3348    if {$cmitmode ne "tree"} {
3349        set end [lindex [split [$cflist index end] .] 0]
3350        for {set l 2} {$l < $end} {incr l} {
3351            set line [$cflist get $l.0 "$l.0 lineend"]
3352            if {[highlight_tag $line] ne {}} {
3353                $cflist tag add bold $l.0 "$l.0 lineend"
3354            }
3355        }
3356    } else {
3357        highlight_tree 2 {}
3358    }
3359    $cflist conf -state disabled
3360}
3361
3362proc unhighlight_filelist {} {
3363    global cflist
3364
3365    $cflist conf -state normal
3366    $cflist tag remove bold 1.0 end
3367    $cflist conf -state disabled
3368}
3369
3370proc add_flist {fl} {
3371    global cflist
3372
3373    $cflist conf -state normal
3374    foreach f $fl {
3375        $cflist insert end "\n"
3376        $cflist insert end $f [highlight_tag $f]
3377    }
3378    $cflist conf -state disabled
3379}
3380
3381proc sel_flist {w x y} {
3382    global ctext difffilestart cflist cflist_top cmitmode
3383
3384    if {$cmitmode eq "tree"} return
3385    if {![info exists cflist_top]} return
3386    set l [lindex [split [$w index "@$x,$y"] "."] 0]
3387    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3388    $cflist tag add highlight $l.0 "$l.0 lineend"
3389    set cflist_top $l
3390    if {$l == 1} {
3391        $ctext yview 1.0
3392    } else {
3393        catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3394    }
3395    suppress_highlighting_file_for_current_scrollpos
3396}
3397
3398proc pop_flist_menu {w X Y x y} {
3399    global ctext cflist cmitmode flist_menu flist_menu_file
3400    global treediffs diffids
3401
3402    stopfinding
3403    set l [lindex [split [$w index "@$x,$y"] "."] 0]
3404    if {$l <= 1} return
3405    if {$cmitmode eq "tree"} {
3406        set e [linetoelt $l]
3407        if {[string index $e end] eq "/"} return
3408    } else {
3409        set e [lindex $treediffs($diffids) [expr {$l-2}]]
3410    }
3411    set flist_menu_file $e
3412    set xdiffstate "normal"
3413    if {$cmitmode eq "tree"} {
3414        set xdiffstate "disabled"
3415    }
3416    # Disable "External diff" item in tree mode
3417    $flist_menu entryconf 2 -state $xdiffstate
3418    tk_popup $flist_menu $X $Y
3419}
3420
3421proc find_ctext_fileinfo {line} {
3422    global ctext_file_names ctext_file_lines
3423
3424    set ok [bsearch $ctext_file_lines $line]
3425    set tline [lindex $ctext_file_lines $ok]
3426
3427    if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3428        return {}
3429    } else {
3430        return [list [lindex $ctext_file_names $ok] $tline]
3431    }
3432}
3433
3434proc pop_diff_menu {w X Y x y} {
3435    global ctext diff_menu flist_menu_file
3436    global diff_menu_txtpos diff_menu_line
3437    global diff_menu_filebase
3438
3439    set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3440    set diff_menu_line [lindex $diff_menu_txtpos 0]
3441    # don't pop up the menu on hunk-separator or file-separator lines
3442    if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3443        return
3444    }
3445    stopfinding
3446    set f [find_ctext_fileinfo $diff_menu_line]
3447    if {$f eq {}} return
3448    set flist_menu_file [lindex $f 0]
3449    set diff_menu_filebase [lindex $f 1]
3450    tk_popup $diff_menu $X $Y
3451}
3452
3453proc flist_hl {only} {
3454    global flist_menu_file findstring gdttype
3455
3456    set x [shellquote $flist_menu_file]
3457    if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3458        set findstring $x
3459    } else {
3460        append findstring " " $x
3461    }
3462    set gdttype [mc "touching paths:"]
3463}
3464
3465proc gitknewtmpdir {} {
3466    global diffnum gitktmpdir gitdir
3467
3468    if {![info exists gitktmpdir]} {
3469        set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3470        if {[catch {file mkdir $gitktmpdir} err]} {
3471            error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3472            unset gitktmpdir
3473            return {}
3474        }
3475        set diffnum 0
3476    }
3477    incr diffnum
3478    set diffdir [file join $gitktmpdir $diffnum]
3479    if {[catch {file mkdir $diffdir} err]} {
3480        error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3481        return {}
3482    }
3483    return $diffdir
3484}
3485
3486proc save_file_from_commit {filename output what} {
3487    global nullfile
3488
3489    if {[catch {exec git show $filename -- > $output} err]} {
3490        if {[string match "fatal: bad revision *" $err]} {
3491            return $nullfile
3492        }
3493        error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3494        return {}
3495    }
3496    return $output
3497}
3498
3499proc external_diff_get_one_file {diffid filename diffdir} {
3500    global nullid nullid2 nullfile
3501    global worktree
3502
3503    if {$diffid == $nullid} {
3504        set difffile [file join $worktree $filename]
3505        if {[file exists $difffile]} {
3506            return $difffile
3507        }
3508        return $nullfile
3509    }
3510    if {$diffid == $nullid2} {
3511        set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3512        return [save_file_from_commit :$filename $difffile index]
3513    }
3514    set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3515    return [save_file_from_commit $diffid:$filename $difffile \
3516               "revision $diffid"]
3517}
3518
3519proc external_diff {} {
3520    global nullid nullid2
3521    global flist_menu_file
3522    global diffids
3523    global extdifftool
3524
3525    if {[llength $diffids] == 1} {
3526        # no reference commit given
3527        set diffidto [lindex $diffids 0]
3528        if {$diffidto eq $nullid} {
3529            # diffing working copy with index
3530            set diffidfrom $nullid2
3531        } elseif {$diffidto eq $nullid2} {
3532            # diffing index with HEAD
3533            set diffidfrom "HEAD"
3534        } else {
3535            # use first parent commit
3536            global parentlist selectedline
3537            set diffidfrom [lindex $parentlist $selectedline 0]
3538        }
3539    } else {
3540        set diffidfrom [lindex $diffids 0]
3541        set diffidto [lindex $diffids 1]
3542    }
3543
3544    # make sure that several diffs wont collide
3545    set diffdir [gitknewtmpdir]
3546    if {$diffdir eq {}} return
3547
3548    # gather files to diff
3549    set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3550    set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3551
3552    if {$difffromfile ne {} && $difftofile ne {}} {
3553        set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3554        if {[catch {set fl [open |$cmd r]} err]} {
3555            file delete -force $diffdir
3556            error_popup "$extdifftool: [mc "command failed:"] $err"
3557        } else {
3558            fconfigure $fl -blocking 0
3559            filerun $fl [list delete_at_eof $fl $diffdir]
3560        }
3561    }
3562}
3563
3564proc find_hunk_blamespec {base line} {
3565    global ctext
3566
3567    # Find and parse the hunk header
3568    set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3569    if {$s_lix eq {}} return
3570
3571    set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3572    if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3573            s_line old_specs osz osz1 new_line nsz]} {
3574        return
3575    }
3576
3577    # base lines for the parents
3578    set base_lines [list $new_line]
3579    foreach old_spec [lrange [split $old_specs " "] 1 end] {
3580        if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3581                old_spec old_line osz]} {
3582            return
3583        }
3584        lappend base_lines $old_line
3585    }
3586
3587    # Now scan the lines to determine offset within the hunk
3588    set max_parent [expr {[llength $base_lines]-2}]
3589    set dline 0
3590    set s_lno [lindex [split $s_lix "."] 0]
3591
3592    # Determine if the line is removed
3593    set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3594    if {[string match {[-+ ]*} $chunk]} {
3595        set removed_idx [string first "-" $chunk]
3596        # Choose a parent index
3597        if {$removed_idx >= 0} {
3598            set parent $removed_idx
3599        } else {
3600            set unchanged_idx [string first " " $chunk]
3601            if {$unchanged_idx >= 0} {
3602                set parent $unchanged_idx
3603            } else {
3604                # blame the current commit
3605                set parent -1
3606            }
3607        }
3608        # then count other lines that belong to it
3609        for {set i $line} {[incr i -1] > $s_lno} {} {
3610            set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3611            # Determine if the line is removed
3612            set removed_idx [string first "-" $chunk]
3613            if {$parent >= 0} {
3614                set code [string index $chunk $parent]
3615                if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3616                    incr dline
3617                }
3618            } else {
3619                if {$removed_idx < 0} {
3620                    incr dline
3621                }
3622            }
3623        }
3624        incr parent
3625    } else {
3626        set parent 0
3627    }
3628
3629    incr dline [lindex $base_lines $parent]
3630    return [list $parent $dline]
3631}
3632
3633proc external_blame_diff {} {
3634    global currentid cmitmode
3635    global diff_menu_txtpos diff_menu_line
3636    global diff_menu_filebase flist_menu_file
3637
3638    if {$cmitmode eq "tree"} {
3639        set parent_idx 0
3640        set line [expr {$diff_menu_line - $diff_menu_filebase}]
3641    } else {
3642        set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3643        if {$hinfo ne {}} {
3644            set parent_idx [lindex $hinfo 0]
3645            set line [lindex $hinfo 1]
3646        } else {
3647            set parent_idx 0
3648            set line 0
3649        }
3650    }
3651
3652    external_blame $parent_idx $line
3653}
3654
3655# Find the SHA1 ID of the blob for file $fname in the index
3656# at stage 0 or 2
3657proc index_sha1 {fname} {
3658    set f [open [list | git ls-files -s $fname] r]
3659    while {[gets $f line] >= 0} {
3660        set info [lindex [split $line "\t"] 0]
3661        set stage [lindex $info 2]
3662        if {$stage eq "0" || $stage eq "2"} {
3663            close $f
3664            return [lindex $info 1]
3665        }
3666    }
3667    close $f
3668    return {}
3669}
3670
3671# Turn an absolute path into one relative to the current directory
3672proc make_relative {f} {
3673    if {[file pathtype $f] eq "relative"} {
3674        return $f
3675    }
3676    set elts [file split $f]
3677    set here [file split [pwd]]
3678    set ei 0
3679    set hi 0
3680    set res {}
3681    foreach d $here {
3682        if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3683            lappend res ".."
3684        } else {
3685            incr ei
3686        }
3687        incr hi
3688    }
3689    set elts [concat $res [lrange $elts $ei end]]
3690    return [eval file join $elts]
3691}
3692
3693proc external_blame {parent_idx {line {}}} {
3694    global flist_menu_file cdup
3695    global nullid nullid2
3696    global parentlist selectedline currentid
3697
3698    if {$parent_idx > 0} {
3699        set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3700    } else {
3701        set base_commit $currentid
3702    }
3703
3704    if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3705        error_popup [mc "No such commit"]
3706        return
3707    }
3708
3709    set cmdline [list git gui blame]
3710    if {$line ne {} && $line > 1} {
3711        lappend cmdline "--line=$line"
3712    }
3713    set f [file join $cdup $flist_menu_file]
3714    # Unfortunately it seems git gui blame doesn't like
3715    # being given an absolute path...
3716    set f [make_relative $f]
3717    lappend cmdline $base_commit $f
3718    if {[catch {eval exec $cmdline &} err]} {
3719        error_popup "[mc "git gui blame: command failed:"] $err"
3720    }
3721}
3722
3723proc show_line_source {} {
3724    global cmitmode currentid parents curview blamestuff blameinst
3725    global diff_menu_line diff_menu_filebase flist_menu_file
3726    global nullid nullid2 gitdir cdup
3727
3728    set from_index {}
3729    if {$cmitmode eq "tree"} {
3730        set id $currentid
3731        set line [expr {$diff_menu_line - $diff_menu_filebase}]
3732    } else {
3733        set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3734        if {$h eq {}} return
3735        set pi [lindex $h 0]
3736        if {$pi == 0} {
3737            mark_ctext_line $diff_menu_line
3738            return
3739        }
3740        incr pi -1
3741        if {$currentid eq $nullid} {
3742            if {$pi > 0} {
3743                # must be a merge in progress...
3744                if {[catch {
3745                    # get the last line from .git/MERGE_HEAD
3746                    set f [open [file join $gitdir MERGE_HEAD] r]
3747                    set id [lindex [split [read $f] "\n"] end-1]
3748                    close $f
3749                } err]} {
3750                    error_popup [mc "Couldn't read merge head: %s" $err]
3751                    return
3752                }
3753            } elseif {$parents($curview,$currentid) eq $nullid2} {
3754                # need to do the blame from the index
3755                if {[catch {
3756                    set from_index [index_sha1 $flist_menu_file]
3757                } err]} {
3758                    error_popup [mc "Error reading index: %s" $err]
3759                    return
3760                }
3761            } else {
3762                set id $parents($curview,$currentid)
3763            }
3764        } else {
3765            set id [lindex $parents($curview,$currentid) $pi]
3766        }
3767        set line [lindex $h 1]
3768    }
3769    set blameargs {}
3770    if {$from_index ne {}} {
3771        lappend blameargs | git cat-file blob $from_index
3772    }
3773    lappend blameargs | git blame -p -L$line,+1
3774    if {$from_index ne {}} {
3775        lappend blameargs --contents -
3776    } else {
3777        lappend blameargs $id
3778    }
3779    lappend blameargs -- [file join $cdup $flist_menu_file]
3780    if {[catch {
3781        set f [open $blameargs r]
3782    } err]} {
3783        error_popup [mc "Couldn't start git blame: %s" $err]
3784        return
3785    }
3786    nowbusy blaming [mc "Searching"]
3787    fconfigure $f -blocking 0
3788    set i [reg_instance $f]
3789    set blamestuff($i) {}
3790    set blameinst $i
3791    filerun $f [list read_line_source $f $i]
3792}
3793
3794proc stopblaming {} {
3795    global blameinst
3796
3797    if {[info exists blameinst]} {
3798        stop_instance $blameinst
3799        unset blameinst
3800        notbusy blaming
3801    }
3802}
3803
3804proc read_line_source {fd inst} {
3805    global blamestuff curview commfd blameinst nullid nullid2
3806
3807    while {[gets $fd line] >= 0} {
3808        lappend blamestuff($inst) $line
3809    }
3810    if {![eof $fd]} {
3811        return 1
3812    }
3813    unset commfd($inst)
3814    unset blameinst
3815    notbusy blaming
3816    fconfigure $fd -blocking 1
3817    if {[catch {close $fd} err]} {
3818        error_popup [mc "Error running git blame: %s" $err]
3819        return 0
3820    }
3821
3822    set fname {}
3823    set line [split [lindex $blamestuff($inst) 0] " "]
3824    set id [lindex $line 0]
3825    set lnum [lindex $line 1]
3826    if {[string length $id] == 40 && [string is xdigit $id] &&
3827        [string is digit -strict $lnum]} {
3828        # look for "filename" line
3829        foreach l $blamestuff($inst) {
3830            if {[string match "filename *" $l]} {
3831                set fname [string range $l 9 end]
3832                break
3833            }
3834        }
3835    }
3836    if {$fname ne {}} {
3837        # all looks good, select it
3838        if {$id eq $nullid} {
3839            # blame uses all-zeroes to mean not committed,
3840            # which would mean a change in the index
3841            set id $nullid2
3842        }
3843        if {[commitinview $id $curview]} {
3844            selectline [rowofcommit $id] 1 [list $fname $lnum]
3845        } else {
3846            error_popup [mc "That line comes from commit %s, \
3847                             which is not in this view" [shortids $id]]
3848        }
3849    } else {
3850        puts "oops couldn't parse git blame output"
3851    }
3852    return 0
3853}
3854
3855# delete $dir when we see eof on $f (presumably because the child has exited)
3856proc delete_at_eof {f dir} {
3857    while {[gets $f line] >= 0} {}
3858    if {[eof $f]} {
3859        if {[catch {close $f} err]} {
3860            error_popup "[mc "External diff viewer failed:"] $err"
3861        }
3862        file delete -force $dir
3863        return 0
3864    }
3865    return 1
3866}
3867
3868# Functions for adding and removing shell-type quoting
3869
3870proc shellquote {str} {
3871    if {![string match "*\['\"\\ \t]*" $str]} {
3872        return $str
3873    }
3874    if {![string match "*\['\"\\]*" $str]} {
3875        return "\"$str\""
3876    }
3877    if {![string match "*'*" $str]} {
3878        return "'$str'"
3879    }
3880    return "\"[string map {\" \\\" \\ \\\\} $str]\""
3881}
3882
3883proc shellarglist {l} {
3884    set str {}
3885    foreach a $l {
3886        if {$str ne {}} {
3887            append str " "
3888        }
3889        append str [shellquote $a]
3890    }
3891    return $str
3892}
3893
3894proc shelldequote {str} {
3895    set ret {}
3896    set used -1
3897    while {1} {
3898        incr used
3899        if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3900            append ret [string range $str $used end]
3901            set used [string length $str]
3902            break
3903        }
3904        set first [lindex $first 0]
3905        set ch [string index $str $first]
3906        if {$first > $used} {
3907            append ret [string range $str $used [expr {$first - 1}]]
3908            set used $first
3909        }
3910        if {$ch eq " " || $ch eq "\t"} break
3911        incr used
3912        if {$ch eq "'"} {
3913            set first [string first "'" $str $used]
3914            if {$first < 0} {
3915                error "unmatched single-quote"
3916            }
3917            append ret [string range $str $used [expr {$first - 1}]]
3918            set used $first
3919            continue
3920        }
3921        if {$ch eq "\\"} {
3922            if {$used >= [string length $str]} {
3923                error "trailing backslash"
3924            }
3925            append ret [string index $str $used]
3926            continue
3927        }
3928        # here ch == "\""
3929        while {1} {
3930            if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3931                error "unmatched double-quote"
3932            }
3933            set first [lindex $first 0]
3934            set ch [string index $str $first]
3935            if {$first > $used} {
3936                append ret [string range $str $used [expr {$first - 1}]]
3937                set used $first
3938            }
3939            if {$ch eq "\""} break
3940            incr used
3941            append ret [string index $str $used]
3942            incr used
3943        }
3944    }
3945    return [list $used $ret]
3946}
3947
3948proc shellsplit {str} {
3949    set l {}
3950    while {1} {
3951        set str [string trimleft $str]
3952        if {$str eq {}} break
3953        set dq [shelldequote $str]
3954        set n [lindex $dq 0]
3955        set word [lindex $dq 1]
3956        set str [string range $str $n end]
3957        lappend l $word
3958    }
3959    return $l
3960}
3961
3962# Code to implement multiple views
3963
3964proc newview {ishighlight} {
3965    global nextviewnum newviewname newishighlight
3966    global revtreeargs viewargscmd newviewopts curview
3967
3968    set newishighlight $ishighlight
3969    set top .gitkview
3970    if {[winfo exists $top]} {
3971        raise $top
3972        return
3973    }
3974    decode_view_opts $nextviewnum $revtreeargs
3975    set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
3976    set newviewopts($nextviewnum,perm) 0
3977    set newviewopts($nextviewnum,cmd)  $viewargscmd($curview)
3978    vieweditor $top $nextviewnum [mc "Gitk view definition"]
3979}
3980
3981set known_view_options {
3982    {perm      b    .  {}               {mc "Remember this view"}}
3983    {reflabel  l    +  {}               {mc "References (space separated list):"}}
3984    {refs      t15  .. {}               {mc "Branches & tags:"}}
3985    {allrefs   b    *. "--all"          {mc "All refs"}}
3986    {branches  b    .  "--branches"     {mc "All (local) branches"}}
3987    {tags      b    .  "--tags"         {mc "All tags"}}
3988    {remotes   b    .  "--remotes"      {mc "All remote-tracking branches"}}
3989    {commitlbl l    +  {}               {mc "Commit Info (regular expressions):"}}
3990    {author    t15  .. "--author=*"     {mc "Author:"}}
3991    {committer t15  .  "--committer=*"  {mc "Committer:"}}
3992    {loginfo   t15  .. "--grep=*"       {mc "Commit Message:"}}
3993    {allmatch  b    .. "--all-match"    {mc "Matches all Commit Info criteria"}}
3994    {changes_l l    +  {}               {mc "Changes to Files:"}}
3995    {pickaxe_s r0   .  {}               {mc "Fixed String"}}
3996    {pickaxe_t r1   .  "--pickaxe-regex"  {mc "Regular Expression"}}
3997    {pickaxe   t15  .. "-S*"            {mc "Search string:"}}
3998    {datelabel l    +  {}               {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
3999    {since     t15  ..  {"--since=*" "--after=*"}  {mc "Since:"}}
4000    {until     t15  .   {"--until=*" "--before=*"} {mc "Until:"}}
4001    {limit_lbl l    +  {}               {mc "Limit and/or skip a number of revisions (positive integer):"}}
4002    {limit     t10  *. "--max-count=*"  {mc "Number to show:"}}
4003    {skip      t10  .  "--skip=*"       {mc "Number to skip:"}}
4004    {misc_lbl  l    +  {}               {mc "Miscellaneous options:"}}
4005    {dorder    b    *. {"--date-order" "-d"}      {mc "Strictly sort by date"}}
4006    {lright    b    .  "--left-right"   {mc "Mark branch sides"}}
4007    {first     b    .  "--first-parent" {mc "Limit to first parent"}}
4008    {smplhst   b    .  "--simplify-by-decoration"   {mc "Simple history"}}
4009    {args      t50  *. {}               {mc "Additional arguments to git log:"}}
4010    {allpaths  path +  {}               {mc "Enter files and directories to include, one per line:"}}
4011    {cmd       t50= +  {}               {mc "Command to generate more commits to include:"}}
4012    }
4013
4014# Convert $newviewopts($n, ...) into args for git log.
4015proc encode_view_opts {n} {
4016    global known_view_options newviewopts
4017
4018    set rargs [list]
4019    foreach opt $known_view_options {
4020        set patterns [lindex $opt 3]
4021        if {$patterns eq {}} continue
4022        set pattern [lindex $patterns 0]
4023
4024        if {[lindex $opt 1] eq "b"} {
4025            set val $newviewopts($n,[lindex $opt 0])
4026            if {$val} {
4027                lappend rargs $pattern
4028            }
4029        } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4030            regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4031            set val $newviewopts($n,$button_id)
4032            if {$val eq $value} {
4033                lappend rargs $pattern
4034            }
4035        } else {
4036            set val $newviewopts($n,[lindex $opt 0])
4037            set val [string trim $val]
4038            if {$val ne {}} {
4039                set pfix [string range $pattern 0 end-1]
4040                lappend rargs $pfix$val
4041            }
4042        }
4043    }
4044    set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4045    return [concat $rargs [shellsplit $newviewopts($n,args)]]
4046}
4047
4048# Fill $newviewopts($n, ...) based on args for git log.
4049proc decode_view_opts {n view_args} {
4050    global known_view_options newviewopts
4051
4052    foreach opt $known_view_options {
4053        set id [lindex $opt 0]
4054        if {[lindex $opt 1] eq "b"} {
4055            # Checkboxes
4056            set val 0
4057        } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4058            # Radiobuttons
4059            regexp {^(.*_)} $id uselessvar id
4060            set val 0
4061        } else {
4062            # Text fields
4063            set val {}
4064        }
4065        set newviewopts($n,$id) $val
4066    }
4067    set oargs [list]
4068    set refargs [list]
4069    foreach arg $view_args {
4070        if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4071            && ![info exists found(limit)]} {
4072            set newviewopts($n,limit) $cnt
4073            set found(limit) 1
4074            continue
4075        }
4076        catch { unset val }
4077        foreach opt $known_view_options {
4078            set id [lindex $opt 0]
4079            if {[info exists found($id)]} continue
4080            foreach pattern [lindex $opt 3] {
4081                if {![string match $pattern $arg]} continue
4082                if {[lindex $opt 1] eq "b"} {
4083                    # Check buttons
4084                    set val 1
4085                } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4086                    # Radio buttons
4087                    regexp {^(.*_)} $id uselessvar id
4088                    set val $num
4089                } else {
4090                    # Text input fields
4091                    set size [string length $pattern]
4092                    set val [string range $arg [expr {$size-1}] end]
4093                }
4094                set newviewopts($n,$id) $val
4095                set found($id) 1
4096                break
4097            }
4098            if {[info exists val]} break
4099        }
4100        if {[info exists val]} continue
4101        if {[regexp {^-} $arg]} {
4102            lappend oargs $arg
4103        } else {
4104            lappend refargs $arg
4105        }
4106    }
4107    set newviewopts($n,refs) [shellarglist $refargs]
4108    set newviewopts($n,args) [shellarglist $oargs]
4109}
4110
4111proc edit_or_newview {} {
4112    global curview
4113
4114    if {$curview > 0} {
4115        editview
4116    } else {
4117        newview 0
4118    }
4119}
4120
4121proc editview {} {
4122    global curview
4123    global viewname viewperm newviewname newviewopts
4124    global viewargs viewargscmd
4125
4126    set top .gitkvedit-$curview
4127    if {[winfo exists $top]} {
4128        raise $top
4129        return
4130    }
4131    decode_view_opts $curview $viewargs($curview)
4132    set newviewname($curview)      $viewname($curview)
4133    set newviewopts($curview,perm) $viewperm($curview)
4134    set newviewopts($curview,cmd)  $viewargscmd($curview)
4135    vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4136}
4137
4138proc vieweditor {top n title} {
4139    global newviewname newviewopts viewfiles bgcolor
4140    global known_view_options NS
4141
4142    ttk_toplevel $top
4143    wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4144    make_transient $top .
4145
4146    # View name
4147    ${NS}::frame $top.nfr
4148    ${NS}::label $top.nl -text [mc "View Name"]
4149    ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4150    pack $top.nfr -in $top -fill x -pady 5 -padx 3
4151    pack $top.nl -in $top.nfr -side left -padx {0 5}
4152    pack $top.name -in $top.nfr -side left -padx {0 25}
4153
4154    # View options
4155    set cframe $top.nfr
4156    set cexpand 0
4157    set cnt 0
4158    foreach opt $known_view_options {
4159        set id [lindex $opt 0]
4160        set type [lindex $opt 1]
4161        set flags [lindex $opt 2]
4162        set title [eval [lindex $opt 4]]
4163        set lxpad 0
4164
4165        if {$flags eq "+" || $flags eq "*"} {
4166            set cframe $top.fr$cnt
4167            incr cnt
4168            ${NS}::frame $cframe
4169            pack $cframe -in $top -fill x -pady 3 -padx 3
4170            set cexpand [expr {$flags eq "*"}]
4171        } elseif {$flags eq ".." || $flags eq "*."} {
4172            set cframe $top.fr$cnt
4173            incr cnt
4174            ${NS}::frame $cframe
4175            pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4176            set cexpand [expr {$flags eq "*."}]
4177        } else {
4178            set lxpad 5
4179        }
4180
4181        if {$type eq "l"} {
4182            ${NS}::label $cframe.l_$id -text $title
4183            pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4184        } elseif {$type eq "b"} {
4185            ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4186            pack $cframe.c_$id -in $cframe -side left \
4187                -padx [list $lxpad 0] -expand $cexpand -anchor w
4188        } elseif {[regexp {^r(\d+)$} $type type sz]} {
4189            regexp {^(.*_)} $id uselessvar button_id
4190            ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4191            pack $cframe.c_$id -in $cframe -side left \
4192                -padx [list $lxpad 0] -expand $cexpand -anchor w
4193        } elseif {[regexp {^t(\d+)$} $type type sz]} {
4194            ${NS}::label $cframe.l_$id -text $title
4195            ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4196                -textvariable newviewopts($n,$id)
4197            pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4198            pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4199        } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4200            ${NS}::label $cframe.l_$id -text $title
4201            ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4202                -textvariable newviewopts($n,$id)
4203            pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4204            pack $cframe.e_$id -in $cframe -side top -fill x
4205        } elseif {$type eq "path"} {
4206            ${NS}::label $top.l -text $title
4207            pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4208            text $top.t -width 40 -height 5 -background $bgcolor
4209            if {[info exists viewfiles($n)]} {
4210                foreach f $viewfiles($n) {
4211                    $top.t insert end $f
4212                    $top.t insert end "\n"
4213                }
4214                $top.t delete {end - 1c} end
4215                $top.t mark set insert 0.0
4216            }
4217            pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4218        }
4219    }
4220
4221    ${NS}::frame $top.buts
4222    ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4223    ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4224    ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4225    bind $top <Control-Return> [list newviewok $top $n]
4226    bind $top <F5> [list newviewok $top $n 1]
4227    bind $top <Escape> [list destroy $top]
4228    grid $top.buts.ok $top.buts.apply $top.buts.can
4229    grid columnconfigure $top.buts 0 -weight 1 -uniform a
4230    grid columnconfigure $top.buts 1 -weight 1 -uniform a
4231    grid columnconfigure $top.buts 2 -weight 1 -uniform a
4232    pack $top.buts -in $top -side top -fill x
4233    focus $top.t
4234}
4235
4236proc doviewmenu {m first cmd op argv} {
4237    set nmenu [$m index end]
4238    for {set i $first} {$i <= $nmenu} {incr i} {
4239        if {[$m entrycget $i -command] eq $cmd} {
4240            eval $m $op $i $argv
4241            break
4242        }
4243    }
4244}
4245
4246proc allviewmenus {n op args} {
4247    # global viewhlmenu
4248
4249    doviewmenu .bar.view 5 [list showview $n] $op $args
4250    # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4251}
4252
4253proc newviewok {top n {apply 0}} {
4254    global nextviewnum newviewperm newviewname newishighlight
4255    global viewname viewfiles viewperm selectedview curview
4256    global viewargs viewargscmd newviewopts viewhlmenu
4257
4258    if {[catch {
4259        set newargs [encode_view_opts $n]
4260    } err]} {
4261        error_popup "[mc "Error in commit selection arguments:"] $err" $top
4262        return
4263    }
4264    set files {}
4265    foreach f [split [$top.t get 0.0 end] "\n"] {
4266        set ft [string trim $f]
4267        if {$ft ne {}} {
4268            lappend files $ft
4269        }
4270    }
4271    if {![info exists viewfiles($n)]} {
4272        # creating a new view
4273        incr nextviewnum
4274        set viewname($n) $newviewname($n)
4275        set viewperm($n) $newviewopts($n,perm)
4276        set viewfiles($n) $files
4277        set viewargs($n) $newargs
4278        set viewargscmd($n) $newviewopts($n,cmd)
4279        addviewmenu $n
4280        if {!$newishighlight} {
4281            run showview $n
4282        } else {
4283            run addvhighlight $n
4284        }
4285    } else {
4286        # editing an existing view
4287        set viewperm($n) $newviewopts($n,perm)
4288        if {$newviewname($n) ne $viewname($n)} {
4289            set viewname($n) $newviewname($n)
4290            doviewmenu .bar.view 5 [list showview $n] \
4291                entryconf [list -label $viewname($n)]
4292            # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4293                # entryconf [list -label $viewname($n) -value $viewname($n)]
4294        }
4295        if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4296                $newviewopts($n,cmd) ne $viewargscmd($n)} {
4297            set viewfiles($n) $files
4298            set viewargs($n) $newargs
4299            set viewargscmd($n) $newviewopts($n,cmd)
4300            if {$curview == $n} {
4301                run reloadcommits
4302            }
4303        }
4304    }
4305    if {$apply} return
4306    catch {destroy $top}
4307}
4308
4309proc delview {} {
4310    global curview viewperm hlview selectedhlview
4311
4312    if {$curview == 0} return
4313    if {[info exists hlview] && $hlview == $curview} {
4314        set selectedhlview [mc "None"]
4315        unset hlview
4316    }
4317    allviewmenus $curview delete
4318    set viewperm($curview) 0
4319    showview 0
4320}
4321
4322proc addviewmenu {n} {
4323    global viewname viewhlmenu
4324
4325    .bar.view add radiobutton -label $viewname($n) \
4326        -command [list showview $n] -variable selectedview -value $n
4327    #$viewhlmenu add radiobutton -label $viewname($n) \
4328    #   -command [list addvhighlight $n] -variable selectedhlview
4329}
4330
4331proc showview {n} {
4332    global curview cached_commitrow ordertok
4333    global displayorder parentlist rowidlist rowisopt rowfinal
4334    global colormap rowtextx nextcolor canvxmax
4335    global numcommits viewcomplete
4336    global selectedline currentid canv canvy0
4337    global treediffs
4338    global pending_select mainheadid
4339    global commitidx
4340    global selectedview
4341    global hlview selectedhlview commitinterest
4342
4343    if {$n == $curview} return
4344    set selid {}
4345    set ymax [lindex [$canv cget -scrollregion] 3]
4346    set span [$canv yview]
4347    set ytop [expr {[lindex $span 0] * $ymax}]
4348    set ybot [expr {[lindex $span 1] * $ymax}]
4349    set yscreen [expr {($ybot - $ytop) / 2}]
4350    if {$selectedline ne {}} {
4351        set selid $currentid
4352        set y [yc $selectedline]
4353        if {$ytop < $y && $y < $ybot} {
4354            set yscreen [expr {$y - $ytop}]
4355        }
4356    } elseif {[info exists pending_select]} {
4357        set selid $pending_select
4358        unset pending_select
4359    }
4360    unselectline
4361    normalline
4362    catch {unset treediffs}
4363    clear_display
4364    if {[info exists hlview] && $hlview == $n} {
4365        unset hlview
4366        set selectedhlview [mc "None"]
4367    }
4368    catch {unset commitinterest}
4369    catch {unset cached_commitrow}
4370    catch {unset ordertok}
4371
4372    set curview $n
4373    set selectedview $n
4374    .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4375    .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4376
4377    run refill_reflist
4378    if {![info exists viewcomplete($n)]} {
4379        getcommits $selid
4380        return
4381    }
4382
4383    set displayorder {}
4384    set parentlist {}
4385    set rowidlist {}
4386    set rowisopt {}
4387    set rowfinal {}
4388    set numcommits $commitidx($n)
4389
4390    catch {unset colormap}
4391    catch {unset rowtextx}
4392    set nextcolor 0
4393    set canvxmax [$canv cget -width]
4394    set curview $n
4395    set row 0
4396    setcanvscroll
4397    set yf 0
4398    set row {}
4399    if {$selid ne {} && [commitinview $selid $n]} {
4400        set row [rowofcommit $selid]
4401        # try to get the selected row in the same position on the screen
4402        set ymax [lindex [$canv cget -scrollregion] 3]
4403        set ytop [expr {[yc $row] - $yscreen}]
4404        if {$ytop < 0} {
4405            set ytop 0
4406        }
4407        set yf [expr {$ytop * 1.0 / $ymax}]
4408    }
4409    allcanvs yview moveto $yf
4410    drawvisible
4411    if {$row ne {}} {
4412        selectline $row 0
4413    } elseif {!$viewcomplete($n)} {
4414        reset_pending_select $selid
4415    } else {
4416        reset_pending_select {}
4417
4418        if {[commitinview $pending_select $curview]} {
4419            selectline [rowofcommit $pending_select] 1
4420        } else {
4421            set row [first_real_row]
4422            if {$row < $numcommits} {
4423                selectline $row 0
4424            }
4425        }
4426    }
4427    if {!$viewcomplete($n)} {
4428        if {$numcommits == 0} {
4429            show_status [mc "Reading commits..."]
4430        }
4431    } elseif {$numcommits == 0} {
4432        show_status [mc "No commits selected"]
4433    }
4434}
4435
4436# Stuff relating to the highlighting facility
4437
4438proc ishighlighted {id} {
4439    global vhighlights fhighlights nhighlights rhighlights
4440
4441    if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4442        return $nhighlights($id)
4443    }
4444    if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4445        return $vhighlights($id)
4446    }
4447    if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4448        return $fhighlights($id)
4449    }
4450    if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4451        return $rhighlights($id)
4452    }
4453    return 0
4454}
4455
4456proc bolden {id font} {
4457    global canv linehtag currentid boldids need_redisplay markedid
4458
4459    # need_redisplay = 1 means the display is stale and about to be redrawn
4460    if {$need_redisplay} return
4461    lappend boldids $id
4462    $canv itemconf $linehtag($id) -font $font
4463    if {[info exists currentid] && $id eq $currentid} {
4464        $canv delete secsel
4465        set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4466                   -outline {{}} -tags secsel \
4467                   -fill [$canv cget -selectbackground]]
4468        $canv lower $t
4469    }
4470    if {[info exists markedid] && $id eq $markedid} {
4471        make_idmark $id
4472    }
4473}
4474
4475proc bolden_name {id font} {
4476    global canv2 linentag currentid boldnameids need_redisplay
4477
4478    if {$need_redisplay} return
4479    lappend boldnameids $id
4480    $canv2 itemconf $linentag($id) -font $font
4481    if {[info exists currentid] && $id eq $currentid} {
4482        $canv2 delete secsel
4483        set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4484                   -outline {{}} -tags secsel \
4485                   -fill [$canv2 cget -selectbackground]]
4486        $canv2 lower $t
4487    }
4488}
4489
4490proc unbolden {} {
4491    global boldids
4492
4493    set stillbold {}
4494    foreach id $boldids {
4495        if {![ishighlighted $id]} {
4496            bolden $id mainfont
4497        } else {
4498            lappend stillbold $id
4499        }
4500    }
4501    set boldids $stillbold
4502}
4503
4504proc addvhighlight {n} {
4505    global hlview viewcomplete curview vhl_done commitidx
4506
4507    if {[info exists hlview]} {
4508        delvhighlight
4509    }
4510    set hlview $n
4511    if {$n != $curview && ![info exists viewcomplete($n)]} {
4512        start_rev_list $n
4513    }
4514    set vhl_done $commitidx($hlview)
4515    if {$vhl_done > 0} {
4516        drawvisible
4517    }
4518}
4519
4520proc delvhighlight {} {
4521    global hlview vhighlights
4522
4523    if {![info exists hlview]} return
4524    unset hlview
4525    catch {unset vhighlights}
4526    unbolden
4527}
4528
4529proc vhighlightmore {} {
4530    global hlview vhl_done commitidx vhighlights curview
4531
4532    set max $commitidx($hlview)
4533    set vr [visiblerows]
4534    set r0 [lindex $vr 0]
4535    set r1 [lindex $vr 1]
4536    for {set i $vhl_done} {$i < $max} {incr i} {
4537        set id [commitonrow $i $hlview]
4538        if {[commitinview $id $curview]} {
4539            set row [rowofcommit $id]
4540            if {$r0 <= $row && $row <= $r1} {
4541                if {![highlighted $row]} {
4542                    bolden $id mainfontbold
4543                }
4544                set vhighlights($id) 1
4545            }
4546        }
4547    }
4548    set vhl_done $max
4549    return 0
4550}
4551
4552proc askvhighlight {row id} {
4553    global hlview vhighlights iddrawn
4554
4555    if {[commitinview $id $hlview]} {
4556        if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4557            bolden $id mainfontbold
4558        }
4559        set vhighlights($id) 1
4560    } else {
4561        set vhighlights($id) 0
4562    }
4563}
4564
4565proc hfiles_change {} {
4566    global highlight_files filehighlight fhighlights fh_serial
4567    global highlight_paths
4568
4569    if {[info exists filehighlight]} {
4570        # delete previous highlights
4571        catch {close $filehighlight}
4572        unset filehighlight
4573        catch {unset fhighlights}
4574        unbolden
4575        unhighlight_filelist
4576    }
4577    set highlight_paths {}
4578    after cancel do_file_hl $fh_serial
4579    incr fh_serial
4580    if {$highlight_files ne {}} {
4581        after 300 do_file_hl $fh_serial
4582    }
4583}
4584
4585proc gdttype_change {name ix op} {
4586    global gdttype highlight_files findstring findpattern
4587
4588    stopfinding
4589    if {$findstring ne {}} {
4590        if {$gdttype eq [mc "containing:"]} {
4591            if {$highlight_files ne {}} {
4592                set highlight_files {}
4593                hfiles_change
4594            }
4595            findcom_change
4596        } else {
4597            if {$findpattern ne {}} {
4598                set findpattern {}
4599                findcom_change
4600            }
4601            set highlight_files $findstring
4602            hfiles_change
4603        }
4604        drawvisible
4605    }
4606    # enable/disable findtype/findloc menus too
4607}
4608
4609proc find_change {name ix op} {
4610    global gdttype findstring highlight_files
4611
4612    stopfinding
4613    if {$gdttype eq [mc "containing:"]} {
4614        findcom_change
4615    } else {
4616        if {$highlight_files ne $findstring} {
4617            set highlight_files $findstring
4618            hfiles_change
4619        }
4620    }
4621    drawvisible
4622}
4623
4624proc findcom_change args {
4625    global nhighlights boldnameids
4626    global findpattern findtype findstring gdttype
4627
4628    stopfinding
4629    # delete previous highlights, if any
4630    foreach id $boldnameids {
4631        bolden_name $id mainfont
4632    }
4633    set boldnameids {}
4634    catch {unset nhighlights}
4635    unbolden
4636    unmarkmatches
4637    if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4638        set findpattern {}
4639    } elseif {$findtype eq [mc "Regexp"]} {
4640        set findpattern $findstring
4641    } else {
4642        set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4643                   $findstring]
4644        set findpattern "*$e*"
4645    }
4646}
4647
4648proc makepatterns {l} {
4649    set ret {}
4650    foreach e $l {
4651        set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4652        if {[string index $ee end] eq "/"} {
4653            lappend ret "$ee*"
4654        } else {
4655            lappend ret $ee
4656            lappend ret "$ee/*"
4657        }
4658    }
4659    return $ret
4660}
4661
4662proc do_file_hl {serial} {
4663    global highlight_files filehighlight highlight_paths gdttype fhl_list
4664    global cdup findtype
4665
4666    if {$gdttype eq [mc "touching paths:"]} {
4667        # If "exact" match then convert backslashes to forward slashes.
4668        # Most useful to support Windows-flavoured file paths.
4669        if {$findtype eq [mc "Exact"]} {
4670            set highlight_files [string map {"\\" "/"} $highlight_files]
4671        }
4672        if {[catch {set paths [shellsplit $highlight_files]}]} return
4673        set highlight_paths [makepatterns $paths]
4674        highlight_filelist
4675        set relative_paths {}
4676        foreach path $paths {
4677            lappend relative_paths [file join $cdup $path]
4678        }
4679        set gdtargs [concat -- $relative_paths]
4680    } elseif {$gdttype eq [mc "adding/removing string:"]} {
4681        set gdtargs [list "-S$highlight_files"]
4682    } elseif {$gdttype eq [mc "changing lines matching:"]} {
4683        set gdtargs [list "-G$highlight_files"]
4684    } else {
4685        # must be "containing:", i.e. we're searching commit info
4686        return
4687    }
4688    set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4689    set filehighlight [open $cmd r+]
4690    fconfigure $filehighlight -blocking 0
4691    filerun $filehighlight readfhighlight
4692    set fhl_list {}
4693    drawvisible
4694    flushhighlights
4695}
4696
4697proc flushhighlights {} {
4698    global filehighlight fhl_list
4699
4700    if {[info exists filehighlight]} {
4701        lappend fhl_list {}
4702        puts $filehighlight ""
4703        flush $filehighlight
4704    }
4705}
4706
4707proc askfilehighlight {row id} {
4708    global filehighlight fhighlights fhl_list
4709
4710    lappend fhl_list $id
4711    set fhighlights($id) -1
4712    puts $filehighlight $id
4713}
4714
4715proc readfhighlight {} {
4716    global filehighlight fhighlights curview iddrawn
4717    global fhl_list find_dirn
4718
4719    if {![info exists filehighlight]} {
4720        return 0
4721    }
4722    set nr 0
4723    while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4724        set line [string trim $line]
4725        set i [lsearch -exact $fhl_list $line]
4726        if {$i < 0} continue
4727        for {set j 0} {$j < $i} {incr j} {
4728            set id [lindex $fhl_list $j]
4729            set fhighlights($id) 0
4730        }
4731        set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4732        if {$line eq {}} continue
4733        if {![commitinview $line $curview]} continue
4734        if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4735            bolden $line mainfontbold
4736        }
4737        set fhighlights($line) 1
4738    }
4739    if {[eof $filehighlight]} {
4740        # strange...
4741        puts "oops, git diff-tree died"
4742        catch {close $filehighlight}
4743        unset filehighlight
4744        return 0
4745    }
4746    if {[info exists find_dirn]} {
4747        run findmore
4748    }
4749    return 1
4750}
4751
4752proc doesmatch {f} {
4753    global findtype findpattern
4754
4755    if {$findtype eq [mc "Regexp"]} {
4756        return [regexp $findpattern $f]
4757    } elseif {$findtype eq [mc "IgnCase"]} {
4758        return [string match -nocase $findpattern $f]
4759    } else {
4760        return [string match $findpattern $f]
4761    }
4762}
4763
4764proc askfindhighlight {row id} {
4765    global nhighlights commitinfo iddrawn
4766    global findloc
4767    global markingmatches
4768
4769    if {![info exists commitinfo($id)]} {
4770        getcommit $id
4771    }
4772    set info $commitinfo($id)
4773    set isbold 0
4774    set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4775    foreach f $info ty $fldtypes {
4776        if {$ty eq ""} continue
4777        if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4778            [doesmatch $f]} {
4779            if {$ty eq [mc "Author"]} {
4780                set isbold 2
4781                break
4782            }
4783            set isbold 1
4784        }
4785    }
4786    if {$isbold && [info exists iddrawn($id)]} {
4787        if {![ishighlighted $id]} {
4788            bolden $id mainfontbold
4789            if {$isbold > 1} {
4790                bolden_name $id mainfontbold
4791            }
4792        }
4793        if {$markingmatches} {
4794            markrowmatches $row $id
4795        }
4796    }
4797    set nhighlights($id) $isbold
4798}
4799
4800proc markrowmatches {row id} {
4801    global canv canv2 linehtag linentag commitinfo findloc
4802
4803    set headline [lindex $commitinfo($id) 0]
4804    set author [lindex $commitinfo($id) 1]
4805    $canv delete match$row
4806    $canv2 delete match$row
4807    if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4808        set m [findmatches $headline]
4809        if {$m ne {}} {
4810            markmatches $canv $row $headline $linehtag($id) $m \
4811                [$canv itemcget $linehtag($id) -font] $row
4812        }
4813    }
4814    if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4815        set m [findmatches $author]
4816        if {$m ne {}} {
4817            markmatches $canv2 $row $author $linentag($id) $m \
4818                [$canv2 itemcget $linentag($id) -font] $row
4819        }
4820    }
4821}
4822
4823proc vrel_change {name ix op} {
4824    global highlight_related
4825
4826    rhighlight_none
4827    if {$highlight_related ne [mc "None"]} {
4828        run drawvisible
4829    }
4830}
4831
4832# prepare for testing whether commits are descendents or ancestors of a
4833proc rhighlight_sel {a} {
4834    global descendent desc_todo ancestor anc_todo
4835    global highlight_related
4836
4837    catch {unset descendent}
4838    set desc_todo [list $a]
4839    catch {unset ancestor}
4840    set anc_todo [list $a]
4841    if {$highlight_related ne [mc "None"]} {
4842        rhighlight_none
4843        run drawvisible
4844    }
4845}
4846
4847proc rhighlight_none {} {
4848    global rhighlights
4849
4850    catch {unset rhighlights}
4851    unbolden
4852}
4853
4854proc is_descendent {a} {
4855    global curview children descendent desc_todo
4856
4857    set v $curview
4858    set la [rowofcommit $a]
4859    set todo $desc_todo
4860    set leftover {}
4861    set done 0
4862    for {set i 0} {$i < [llength $todo]} {incr i} {
4863        set do [lindex $todo $i]
4864        if {[rowofcommit $do] < $la} {
4865            lappend leftover $do
4866            continue
4867        }
4868        foreach nk $children($v,$do) {
4869            if {![info exists descendent($nk)]} {
4870                set descendent($nk) 1
4871                lappend todo $nk
4872                if {$nk eq $a} {
4873                    set done 1
4874                }
4875            }
4876        }
4877        if {$done} {
4878            set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4879            return
4880        }
4881    }
4882    set descendent($a) 0
4883    set desc_todo $leftover
4884}
4885
4886proc is_ancestor {a} {
4887    global curview parents ancestor anc_todo
4888
4889    set v $curview
4890    set la [rowofcommit $a]
4891    set todo $anc_todo
4892    set leftover {}
4893    set done 0
4894    for {set i 0} {$i < [llength $todo]} {incr i} {
4895        set do [lindex $todo $i]
4896        if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4897            lappend leftover $do
4898            continue
4899        }
4900        foreach np $parents($v,$do) {
4901            if {![info exists ancestor($np)]} {
4902                set ancestor($np) 1
4903                lappend todo $np
4904                if {$np eq $a} {
4905                    set done 1
4906                }
4907            }
4908        }
4909        if {$done} {
4910            set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4911            return
4912        }
4913    }
4914    set ancestor($a) 0
4915    set anc_todo $leftover
4916}
4917
4918proc askrelhighlight {row id} {
4919    global descendent highlight_related iddrawn rhighlights
4920    global selectedline ancestor
4921
4922    if {$selectedline eq {}} return
4923    set isbold 0
4924    if {$highlight_related eq [mc "Descendant"] ||
4925        $highlight_related eq [mc "Not descendant"]} {
4926        if {![info exists descendent($id)]} {
4927            is_descendent $id
4928        }
4929        if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4930            set isbold 1
4931        }
4932    } elseif {$highlight_related eq [mc "Ancestor"] ||
4933              $highlight_related eq [mc "Not ancestor"]} {
4934        if {![info exists ancestor($id)]} {
4935            is_ancestor $id
4936        }
4937        if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4938            set isbold 1
4939        }
4940    }
4941    if {[info exists iddrawn($id)]} {
4942        if {$isbold && ![ishighlighted $id]} {
4943            bolden $id mainfontbold
4944        }
4945    }
4946    set rhighlights($id) $isbold
4947}
4948
4949# Graph layout functions
4950
4951proc shortids {ids} {
4952    set res {}
4953    foreach id $ids {
4954        if {[llength $id] > 1} {
4955            lappend res [shortids $id]
4956        } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
4957            lappend res [string range $id 0 7]
4958        } else {
4959            lappend res $id
4960        }
4961    }
4962    return $res
4963}
4964
4965proc ntimes {n o} {
4966    set ret {}
4967    set o [list $o]
4968    for {set mask 1} {$mask <= $n} {incr mask $mask} {
4969        if {($n & $mask) != 0} {
4970            set ret [concat $ret $o]
4971        }
4972        set o [concat $o $o]
4973    }
4974    return $ret
4975}
4976
4977proc ordertoken {id} {
4978    global ordertok curview varcid varcstart varctok curview parents children
4979    global nullid nullid2
4980
4981    if {[info exists ordertok($id)]} {
4982        return $ordertok($id)
4983    }
4984    set origid $id
4985    set todo {}
4986    while {1} {
4987        if {[info exists varcid($curview,$id)]} {
4988            set a $varcid($curview,$id)
4989            set p [lindex $varcstart($curview) $a]
4990        } else {
4991            set p [lindex $children($curview,$id) 0]
4992        }
4993        if {[info exists ordertok($p)]} {
4994            set tok $ordertok($p)
4995            break
4996        }
4997        set id [first_real_child $curview,$p]
4998        if {$id eq {}} {
4999            # it's a root
5000            set tok [lindex $varctok($curview) $varcid($curview,$p)]
5001            break
5002        }
5003        if {[llength $parents($curview,$id)] == 1} {
5004            lappend todo [list $p {}]
5005        } else {
5006            set j [lsearch -exact $parents($curview,$id) $p]
5007            if {$j < 0} {
5008                puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5009            }
5010            lappend todo [list $p [strrep $j]]
5011        }
5012    }
5013    for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5014        set p [lindex $todo $i 0]
5015        append tok [lindex $todo $i 1]
5016        set ordertok($p) $tok
5017    }
5018    set ordertok($origid) $tok
5019    return $tok
5020}
5021
5022# Work out where id should go in idlist so that order-token
5023# values increase from left to right
5024proc idcol {idlist id {i 0}} {
5025    set t [ordertoken $id]
5026    if {$i < 0} {
5027        set i 0
5028    }
5029    if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5030        if {$i > [llength $idlist]} {
5031            set i [llength $idlist]
5032        }
5033        while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5034        incr i
5035    } else {
5036        if {$t > [ordertoken [lindex $idlist $i]]} {
5037            while {[incr i] < [llength $idlist] &&
5038                   $t >= [ordertoken [lindex $idlist $i]]} {}
5039        }
5040    }
5041    return $i
5042}
5043
5044proc initlayout {} {
5045    global rowidlist rowisopt rowfinal displayorder parentlist
5046    global numcommits canvxmax canv
5047    global nextcolor
5048    global colormap rowtextx
5049
5050    set numcommits 0
5051    set displayorder {}
5052    set parentlist {}
5053    set nextcolor 0
5054    set rowidlist {}
5055    set rowisopt {}
5056    set rowfinal {}
5057    set canvxmax [$canv cget -width]
5058    catch {unset colormap}
5059    catch {unset rowtextx}
5060    setcanvscroll
5061}
5062
5063proc setcanvscroll {} {
5064    global canv canv2 canv3 numcommits linespc canvxmax canvy0
5065    global lastscrollset lastscrollrows
5066
5067    set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5068    $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5069    $canv2 conf -scrollregion [list 0 0 0 $ymax]
5070    $canv3 conf -scrollregion [list 0 0 0 $ymax]
5071    set lastscrollset [clock clicks -milliseconds]
5072    set lastscrollrows $numcommits
5073}
5074
5075proc visiblerows {} {
5076    global canv numcommits linespc
5077
5078    set ymax [lindex [$canv cget -scrollregion] 3]
5079    if {$ymax eq {} || $ymax == 0} return
5080    set f [$canv yview]
5081    set y0 [expr {int([lindex $f 0] * $ymax)}]
5082    set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5083    if {$r0 < 0} {
5084        set r0 0
5085    }
5086    set y1 [expr {int([lindex $f 1] * $ymax)}]
5087    set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5088    if {$r1 >= $numcommits} {
5089        set r1 [expr {$numcommits - 1}]
5090    }
5091    return [list $r0 $r1]
5092}
5093
5094proc layoutmore {} {
5095    global commitidx viewcomplete curview
5096    global numcommits pending_select curview
5097    global lastscrollset lastscrollrows
5098
5099    if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5100        [clock clicks -milliseconds] - $lastscrollset > 500} {
5101        setcanvscroll
5102    }
5103    if {[info exists pending_select] &&
5104        [commitinview $pending_select $curview]} {
5105        update
5106        selectline [rowofcommit $pending_select] 1
5107    }
5108    drawvisible
5109}
5110
5111# With path limiting, we mightn't get the actual HEAD commit,
5112# so ask git rev-list what is the first ancestor of HEAD that
5113# touches a file in the path limit.
5114proc get_viewmainhead {view} {
5115    global viewmainheadid vfilelimit viewinstances mainheadid
5116
5117    catch {
5118        set rfd [open [concat | git rev-list -1 $mainheadid \
5119                           -- $vfilelimit($view)] r]
5120        set j [reg_instance $rfd]
5121        lappend viewinstances($view) $j
5122        fconfigure $rfd -blocking 0
5123        filerun $rfd [list getviewhead $rfd $j $view]
5124        set viewmainheadid($curview) {}
5125    }
5126}
5127
5128# git rev-list should give us just 1 line to use as viewmainheadid($view)
5129proc getviewhead {fd inst view} {
5130    global viewmainheadid commfd curview viewinstances showlocalchanges
5131
5132    set id {}
5133    if {[gets $fd line] < 0} {
5134        if {![eof $fd]} {
5135            return 1
5136        }
5137    } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5138        set id $line
5139    }
5140    set viewmainheadid($view) $id
5141    close $fd
5142    unset commfd($inst)
5143    set i [lsearch -exact $viewinstances($view) $inst]
5144    if {$i >= 0} {
5145        set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5146    }
5147    if {$showlocalchanges && $id ne {} && $view == $curview} {
5148        doshowlocalchanges
5149    }
5150    return 0
5151}
5152
5153proc doshowlocalchanges {} {
5154    global curview viewmainheadid
5155
5156    if {$viewmainheadid($curview) eq {}} return
5157    if {[commitinview $viewmainheadid($curview) $curview]} {
5158        dodiffindex
5159    } else {
5160        interestedin $viewmainheadid($curview) dodiffindex
5161    }
5162}
5163
5164proc dohidelocalchanges {} {
5165    global nullid nullid2 lserial curview
5166
5167    if {[commitinview $nullid $curview]} {
5168        removefakerow $nullid
5169    }
5170    if {[commitinview $nullid2 $curview]} {
5171        removefakerow $nullid2
5172    }
5173    incr lserial
5174}
5175
5176# spawn off a process to do git diff-index --cached HEAD
5177proc dodiffindex {} {
5178    global lserial showlocalchanges vfilelimit curview
5179    global hasworktree
5180
5181    if {!$showlocalchanges || !$hasworktree} return
5182    incr lserial
5183    set cmd "|git diff-index --cached HEAD"
5184    if {$vfilelimit($curview) ne {}} {
5185        set cmd [concat $cmd -- $vfilelimit($curview)]
5186    }
5187    set fd [open $cmd r]
5188    fconfigure $fd -blocking 0
5189    set i [reg_instance $fd]
5190    filerun $fd [list readdiffindex $fd $lserial $i]
5191}
5192
5193proc readdiffindex {fd serial inst} {
5194    global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5195    global vfilelimit
5196
5197    set isdiff 1
5198    if {[gets $fd line] < 0} {
5199        if {![eof $fd]} {
5200            return 1
5201        }
5202        set isdiff 0
5203    }
5204    # we only need to see one line and we don't really care what it says...
5205    stop_instance $inst
5206
5207    if {$serial != $lserial} {
5208        return 0
5209    }
5210
5211    # now see if there are any local changes not checked in to the index
5212    set cmd "|git diff-files"
5213    if {$vfilelimit($curview) ne {}} {
5214        set cmd [concat $cmd -- $vfilelimit($curview)]
5215    }
5216    set fd [open $cmd r]
5217    fconfigure $fd -blocking 0
5218    set i [reg_instance $fd]
5219    filerun $fd [list readdifffiles $fd $serial $i]
5220
5221    if {$isdiff && ![commitinview $nullid2 $curview]} {
5222        # add the line for the changes in the index to the graph
5223        set hl [mc "Local changes checked in to index but not committed"]
5224        set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
5225        set commitdata($nullid2) "\n    $hl\n"
5226        if {[commitinview $nullid $curview]} {
5227            removefakerow $nullid
5228        }
5229        insertfakerow $nullid2 $viewmainheadid($curview)
5230    } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5231        if {[commitinview $nullid $curview]} {
5232            removefakerow $nullid
5233        }
5234        removefakerow $nullid2
5235    }
5236    return 0
5237}
5238
5239proc readdifffiles {fd serial inst} {
5240    global viewmainheadid nullid nullid2 curview
5241    global commitinfo commitdata lserial
5242
5243    set isdiff 1
5244    if {[gets $fd line] < 0} {
5245        if {![eof $fd]} {
5246            return 1
5247        }
5248        set isdiff 0
5249    }
5250    # we only need to see one line and we don't really care what it says...
5251    stop_instance $inst
5252
5253    if {$serial != $lserial} {
5254        return 0
5255    }
5256
5257    if {$isdiff && ![commitinview $nullid $curview]} {
5258        # add the line for the local diff to the graph
5259        set hl [mc "Local uncommitted changes, not checked in to index"]
5260        set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
5261        set commitdata($nullid) "\n    $hl\n"
5262        if {[commitinview $nullid2 $curview]} {
5263            set p $nullid2
5264        } else {
5265            set p $viewmainheadid($curview)
5266        }
5267        insertfakerow $nullid $p
5268    } elseif {!$isdiff && [commitinview $nullid $curview]} {
5269        removefakerow $nullid
5270    }
5271    return 0
5272}
5273
5274proc nextuse {id row} {
5275    global curview children
5276
5277    if {[info exists children($curview,$id)]} {
5278        foreach kid $children($curview,$id) {
5279            if {![commitinview $kid $curview]} {
5280                return -1
5281            }
5282            if {[rowofcommit $kid] > $row} {
5283                return [rowofcommit $kid]
5284            }
5285        }
5286    }
5287    if {[commitinview $id $curview]} {
5288        return [rowofcommit $id]
5289    }
5290    return -1
5291}
5292
5293proc prevuse {id row} {
5294    global curview children
5295
5296    set ret -1
5297    if {[info exists children($curview,$id)]} {
5298        foreach kid $children($curview,$id) {
5299            if {![commitinview $kid $curview]} break
5300            if {[rowofcommit $kid] < $row} {
5301                set ret [rowofcommit $kid]
5302            }
5303        }
5304    }
5305    return $ret
5306}
5307
5308proc make_idlist {row} {
5309    global displayorder parentlist uparrowlen downarrowlen mingaplen
5310    global commitidx curview children
5311
5312    set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5313    if {$r < 0} {
5314        set r 0
5315    }
5316    set ra [expr {$row - $downarrowlen}]
5317    if {$ra < 0} {
5318        set ra 0
5319    }
5320    set rb [expr {$row + $uparrowlen}]
5321    if {$rb > $commitidx($curview)} {
5322        set rb $commitidx($curview)
5323    }
5324    make_disporder $r [expr {$rb + 1}]
5325    set ids {}
5326    for {} {$r < $ra} {incr r} {
5327        set nextid [lindex $displayorder [expr {$r + 1}]]
5328        foreach p [lindex $parentlist $r] {
5329            if {$p eq $nextid} continue
5330            set rn [nextuse $p $r]
5331            if {$rn >= $row &&
5332                $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5333                lappend ids [list [ordertoken $p] $p]
5334            }
5335        }
5336    }
5337    for {} {$r < $row} {incr r} {
5338        set nextid [lindex $displayorder [expr {$r + 1}]]
5339        foreach p [lindex $parentlist $r] {
5340            if {$p eq $nextid} continue
5341            set rn [nextuse $p $r]
5342            if {$rn < 0 || $rn >= $row} {
5343                lappend ids [list [ordertoken $p] $p]
5344            }
5345        }
5346    }
5347    set id [lindex $displayorder $row]
5348    lappend ids [list [ordertoken $id] $id]
5349    while {$r < $rb} {
5350        foreach p [lindex $parentlist $r] {
5351            set firstkid [lindex $children($curview,$p) 0]
5352            if {[rowofcommit $firstkid] < $row} {
5353                lappend ids [list [ordertoken $p] $p]
5354            }
5355        }
5356        incr r
5357        set id [lindex $displayorder $r]
5358        if {$id ne {}} {
5359            set firstkid [lindex $children($curview,$id) 0]
5360            if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5361                lappend ids [list [ordertoken $id] $id]
5362            }
5363        }
5364    }
5365    set idlist {}
5366    foreach idx [lsort -unique $ids] {
5367        lappend idlist [lindex $idx 1]
5368    }
5369    return $idlist
5370}
5371
5372proc rowsequal {a b} {
5373    while {[set i [lsearch -exact $a {}]] >= 0} {
5374        set a [lreplace $a $i $i]
5375    }
5376    while {[set i [lsearch -exact $b {}]] >= 0} {
5377        set b [lreplace $b $i $i]
5378    }
5379    return [expr {$a eq $b}]
5380}
5381
5382proc makeupline {id row rend col} {
5383    global rowidlist uparrowlen downarrowlen mingaplen
5384
5385    for {set r $rend} {1} {set r $rstart} {
5386        set rstart [prevuse $id $r]
5387        if {$rstart < 0} return
5388        if {$rstart < $row} break
5389    }
5390    if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5391        set rstart [expr {$rend - $uparrowlen - 1}]
5392    }
5393    for {set r $rstart} {[incr r] <= $row} {} {
5394        set idlist [lindex $rowidlist $r]
5395        if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5396            set col [idcol $idlist $id $col]
5397            lset rowidlist $r [linsert $idlist $col $id]
5398            changedrow $r
5399        }
5400    }
5401}
5402
5403proc layoutrows {row endrow} {
5404    global rowidlist rowisopt rowfinal displayorder
5405    global uparrowlen downarrowlen maxwidth mingaplen
5406    global children parentlist
5407    global commitidx viewcomplete curview
5408
5409    make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5410    set idlist {}
5411    if {$row > 0} {
5412        set rm1 [expr {$row - 1}]
5413        foreach id [lindex $rowidlist $rm1] {
5414            if {$id ne {}} {
5415                lappend idlist $id
5416            }
5417        }
5418        set final [lindex $rowfinal $rm1]
5419    }
5420    for {} {$row < $endrow} {incr row} {
5421        set rm1 [expr {$row - 1}]
5422        if {$rm1 < 0 || $idlist eq {}} {
5423            set idlist [make_idlist $row]
5424            set final 1
5425        } else {
5426            set id [lindex $displayorder $rm1]
5427            set col [lsearch -exact $idlist $id]
5428            set idlist [lreplace $idlist $col $col]
5429            foreach p [lindex $parentlist $rm1] {
5430                if {[lsearch -exact $idlist $p] < 0} {
5431                    set col [idcol $idlist $p $col]
5432                    set idlist [linsert $idlist $col $p]
5433                    # if not the first child, we have to insert a line going up
5434                    if {$id ne [lindex $children($curview,$p) 0]} {
5435                        makeupline $p $rm1 $row $col
5436                    }
5437                }
5438            }
5439            set id [lindex $displayorder $row]
5440            if {$row > $downarrowlen} {
5441                set termrow [expr {$row - $downarrowlen - 1}]
5442                foreach p [lindex $parentlist $termrow] {
5443                    set i [lsearch -exact $idlist $p]
5444                    if {$i < 0} continue
5445                    set nr [nextuse $p $termrow]
5446                    if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5447                        set idlist [lreplace $idlist $i $i]
5448                    }
5449                }
5450            }
5451            set col [lsearch -exact $idlist $id]
5452            if {$col < 0} {
5453                set col [idcol $idlist $id]
5454                set idlist [linsert $idlist $col $id]
5455                if {$children($curview,$id) ne {}} {
5456                    makeupline $id $rm1 $row $col
5457                }
5458            }
5459            set r [expr {$row + $uparrowlen - 1}]
5460            if {$r < $commitidx($curview)} {
5461                set x $col
5462                foreach p [lindex $parentlist $r] {
5463                    if {[lsearch -exact $idlist $p] >= 0} continue
5464                    set fk [lindex $children($curview,$p) 0]
5465                    if {[rowofcommit $fk] < $row} {
5466                        set x [idcol $idlist $p $x]
5467                        set idlist [linsert $idlist $x $p]
5468                    }
5469                }
5470                if {[incr r] < $commitidx($curview)} {
5471                    set p [lindex $displayorder $r]
5472                    if {[lsearch -exact $idlist $p] < 0} {
5473                        set fk [lindex $children($curview,$p) 0]
5474                        if {$fk ne {} && [rowofcommit $fk] < $row} {
5475                            set x [idcol $idlist $p $x]
5476                            set idlist [linsert $idlist $x $p]
5477                        }
5478                    }
5479                }
5480            }
5481        }
5482        if {$final && !$viewcomplete($curview) &&
5483            $row + $uparrowlen + $mingaplen + $downarrowlen
5484                >= $commitidx($curview)} {
5485            set final 0
5486        }
5487        set l [llength $rowidlist]
5488        if {$row == $l} {
5489            lappend rowidlist $idlist
5490            lappend rowisopt 0
5491            lappend rowfinal $final
5492        } elseif {$row < $l} {
5493            if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5494                lset rowidlist $row $idlist
5495                changedrow $row
5496            }
5497            lset rowfinal $row $final
5498        } else {
5499            set pad [ntimes [expr {$row - $l}] {}]
5500            set rowidlist [concat $rowidlist $pad]
5501            lappend rowidlist $idlist
5502            set rowfinal [concat $rowfinal $pad]
5503            lappend rowfinal $final
5504            set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5505        }
5506    }
5507    return $row
5508}
5509
5510proc changedrow {row} {
5511    global displayorder iddrawn rowisopt need_redisplay
5512
5513    set l [llength $rowisopt]
5514    if {$row < $l} {
5515        lset rowisopt $row 0
5516        if {$row + 1 < $l} {
5517            lset rowisopt [expr {$row + 1}] 0
5518            if {$row + 2 < $l} {
5519                lset rowisopt [expr {$row + 2}] 0
5520            }
5521        }
5522    }
5523    set id [lindex $displayorder $row]
5524    if {[info exists iddrawn($id)]} {
5525        set need_redisplay 1
5526    }
5527}
5528
5529proc insert_pad {row col npad} {
5530    global rowidlist
5531
5532    set pad [ntimes $npad {}]
5533    set idlist [lindex $rowidlist $row]
5534    set bef [lrange $idlist 0 [expr {$col - 1}]]
5535    set aft [lrange $idlist $col end]
5536    set i [lsearch -exact $aft {}]
5537    if {$i > 0} {
5538        set aft [lreplace $aft $i $i]
5539    }
5540    lset rowidlist $row [concat $bef $pad $aft]
5541    changedrow $row
5542}
5543
5544proc optimize_rows {row col endrow} {
5545    global rowidlist rowisopt displayorder curview children
5546
5547    if {$row < 1} {
5548        set row 1
5549    }
5550    for {} {$row < $endrow} {incr row; set col 0} {
5551        if {[lindex $rowisopt $row]} continue
5552        set haspad 0
5553        set y0 [expr {$row - 1}]
5554        set ym [expr {$row - 2}]
5555        set idlist [lindex $rowidlist $row]
5556        set previdlist [lindex $rowidlist $y0]
5557        if {$idlist eq {} || $previdlist eq {}} continue
5558        if {$ym >= 0} {
5559            set pprevidlist [lindex $rowidlist $ym]
5560            if {$pprevidlist eq {}} continue
5561        } else {
5562            set pprevidlist {}
5563        }
5564        set x0 -1
5565        set xm -1
5566        for {} {$col < [llength $idlist]} {incr col} {
5567            set id [lindex $idlist $col]
5568            if {[lindex $previdlist $col] eq $id} continue
5569            if {$id eq {}} {
5570                set haspad 1
5571                continue
5572            }
5573            set x0 [lsearch -exact $previdlist $id]
5574            if {$x0 < 0} continue
5575            set z [expr {$x0 - $col}]
5576            set isarrow 0
5577            set z0 {}
5578            if {$ym >= 0} {
5579                set xm [lsearch -exact $pprevidlist $id]
5580                if {$xm >= 0} {
5581                    set z0 [expr {$xm - $x0}]
5582                }
5583            }
5584            if {$z0 eq {}} {
5585                # if row y0 is the first child of $id then it's not an arrow
5586                if {[lindex $children($curview,$id) 0] ne
5587                    [lindex $displayorder $y0]} {
5588                    set isarrow 1
5589                }
5590            }
5591            if {!$isarrow && $id ne [lindex $displayorder $row] &&
5592                [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5593                set isarrow 1
5594            }
5595            # Looking at lines from this row to the previous row,
5596            # make them go straight up if they end in an arrow on
5597            # the previous row; otherwise make them go straight up
5598            # or at 45 degrees.
5599            if {$z < -1 || ($z < 0 && $isarrow)} {
5600                # Line currently goes left too much;
5601                # insert pads in the previous row, then optimize it
5602                set npad [expr {-1 - $z + $isarrow}]
5603                insert_pad $y0 $x0 $npad
5604                if {$y0 > 0} {
5605                    optimize_rows $y0 $x0 $row
5606                }
5607                set previdlist [lindex $rowidlist $y0]
5608                set x0 [lsearch -exact $previdlist $id]
5609                set z [expr {$x0 - $col}]
5610                if {$z0 ne {}} {
5611                    set pprevidlist [lindex $rowidlist $ym]
5612                    set xm [lsearch -exact $pprevidlist $id]
5613                    set z0 [expr {$xm - $x0}]
5614                }
5615            } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5616                # Line currently goes right too much;
5617                # insert pads in this line
5618                set npad [expr {$z - 1 + $isarrow}]
5619                insert_pad $row $col $npad
5620                set idlist [lindex $rowidlist $row]
5621                incr col $npad
5622                set z [expr {$x0 - $col}]
5623                set haspad 1
5624            }
5625            if {$z0 eq {} && !$isarrow && $ym >= 0} {
5626                # this line links to its first child on row $row-2
5627                set id [lindex $displayorder $ym]
5628                set xc [lsearch -exact $pprevidlist $id]
5629                if {$xc >= 0} {
5630                    set z0 [expr {$xc - $x0}]
5631                }
5632            }
5633            # avoid lines jigging left then immediately right
5634            if {$z0 ne {} && $z < 0 && $z0 > 0} {
5635                insert_pad $y0 $x0 1
5636                incr x0
5637                optimize_rows $y0 $x0 $row
5638                set previdlist [lindex $rowidlist $y0]
5639            }
5640        }
5641        if {!$haspad} {
5642            # Find the first column that doesn't have a line going right
5643            for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5644                set id [lindex $idlist $col]
5645                if {$id eq {}} break
5646                set x0 [lsearch -exact $previdlist $id]
5647                if {$x0 < 0} {
5648                    # check if this is the link to the first child
5649                    set kid [lindex $displayorder $y0]
5650                    if {[lindex $children($curview,$id) 0] eq $kid} {
5651                        # it is, work out offset to child
5652                        set x0 [lsearch -exact $previdlist $kid]
5653                    }
5654                }
5655                if {$x0 <= $col} break
5656            }
5657            # Insert a pad at that column as long as it has a line and
5658            # isn't the last column
5659            if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5660                set idlist [linsert $idlist $col {}]
5661                lset rowidlist $row $idlist
5662                changedrow $row
5663            }
5664        }
5665    }
5666}
5667
5668proc xc {row col} {
5669    global canvx0 linespc
5670    return [expr {$canvx0 + $col * $linespc}]
5671}
5672
5673proc yc {row} {
5674    global canvy0 linespc
5675    return [expr {$canvy0 + $row * $linespc}]
5676}
5677
5678proc linewidth {id} {
5679    global thickerline lthickness
5680
5681    set wid $lthickness
5682    if {[info exists thickerline] && $id eq $thickerline} {
5683        set wid [expr {2 * $lthickness}]
5684    }
5685    return $wid
5686}
5687
5688proc rowranges {id} {
5689    global curview children uparrowlen downarrowlen
5690    global rowidlist
5691
5692    set kids $children($curview,$id)
5693    if {$kids eq {}} {
5694        return {}
5695    }
5696    set ret {}
5697    lappend kids $id
5698    foreach child $kids {
5699        if {![commitinview $child $curview]} break
5700        set row [rowofcommit $child]
5701        if {![info exists prev]} {
5702            lappend ret [expr {$row + 1}]
5703        } else {
5704            if {$row <= $prevrow} {
5705                puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5706            }
5707            # see if the line extends the whole way from prevrow to row
5708            if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5709                [lsearch -exact [lindex $rowidlist \
5710                            [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5711                # it doesn't, see where it ends
5712                set r [expr {$prevrow + $downarrowlen}]
5713                if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5714                    while {[incr r -1] > $prevrow &&
5715                           [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5716                } else {
5717                    while {[incr r] <= $row &&
5718                           [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5719                    incr r -1
5720                }
5721                lappend ret $r
5722                # see where it starts up again
5723                set r [expr {$row - $uparrowlen}]
5724                if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5725                    while {[incr r] < $row &&
5726                           [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5727                } else {
5728                    while {[incr r -1] >= $prevrow &&
5729                           [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5730                    incr r
5731                }
5732                lappend ret $r
5733            }
5734        }
5735        if {$child eq $id} {
5736            lappend ret $row
5737        }
5738        set prev $child
5739        set prevrow $row
5740    }
5741    return $ret
5742}
5743
5744proc drawlineseg {id row endrow arrowlow} {
5745    global rowidlist displayorder iddrawn linesegs
5746    global canv colormap linespc curview maxlinelen parentlist
5747
5748    set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5749    set le [expr {$row + 1}]
5750    set arrowhigh 1
5751    while {1} {
5752        set c [lsearch -exact [lindex $rowidlist $le] $id]
5753        if {$c < 0} {
5754            incr le -1
5755            break
5756        }
5757        lappend cols $c
5758        set x [lindex $displayorder $le]
5759        if {$x eq $id} {
5760            set arrowhigh 0
5761            break
5762        }
5763        if {[info exists iddrawn($x)] || $le == $endrow} {
5764            set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5765            if {$c >= 0} {
5766                lappend cols $c
5767                set arrowhigh 0
5768            }
5769            break
5770        }
5771        incr le
5772    }
5773    if {$le <= $row} {
5774        return $row
5775    }
5776
5777    set lines {}
5778    set i 0
5779    set joinhigh 0
5780    if {[info exists linesegs($id)]} {
5781        set lines $linesegs($id)
5782        foreach li $lines {
5783            set r0 [lindex $li 0]
5784            if {$r0 > $row} {
5785                if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5786                    set joinhigh 1
5787                }
5788                break
5789            }
5790            incr i
5791        }
5792    }
5793    set joinlow 0
5794    if {$i > 0} {
5795        set li [lindex $lines [expr {$i-1}]]
5796        set r1 [lindex $li 1]
5797        if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5798            set joinlow 1
5799        }
5800    }
5801
5802    set x [lindex $cols [expr {$le - $row}]]
5803    set xp [lindex $cols [expr {$le - 1 - $row}]]
5804    set dir [expr {$xp - $x}]
5805    if {$joinhigh} {
5806        set ith [lindex $lines $i 2]
5807        set coords [$canv coords $ith]
5808        set ah [$canv itemcget $ith -arrow]
5809        set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5810        set x2 [lindex $cols [expr {$le + 1 - $row}]]
5811        if {$x2 ne {} && $x - $x2 == $dir} {
5812            set coords [lrange $coords 0 end-2]
5813        }
5814    } else {
5815        set coords [list [xc $le $x] [yc $le]]
5816    }
5817    if {$joinlow} {
5818        set itl [lindex $lines [expr {$i-1}] 2]
5819        set al [$canv itemcget $itl -arrow]
5820        set arrowlow [expr {$al eq "last" || $al eq "both"}]
5821    } elseif {$arrowlow} {
5822        if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5823            [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5824            set arrowlow 0
5825        }
5826    }
5827    set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5828    for {set y $le} {[incr y -1] > $row} {} {
5829        set x $xp
5830        set xp [lindex $cols [expr {$y - 1 - $row}]]
5831        set ndir [expr {$xp - $x}]
5832        if {$dir != $ndir || $xp < 0} {
5833            lappend coords [xc $y $x] [yc $y]
5834        }
5835        set dir $ndir
5836    }
5837    if {!$joinlow} {
5838        if {$xp < 0} {
5839            # join parent line to first child
5840            set ch [lindex $displayorder $row]
5841            set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5842            if {$xc < 0} {
5843                puts "oops: drawlineseg: child $ch not on row $row"
5844            } elseif {$xc != $x} {
5845                if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5846                    set d [expr {int(0.5 * $linespc)}]
5847                    set x1 [xc $row $x]
5848                    if {$xc < $x} {
5849                        set x2 [expr {$x1 - $d}]
5850                    } else {
5851                        set x2 [expr {$x1 + $d}]
5852                    }
5853                    set y2 [yc $row]
5854                    set y1 [expr {$y2 + $d}]
5855                    lappend coords $x1 $y1 $x2 $y2
5856                } elseif {$xc < $x - 1} {
5857                    lappend coords [xc $row [expr {$x-1}]] [yc $row]
5858                } elseif {$xc > $x + 1} {
5859                    lappend coords [xc $row [expr {$x+1}]] [yc $row]
5860                }
5861                set x $xc
5862            }
5863            lappend coords [xc $row $x] [yc $row]
5864        } else {
5865            set xn [xc $row $xp]
5866            set yn [yc $row]
5867            lappend coords $xn $yn
5868        }
5869        if {!$joinhigh} {
5870            assigncolor $id
5871            set t [$canv create line $coords -width [linewidth $id] \
5872                       -fill $colormap($id) -tags lines.$id -arrow $arrow]
5873            $canv lower $t
5874            bindline $t $id
5875            set lines [linsert $lines $i [list $row $le $t]]
5876        } else {
5877            $canv coords $ith $coords
5878            if {$arrow ne $ah} {
5879                $canv itemconf $ith -arrow $arrow
5880            }
5881            lset lines $i 0 $row
5882        }
5883    } else {
5884        set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5885        set ndir [expr {$xo - $xp}]
5886        set clow [$canv coords $itl]
5887        if {$dir == $ndir} {
5888            set clow [lrange $clow 2 end]
5889        }
5890        set coords [concat $coords $clow]
5891        if {!$joinhigh} {
5892            lset lines [expr {$i-1}] 1 $le
5893        } else {
5894            # coalesce two pieces
5895            $canv delete $ith
5896            set b [lindex $lines [expr {$i-1}] 0]
5897            set e [lindex $lines $i 1]
5898            set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5899        }
5900        $canv coords $itl $coords
5901        if {$arrow ne $al} {
5902            $canv itemconf $itl -arrow $arrow
5903        }
5904    }
5905
5906    set linesegs($id) $lines
5907    return $le
5908}
5909
5910proc drawparentlinks {id row} {
5911    global rowidlist canv colormap curview parentlist
5912    global idpos linespc
5913
5914    set rowids [lindex $rowidlist $row]
5915    set col [lsearch -exact $rowids $id]
5916    if {$col < 0} return
5917    set olds [lindex $parentlist $row]
5918    set row2 [expr {$row + 1}]
5919    set x [xc $row $col]
5920    set y [yc $row]
5921    set y2 [yc $row2]
5922    set d [expr {int(0.5 * $linespc)}]
5923    set ymid [expr {$y + $d}]
5924    set ids [lindex $rowidlist $row2]
5925    # rmx = right-most X coord used
5926    set rmx 0
5927    foreach p $olds {
5928        set i [lsearch -exact $ids $p]
5929        if {$i < 0} {
5930            puts "oops, parent $p of $id not in list"
5931            continue
5932        }
5933        set x2 [xc $row2 $i]
5934        if {$x2 > $rmx} {
5935            set rmx $x2
5936        }
5937        set j [lsearch -exact $rowids $p]
5938        if {$j < 0} {
5939            # drawlineseg will do this one for us
5940            continue
5941        }
5942        assigncolor $p
5943        # should handle duplicated parents here...
5944        set coords [list $x $y]
5945        if {$i != $col} {
5946            # if attaching to a vertical segment, draw a smaller
5947            # slant for visual distinctness
5948            if {$i == $j} {
5949                if {$i < $col} {
5950                    lappend coords [expr {$x2 + $d}] $y $x2 $ymid
5951                } else {
5952                    lappend coords [expr {$x2 - $d}] $y $x2 $ymid
5953                }
5954            } elseif {$i < $col && $i < $j} {
5955                # segment slants towards us already
5956                lappend coords [xc $row $j] $y
5957            } else {
5958                if {$i < $col - 1} {
5959                    lappend coords [expr {$x2 + $linespc}] $y
5960                } elseif {$i > $col + 1} {
5961                    lappend coords [expr {$x2 - $linespc}] $y
5962                }
5963                lappend coords $x2 $y2
5964            }
5965        } else {
5966            lappend coords $x2 $y2
5967        }
5968        set t [$canv create line $coords -width [linewidth $p] \
5969                   -fill $colormap($p) -tags lines.$p]
5970        $canv lower $t
5971        bindline $t $p
5972    }
5973    if {$rmx > [lindex $idpos($id) 1]} {
5974        lset idpos($id) 1 $rmx
5975        redrawtags $id
5976    }
5977}
5978
5979proc drawlines {id} {
5980    global canv
5981
5982    $canv itemconf lines.$id -width [linewidth $id]
5983}
5984
5985proc drawcmittext {id row col} {
5986    global linespc canv canv2 canv3 fgcolor curview
5987    global cmitlisted commitinfo rowidlist parentlist
5988    global rowtextx idpos idtags idheads idotherrefs
5989    global linehtag linentag linedtag selectedline
5990    global canvxmax boldids boldnameids fgcolor markedid
5991    global mainheadid nullid nullid2 circleitem circlecolors ctxbut
5992    global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
5993    global circleoutlinecolor
5994
5995    # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
5996    set listed $cmitlisted($curview,$id)
5997    if {$id eq $nullid} {
5998        set ofill $workingfilescirclecolor
5999    } elseif {$id eq $nullid2} {
6000        set ofill $indexcirclecolor
6001    } elseif {$id eq $mainheadid} {
6002        set ofill $mainheadcirclecolor
6003    } else {
6004        set ofill [lindex $circlecolors $listed]
6005    }
6006    set x [xc $row $col]
6007    set y [yc $row]
6008    set orad [expr {$linespc / 3}]
6009    if {$listed <= 2} {
6010        set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6011                   [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6012                   -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6013    } elseif {$listed == 3} {
6014        # triangle pointing left for left-side commits
6015        set t [$canv create polygon \
6016                   [expr {$x - $orad}] $y \
6017                   [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6018                   [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6019                   -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6020    } else {
6021        # triangle pointing right for right-side commits
6022        set t [$canv create polygon \
6023                   [expr {$x + $orad - 1}] $y \
6024                   [expr {$x - $orad}] [expr {$y - $orad}] \
6025                   [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6026                   -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6027    }
6028    set circleitem($row) $t
6029    $canv raise $t
6030    $canv bind $t <1> {selcanvline {} %x %y}
6031    set rmx [llength [lindex $rowidlist $row]]
6032    set olds [lindex $parentlist $row]
6033    if {$olds ne {}} {
6034        set nextids [lindex $rowidlist [expr {$row + 1}]]
6035        foreach p $olds {
6036            set i [lsearch -exact $nextids $p]
6037            if {$i > $rmx} {
6038                set rmx $i
6039            }
6040        }
6041    }
6042    set xt [xc $row $rmx]
6043    set rowtextx($row) $xt
6044    set idpos($id) [list $x $xt $y]
6045    if {[info exists idtags($id)] || [info exists idheads($id)]
6046        || [info exists idotherrefs($id)]} {
6047        set xt [drawtags $id $x $xt $y]
6048    }
6049    if {[lindex $commitinfo($id) 6] > 0} {
6050        set xt [drawnotesign $xt $y]
6051    }
6052    set headline [lindex $commitinfo($id) 0]
6053    set name [lindex $commitinfo($id) 1]
6054    set date [lindex $commitinfo($id) 2]
6055    set date [formatdate $date]
6056    set font mainfont
6057    set nfont mainfont
6058    set isbold [ishighlighted $id]
6059    if {$isbold > 0} {
6060        lappend boldids $id
6061        set font mainfontbold
6062        if {$isbold > 1} {
6063            lappend boldnameids $id
6064            set nfont mainfontbold
6065        }
6066    }
6067    set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6068                           -text $headline -font $font -tags text]
6069    $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6070    set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6071                           -text $name -font $nfont -tags text]
6072    set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6073                           -text $date -font mainfont -tags text]
6074    if {$selectedline == $row} {
6075        make_secsel $id
6076    }
6077    if {[info exists markedid] && $markedid eq $id} {
6078        make_idmark $id
6079    }
6080    set xr [expr {$xt + [font measure $font $headline]}]
6081    if {$xr > $canvxmax} {
6082        set canvxmax $xr
6083        setcanvscroll
6084    }
6085}
6086
6087proc drawcmitrow {row} {
6088    global displayorder rowidlist nrows_drawn
6089    global iddrawn markingmatches
6090    global commitinfo numcommits
6091    global filehighlight fhighlights findpattern nhighlights
6092    global hlview vhighlights
6093    global highlight_related rhighlights
6094
6095    if {$row >= $numcommits} return
6096
6097    set id [lindex $displayorder $row]
6098    if {[info exists hlview] && ![info exists vhighlights($id)]} {
6099        askvhighlight $row $id
6100    }
6101    if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6102        askfilehighlight $row $id
6103    }
6104    if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6105        askfindhighlight $row $id
6106    }
6107    if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6108        askrelhighlight $row $id
6109    }
6110    if {![info exists iddrawn($id)]} {
6111        set col [lsearch -exact [lindex $rowidlist $row] $id]
6112        if {$col < 0} {
6113            puts "oops, row $row id $id not in list"
6114            return
6115        }
6116        if {![info exists commitinfo($id)]} {
6117            getcommit $id
6118        }
6119        assigncolor $id
6120        drawcmittext $id $row $col
6121        set iddrawn($id) 1
6122        incr nrows_drawn
6123    }
6124    if {$markingmatches} {
6125        markrowmatches $row $id
6126    }
6127}
6128
6129proc drawcommits {row {endrow {}}} {
6130    global numcommits iddrawn displayorder curview need_redisplay
6131    global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6132
6133    if {$row < 0} {
6134        set row 0
6135    }
6136    if {$endrow eq {}} {
6137        set endrow $row
6138    }
6139    if {$endrow >= $numcommits} {
6140        set endrow [expr {$numcommits - 1}]
6141    }
6142
6143    set rl1 [expr {$row - $downarrowlen - 3}]
6144    if {$rl1 < 0} {
6145        set rl1 0
6146    }
6147    set ro1 [expr {$row - 3}]
6148    if {$ro1 < 0} {
6149        set ro1 0
6150    }
6151    set r2 [expr {$endrow + $uparrowlen + 3}]
6152    if {$r2 > $numcommits} {
6153        set r2 $numcommits
6154    }
6155    for {set r $rl1} {$r < $r2} {incr r} {
6156        if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6157            if {$rl1 < $r} {
6158                layoutrows $rl1 $r
6159            }
6160            set rl1 [expr {$r + 1}]
6161        }
6162    }
6163    if {$rl1 < $r} {
6164        layoutrows $rl1 $r
6165    }
6166    optimize_rows $ro1 0 $r2
6167    if {$need_redisplay || $nrows_drawn > 2000} {
6168        clear_display
6169    }
6170
6171    # make the lines join to already-drawn rows either side
6172    set r [expr {$row - 1}]
6173    if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6174        set r $row
6175    }
6176    set er [expr {$endrow + 1}]
6177    if {$er >= $numcommits ||
6178        ![info exists iddrawn([lindex $displayorder $er])]} {
6179        set er $endrow
6180    }
6181    for {} {$r <= $er} {incr r} {
6182        set id [lindex $displayorder $r]
6183        set wasdrawn [info exists iddrawn($id)]
6184        drawcmitrow $r
6185        if {$r == $er} break
6186        set nextid [lindex $displayorder [expr {$r + 1}]]
6187        if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6188        drawparentlinks $id $r
6189
6190        set rowids [lindex $rowidlist $r]
6191        foreach lid $rowids {
6192            if {$lid eq {}} continue
6193            if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6194            if {$lid eq $id} {
6195                # see if this is the first child of any of its parents
6196                foreach p [lindex $parentlist $r] {
6197                    if {[lsearch -exact $rowids $p] < 0} {
6198                        # make this line extend up to the child
6199                        set lineend($p) [drawlineseg $p $r $er 0]
6200                    }
6201                }
6202            } else {
6203                set lineend($lid) [drawlineseg $lid $r $er 1]
6204            }
6205        }
6206    }
6207}
6208
6209proc undolayout {row} {
6210    global uparrowlen mingaplen downarrowlen
6211    global rowidlist rowisopt rowfinal need_redisplay
6212
6213    set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6214    if {$r < 0} {
6215        set r 0
6216    }
6217    if {[llength $rowidlist] > $r} {
6218        incr r -1
6219        set rowidlist [lrange $rowidlist 0 $r]
6220        set rowfinal [lrange $rowfinal 0 $r]
6221        set rowisopt [lrange $rowisopt 0 $r]
6222        set need_redisplay 1
6223        run drawvisible
6224    }
6225}
6226
6227proc drawvisible {} {
6228    global canv linespc curview vrowmod selectedline targetrow targetid
6229    global need_redisplay cscroll numcommits
6230
6231    set fs [$canv yview]
6232    set ymax [lindex [$canv cget -scrollregion] 3]
6233    if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6234    set f0 [lindex $fs 0]
6235    set f1 [lindex $fs 1]
6236    set y0 [expr {int($f0 * $ymax)}]
6237    set y1 [expr {int($f1 * $ymax)}]
6238
6239    if {[info exists targetid]} {
6240        if {[commitinview $targetid $curview]} {
6241            set r [rowofcommit $targetid]
6242            if {$r != $targetrow} {
6243                # Fix up the scrollregion and change the scrolling position
6244                # now that our target row has moved.
6245                set diff [expr {($r - $targetrow) * $linespc}]
6246                set targetrow $r
6247                setcanvscroll
6248                set ymax [lindex [$canv cget -scrollregion] 3]
6249                incr y0 $diff
6250                incr y1 $diff
6251                set f0 [expr {$y0 / $ymax}]
6252                set f1 [expr {$y1 / $ymax}]
6253                allcanvs yview moveto $f0
6254                $cscroll set $f0 $f1
6255                set need_redisplay 1
6256            }
6257        } else {
6258            unset targetid
6259        }
6260    }
6261
6262    set row [expr {int(($y0 - 3) / $linespc) - 1}]
6263    set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6264    if {$endrow >= $vrowmod($curview)} {
6265        update_arcrows $curview
6266    }
6267    if {$selectedline ne {} &&
6268        $row <= $selectedline && $selectedline <= $endrow} {
6269        set targetrow $selectedline
6270    } elseif {[info exists targetid]} {
6271        set targetrow [expr {int(($row + $endrow) / 2)}]
6272    }
6273    if {[info exists targetrow]} {
6274        if {$targetrow >= $numcommits} {
6275            set targetrow [expr {$numcommits - 1}]
6276        }
6277        set targetid [commitonrow $targetrow]
6278    }
6279    drawcommits $row $endrow
6280}
6281
6282proc clear_display {} {
6283    global iddrawn linesegs need_redisplay nrows_drawn
6284    global vhighlights fhighlights nhighlights rhighlights
6285    global linehtag linentag linedtag boldids boldnameids
6286
6287    allcanvs delete all
6288    catch {unset iddrawn}
6289    catch {unset linesegs}
6290    catch {unset linehtag}
6291    catch {unset linentag}
6292    catch {unset linedtag}
6293    set boldids {}
6294    set boldnameids {}
6295    catch {unset vhighlights}
6296    catch {unset fhighlights}
6297    catch {unset nhighlights}
6298    catch {unset rhighlights}
6299    set need_redisplay 0
6300    set nrows_drawn 0
6301}
6302
6303proc findcrossings {id} {
6304    global rowidlist parentlist numcommits displayorder
6305
6306    set cross {}
6307    set ccross {}
6308    foreach {s e} [rowranges $id] {
6309        if {$e >= $numcommits} {
6310            set e [expr {$numcommits - 1}]
6311        }
6312        if {$e <= $s} continue
6313        for {set row $e} {[incr row -1] >= $s} {} {
6314            set x [lsearch -exact [lindex $rowidlist $row] $id]
6315            if {$x < 0} break
6316            set olds [lindex $parentlist $row]
6317            set kid [lindex $displayorder $row]
6318            set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6319            if {$kidx < 0} continue
6320            set nextrow [lindex $rowidlist [expr {$row + 1}]]
6321            foreach p $olds {
6322                set px [lsearch -exact $nextrow $p]
6323                if {$px < 0} continue
6324                if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6325                    if {[lsearch -exact $ccross $p] >= 0} continue
6326                    if {$x == $px + ($kidx < $px? -1: 1)} {
6327                        lappend ccross $p
6328                    } elseif {[lsearch -exact $cross $p] < 0} {
6329                        lappend cross $p
6330                    }
6331                }
6332            }
6333        }
6334    }
6335    return [concat $ccross {{}} $cross]
6336}
6337
6338proc assigncolor {id} {
6339    global colormap colors nextcolor
6340    global parents children children curview
6341
6342    if {[info exists colormap($id)]} return
6343    set ncolors [llength $colors]
6344    if {[info exists children($curview,$id)]} {
6345        set kids $children($curview,$id)
6346    } else {
6347        set kids {}
6348    }
6349    if {[llength $kids] == 1} {
6350        set child [lindex $kids 0]
6351        if {[info exists colormap($child)]
6352            && [llength $parents($curview,$child)] == 1} {
6353            set colormap($id) $colormap($child)
6354            return
6355        }
6356    }
6357    set badcolors {}
6358    set origbad {}
6359    foreach x [findcrossings $id] {
6360        if {$x eq {}} {
6361            # delimiter between corner crossings and other crossings
6362            if {[llength $badcolors] >= $ncolors - 1} break
6363            set origbad $badcolors
6364        }
6365        if {[info exists colormap($x)]
6366            && [lsearch -exact $badcolors $colormap($x)] < 0} {
6367            lappend badcolors $colormap($x)
6368        }
6369    }
6370    if {[llength $badcolors] >= $ncolors} {
6371        set badcolors $origbad
6372    }
6373    set origbad $badcolors
6374    if {[llength $badcolors] < $ncolors - 1} {
6375        foreach child $kids {
6376            if {[info exists colormap($child)]
6377                && [lsearch -exact $badcolors $colormap($child)] < 0} {
6378                lappend badcolors $colormap($child)
6379            }
6380            foreach p $parents($curview,$child) {
6381                if {[info exists colormap($p)]
6382                    && [lsearch -exact $badcolors $colormap($p)] < 0} {
6383                    lappend badcolors $colormap($p)
6384                }
6385            }
6386        }
6387        if {[llength $badcolors] >= $ncolors} {
6388            set badcolors $origbad
6389        }
6390    }
6391    for {set i 0} {$i <= $ncolors} {incr i} {
6392        set c [lindex $colors $nextcolor]
6393        if {[incr nextcolor] >= $ncolors} {
6394            set nextcolor 0
6395        }
6396        if {[lsearch -exact $badcolors $c]} break
6397    }
6398    set colormap($id) $c
6399}
6400
6401proc bindline {t id} {
6402    global canv
6403
6404    $canv bind $t <Enter> "lineenter %x %y $id"
6405    $canv bind $t <Motion> "linemotion %x %y $id"
6406    $canv bind $t <Leave> "lineleave $id"
6407    $canv bind $t <Button-1> "lineclick %x %y $id 1"
6408}
6409
6410proc graph_pane_width {} {
6411    global use_ttk
6412
6413    if {$use_ttk} {
6414        set g [.tf.histframe.pwclist sashpos 0]
6415    } else {
6416        set g [.tf.histframe.pwclist sash coord 0]
6417    }
6418    return [lindex $g 0]
6419}
6420
6421proc totalwidth {l font extra} {
6422    set tot 0
6423    foreach str $l {
6424        set tot [expr {$tot + [font measure $font $str] + $extra}]
6425    }
6426    return $tot
6427}
6428
6429proc drawtags {id x xt y1} {
6430    global idtags idheads idotherrefs mainhead
6431    global linespc lthickness
6432    global canv rowtextx curview fgcolor bgcolor ctxbut
6433    global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6434    global tagbgcolor tagfgcolor tagoutlinecolor
6435    global reflinecolor
6436
6437    set marks {}
6438    set ntags 0
6439    set nheads 0
6440    set singletag 0
6441    set maxtags 3
6442    set maxtagpct 25
6443    set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6444    set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6445    set extra [expr {$delta + $lthickness + $linespc}]
6446
6447    if {[info exists idtags($id)]} {
6448        set marks $idtags($id)
6449        set ntags [llength $marks]
6450        if {$ntags > $maxtags ||
6451            [totalwidth $marks mainfont $extra] > $maxwidth} {
6452            # show just a single "n tags..." tag
6453            set singletag 1
6454            if {$ntags == 1} {
6455                set marks [list "tag..."]
6456            } else {
6457                set marks [list [format "%d tags..." $ntags]]
6458            }
6459            set ntags 1
6460        }
6461    }
6462    if {[info exists idheads($id)]} {
6463        set marks [concat $marks $idheads($id)]
6464        set nheads [llength $idheads($id)]
6465    }
6466    if {[info exists idotherrefs($id)]} {
6467        set marks [concat $marks $idotherrefs($id)]
6468    }
6469    if {$marks eq {}} {
6470        return $xt
6471    }
6472
6473    set yt [expr {$y1 - 0.5 * $linespc}]
6474    set yb [expr {$yt + $linespc - 1}]
6475    set xvals {}
6476    set wvals {}
6477    set i -1
6478    foreach tag $marks {
6479        incr i
6480        if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6481            set wid [font measure mainfontbold $tag]
6482        } else {
6483            set wid [font measure mainfont $tag]
6484        }
6485        lappend xvals $xt
6486        lappend wvals $wid
6487        set xt [expr {$xt + $wid + $extra}]
6488    }
6489    set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6490               -width $lthickness -fill $reflinecolor -tags tag.$id]
6491    $canv lower $t
6492    foreach tag $marks x $xvals wid $wvals {
6493        set tag_quoted [string map {% %%} $tag]
6494        set xl [expr {$x + $delta}]
6495        set xr [expr {$x + $delta + $wid + $lthickness}]
6496        set font mainfont
6497        if {[incr ntags -1] >= 0} {
6498            # draw a tag
6499            set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6500                       $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6501                       -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6502                       -tags tag.$id]
6503            if {$singletag} {
6504                set tagclick [list showtags $id 1]
6505            } else {
6506                set tagclick [list showtag $tag_quoted 1]
6507            }
6508            $canv bind $t <1> $tagclick
6509            set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6510        } else {
6511            # draw a head or other ref
6512            if {[incr nheads -1] >= 0} {
6513                set col $headbgcolor
6514                if {$tag eq $mainhead} {
6515                    set font mainfontbold
6516                }
6517            } else {
6518                set col "#ddddff"
6519            }
6520            set xl [expr {$xl - $delta/2}]
6521            $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6522                -width 1 -outline black -fill $col -tags tag.$id
6523            if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6524                set rwid [font measure mainfont $remoteprefix]
6525                set xi [expr {$x + 1}]
6526                set yti [expr {$yt + 1}]
6527                set xri [expr {$x + $rwid}]
6528                $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6529                        -width 0 -fill $remotebgcolor -tags tag.$id
6530            }
6531        }
6532        set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6533                   -font $font -tags [list tag.$id text]]
6534        if {$ntags >= 0} {
6535            $canv bind $t <1> $tagclick
6536        } elseif {$nheads >= 0} {
6537            $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6538        }
6539    }
6540    return $xt
6541}
6542
6543proc drawnotesign {xt y} {
6544    global linespc canv fgcolor
6545
6546    set orad [expr {$linespc / 3}]
6547    set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6548               [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6549               -fill yellow -outline $fgcolor -width 1 -tags circle]
6550    set xt [expr {$xt + $orad * 3}]
6551    return $xt
6552}
6553
6554proc xcoord {i level ln} {
6555    global canvx0 xspc1 xspc2
6556
6557    set x [expr {$canvx0 + $i * $xspc1($ln)}]
6558    if {$i > 0 && $i == $level} {
6559        set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6560    } elseif {$i > $level} {
6561        set x [expr {$x + $xspc2 - $xspc1($ln)}]
6562    }
6563    return $x
6564}
6565
6566proc show_status {msg} {
6567    global canv fgcolor
6568
6569    clear_display
6570    $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6571        -tags text -fill $fgcolor
6572}
6573
6574# Don't change the text pane cursor if it is currently the hand cursor,
6575# showing that we are over a sha1 ID link.
6576proc settextcursor {c} {
6577    global ctext curtextcursor
6578
6579    if {[$ctext cget -cursor] == $curtextcursor} {
6580        $ctext config -cursor $c
6581    }
6582    set curtextcursor $c
6583}
6584
6585proc nowbusy {what {name {}}} {
6586    global isbusy busyname statusw
6587
6588    if {[array names isbusy] eq {}} {
6589        . config -cursor watch
6590        settextcursor watch
6591    }
6592    set isbusy($what) 1
6593    set busyname($what) $name
6594    if {$name ne {}} {
6595        $statusw conf -text $name
6596    }
6597}
6598
6599proc notbusy {what} {
6600    global isbusy maincursor textcursor busyname statusw
6601
6602    catch {
6603        unset isbusy($what)
6604        if {$busyname($what) ne {} &&
6605            [$statusw cget -text] eq $busyname($what)} {
6606            $statusw conf -text {}
6607        }
6608    }
6609    if {[array names isbusy] eq {}} {
6610        . config -cursor $maincursor
6611        settextcursor $textcursor
6612    }
6613}
6614
6615proc findmatches {f} {
6616    global findtype findstring
6617    if {$findtype == [mc "Regexp"]} {
6618        set matches [regexp -indices -all -inline $findstring $f]
6619    } else {
6620        set fs $findstring
6621        if {$findtype == [mc "IgnCase"]} {
6622            set f [string tolower $f]
6623            set fs [string tolower $fs]
6624        }
6625        set matches {}
6626        set i 0
6627        set l [string length $fs]
6628        while {[set j [string first $fs $f $i]] >= 0} {
6629            lappend matches [list $j [expr {$j+$l-1}]]
6630            set i [expr {$j + $l}]
6631        }
6632    }
6633    return $matches
6634}
6635
6636proc dofind {{dirn 1} {wrap 1}} {
6637    global findstring findstartline findcurline selectedline numcommits
6638    global gdttype filehighlight fh_serial find_dirn findallowwrap
6639
6640    if {[info exists find_dirn]} {
6641        if {$find_dirn == $dirn} return
6642        stopfinding
6643    }
6644    focus .
6645    if {$findstring eq {} || $numcommits == 0} return
6646    if {$selectedline eq {}} {
6647        set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6648    } else {
6649        set findstartline $selectedline
6650    }
6651    set findcurline $findstartline
6652    nowbusy finding [mc "Searching"]
6653    if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6654        after cancel do_file_hl $fh_serial
6655        do_file_hl $fh_serial
6656    }
6657    set find_dirn $dirn
6658    set findallowwrap $wrap
6659    run findmore
6660}
6661
6662proc stopfinding {} {
6663    global find_dirn findcurline fprogcoord
6664
6665    if {[info exists find_dirn]} {
6666        unset find_dirn
6667        unset findcurline
6668        notbusy finding
6669        set fprogcoord 0
6670        adjustprogress
6671    }
6672    stopblaming
6673}
6674
6675proc findmore {} {
6676    global commitdata commitinfo numcommits findpattern findloc
6677    global findstartline findcurline findallowwrap
6678    global find_dirn gdttype fhighlights fprogcoord
6679    global curview varcorder vrownum varccommits vrowmod
6680
6681    if {![info exists find_dirn]} {
6682        return 0
6683    }
6684    set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6685    set l $findcurline
6686    set moretodo 0
6687    if {$find_dirn > 0} {
6688        incr l
6689        if {$l >= $numcommits} {
6690            set l 0
6691        }
6692        if {$l <= $findstartline} {
6693            set lim [expr {$findstartline + 1}]
6694        } else {
6695            set lim $numcommits
6696            set moretodo $findallowwrap
6697        }
6698    } else {
6699        if {$l == 0} {
6700            set l $numcommits
6701        }
6702        incr l -1
6703        if {$l >= $findstartline} {
6704            set lim [expr {$findstartline - 1}]
6705        } else {
6706            set lim -1
6707            set moretodo $findallowwrap
6708        }
6709    }
6710    set n [expr {($lim - $l) * $find_dirn}]
6711    if {$n > 500} {
6712        set n 500
6713        set moretodo 1
6714    }
6715    if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6716        update_arcrows $curview
6717    }
6718    set found 0
6719    set domore 1
6720    set ai [bsearch $vrownum($curview) $l]
6721    set a [lindex $varcorder($curview) $ai]
6722    set arow [lindex $vrownum($curview) $ai]
6723    set ids [lindex $varccommits($curview,$a)]
6724    set arowend [expr {$arow + [llength $ids]}]
6725    if {$gdttype eq [mc "containing:"]} {
6726        for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6727            if {$l < $arow || $l >= $arowend} {
6728                incr ai $find_dirn
6729                set a [lindex $varcorder($curview) $ai]
6730                set arow [lindex $vrownum($curview) $ai]
6731                set ids [lindex $varccommits($curview,$a)]
6732                set arowend [expr {$arow + [llength $ids]}]
6733            }
6734            set id [lindex $ids [expr {$l - $arow}]]
6735            # shouldn't happen unless git log doesn't give all the commits...
6736            if {![info exists commitdata($id)] ||
6737                ![doesmatch $commitdata($id)]} {
6738                continue
6739            }
6740            if {![info exists commitinfo($id)]} {
6741                getcommit $id
6742            }
6743            set info $commitinfo($id)
6744            foreach f $info ty $fldtypes {
6745                if {$ty eq ""} continue
6746                if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6747                    [doesmatch $f]} {
6748                    set found 1
6749                    break
6750                }
6751            }
6752            if {$found} break
6753        }
6754    } else {
6755        for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6756            if {$l < $arow || $l >= $arowend} {
6757                incr ai $find_dirn
6758                set a [lindex $varcorder($curview) $ai]
6759                set arow [lindex $vrownum($curview) $ai]
6760                set ids [lindex $varccommits($curview,$a)]
6761                set arowend [expr {$arow + [llength $ids]}]
6762            }
6763            set id [lindex $ids [expr {$l - $arow}]]
6764            if {![info exists fhighlights($id)]} {
6765                # this sets fhighlights($id) to -1
6766                askfilehighlight $l $id
6767            }
6768            if {$fhighlights($id) > 0} {
6769                set found $domore
6770                break
6771            }
6772            if {$fhighlights($id) < 0} {
6773                if {$domore} {
6774                    set domore 0
6775                    set findcurline [expr {$l - $find_dirn}]
6776                }
6777            }
6778        }
6779    }
6780    if {$found || ($domore && !$moretodo)} {
6781        unset findcurline
6782        unset find_dirn
6783        notbusy finding
6784        set fprogcoord 0
6785        adjustprogress
6786        if {$found} {
6787            findselectline $l
6788        } else {
6789            bell
6790        }
6791        return 0
6792    }
6793    if {!$domore} {
6794        flushhighlights
6795    } else {
6796        set findcurline [expr {$l - $find_dirn}]
6797    }
6798    set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6799    if {$n < 0} {
6800        incr n $numcommits
6801    }
6802    set fprogcoord [expr {$n * 1.0 / $numcommits}]
6803    adjustprogress
6804    return $domore
6805}
6806
6807proc findselectline {l} {
6808    global findloc commentend ctext findcurline markingmatches gdttype
6809
6810    set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6811    set findcurline $l
6812    selectline $l 1
6813    if {$markingmatches &&
6814        ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6815        # highlight the matches in the comments
6816        set f [$ctext get 1.0 $commentend]
6817        set matches [findmatches $f]
6818        foreach match $matches {
6819            set start [lindex $match 0]
6820            set end [expr {[lindex $match 1] + 1}]
6821            $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6822        }
6823    }
6824    drawvisible
6825}
6826
6827# mark the bits of a headline or author that match a find string
6828proc markmatches {canv l str tag matches font row} {
6829    global selectedline
6830
6831    set bbox [$canv bbox $tag]
6832    set x0 [lindex $bbox 0]
6833    set y0 [lindex $bbox 1]
6834    set y1 [lindex $bbox 3]
6835    foreach match $matches {
6836        set start [lindex $match 0]
6837        set end [lindex $match 1]
6838        if {$start > $end} continue
6839        set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6840        set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6841        set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6842                   [expr {$x0+$xlen+2}] $y1 \
6843                   -outline {} -tags [list match$l matches] -fill yellow]
6844        $canv lower $t
6845        if {$row == $selectedline} {
6846            $canv raise $t secsel
6847        }
6848    }
6849}
6850
6851proc unmarkmatches {} {
6852    global markingmatches
6853
6854    allcanvs delete matches
6855    set markingmatches 0
6856    stopfinding
6857}
6858
6859proc selcanvline {w x y} {
6860    global canv canvy0 ctext linespc
6861    global rowtextx
6862    set ymax [lindex [$canv cget -scrollregion] 3]
6863    if {$ymax == {}} return
6864    set yfrac [lindex [$canv yview] 0]
6865    set y [expr {$y + $yfrac * $ymax}]
6866    set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6867    if {$l < 0} {
6868        set l 0
6869    }
6870    if {$w eq $canv} {
6871        set xmax [lindex [$canv cget -scrollregion] 2]
6872        set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6873        if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6874    }
6875    unmarkmatches
6876    selectline $l 1
6877}
6878
6879proc commit_descriptor {p} {
6880    global commitinfo
6881    if {![info exists commitinfo($p)]} {
6882        getcommit $p
6883    }
6884    set l "..."
6885    if {[llength $commitinfo($p)] > 1} {
6886        set l [lindex $commitinfo($p) 0]
6887    }
6888    return "$p ($l)\n"
6889}
6890
6891# append some text to the ctext widget, and make any SHA1 ID
6892# that we know about be a clickable link.
6893proc appendwithlinks {text tags} {
6894    global ctext linknum curview
6895
6896    set start [$ctext index "end - 1c"]
6897    $ctext insert end $text $tags
6898    set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6899    foreach l $links {
6900        set s [lindex $l 0]
6901        set e [lindex $l 1]
6902        set linkid [string range $text $s $e]
6903        incr e
6904        $ctext tag delete link$linknum
6905        $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6906        setlink $linkid link$linknum
6907        incr linknum
6908    }
6909}
6910
6911proc setlink {id lk} {
6912    global curview ctext pendinglinks
6913    global linkfgcolor
6914
6915    if {[string range $id 0 1] eq "-g"} {
6916      set id [string range $id 2 end]
6917    }
6918
6919    set known 0
6920    if {[string length $id] < 40} {
6921        set matches [longid $id]
6922        if {[llength $matches] > 0} {
6923            if {[llength $matches] > 1} return
6924            set known 1
6925            set id [lindex $matches 0]
6926        }
6927    } else {
6928        set known [commitinview $id $curview]
6929    }
6930    if {$known} {
6931        $ctext tag conf $lk -foreground $linkfgcolor -underline 1
6932        $ctext tag bind $lk <1> [list selbyid $id]
6933        $ctext tag bind $lk <Enter> {linkcursor %W 1}
6934        $ctext tag bind $lk <Leave> {linkcursor %W -1}
6935    } else {
6936        lappend pendinglinks($id) $lk
6937        interestedin $id {makelink %P}
6938    }
6939}
6940
6941proc appendshortlink {id {pre {}} {post {}}} {
6942    global ctext linknum
6943
6944    $ctext insert end $pre
6945    $ctext tag delete link$linknum
6946    $ctext insert end [string range $id 0 7] link$linknum
6947    $ctext insert end $post
6948    setlink $id link$linknum
6949    incr linknum
6950}
6951
6952proc makelink {id} {
6953    global pendinglinks
6954
6955    if {![info exists pendinglinks($id)]} return
6956    foreach lk $pendinglinks($id) {
6957        setlink $id $lk
6958    }
6959    unset pendinglinks($id)
6960}
6961
6962proc linkcursor {w inc} {
6963    global linkentercount curtextcursor
6964
6965    if {[incr linkentercount $inc] > 0} {
6966        $w configure -cursor hand2
6967    } else {
6968        $w configure -cursor $curtextcursor
6969        if {$linkentercount < 0} {
6970            set linkentercount 0
6971        }
6972    }
6973}
6974
6975proc viewnextline {dir} {
6976    global canv linespc
6977
6978    $canv delete hover
6979    set ymax [lindex [$canv cget -scrollregion] 3]
6980    set wnow [$canv yview]
6981    set wtop [expr {[lindex $wnow 0] * $ymax}]
6982    set newtop [expr {$wtop + $dir * $linespc}]
6983    if {$newtop < 0} {
6984        set newtop 0
6985    } elseif {$newtop > $ymax} {
6986        set newtop $ymax
6987    }
6988    allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
6989}
6990
6991# add a list of tag or branch names at position pos
6992# returns the number of names inserted
6993proc appendrefs {pos ids var} {
6994    global ctext linknum curview $var maxrefs mainheadid
6995
6996    if {[catch {$ctext index $pos}]} {
6997        return 0
6998    }
6999    $ctext conf -state normal
7000    $ctext delete $pos "$pos lineend"
7001    set tags {}
7002    foreach id $ids {
7003        foreach tag [set $var\($id\)] {
7004            lappend tags [list $tag $id]
7005        }
7006    }
7007
7008    set sep {}
7009    set tags [lsort -index 0 -decreasing $tags]
7010    set nutags 0
7011
7012    if {[llength $tags] > $maxrefs} {
7013        # If we are displaying heads, and there are too many,
7014        # see if there are some important heads to display.
7015        # Currently this means "master" and the current head.
7016        set itags {}
7017        if {$var eq "idheads"} {
7018            set utags {}
7019            foreach ti $tags {
7020                set hname [lindex $ti 0]
7021                set id [lindex $ti 1]
7022                if {($hname eq "master" || $id eq $mainheadid) &&
7023                    [llength $itags] < $maxrefs} {
7024                    lappend itags $ti
7025                } else {
7026                    lappend utags $ti
7027                }
7028            }
7029            set tags $utags
7030        }
7031        if {$itags ne {}} {
7032            set str [mc "and many more"]
7033            set sep " "
7034        } else {
7035            set str [mc "many"]
7036        }
7037        $ctext insert $pos "$str ([llength $tags])"
7038        set nutags [llength $tags]
7039        set tags $itags
7040    }
7041
7042    foreach ti $tags {
7043        set id [lindex $ti 1]
7044        set lk link$linknum
7045        incr linknum
7046        $ctext tag delete $lk
7047        $ctext insert $pos $sep
7048        $ctext insert $pos [lindex $ti 0] $lk
7049        setlink $id $lk
7050        set sep ", "
7051    }
7052    $ctext tag add wwrap "$pos linestart" "$pos lineend"
7053    $ctext conf -state disabled
7054    return [expr {[llength $tags] + $nutags}]
7055}
7056
7057# called when we have finished computing the nearby tags
7058proc dispneartags {delay} {
7059    global selectedline currentid showneartags tagphase
7060
7061    if {$selectedline eq {} || !$showneartags} return
7062    after cancel dispnexttag
7063    if {$delay} {
7064        after 200 dispnexttag
7065        set tagphase -1
7066    } else {
7067        after idle dispnexttag
7068        set tagphase 0
7069    }
7070}
7071
7072proc dispnexttag {} {
7073    global selectedline currentid showneartags tagphase ctext
7074
7075    if {$selectedline eq {} || !$showneartags} return
7076    switch -- $tagphase {
7077        0 {
7078            set dtags [desctags $currentid]
7079            if {$dtags ne {}} {
7080                appendrefs precedes $dtags idtags
7081            }
7082        }
7083        1 {
7084            set atags [anctags $currentid]
7085            if {$atags ne {}} {
7086                appendrefs follows $atags idtags
7087            }
7088        }
7089        2 {
7090            set dheads [descheads $currentid]
7091            if {$dheads ne {}} {
7092                if {[appendrefs branch $dheads idheads] > 1
7093                    && [$ctext get "branch -3c"] eq "h"} {
7094                    # turn "Branch" into "Branches"
7095                    $ctext conf -state normal
7096                    $ctext insert "branch -2c" "es"
7097                    $ctext conf -state disabled
7098                }
7099            }
7100        }
7101    }
7102    if {[incr tagphase] <= 2} {
7103        after idle dispnexttag
7104    }
7105}
7106
7107proc make_secsel {id} {
7108    global linehtag linentag linedtag canv canv2 canv3
7109
7110    if {![info exists linehtag($id)]} return
7111    $canv delete secsel
7112    set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7113               -tags secsel -fill [$canv cget -selectbackground]]
7114    $canv lower $t
7115    $canv2 delete secsel
7116    set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7117               -tags secsel -fill [$canv2 cget -selectbackground]]
7118    $canv2 lower $t
7119    $canv3 delete secsel
7120    set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7121               -tags secsel -fill [$canv3 cget -selectbackground]]
7122    $canv3 lower $t
7123}
7124
7125proc make_idmark {id} {
7126    global linehtag canv fgcolor
7127
7128    if {![info exists linehtag($id)]} return
7129    $canv delete markid
7130    set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7131               -tags markid -outline $fgcolor]
7132    $canv raise $t
7133}
7134
7135proc selectline {l isnew {desired_loc {}}} {
7136    global canv ctext commitinfo selectedline
7137    global canvy0 linespc parents children curview
7138    global currentid sha1entry
7139    global commentend idtags linknum
7140    global mergemax numcommits pending_select
7141    global cmitmode showneartags allcommits
7142    global targetrow targetid lastscrollrows
7143    global autoselect autosellen jump_to_here
7144    global vinlinediff
7145
7146    catch {unset pending_select}
7147    $canv delete hover
7148    normalline
7149    unsel_reflist
7150    stopfinding
7151    if {$l < 0 || $l >= $numcommits} return
7152    set id [commitonrow $l]
7153    set targetid $id
7154    set targetrow $l
7155    set selectedline $l
7156    set currentid $id
7157    if {$lastscrollrows < $numcommits} {
7158        setcanvscroll
7159    }
7160
7161    set y [expr {$canvy0 + $l * $linespc}]
7162    set ymax [lindex [$canv cget -scrollregion] 3]
7163    set ytop [expr {$y - $linespc - 1}]
7164    set ybot [expr {$y + $linespc + 1}]
7165    set wnow [$canv yview]
7166    set wtop [expr {[lindex $wnow 0] * $ymax}]
7167    set wbot [expr {[lindex $wnow 1] * $ymax}]
7168    set wh [expr {$wbot - $wtop}]
7169    set newtop $wtop
7170    if {$ytop < $wtop} {
7171        if {$ybot < $wtop} {
7172            set newtop [expr {$y - $wh / 2.0}]
7173        } else {
7174            set newtop $ytop
7175            if {$newtop > $wtop - $linespc} {
7176                set newtop [expr {$wtop - $linespc}]
7177            }
7178        }
7179    } elseif {$ybot > $wbot} {
7180        if {$ytop > $wbot} {
7181            set newtop [expr {$y - $wh / 2.0}]
7182        } else {
7183            set newtop [expr {$ybot - $wh}]
7184            if {$newtop < $wtop + $linespc} {
7185                set newtop [expr {$wtop + $linespc}]
7186            }
7187        }
7188    }
7189    if {$newtop != $wtop} {
7190        if {$newtop < 0} {
7191            set newtop 0
7192        }
7193        allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7194        drawvisible
7195    }
7196
7197    make_secsel $id
7198
7199    if {$isnew} {
7200        addtohistory [list selbyid $id 0] savecmitpos
7201    }
7202
7203    $sha1entry delete 0 end
7204    $sha1entry insert 0 $id
7205    if {$autoselect} {
7206        $sha1entry selection range 0 $autosellen
7207    }
7208    rhighlight_sel $id
7209
7210    $ctext conf -state normal
7211    clear_ctext
7212    set linknum 0
7213    if {![info exists commitinfo($id)]} {
7214        getcommit $id
7215    }
7216    set info $commitinfo($id)
7217    set date [formatdate [lindex $info 2]]
7218    $ctext insert end "[mc "Author"]: [lindex $info 1]  $date\n"
7219    set date [formatdate [lindex $info 4]]
7220    $ctext insert end "[mc "Committer"]: [lindex $info 3]  $date\n"
7221    if {[info exists idtags($id)]} {
7222        $ctext insert end [mc "Tags:"]
7223        foreach tag $idtags($id) {
7224            $ctext insert end " $tag"
7225        }
7226        $ctext insert end "\n"
7227    }
7228
7229    set headers {}
7230    set olds $parents($curview,$id)
7231    if {[llength $olds] > 1} {
7232        set np 0
7233        foreach p $olds {
7234            if {$np >= $mergemax} {
7235                set tag mmax
7236            } else {
7237                set tag m$np
7238            }
7239            $ctext insert end "[mc "Parent"]: " $tag
7240            appendwithlinks [commit_descriptor $p] {}
7241            incr np
7242        }
7243    } else {
7244        foreach p $olds {
7245            append headers "[mc "Parent"]: [commit_descriptor $p]"
7246        }
7247    }
7248
7249    foreach c $children($curview,$id) {
7250        append headers "[mc "Child"]:  [commit_descriptor $c]"
7251    }
7252
7253    # make anything that looks like a SHA1 ID be a clickable link
7254    appendwithlinks $headers {}
7255    if {$showneartags} {
7256        if {![info exists allcommits]} {
7257            getallcommits
7258        }
7259        $ctext insert end "[mc "Branch"]: "
7260        $ctext mark set branch "end -1c"
7261        $ctext mark gravity branch left
7262        $ctext insert end "\n[mc "Follows"]: "
7263        $ctext mark set follows "end -1c"
7264        $ctext mark gravity follows left
7265        $ctext insert end "\n[mc "Precedes"]: "
7266        $ctext mark set precedes "end -1c"
7267        $ctext mark gravity precedes left
7268        $ctext insert end "\n"
7269        dispneartags 1
7270    }
7271    $ctext insert end "\n"
7272    set comment [lindex $info 5]
7273    if {[string first "\r" $comment] >= 0} {
7274        set comment [string map {"\r" "\n    "} $comment]
7275    }
7276    appendwithlinks $comment {comment}
7277
7278    $ctext tag remove found 1.0 end
7279    $ctext conf -state disabled
7280    set commentend [$ctext index "end - 1c"]
7281
7282    set jump_to_here $desired_loc
7283    init_flist [mc "Comments"]
7284    if {$cmitmode eq "tree"} {
7285        gettree $id
7286    } elseif {$vinlinediff($curview) == 1} {
7287        showinlinediff $id
7288    } elseif {[llength $olds] <= 1} {
7289        startdiff $id
7290    } else {
7291        mergediff $id
7292    }
7293}
7294
7295proc selfirstline {} {
7296    unmarkmatches
7297    selectline 0 1
7298}
7299
7300proc sellastline {} {
7301    global numcommits
7302    unmarkmatches
7303    set l [expr {$numcommits - 1}]
7304    selectline $l 1
7305}
7306
7307proc selnextline {dir} {
7308    global selectedline
7309    focus .
7310    if {$selectedline eq {}} return
7311    set l [expr {$selectedline + $dir}]
7312    unmarkmatches
7313    selectline $l 1
7314}
7315
7316proc selnextpage {dir} {
7317    global canv linespc selectedline numcommits
7318
7319    set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7320    if {$lpp < 1} {
7321        set lpp 1
7322    }
7323    allcanvs yview scroll [expr {$dir * $lpp}] units
7324    drawvisible
7325    if {$selectedline eq {}} return
7326    set l [expr {$selectedline + $dir * $lpp}]
7327    if {$l < 0} {
7328        set l 0
7329    } elseif {$l >= $numcommits} {
7330        set l [expr $numcommits - 1]
7331    }
7332    unmarkmatches
7333    selectline $l 1
7334}
7335
7336proc unselectline {} {
7337    global selectedline currentid
7338
7339    set selectedline {}
7340    catch {unset currentid}
7341    allcanvs delete secsel
7342    rhighlight_none
7343}
7344
7345proc reselectline {} {
7346    global selectedline
7347
7348    if {$selectedline ne {}} {
7349        selectline $selectedline 0
7350    }
7351}
7352
7353proc addtohistory {cmd {saveproc {}}} {
7354    global history historyindex curview
7355
7356    unset_posvars
7357    save_position
7358    set elt [list $curview $cmd $saveproc {}]
7359    if {$historyindex > 0
7360        && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7361        return
7362    }
7363
7364    if {$historyindex < [llength $history]} {
7365        set history [lreplace $history $historyindex end $elt]
7366    } else {
7367        lappend history $elt
7368    }
7369    incr historyindex
7370    if {$historyindex > 1} {
7371        .tf.bar.leftbut conf -state normal
7372    } else {
7373        .tf.bar.leftbut conf -state disabled
7374    }
7375    .tf.bar.rightbut conf -state disabled
7376}
7377
7378# save the scrolling position of the diff display pane
7379proc save_position {} {
7380    global historyindex history
7381
7382    if {$historyindex < 1} return
7383    set hi [expr {$historyindex - 1}]
7384    set fn [lindex $history $hi 2]
7385    if {$fn ne {}} {
7386        lset history $hi 3 [eval $fn]
7387    }
7388}
7389
7390proc unset_posvars {} {
7391    global last_posvars
7392
7393    if {[info exists last_posvars]} {
7394        foreach {var val} $last_posvars {
7395            global $var
7396            catch {unset $var}
7397        }
7398        unset last_posvars
7399    }
7400}
7401
7402proc godo {elt} {
7403    global curview last_posvars
7404
7405    set view [lindex $elt 0]
7406    set cmd [lindex $elt 1]
7407    set pv [lindex $elt 3]
7408    if {$curview != $view} {
7409        showview $view
7410    }
7411    unset_posvars
7412    foreach {var val} $pv {
7413        global $var
7414        set $var $val
7415    }
7416    set last_posvars $pv
7417    eval $cmd
7418}
7419
7420proc goback {} {
7421    global history historyindex
7422    focus .
7423
7424    if {$historyindex > 1} {
7425        save_position
7426        incr historyindex -1
7427        godo [lindex $history [expr {$historyindex - 1}]]
7428        .tf.bar.rightbut conf -state normal
7429    }
7430    if {$historyindex <= 1} {
7431        .tf.bar.leftbut conf -state disabled
7432    }
7433}
7434
7435proc goforw {} {
7436    global history historyindex
7437    focus .
7438
7439    if {$historyindex < [llength $history]} {
7440        save_position
7441        set cmd [lindex $history $historyindex]
7442        incr historyindex
7443        godo $cmd
7444        .tf.bar.leftbut conf -state normal
7445    }
7446    if {$historyindex >= [llength $history]} {
7447        .tf.bar.rightbut conf -state disabled
7448    }
7449}
7450
7451proc gettree {id} {
7452    global treefilelist treeidlist diffids diffmergeid treepending
7453    global nullid nullid2
7454
7455    set diffids $id
7456    catch {unset diffmergeid}
7457    if {![info exists treefilelist($id)]} {
7458        if {![info exists treepending]} {
7459            if {$id eq $nullid} {
7460                set cmd [list | git ls-files]
7461            } elseif {$id eq $nullid2} {
7462                set cmd [list | git ls-files --stage -t]
7463            } else {
7464                set cmd [list | git ls-tree -r $id]
7465            }
7466            if {[catch {set gtf [open $cmd r]}]} {
7467                return
7468            }
7469            set treepending $id
7470            set treefilelist($id) {}
7471            set treeidlist($id) {}
7472            fconfigure $gtf -blocking 0 -encoding binary
7473            filerun $gtf [list gettreeline $gtf $id]
7474        }
7475    } else {
7476        setfilelist $id
7477    }
7478}
7479
7480proc gettreeline {gtf id} {
7481    global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7482
7483    set nl 0
7484    while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7485        if {$diffids eq $nullid} {
7486            set fname $line
7487        } else {
7488            set i [string first "\t" $line]
7489            if {$i < 0} continue
7490            set fname [string range $line [expr {$i+1}] end]
7491            set line [string range $line 0 [expr {$i-1}]]
7492            if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7493            set sha1 [lindex $line 2]
7494            lappend treeidlist($id) $sha1
7495        }
7496        if {[string index $fname 0] eq "\""} {
7497            set fname [lindex $fname 0]
7498        }
7499        set fname [encoding convertfrom $fname]
7500        lappend treefilelist($id) $fname
7501    }
7502    if {![eof $gtf]} {
7503        return [expr {$nl >= 1000? 2: 1}]
7504    }
7505    close $gtf
7506    unset treepending
7507    if {$cmitmode ne "tree"} {
7508        if {![info exists diffmergeid]} {
7509            gettreediffs $diffids
7510        }
7511    } elseif {$id ne $diffids} {
7512        gettree $diffids
7513    } else {
7514        setfilelist $id
7515    }
7516    return 0
7517}
7518
7519proc showfile {f} {
7520    global treefilelist treeidlist diffids nullid nullid2
7521    global ctext_file_names ctext_file_lines
7522    global ctext commentend
7523
7524    set i [lsearch -exact $treefilelist($diffids) $f]
7525    if {$i < 0} {
7526        puts "oops, $f not in list for id $diffids"
7527        return
7528    }
7529    if {$diffids eq $nullid} {
7530        if {[catch {set bf [open $f r]} err]} {
7531            puts "oops, can't read $f: $err"
7532            return
7533        }
7534    } else {
7535        set blob [lindex $treeidlist($diffids) $i]
7536        if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7537            puts "oops, error reading blob $blob: $err"
7538            return
7539        }
7540    }
7541    fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7542    filerun $bf [list getblobline $bf $diffids]
7543    $ctext config -state normal
7544    clear_ctext $commentend
7545    lappend ctext_file_names $f
7546    lappend ctext_file_lines [lindex [split $commentend "."] 0]
7547    $ctext insert end "\n"
7548    $ctext insert end "$f\n" filesep
7549    $ctext config -state disabled
7550    $ctext yview $commentend
7551    settabs 0
7552}
7553
7554proc getblobline {bf id} {
7555    global diffids cmitmode ctext
7556
7557    if {$id ne $diffids || $cmitmode ne "tree"} {
7558        catch {close $bf}
7559        return 0
7560    }
7561    $ctext config -state normal
7562    set nl 0
7563    while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7564        $ctext insert end "$line\n"
7565    }
7566    if {[eof $bf]} {
7567        global jump_to_here ctext_file_names commentend
7568
7569        # delete last newline
7570        $ctext delete "end - 2c" "end - 1c"
7571        close $bf
7572        if {$jump_to_here ne {} &&
7573            [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7574            set lnum [expr {[lindex $jump_to_here 1] +
7575                            [lindex [split $commentend .] 0]}]
7576            mark_ctext_line $lnum
7577        }
7578        $ctext config -state disabled
7579        return 0
7580    }
7581    $ctext config -state disabled
7582    return [expr {$nl >= 1000? 2: 1}]
7583}
7584
7585proc mark_ctext_line {lnum} {
7586    global ctext markbgcolor
7587
7588    $ctext tag delete omark
7589    $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7590    $ctext tag conf omark -background $markbgcolor
7591    $ctext see $lnum.0
7592}
7593
7594proc mergediff {id} {
7595    global diffmergeid
7596    global diffids treediffs
7597    global parents curview
7598
7599    set diffmergeid $id
7600    set diffids $id
7601    set treediffs($id) {}
7602    set np [llength $parents($curview,$id)]
7603    settabs $np
7604    getblobdiffs $id
7605}
7606
7607proc startdiff {ids} {
7608    global treediffs diffids treepending diffmergeid nullid nullid2
7609
7610    settabs 1
7611    set diffids $ids
7612    catch {unset diffmergeid}
7613    if {![info exists treediffs($ids)] ||
7614        [lsearch -exact $ids $nullid] >= 0 ||
7615        [lsearch -exact $ids $nullid2] >= 0} {
7616        if {![info exists treepending]} {
7617            gettreediffs $ids
7618        }
7619    } else {
7620        addtocflist $ids
7621    }
7622}
7623
7624proc showinlinediff {ids} {
7625    global commitinfo commitdata ctext
7626    global treediffs
7627
7628    set info $commitinfo($ids)
7629    set diff [lindex $info 7]
7630    set difflines [split $diff "\n"]
7631
7632    initblobdiffvars
7633    set treediff {}
7634
7635    set inhdr 0
7636    foreach line $difflines {
7637        if {![string compare -length 5 "diff " $line]} {
7638            set inhdr 1
7639        } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7640            # offset also accounts for the b/ prefix
7641            lappend treediff [string range $line 6 end]
7642            set inhdr 0
7643        }
7644    }
7645
7646    set treediffs($ids) $treediff
7647    add_flist $treediff
7648
7649    $ctext conf -state normal
7650    foreach line $difflines {
7651        parseblobdiffline $ids $line
7652    }
7653    maybe_scroll_ctext 1
7654    $ctext conf -state disabled
7655}
7656
7657# If the filename (name) is under any of the passed filter paths
7658# then return true to include the file in the listing.
7659proc path_filter {filter name} {
7660    set worktree [gitworktree]
7661    foreach p $filter {
7662        set fq_p [file normalize $p]
7663        set fq_n [file normalize [file join $worktree $name]]
7664        if {[string match [file normalize $fq_p]* $fq_n]} {
7665            return 1
7666        }
7667    }
7668    return 0
7669}
7670
7671proc addtocflist {ids} {
7672    global treediffs
7673
7674    add_flist $treediffs($ids)
7675    getblobdiffs $ids
7676}
7677
7678proc diffcmd {ids flags} {
7679    global log_showroot nullid nullid2
7680
7681    set i [lsearch -exact $ids $nullid]
7682    set j [lsearch -exact $ids $nullid2]
7683    if {$i >= 0} {
7684        if {[llength $ids] > 1 && $j < 0} {
7685            # comparing working directory with some specific revision
7686            set cmd [concat | git diff-index $flags]
7687            if {$i == 0} {
7688                lappend cmd -R [lindex $ids 1]
7689            } else {
7690                lappend cmd [lindex $ids 0]
7691            }
7692        } else {
7693            # comparing working directory with index
7694            set cmd [concat | git diff-files $flags]
7695            if {$j == 1} {
7696                lappend cmd -R
7697            }
7698        }
7699    } elseif {$j >= 0} {
7700        set cmd [concat | git diff-index --cached $flags]
7701        if {[llength $ids] > 1} {
7702            # comparing index with specific revision
7703            if {$j == 0} {
7704                lappend cmd -R [lindex $ids 1]
7705            } else {
7706                lappend cmd [lindex $ids 0]
7707            }
7708        } else {
7709            # comparing index with HEAD
7710            lappend cmd HEAD
7711        }
7712    } else {
7713        if {$log_showroot} {
7714            lappend flags --root
7715        }
7716        set cmd [concat | git diff-tree -r $flags $ids]
7717    }
7718    return $cmd
7719}
7720
7721proc gettreediffs {ids} {
7722    global treediff treepending limitdiffs vfilelimit curview
7723
7724    set cmd [diffcmd $ids {--no-commit-id}]
7725    if {$limitdiffs && $vfilelimit($curview) ne {}} {
7726            set cmd [concat $cmd -- $vfilelimit($curview)]
7727    }
7728    if {[catch {set gdtf [open $cmd r]}]} return
7729
7730    set treepending $ids
7731    set treediff {}
7732    fconfigure $gdtf -blocking 0 -encoding binary
7733    filerun $gdtf [list gettreediffline $gdtf $ids]
7734}
7735
7736proc gettreediffline {gdtf ids} {
7737    global treediff treediffs treepending diffids diffmergeid
7738    global cmitmode vfilelimit curview limitdiffs perfile_attrs
7739
7740    set nr 0
7741    set sublist {}
7742    set max 1000
7743    if {$perfile_attrs} {
7744        # cache_gitattr is slow, and even slower on win32 where we
7745        # have to invoke it for only about 30 paths at a time
7746        set max 500
7747        if {[tk windowingsystem] == "win32"} {
7748            set max 120
7749        }
7750    }
7751    while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7752        set i [string first "\t" $line]
7753        if {$i >= 0} {
7754            set file [string range $line [expr {$i+1}] end]
7755            if {[string index $file 0] eq "\""} {
7756                set file [lindex $file 0]
7757            }
7758            set file [encoding convertfrom $file]
7759            if {$file ne [lindex $treediff end]} {
7760                lappend treediff $file
7761                lappend sublist $file
7762            }
7763        }
7764    }
7765    if {$perfile_attrs} {
7766        cache_gitattr encoding $sublist
7767    }
7768    if {![eof $gdtf]} {
7769        return [expr {$nr >= $max? 2: 1}]
7770    }
7771    close $gdtf
7772    set treediffs($ids) $treediff
7773    unset treepending
7774    if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7775        gettree $diffids
7776    } elseif {$ids != $diffids} {
7777        if {![info exists diffmergeid]} {
7778            gettreediffs $diffids
7779        }
7780    } else {
7781        addtocflist $ids
7782    }
7783    return 0
7784}
7785
7786# empty string or positive integer
7787proc diffcontextvalidate {v} {
7788    return [regexp {^(|[1-9][0-9]*)$} $v]
7789}
7790
7791proc diffcontextchange {n1 n2 op} {
7792    global diffcontextstring diffcontext
7793
7794    if {[string is integer -strict $diffcontextstring]} {
7795        if {$diffcontextstring >= 0} {
7796            set diffcontext $diffcontextstring
7797            reselectline
7798        }
7799    }
7800}
7801
7802proc changeignorespace {} {
7803    reselectline
7804}
7805
7806proc changeworddiff {name ix op} {
7807    reselectline
7808}
7809
7810proc initblobdiffvars {} {
7811    global diffencoding targetline diffnparents
7812    global diffinhdr currdiffsubmod diffseehere
7813    set targetline {}
7814    set diffnparents 0
7815    set diffinhdr 0
7816    set diffencoding [get_path_encoding {}]
7817    set currdiffsubmod ""
7818    set diffseehere -1
7819}
7820
7821proc getblobdiffs {ids} {
7822    global blobdifffd diffids env
7823    global treediffs
7824    global diffcontext
7825    global ignorespace
7826    global worddiff
7827    global limitdiffs vfilelimit curview
7828    global git_version
7829
7830    set textconv {}
7831    if {[package vcompare $git_version "1.6.1"] >= 0} {
7832        set textconv "--textconv"
7833    }
7834    set submodule {}
7835    if {[package vcompare $git_version "1.6.6"] >= 0} {
7836        set submodule "--submodule"
7837    }
7838    set cmd [diffcmd $ids "-p $textconv $submodule  -C --cc --no-commit-id -U$diffcontext"]
7839    if {$ignorespace} {
7840        append cmd " -w"
7841    }
7842    if {$worddiff ne [mc "Line diff"]} {
7843        append cmd " --word-diff=porcelain"
7844    }
7845    if {$limitdiffs && $vfilelimit($curview) ne {}} {
7846        set cmd [concat $cmd -- $vfilelimit($curview)]
7847    }
7848    if {[catch {set bdf [open $cmd r]} err]} {
7849        error_popup [mc "Error getting diffs: %s" $err]
7850        return
7851    }
7852    fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7853    set blobdifffd($ids) $bdf
7854    initblobdiffvars
7855    filerun $bdf [list getblobdiffline $bdf $diffids]
7856}
7857
7858proc savecmitpos {} {
7859    global ctext cmitmode
7860
7861    if {$cmitmode eq "tree"} {
7862        return {}
7863    }
7864    return [list target_scrollpos [$ctext index @0,0]]
7865}
7866
7867proc savectextpos {} {
7868    global ctext
7869
7870    return [list target_scrollpos [$ctext index @0,0]]
7871}
7872
7873proc maybe_scroll_ctext {ateof} {
7874    global ctext target_scrollpos
7875
7876    if {![info exists target_scrollpos]} return
7877    if {!$ateof} {
7878        set nlines [expr {[winfo height $ctext]
7879                          / [font metrics textfont -linespace]}]
7880        if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7881    }
7882    $ctext yview $target_scrollpos
7883    unset target_scrollpos
7884}
7885
7886proc setinlist {var i val} {
7887    global $var
7888
7889    while {[llength [set $var]] < $i} {
7890        lappend $var {}
7891    }
7892    if {[llength [set $var]] == $i} {
7893        lappend $var $val
7894    } else {
7895        lset $var $i $val
7896    }
7897}
7898
7899proc makediffhdr {fname ids} {
7900    global ctext curdiffstart treediffs diffencoding
7901    global ctext_file_names jump_to_here targetline diffline
7902
7903    set fname [encoding convertfrom $fname]
7904    set diffencoding [get_path_encoding $fname]
7905    set i [lsearch -exact $treediffs($ids) $fname]
7906    if {$i >= 0} {
7907        setinlist difffilestart $i $curdiffstart
7908    }
7909    lset ctext_file_names end $fname
7910    set l [expr {(78 - [string length $fname]) / 2}]
7911    set pad [string range "----------------------------------------" 1 $l]
7912    $ctext insert $curdiffstart "$pad $fname $pad" filesep
7913    set targetline {}
7914    if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7915        set targetline [lindex $jump_to_here 1]
7916    }
7917    set diffline 0
7918}
7919
7920proc blobdiffmaybeseehere {ateof} {
7921    global diffseehere
7922    if {$diffseehere >= 0} {
7923        mark_ctext_line [lindex [split $diffseehere .] 0]
7924    }
7925    maybe_scroll_ctext ateof
7926}
7927
7928proc getblobdiffline {bdf ids} {
7929    global diffids blobdifffd
7930    global ctext
7931
7932    set nr 0
7933    $ctext conf -state normal
7934    while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
7935        if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
7936            catch {close $bdf}
7937            return 0
7938        }
7939        parseblobdiffline $ids $line
7940    }
7941    $ctext conf -state disabled
7942    blobdiffmaybeseehere [eof $bdf]
7943    if {[eof $bdf]} {
7944        catch {close $bdf}
7945        return 0
7946    }
7947    return [expr {$nr >= 1000? 2: 1}]
7948}
7949
7950proc parseblobdiffline {ids line} {
7951    global ctext curdiffstart
7952    global diffnexthead diffnextnote difffilestart
7953    global ctext_file_names ctext_file_lines
7954    global diffinhdr treediffs mergemax diffnparents
7955    global diffencoding jump_to_here targetline diffline currdiffsubmod
7956    global worddiff diffseehere
7957
7958    if {![string compare -length 5 "diff " $line]} {
7959        if {![regexp {^diff (--cc|--git) } $line m type]} {
7960            set line [encoding convertfrom $line]
7961            $ctext insert end "$line\n" hunksep
7962            continue
7963        }
7964        # start of a new file
7965        set diffinhdr 1
7966        $ctext insert end "\n"
7967        set curdiffstart [$ctext index "end - 1c"]
7968        lappend ctext_file_names ""
7969        lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
7970        $ctext insert end "\n" filesep
7971
7972        if {$type eq "--cc"} {
7973            # start of a new file in a merge diff
7974            set fname [string range $line 10 end]
7975            if {[lsearch -exact $treediffs($ids) $fname] < 0} {
7976                lappend treediffs($ids) $fname
7977                add_flist [list $fname]
7978            }
7979
7980        } else {
7981            set line [string range $line 11 end]
7982            # If the name hasn't changed the length will be odd,
7983            # the middle char will be a space, and the two bits either
7984            # side will be a/name and b/name, or "a/name" and "b/name".
7985            # If the name has changed we'll get "rename from" and
7986            # "rename to" or "copy from" and "copy to" lines following
7987            # this, and we'll use them to get the filenames.
7988            # This complexity is necessary because spaces in the
7989            # filename(s) don't get escaped.
7990            set l [string length $line]
7991            set i [expr {$l / 2}]
7992            if {!(($l & 1) && [string index $line $i] eq " " &&
7993                  [string range $line 2 [expr {$i - 1}]] eq \
7994                      [string range $line [expr {$i + 3}] end])} {
7995                return
7996            }
7997            # unescape if quoted and chop off the a/ from the front
7998            if {[string index $line 0] eq "\""} {
7999                set fname [string range [lindex $line 0] 2 end]
8000            } else {
8001                set fname [string range $line 2 [expr {$i - 1}]]
8002            }
8003        }
8004        makediffhdr $fname $ids
8005
8006    } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8007        set fname [encoding convertfrom [string range $line 16 end]]
8008        $ctext insert end "\n"
8009        set curdiffstart [$ctext index "end - 1c"]
8010        lappend ctext_file_names $fname
8011        lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8012        $ctext insert end "$line\n" filesep
8013        set i [lsearch -exact $treediffs($ids) $fname]
8014        if {$i >= 0} {
8015            setinlist difffilestart $i $curdiffstart
8016        }
8017
8018    } elseif {![string compare -length 2 "@@" $line]} {
8019        regexp {^@@+} $line ats
8020        set line [encoding convertfrom $diffencoding $line]
8021        $ctext insert end "$line\n" hunksep
8022        if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8023            set diffline $nl
8024        }
8025        set diffnparents [expr {[string length $ats] - 1}]
8026        set diffinhdr 0
8027
8028    } elseif {![string compare -length 10 "Submodule " $line]} {
8029        # start of a new submodule
8030        if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8031            set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8032        } else {
8033            set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8034        }
8035        if {$currdiffsubmod != $fname} {
8036            $ctext insert end "\n";     # Add newline after commit message
8037        }
8038        set curdiffstart [$ctext index "end - 1c"]
8039        lappend ctext_file_names ""
8040        if {$currdiffsubmod != $fname} {
8041            lappend ctext_file_lines $fname
8042            makediffhdr $fname $ids
8043            set currdiffsubmod $fname
8044            $ctext insert end "\n$line\n" filesep
8045        } else {
8046            $ctext insert end "$line\n" filesep
8047        }
8048    } elseif {![string compare -length 3 "  >" $line]} {
8049        set $currdiffsubmod ""
8050        set line [encoding convertfrom $diffencoding $line]
8051        $ctext insert end "$line\n" dresult
8052    } elseif {![string compare -length 3 "  <" $line]} {
8053        set $currdiffsubmod ""
8054        set line [encoding convertfrom $diffencoding $line]
8055        $ctext insert end "$line\n" d0
8056    } elseif {$diffinhdr} {
8057        if {![string compare -length 12 "rename from " $line]} {
8058            set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8059            if {[string index $fname 0] eq "\""} {
8060                set fname [lindex $fname 0]
8061            }
8062            set fname [encoding convertfrom $fname]
8063            set i [lsearch -exact $treediffs($ids) $fname]
8064            if {$i >= 0} {
8065                setinlist difffilestart $i $curdiffstart
8066            }
8067        } elseif {![string compare -length 10 $line "rename to "] ||
8068                  ![string compare -length 8 $line "copy to "]} {
8069            set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8070            if {[string index $fname 0] eq "\""} {
8071                set fname [lindex $fname 0]
8072            }
8073            makediffhdr $fname $ids
8074        } elseif {[string compare -length 3 $line "---"] == 0} {
8075            # do nothing
8076            return
8077        } elseif {[string compare -length 3 $line "+++"] == 0} {
8078            set diffinhdr 0
8079            return
8080        }
8081        $ctext insert end "$line\n" filesep
8082
8083    } else {
8084        set line [string map {\x1A ^Z} \
8085                      [encoding convertfrom $diffencoding $line]]
8086        # parse the prefix - one ' ', '-' or '+' for each parent
8087        set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8088        set tag [expr {$diffnparents > 1? "m": "d"}]
8089        set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8090        set words_pre_markup ""
8091        set words_post_markup ""
8092        if {[string trim $prefix " -+"] eq {}} {
8093            # prefix only has " ", "-" and "+" in it: normal diff line
8094            set num [string first "-" $prefix]
8095            if {$dowords} {
8096                set line [string range $line 1 end]
8097            }
8098            if {$num >= 0} {
8099                # removed line, first parent with line is $num
8100                if {$num >= $mergemax} {
8101                    set num "max"
8102                }
8103                if {$dowords && $worddiff eq [mc "Markup words"]} {
8104                    $ctext insert end "\[-$line-\]" $tag$num
8105                } else {
8106                    $ctext insert end "$line" $tag$num
8107                }
8108                if {!$dowords} {
8109                    $ctext insert end "\n" $tag$num
8110                }
8111            } else {
8112                set tags {}
8113                if {[string first "+" $prefix] >= 0} {
8114                    # added line
8115                    lappend tags ${tag}result
8116                    if {$diffnparents > 1} {
8117                        set num [string first " " $prefix]
8118                        if {$num >= 0} {
8119                            if {$num >= $mergemax} {
8120                                set num "max"
8121                            }
8122                            lappend tags m$num
8123                        }
8124                    }
8125                    set words_pre_markup "{+"
8126                    set words_post_markup "+}"
8127                }
8128                if {$targetline ne {}} {
8129                    if {$diffline == $targetline} {
8130                        set diffseehere [$ctext index "end - 1 chars"]
8131                        set targetline {}
8132                    } else {
8133                        incr diffline
8134                    }
8135                }
8136                if {$dowords && $worddiff eq [mc "Markup words"]} {
8137                    $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8138                } else {
8139                    $ctext insert end "$line" $tags
8140                }
8141                if {!$dowords} {
8142                    $ctext insert end "\n" $tags
8143                }
8144            }
8145        } elseif {$dowords && $prefix eq "~"} {
8146            $ctext insert end "\n" {}
8147        } else {
8148            # "\ No newline at end of file",
8149            # or something else we don't recognize
8150            $ctext insert end "$line\n" hunksep
8151        }
8152    }
8153}
8154
8155proc changediffdisp {} {
8156    global ctext diffelide
8157
8158    $ctext tag conf d0 -elide [lindex $diffelide 0]
8159    $ctext tag conf dresult -elide [lindex $diffelide 1]
8160}
8161
8162proc highlightfile {cline} {
8163    global cflist cflist_top
8164
8165    if {![info exists cflist_top]} return
8166
8167    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8168    $cflist tag add highlight $cline.0 "$cline.0 lineend"
8169    $cflist see $cline.0
8170    set cflist_top $cline
8171}
8172
8173proc highlightfile_for_scrollpos {topidx} {
8174    global cmitmode difffilestart
8175
8176    if {$cmitmode eq "tree"} return
8177    if {![info exists difffilestart]} return
8178
8179    set top [lindex [split $topidx .] 0]
8180    if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8181        highlightfile 0
8182    } else {
8183        highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8184    }
8185}
8186
8187proc prevfile {} {
8188    global difffilestart ctext cmitmode
8189
8190    if {$cmitmode eq "tree"} return
8191    set prev 0.0
8192    set here [$ctext index @0,0]
8193    foreach loc $difffilestart {
8194        if {[$ctext compare $loc >= $here]} {
8195            $ctext yview $prev
8196            return
8197        }
8198        set prev $loc
8199    }
8200    $ctext yview $prev
8201}
8202
8203proc nextfile {} {
8204    global difffilestart ctext cmitmode
8205
8206    if {$cmitmode eq "tree"} return
8207    set here [$ctext index @0,0]
8208    foreach loc $difffilestart {
8209        if {[$ctext compare $loc > $here]} {
8210            $ctext yview $loc
8211            return
8212        }
8213    }
8214}
8215
8216proc clear_ctext {{first 1.0}} {
8217    global ctext smarktop smarkbot
8218    global ctext_file_names ctext_file_lines
8219    global pendinglinks
8220
8221    set l [lindex [split $first .] 0]
8222    if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8223        set smarktop $l
8224    }
8225    if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8226        set smarkbot $l
8227    }
8228    $ctext delete $first end
8229    if {$first eq "1.0"} {
8230        catch {unset pendinglinks}
8231    }
8232    set ctext_file_names {}
8233    set ctext_file_lines {}
8234}
8235
8236proc settabs {{firstab {}}} {
8237    global firsttabstop tabstop ctext have_tk85
8238
8239    if {$firstab ne {} && $have_tk85} {
8240        set firsttabstop $firstab
8241    }
8242    set w [font measure textfont "0"]
8243    if {$firsttabstop != 0} {
8244        $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8245                               [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8246    } elseif {$have_tk85 || $tabstop != 8} {
8247        $ctext conf -tabs [expr {$tabstop * $w}]
8248    } else {
8249        $ctext conf -tabs {}
8250    }
8251}
8252
8253proc incrsearch {name ix op} {
8254    global ctext searchstring searchdirn
8255
8256    if {[catch {$ctext index anchor}]} {
8257        # no anchor set, use start of selection, or of visible area
8258        set sel [$ctext tag ranges sel]
8259        if {$sel ne {}} {
8260            $ctext mark set anchor [lindex $sel 0]
8261        } elseif {$searchdirn eq "-forwards"} {
8262            $ctext mark set anchor @0,0
8263        } else {
8264            $ctext mark set anchor @0,[winfo height $ctext]
8265        }
8266    }
8267    if {$searchstring ne {}} {
8268        set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8269        if {$here ne {}} {
8270            $ctext see $here
8271            set mend "$here + $mlen c"
8272            $ctext tag remove sel 1.0 end
8273            $ctext tag add sel $here $mend
8274            suppress_highlighting_file_for_current_scrollpos
8275            highlightfile_for_scrollpos $here
8276        }
8277    }
8278    rehighlight_search_results
8279}
8280
8281proc dosearch {} {
8282    global sstring ctext searchstring searchdirn
8283
8284    focus $sstring
8285    $sstring icursor end
8286    set searchdirn -forwards
8287    if {$searchstring ne {}} {
8288        set sel [$ctext tag ranges sel]
8289        if {$sel ne {}} {
8290            set start "[lindex $sel 0] + 1c"
8291        } elseif {[catch {set start [$ctext index anchor]}]} {
8292            set start "@0,0"
8293        }
8294        set match [$ctext search -count mlen -- $searchstring $start]
8295        $ctext tag remove sel 1.0 end
8296        if {$match eq {}} {
8297            bell
8298            return
8299        }
8300        $ctext see $match
8301        suppress_highlighting_file_for_current_scrollpos
8302        highlightfile_for_scrollpos $match
8303        set mend "$match + $mlen c"
8304        $ctext tag add sel $match $mend
8305        $ctext mark unset anchor
8306        rehighlight_search_results
8307    }
8308}
8309
8310proc dosearchback {} {
8311    global sstring ctext searchstring searchdirn
8312
8313    focus $sstring
8314    $sstring icursor end
8315    set searchdirn -backwards
8316    if {$searchstring ne {}} {
8317        set sel [$ctext tag ranges sel]
8318        if {$sel ne {}} {
8319            set start [lindex $sel 0]
8320        } elseif {[catch {set start [$ctext index anchor]}]} {
8321            set start @0,[winfo height $ctext]
8322        }
8323        set match [$ctext search -backwards -count ml -- $searchstring $start]
8324        $ctext tag remove sel 1.0 end
8325        if {$match eq {}} {
8326            bell
8327            return
8328        }
8329        $ctext see $match
8330        suppress_highlighting_file_for_current_scrollpos
8331        highlightfile_for_scrollpos $match
8332        set mend "$match + $ml c"
8333        $ctext tag add sel $match $mend
8334        $ctext mark unset anchor
8335        rehighlight_search_results
8336    }
8337}
8338
8339proc rehighlight_search_results {} {
8340    global ctext searchstring
8341
8342    $ctext tag remove found 1.0 end
8343    $ctext tag remove currentsearchhit 1.0 end
8344
8345    if {$searchstring ne {}} {
8346        searchmarkvisible 1
8347    }
8348}
8349
8350proc searchmark {first last} {
8351    global ctext searchstring
8352
8353    set sel [$ctext tag ranges sel]
8354
8355    set mend $first.0
8356    while {1} {
8357        set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8358        if {$match eq {}} break
8359        set mend "$match + $mlen c"
8360        if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8361            $ctext tag add currentsearchhit $match $mend
8362        } else {
8363            $ctext tag add found $match $mend
8364        }
8365    }
8366}
8367
8368proc searchmarkvisible {doall} {
8369    global ctext smarktop smarkbot
8370
8371    set topline [lindex [split [$ctext index @0,0] .] 0]
8372    set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8373    if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8374        # no overlap with previous
8375        searchmark $topline $botline
8376        set smarktop $topline
8377        set smarkbot $botline
8378    } else {
8379        if {$topline < $smarktop} {
8380            searchmark $topline [expr {$smarktop-1}]
8381            set smarktop $topline
8382        }
8383        if {$botline > $smarkbot} {
8384            searchmark [expr {$smarkbot+1}] $botline
8385            set smarkbot $botline
8386        }
8387    }
8388}
8389
8390proc suppress_highlighting_file_for_current_scrollpos {} {
8391    global ctext suppress_highlighting_file_for_this_scrollpos
8392
8393    set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8394}
8395
8396proc scrolltext {f0 f1} {
8397    global searchstring cmitmode ctext
8398    global suppress_highlighting_file_for_this_scrollpos
8399
8400    set topidx [$ctext index @0,0]
8401    if {![info exists suppress_highlighting_file_for_this_scrollpos]
8402        || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8403        highlightfile_for_scrollpos $topidx
8404    }
8405
8406    catch {unset suppress_highlighting_file_for_this_scrollpos}
8407
8408    .bleft.bottom.sb set $f0 $f1
8409    if {$searchstring ne {}} {
8410        searchmarkvisible 0
8411    }
8412}
8413
8414proc setcoords {} {
8415    global linespc charspc canvx0 canvy0
8416    global xspc1 xspc2 lthickness
8417
8418    set linespc [font metrics mainfont -linespace]
8419    set charspc [font measure mainfont "m"]
8420    set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8421    set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8422    set lthickness [expr {int($linespc / 9) + 1}]
8423    set xspc1(0) $linespc
8424    set xspc2 $linespc
8425}
8426
8427proc redisplay {} {
8428    global canv
8429    global selectedline
8430
8431    set ymax [lindex [$canv cget -scrollregion] 3]
8432    if {$ymax eq {} || $ymax == 0} return
8433    set span [$canv yview]
8434    clear_display
8435    setcanvscroll
8436    allcanvs yview moveto [lindex $span 0]
8437    drawvisible
8438    if {$selectedline ne {}} {
8439        selectline $selectedline 0
8440        allcanvs yview moveto [lindex $span 0]
8441    }
8442}
8443
8444proc parsefont {f n} {
8445    global fontattr
8446
8447    set fontattr($f,family) [lindex $n 0]
8448    set s [lindex $n 1]
8449    if {$s eq {} || $s == 0} {
8450        set s 10
8451    } elseif {$s < 0} {
8452        set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8453    }
8454    set fontattr($f,size) $s
8455    set fontattr($f,weight) normal
8456    set fontattr($f,slant) roman
8457    foreach style [lrange $n 2 end] {
8458        switch -- $style {
8459            "normal" -
8460            "bold"   {set fontattr($f,weight) $style}
8461            "roman" -
8462            "italic" {set fontattr($f,slant) $style}
8463        }
8464    }
8465}
8466
8467proc fontflags {f {isbold 0}} {
8468    global fontattr
8469
8470    return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8471                -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8472                -slant $fontattr($f,slant)]
8473}
8474
8475proc fontname {f} {
8476    global fontattr
8477
8478    set n [list $fontattr($f,family) $fontattr($f,size)]
8479    if {$fontattr($f,weight) eq "bold"} {
8480        lappend n "bold"
8481    }
8482    if {$fontattr($f,slant) eq "italic"} {
8483        lappend n "italic"
8484    }
8485    return $n
8486}
8487
8488proc incrfont {inc} {
8489    global mainfont textfont ctext canv cflist showrefstop
8490    global stopped entries fontattr
8491
8492    unmarkmatches
8493    set s $fontattr(mainfont,size)
8494    incr s $inc
8495    if {$s < 1} {
8496        set s 1
8497    }
8498    set fontattr(mainfont,size) $s
8499    font config mainfont -size $s
8500    font config mainfontbold -size $s
8501    set mainfont [fontname mainfont]
8502    set s $fontattr(textfont,size)
8503    incr s $inc
8504    if {$s < 1} {
8505        set s 1
8506    }
8507    set fontattr(textfont,size) $s
8508    font config textfont -size $s
8509    font config textfontbold -size $s
8510    set textfont [fontname textfont]
8511    setcoords
8512    settabs
8513    redisplay
8514}
8515
8516proc clearsha1 {} {
8517    global sha1entry sha1string
8518    if {[string length $sha1string] == 40} {
8519        $sha1entry delete 0 end
8520    }
8521}
8522
8523proc sha1change {n1 n2 op} {
8524    global sha1string currentid sha1but
8525    if {$sha1string == {}
8526        || ([info exists currentid] && $sha1string == $currentid)} {
8527        set state disabled
8528    } else {
8529        set state normal
8530    }
8531    if {[$sha1but cget -state] == $state} return
8532    if {$state == "normal"} {
8533        $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8534    } else {
8535        $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8536    }
8537}
8538
8539proc gotocommit {} {
8540    global sha1string tagids headids curview varcid
8541
8542    if {$sha1string == {}
8543        || ([info exists currentid] && $sha1string == $currentid)} return
8544    if {[info exists tagids($sha1string)]} {
8545        set id $tagids($sha1string)
8546    } elseif {[info exists headids($sha1string)]} {
8547        set id $headids($sha1string)
8548    } else {
8549        set id [string tolower $sha1string]
8550        if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8551            set matches [longid $id]
8552            if {$matches ne {}} {
8553                if {[llength $matches] > 1} {
8554                    error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8555                    return
8556                }
8557                set id [lindex $matches 0]
8558            }
8559        } else {
8560            if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8561                error_popup [mc "Revision %s is not known" $sha1string]
8562                return
8563            }
8564        }
8565    }
8566    if {[commitinview $id $curview]} {
8567        selectline [rowofcommit $id] 1
8568        return
8569    }
8570    if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8571        set msg [mc "SHA1 id %s is not known" $sha1string]
8572    } else {
8573        set msg [mc "Revision %s is not in the current view" $sha1string]
8574    }
8575    error_popup $msg
8576}
8577
8578proc lineenter {x y id} {
8579    global hoverx hovery hoverid hovertimer
8580    global commitinfo canv
8581
8582    if {![info exists commitinfo($id)] && ![getcommit $id]} return
8583    set hoverx $x
8584    set hovery $y
8585    set hoverid $id
8586    if {[info exists hovertimer]} {
8587        after cancel $hovertimer
8588    }
8589    set hovertimer [after 500 linehover]
8590    $canv delete hover
8591}
8592
8593proc linemotion {x y id} {
8594    global hoverx hovery hoverid hovertimer
8595
8596    if {[info exists hoverid] && $id == $hoverid} {
8597        set hoverx $x
8598        set hovery $y
8599        if {[info exists hovertimer]} {
8600            after cancel $hovertimer
8601        }
8602        set hovertimer [after 500 linehover]
8603    }
8604}
8605
8606proc lineleave {id} {
8607    global hoverid hovertimer canv
8608
8609    if {[info exists hoverid] && $id == $hoverid} {
8610        $canv delete hover
8611        if {[info exists hovertimer]} {
8612            after cancel $hovertimer
8613            unset hovertimer
8614        }
8615        unset hoverid
8616    }
8617}
8618
8619proc linehover {} {
8620    global hoverx hovery hoverid hovertimer
8621    global canv linespc lthickness
8622    global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8623
8624    global commitinfo
8625
8626    set text [lindex $commitinfo($hoverid) 0]
8627    set ymax [lindex [$canv cget -scrollregion] 3]
8628    if {$ymax == {}} return
8629    set yfrac [lindex [$canv yview] 0]
8630    set x [expr {$hoverx + 2 * $linespc}]
8631    set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8632    set x0 [expr {$x - 2 * $lthickness}]
8633    set y0 [expr {$y - 2 * $lthickness}]
8634    set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8635    set y1 [expr {$y + $linespc + 2 * $lthickness}]
8636    set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8637               -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8638               -width 1 -tags hover]
8639    $canv raise $t
8640    set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8641               -font mainfont -fill $linehoverfgcolor]
8642    $canv raise $t
8643}
8644
8645proc clickisonarrow {id y} {
8646    global lthickness
8647
8648    set ranges [rowranges $id]
8649    set thresh [expr {2 * $lthickness + 6}]
8650    set n [expr {[llength $ranges] - 1}]
8651    for {set i 1} {$i < $n} {incr i} {
8652        set row [lindex $ranges $i]
8653        if {abs([yc $row] - $y) < $thresh} {
8654            return $i
8655        }
8656    }
8657    return {}
8658}
8659
8660proc arrowjump {id n y} {
8661    global canv
8662
8663    # 1 <-> 2, 3 <-> 4, etc...
8664    set n [expr {(($n - 1) ^ 1) + 1}]
8665    set row [lindex [rowranges $id] $n]
8666    set yt [yc $row]
8667    set ymax [lindex [$canv cget -scrollregion] 3]
8668    if {$ymax eq {} || $ymax <= 0} return
8669    set view [$canv yview]
8670    set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8671    set yfrac [expr {$yt / $ymax - $yspan / 2}]
8672    if {$yfrac < 0} {
8673        set yfrac 0
8674    }
8675    allcanvs yview moveto $yfrac
8676}
8677
8678proc lineclick {x y id isnew} {
8679    global ctext commitinfo children canv thickerline curview
8680
8681    if {![info exists commitinfo($id)] && ![getcommit $id]} return
8682    unmarkmatches
8683    unselectline
8684    normalline
8685    $canv delete hover
8686    # draw this line thicker than normal
8687    set thickerline $id
8688    drawlines $id
8689    if {$isnew} {
8690        set ymax [lindex [$canv cget -scrollregion] 3]
8691        if {$ymax eq {}} return
8692        set yfrac [lindex [$canv yview] 0]
8693        set y [expr {$y + $yfrac * $ymax}]
8694    }
8695    set dirn [clickisonarrow $id $y]
8696    if {$dirn ne {}} {
8697        arrowjump $id $dirn $y
8698        return
8699    }
8700
8701    if {$isnew} {
8702        addtohistory [list lineclick $x $y $id 0] savectextpos
8703    }
8704    # fill the details pane with info about this line
8705    $ctext conf -state normal
8706    clear_ctext
8707    settabs 0
8708    $ctext insert end "[mc "Parent"]:\t"
8709    $ctext insert end $id link0
8710    setlink $id link0
8711    set info $commitinfo($id)
8712    $ctext insert end "\n\t[lindex $info 0]\n"
8713    $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8714    set date [formatdate [lindex $info 2]]
8715    $ctext insert end "\t[mc "Date"]:\t$date\n"
8716    set kids $children($curview,$id)
8717    if {$kids ne {}} {
8718        $ctext insert end "\n[mc "Children"]:"
8719        set i 0
8720        foreach child $kids {
8721            incr i
8722            if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8723            set info $commitinfo($child)
8724            $ctext insert end "\n\t"
8725            $ctext insert end $child link$i
8726            setlink $child link$i
8727            $ctext insert end "\n\t[lindex $info 0]"
8728            $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8729            set date [formatdate [lindex $info 2]]
8730            $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8731        }
8732    }
8733    maybe_scroll_ctext 1
8734    $ctext conf -state disabled
8735    init_flist {}
8736}
8737
8738proc normalline {} {
8739    global thickerline
8740    if {[info exists thickerline]} {
8741        set id $thickerline
8742        unset thickerline
8743        drawlines $id
8744    }
8745}
8746
8747proc selbyid {id {isnew 1}} {
8748    global curview
8749    if {[commitinview $id $curview]} {
8750        selectline [rowofcommit $id] $isnew
8751    }
8752}
8753
8754proc mstime {} {
8755    global startmstime
8756    if {![info exists startmstime]} {
8757        set startmstime [clock clicks -milliseconds]
8758    }
8759    return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8760}
8761
8762proc rowmenu {x y id} {
8763    global rowctxmenu selectedline rowmenuid curview
8764    global nullid nullid2 fakerowmenu mainhead markedid
8765
8766    stopfinding
8767    set rowmenuid $id
8768    if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8769        set state disabled
8770    } else {
8771        set state normal
8772    }
8773    if {[info exists markedid] && $markedid ne $id} {
8774        set mstate normal
8775    } else {
8776        set mstate disabled
8777    }
8778    if {$id ne $nullid && $id ne $nullid2} {
8779        set menu $rowctxmenu
8780        if {$mainhead ne {}} {
8781            $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8782        } else {
8783            $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8784        }
8785        $menu entryconfigure 9 -state $mstate
8786        $menu entryconfigure 10 -state $mstate
8787        $menu entryconfigure 11 -state $mstate
8788    } else {
8789        set menu $fakerowmenu
8790    }
8791    $menu entryconfigure [mca "Diff this -> selected"] -state $state
8792    $menu entryconfigure [mca "Diff selected -> this"] -state $state
8793    $menu entryconfigure [mca "Make patch"] -state $state
8794    $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8795    $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8796    tk_popup $menu $x $y
8797}
8798
8799proc markhere {} {
8800    global rowmenuid markedid canv
8801
8802    set markedid $rowmenuid
8803    make_idmark $markedid
8804}
8805
8806proc gotomark {} {
8807    global markedid
8808
8809    if {[info exists markedid]} {
8810        selbyid $markedid
8811    }
8812}
8813
8814proc replace_by_kids {l r} {
8815    global curview children
8816
8817    set id [commitonrow $r]
8818    set l [lreplace $l 0 0]
8819    foreach kid $children($curview,$id) {
8820        lappend l [rowofcommit $kid]
8821    }
8822    return [lsort -integer -decreasing -unique $l]
8823}
8824
8825proc find_common_desc {} {
8826    global markedid rowmenuid curview children
8827
8828    if {![info exists markedid]} return
8829    if {![commitinview $markedid $curview] ||
8830        ![commitinview $rowmenuid $curview]} return
8831    #set t1 [clock clicks -milliseconds]
8832    set l1 [list [rowofcommit $markedid]]
8833    set l2 [list [rowofcommit $rowmenuid]]
8834    while 1 {
8835        set r1 [lindex $l1 0]
8836        set r2 [lindex $l2 0]
8837        if {$r1 eq {} || $r2 eq {}} break
8838        if {$r1 == $r2} {
8839            selectline $r1 1
8840            break
8841        }
8842        if {$r1 > $r2} {
8843            set l1 [replace_by_kids $l1 $r1]
8844        } else {
8845            set l2 [replace_by_kids $l2 $r2]
8846        }
8847    }
8848    #set t2 [clock clicks -milliseconds]
8849    #puts "took [expr {$t2-$t1}]ms"
8850}
8851
8852proc compare_commits {} {
8853    global markedid rowmenuid curview children
8854
8855    if {![info exists markedid]} return
8856    if {![commitinview $markedid $curview]} return
8857    addtohistory [list do_cmp_commits $markedid $rowmenuid]
8858    do_cmp_commits $markedid $rowmenuid
8859}
8860
8861proc getpatchid {id} {
8862    global patchids
8863
8864    if {![info exists patchids($id)]} {
8865        set cmd [diffcmd [list $id] {-p --root}]
8866        # trim off the initial "|"
8867        set cmd [lrange $cmd 1 end]
8868        if {[catch {
8869            set x [eval exec $cmd | git patch-id]
8870            set patchids($id) [lindex $x 0]
8871        }]} {
8872            set patchids($id) "error"
8873        }
8874    }
8875    return $patchids($id)
8876}
8877
8878proc do_cmp_commits {a b} {
8879    global ctext curview parents children patchids commitinfo
8880
8881    $ctext conf -state normal
8882    clear_ctext
8883    init_flist {}
8884    for {set i 0} {$i < 100} {incr i} {
8885        set skipa 0
8886        set skipb 0
8887        if {[llength $parents($curview,$a)] > 1} {
8888            appendshortlink $a [mc "Skipping merge commit "] "\n"
8889            set skipa 1
8890        } else {
8891            set patcha [getpatchid $a]
8892        }
8893        if {[llength $parents($curview,$b)] > 1} {
8894            appendshortlink $b [mc "Skipping merge commit "] "\n"
8895            set skipb 1
8896        } else {
8897            set patchb [getpatchid $b]
8898        }
8899        if {!$skipa && !$skipb} {
8900            set heada [lindex $commitinfo($a) 0]
8901            set headb [lindex $commitinfo($b) 0]
8902            if {$patcha eq "error"} {
8903                appendshortlink $a [mc "Error getting patch ID for "] \
8904                    [mc " - stopping\n"]
8905                break
8906            }
8907            if {$patchb eq "error"} {
8908                appendshortlink $b [mc "Error getting patch ID for "] \
8909                    [mc " - stopping\n"]
8910                break
8911            }
8912            if {$patcha eq $patchb} {
8913                if {$heada eq $headb} {
8914                    appendshortlink $a [mc "Commit "]
8915                    appendshortlink $b " == " "  $heada\n"
8916                } else {
8917                    appendshortlink $a [mc "Commit "] "  $heada\n"
8918                    appendshortlink $b [mc " is the same patch as\n       "] \
8919                        "  $headb\n"
8920                }
8921                set skipa 1
8922                set skipb 1
8923            } else {
8924                $ctext insert end "\n"
8925                appendshortlink $a [mc "Commit "] "  $heada\n"
8926                appendshortlink $b [mc " differs from\n       "] \
8927                    "  $headb\n"
8928                $ctext insert end [mc "Diff of commits:\n\n"]
8929                $ctext conf -state disabled
8930                update
8931                diffcommits $a $b
8932                return
8933            }
8934        }
8935        if {$skipa} {
8936            set kids [real_children $curview,$a]
8937            if {[llength $kids] != 1} {
8938                $ctext insert end "\n"
8939                appendshortlink $a [mc "Commit "] \
8940                    [mc " has %s children - stopping\n" [llength $kids]]
8941                break
8942            }
8943            set a [lindex $kids 0]
8944        }
8945        if {$skipb} {
8946            set kids [real_children $curview,$b]
8947            if {[llength $kids] != 1} {
8948                appendshortlink $b [mc "Commit "] \
8949                    [mc " has %s children - stopping\n" [llength $kids]]
8950                break
8951            }
8952            set b [lindex $kids 0]
8953        }
8954    }
8955    $ctext conf -state disabled
8956}
8957
8958proc diffcommits {a b} {
8959    global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
8960
8961    set tmpdir [gitknewtmpdir]
8962    set fna [file join $tmpdir "commit-[string range $a 0 7]"]
8963    set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
8964    if {[catch {
8965        exec git diff-tree -p --pretty $a >$fna
8966        exec git diff-tree -p --pretty $b >$fnb
8967    } err]} {
8968        error_popup [mc "Error writing commit to file: %s" $err]
8969        return
8970    }
8971    if {[catch {
8972        set fd [open "| diff -U$diffcontext $fna $fnb" r]
8973    } err]} {
8974        error_popup [mc "Error diffing commits: %s" $err]
8975        return
8976    }
8977    set diffids [list commits $a $b]
8978    set blobdifffd($diffids) $fd
8979    set diffinhdr 0
8980    set currdiffsubmod ""
8981    filerun $fd [list getblobdiffline $fd $diffids]
8982}
8983
8984proc diffvssel {dirn} {
8985    global rowmenuid selectedline
8986
8987    if {$selectedline eq {}} return
8988    if {$dirn} {
8989        set oldid [commitonrow $selectedline]
8990        set newid $rowmenuid
8991    } else {
8992        set oldid $rowmenuid
8993        set newid [commitonrow $selectedline]
8994    }
8995    addtohistory [list doseldiff $oldid $newid] savectextpos
8996    doseldiff $oldid $newid
8997}
8998
8999proc diffvsmark {dirn} {
9000    global rowmenuid markedid
9001
9002    if {![info exists markedid]} return
9003    if {$dirn} {
9004        set oldid $markedid
9005        set newid $rowmenuid
9006    } else {
9007        set oldid $rowmenuid
9008        set newid $markedid
9009    }
9010    addtohistory [list doseldiff $oldid $newid] savectextpos
9011    doseldiff $oldid $newid
9012}
9013
9014proc doseldiff {oldid newid} {
9015    global ctext
9016    global commitinfo
9017
9018    $ctext conf -state normal
9019    clear_ctext
9020    init_flist [mc "Top"]
9021    $ctext insert end "[mc "From"] "
9022    $ctext insert end $oldid link0
9023    setlink $oldid link0
9024    $ctext insert end "\n     "
9025    $ctext insert end [lindex $commitinfo($oldid) 0]
9026    $ctext insert end "\n\n[mc "To"]   "
9027    $ctext insert end $newid link1
9028    setlink $newid link1
9029    $ctext insert end "\n     "
9030    $ctext insert end [lindex $commitinfo($newid) 0]
9031    $ctext insert end "\n"
9032    $ctext conf -state disabled
9033    $ctext tag remove found 1.0 end
9034    startdiff [list $oldid $newid]
9035}
9036
9037proc mkpatch {} {
9038    global rowmenuid currentid commitinfo patchtop patchnum NS
9039
9040    if {![info exists currentid]} return
9041    set oldid $currentid
9042    set oldhead [lindex $commitinfo($oldid) 0]
9043    set newid $rowmenuid
9044    set newhead [lindex $commitinfo($newid) 0]
9045    set top .patch
9046    set patchtop $top
9047    catch {destroy $top}
9048    ttk_toplevel $top
9049    make_transient $top .
9050    ${NS}::label $top.title -text [mc "Generate patch"]
9051    grid $top.title - -pady 10
9052    ${NS}::label $top.from -text [mc "From:"]
9053    ${NS}::entry $top.fromsha1 -width 40
9054    $top.fromsha1 insert 0 $oldid
9055    $top.fromsha1 conf -state readonly
9056    grid $top.from $top.fromsha1 -sticky w
9057    ${NS}::entry $top.fromhead -width 60
9058    $top.fromhead insert 0 $oldhead
9059    $top.fromhead conf -state readonly
9060    grid x $top.fromhead -sticky w
9061    ${NS}::label $top.to -text [mc "To:"]
9062    ${NS}::entry $top.tosha1 -width 40
9063    $top.tosha1 insert 0 $newid
9064    $top.tosha1 conf -state readonly
9065    grid $top.to $top.tosha1 -sticky w
9066    ${NS}::entry $top.tohead -width 60
9067    $top.tohead insert 0 $newhead
9068    $top.tohead conf -state readonly
9069    grid x $top.tohead -sticky w
9070    ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9071    grid $top.rev x -pady 10 -padx 5
9072    ${NS}::label $top.flab -text [mc "Output file:"]
9073    ${NS}::entry $top.fname -width 60
9074    $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9075    incr patchnum
9076    grid $top.flab $top.fname -sticky w
9077    ${NS}::frame $top.buts
9078    ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9079    ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9080    bind $top <Key-Return> mkpatchgo
9081    bind $top <Key-Escape> mkpatchcan
9082    grid $top.buts.gen $top.buts.can
9083    grid columnconfigure $top.buts 0 -weight 1 -uniform a
9084    grid columnconfigure $top.buts 1 -weight 1 -uniform a
9085    grid $top.buts - -pady 10 -sticky ew
9086    focus $top.fname
9087}
9088
9089proc mkpatchrev {} {
9090    global patchtop
9091
9092    set oldid [$patchtop.fromsha1 get]
9093    set oldhead [$patchtop.fromhead get]
9094    set newid [$patchtop.tosha1 get]
9095    set newhead [$patchtop.tohead get]
9096    foreach e [list fromsha1 fromhead tosha1 tohead] \
9097            v [list $newid $newhead $oldid $oldhead] {
9098        $patchtop.$e conf -state normal
9099        $patchtop.$e delete 0 end
9100        $patchtop.$e insert 0 $v
9101        $patchtop.$e conf -state readonly
9102    }
9103}
9104
9105proc mkpatchgo {} {
9106    global patchtop nullid nullid2
9107
9108    set oldid [$patchtop.fromsha1 get]
9109    set newid [$patchtop.tosha1 get]
9110    set fname [$patchtop.fname get]
9111    set cmd [diffcmd [list $oldid $newid] -p]
9112    # trim off the initial "|"
9113    set cmd [lrange $cmd 1 end]
9114    lappend cmd >$fname &
9115    if {[catch {eval exec $cmd} err]} {
9116        error_popup "[mc "Error creating patch:"] $err" $patchtop
9117    }
9118    catch {destroy $patchtop}
9119    unset patchtop
9120}
9121
9122proc mkpatchcan {} {
9123    global patchtop
9124
9125    catch {destroy $patchtop}
9126    unset patchtop
9127}
9128
9129proc mktag {} {
9130    global rowmenuid mktagtop commitinfo NS
9131
9132    set top .maketag
9133    set mktagtop $top
9134    catch {destroy $top}
9135    ttk_toplevel $top
9136    make_transient $top .
9137    ${NS}::label $top.title -text [mc "Create tag"]
9138    grid $top.title - -pady 10
9139    ${NS}::label $top.id -text [mc "ID:"]
9140    ${NS}::entry $top.sha1 -width 40
9141    $top.sha1 insert 0 $rowmenuid
9142    $top.sha1 conf -state readonly
9143    grid $top.id $top.sha1 -sticky w
9144    ${NS}::entry $top.head -width 60
9145    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9146    $top.head conf -state readonly
9147    grid x $top.head -sticky w
9148    ${NS}::label $top.tlab -text [mc "Tag name:"]
9149    ${NS}::entry $top.tag -width 60
9150    grid $top.tlab $top.tag -sticky w
9151    ${NS}::label $top.op -text [mc "Tag message is optional"]
9152    grid $top.op -columnspan 2 -sticky we
9153    ${NS}::label $top.mlab -text [mc "Tag message:"]
9154    ${NS}::entry $top.msg -width 60
9155    grid $top.mlab $top.msg -sticky w
9156    ${NS}::frame $top.buts
9157    ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9158    ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9159    bind $top <Key-Return> mktaggo
9160    bind $top <Key-Escape> mktagcan
9161    grid $top.buts.gen $top.buts.can
9162    grid columnconfigure $top.buts 0 -weight 1 -uniform a
9163    grid columnconfigure $top.buts 1 -weight 1 -uniform a
9164    grid $top.buts - -pady 10 -sticky ew
9165    focus $top.tag
9166}
9167
9168proc domktag {} {
9169    global mktagtop env tagids idtags
9170
9171    set id [$mktagtop.sha1 get]
9172    set tag [$mktagtop.tag get]
9173    set msg [$mktagtop.msg get]
9174    if {$tag == {}} {
9175        error_popup [mc "No tag name specified"] $mktagtop
9176        return 0
9177    }
9178    if {[info exists tagids($tag)]} {
9179        error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9180        return 0
9181    }
9182    if {[catch {
9183        if {$msg != {}} {
9184            exec git tag -a -m $msg $tag $id
9185        } else {
9186            exec git tag $tag $id
9187        }
9188    } err]} {
9189        error_popup "[mc "Error creating tag:"] $err" $mktagtop
9190        return 0
9191    }
9192
9193    set tagids($tag) $id
9194    lappend idtags($id) $tag
9195    redrawtags $id
9196    addedtag $id
9197    dispneartags 0
9198    run refill_reflist
9199    return 1
9200}
9201
9202proc redrawtags {id} {
9203    global canv linehtag idpos currentid curview cmitlisted markedid
9204    global canvxmax iddrawn circleitem mainheadid circlecolors
9205    global mainheadcirclecolor
9206
9207    if {![commitinview $id $curview]} return
9208    if {![info exists iddrawn($id)]} return
9209    set row [rowofcommit $id]
9210    if {$id eq $mainheadid} {
9211        set ofill $mainheadcirclecolor
9212    } else {
9213        set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9214    }
9215    $canv itemconf $circleitem($row) -fill $ofill
9216    $canv delete tag.$id
9217    set xt [eval drawtags $id $idpos($id)]
9218    $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9219    set text [$canv itemcget $linehtag($id) -text]
9220    set font [$canv itemcget $linehtag($id) -font]
9221    set xr [expr {$xt + [font measure $font $text]}]
9222    if {$xr > $canvxmax} {
9223        set canvxmax $xr
9224        setcanvscroll
9225    }
9226    if {[info exists currentid] && $currentid == $id} {
9227        make_secsel $id
9228    }
9229    if {[info exists markedid] && $markedid eq $id} {
9230        make_idmark $id
9231    }
9232}
9233
9234proc mktagcan {} {
9235    global mktagtop
9236
9237    catch {destroy $mktagtop}
9238    unset mktagtop
9239}
9240
9241proc mktaggo {} {
9242    if {![domktag]} return
9243    mktagcan
9244}
9245
9246proc writecommit {} {
9247    global rowmenuid wrcomtop commitinfo wrcomcmd NS
9248
9249    set top .writecommit
9250    set wrcomtop $top
9251    catch {destroy $top}
9252    ttk_toplevel $top
9253    make_transient $top .
9254    ${NS}::label $top.title -text [mc "Write commit to file"]
9255    grid $top.title - -pady 10
9256    ${NS}::label $top.id -text [mc "ID:"]
9257    ${NS}::entry $top.sha1 -width 40
9258    $top.sha1 insert 0 $rowmenuid
9259    $top.sha1 conf -state readonly
9260    grid $top.id $top.sha1 -sticky w
9261    ${NS}::entry $top.head -width 60
9262    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9263    $top.head conf -state readonly
9264    grid x $top.head -sticky w
9265    ${NS}::label $top.clab -text [mc "Command:"]
9266    ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9267    grid $top.clab $top.cmd -sticky w -pady 10
9268    ${NS}::label $top.flab -text [mc "Output file:"]
9269    ${NS}::entry $top.fname -width 60
9270    $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9271    grid $top.flab $top.fname -sticky w
9272    ${NS}::frame $top.buts
9273    ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9274    ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9275    bind $top <Key-Return> wrcomgo
9276    bind $top <Key-Escape> wrcomcan
9277    grid $top.buts.gen $top.buts.can
9278    grid columnconfigure $top.buts 0 -weight 1 -uniform a
9279    grid columnconfigure $top.buts 1 -weight 1 -uniform a
9280    grid $top.buts - -pady 10 -sticky ew
9281    focus $top.fname
9282}
9283
9284proc wrcomgo {} {
9285    global wrcomtop
9286
9287    set id [$wrcomtop.sha1 get]
9288    set cmd "echo $id | [$wrcomtop.cmd get]"
9289    set fname [$wrcomtop.fname get]
9290    if {[catch {exec sh -c $cmd >$fname &} err]} {
9291        error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9292    }
9293    catch {destroy $wrcomtop}
9294    unset wrcomtop
9295}
9296
9297proc wrcomcan {} {
9298    global wrcomtop
9299
9300    catch {destroy $wrcomtop}
9301    unset wrcomtop
9302}
9303
9304proc mkbranch {} {
9305    global rowmenuid mkbrtop NS
9306
9307    set top .makebranch
9308    catch {destroy $top}
9309    ttk_toplevel $top
9310    make_transient $top .
9311    ${NS}::label $top.title -text [mc "Create new branch"]
9312    grid $top.title - -pady 10
9313    ${NS}::label $top.id -text [mc "ID:"]
9314    ${NS}::entry $top.sha1 -width 40
9315    $top.sha1 insert 0 $rowmenuid
9316    $top.sha1 conf -state readonly
9317    grid $top.id $top.sha1 -sticky w
9318    ${NS}::label $top.nlab -text [mc "Name:"]
9319    ${NS}::entry $top.name -width 40
9320    grid $top.nlab $top.name -sticky w
9321    ${NS}::frame $top.buts
9322    ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9323    ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9324    bind $top <Key-Return> [list mkbrgo $top]
9325    bind $top <Key-Escape> "catch {destroy $top}"
9326    grid $top.buts.go $top.buts.can
9327    grid columnconfigure $top.buts 0 -weight 1 -uniform a
9328    grid columnconfigure $top.buts 1 -weight 1 -uniform a
9329    grid $top.buts - -pady 10 -sticky ew
9330    focus $top.name
9331}
9332
9333proc mkbrgo {top} {
9334    global headids idheads
9335
9336    set name [$top.name get]
9337    set id [$top.sha1 get]
9338    set cmdargs {}
9339    set old_id {}
9340    if {$name eq {}} {
9341        error_popup [mc "Please specify a name for the new branch"] $top
9342        return
9343    }
9344    if {[info exists headids($name)]} {
9345        if {![confirm_popup [mc \
9346                "Branch '%s' already exists. Overwrite?" $name] $top]} {
9347            return
9348        }
9349        set old_id $headids($name)
9350        lappend cmdargs -f
9351    }
9352    catch {destroy $top}
9353    lappend cmdargs $name $id
9354    nowbusy newbranch
9355    update
9356    if {[catch {
9357        eval exec git branch $cmdargs
9358    } err]} {
9359        notbusy newbranch
9360        error_popup $err
9361    } else {
9362        notbusy newbranch
9363        if {$old_id ne {}} {
9364            movehead $id $name
9365            movedhead $id $name
9366            redrawtags $old_id
9367            redrawtags $id
9368        } else {
9369            set headids($name) $id
9370            lappend idheads($id) $name
9371            addedhead $id $name
9372            redrawtags $id
9373        }
9374        dispneartags 0
9375        run refill_reflist
9376    }
9377}
9378
9379proc exec_citool {tool_args {baseid {}}} {
9380    global commitinfo env
9381
9382    set save_env [array get env GIT_AUTHOR_*]
9383
9384    if {$baseid ne {}} {
9385        if {![info exists commitinfo($baseid)]} {
9386            getcommit $baseid
9387        }
9388        set author [lindex $commitinfo($baseid) 1]
9389        set date [lindex $commitinfo($baseid) 2]
9390        if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9391                    $author author name email]
9392            && $date ne {}} {
9393            set env(GIT_AUTHOR_NAME) $name
9394            set env(GIT_AUTHOR_EMAIL) $email
9395            set env(GIT_AUTHOR_DATE) $date
9396        }
9397    }
9398
9399    eval exec git citool $tool_args &
9400
9401    array unset env GIT_AUTHOR_*
9402    array set env $save_env
9403}
9404
9405proc cherrypick {} {
9406    global rowmenuid curview
9407    global mainhead mainheadid
9408    global gitdir
9409
9410    set oldhead [exec git rev-parse HEAD]
9411    set dheads [descheads $rowmenuid]
9412    if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9413        set ok [confirm_popup [mc "Commit %s is already\
9414                included in branch %s -- really re-apply it?" \
9415                                   [string range $rowmenuid 0 7] $mainhead]]
9416        if {!$ok} return
9417    }
9418    nowbusy cherrypick [mc "Cherry-picking"]
9419    update
9420    # Unfortunately git-cherry-pick writes stuff to stderr even when
9421    # no error occurs, and exec takes that as an indication of error...
9422    if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9423        notbusy cherrypick
9424        if {[regexp -line \
9425                 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9426                 $err msg fname]} {
9427            error_popup [mc "Cherry-pick failed because of local changes\
9428                        to file '%s'.\nPlease commit, reset or stash\
9429                        your changes and try again." $fname]
9430        } elseif {[regexp -line \
9431                       {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9432                       $err]} {
9433            if {[confirm_popup [mc "Cherry-pick failed because of merge\
9434                        conflict.\nDo you wish to run git citool to\
9435                        resolve it?"]]} {
9436                # Force citool to read MERGE_MSG
9437                file delete [file join $gitdir "GITGUI_MSG"]
9438                exec_citool {} $rowmenuid
9439            }
9440        } else {
9441            error_popup $err
9442        }
9443        run updatecommits
9444        return
9445    }
9446    set newhead [exec git rev-parse HEAD]
9447    if {$newhead eq $oldhead} {
9448        notbusy cherrypick
9449        error_popup [mc "No changes committed"]
9450        return
9451    }
9452    addnewchild $newhead $oldhead
9453    if {[commitinview $oldhead $curview]} {
9454        # XXX this isn't right if we have a path limit...
9455        insertrow $newhead $oldhead $curview
9456        if {$mainhead ne {}} {
9457            movehead $newhead $mainhead
9458            movedhead $newhead $mainhead
9459        }
9460        set mainheadid $newhead
9461        redrawtags $oldhead
9462        redrawtags $newhead
9463        selbyid $newhead
9464    }
9465    notbusy cherrypick
9466}
9467
9468proc revert {} {
9469    global rowmenuid curview
9470    global mainhead mainheadid
9471    global gitdir
9472
9473    set oldhead [exec git rev-parse HEAD]
9474    set dheads [descheads $rowmenuid]
9475    if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9476       set ok [confirm_popup [mc "Commit %s is not\
9477           included in branch %s -- really revert it?" \
9478                      [string range $rowmenuid 0 7] $mainhead]]
9479       if {!$ok} return
9480    }
9481    nowbusy revert [mc "Reverting"]
9482    update
9483
9484    if [catch {exec git revert --no-edit $rowmenuid} err] {
9485        notbusy revert
9486        if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9487                $err match files] {
9488            regsub {\n( |\t)+} $files "\n" files
9489            error_popup [mc "Revert failed because of local changes to\
9490                the following files:%s Please commit, reset or stash \
9491                your changes and try again." $files]
9492        } elseif [regexp {error: could not revert} $err] {
9493            if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9494                Do you wish to run git citool to resolve it?"]] {
9495                # Force citool to read MERGE_MSG
9496                file delete [file join $gitdir "GITGUI_MSG"]
9497                exec_citool {} $rowmenuid
9498            }
9499        } else { error_popup $err }
9500        run updatecommits
9501        return
9502    }
9503
9504    set newhead [exec git rev-parse HEAD]
9505    if { $newhead eq $oldhead } {
9506        notbusy revert
9507        error_popup [mc "No changes committed"]
9508        return
9509    }
9510
9511    addnewchild $newhead $oldhead
9512
9513    if [commitinview $oldhead $curview] {
9514        # XXX this isn't right if we have a path limit...
9515        insertrow $newhead $oldhead $curview
9516        if {$mainhead ne {}} {
9517            movehead $newhead $mainhead
9518            movedhead $newhead $mainhead
9519        }
9520        set mainheadid $newhead
9521        redrawtags $oldhead
9522        redrawtags $newhead
9523        selbyid $newhead
9524    }
9525
9526    notbusy revert
9527}
9528
9529proc resethead {} {
9530    global mainhead rowmenuid confirm_ok resettype NS
9531
9532    set confirm_ok 0
9533    set w ".confirmreset"
9534    ttk_toplevel $w
9535    make_transient $w .
9536    wm title $w [mc "Confirm reset"]
9537    ${NS}::label $w.m -text \
9538        [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9539    pack $w.m -side top -fill x -padx 20 -pady 20
9540    ${NS}::labelframe $w.f -text [mc "Reset type:"]
9541    set resettype mixed
9542    ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9543        -text [mc "Soft: Leave working tree and index untouched"]
9544    grid $w.f.soft -sticky w
9545    ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9546        -text [mc "Mixed: Leave working tree untouched, reset index"]
9547    grid $w.f.mixed -sticky w
9548    ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9549        -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9550    grid $w.f.hard -sticky w
9551    pack $w.f -side top -fill x -padx 4
9552    ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9553    pack $w.ok -side left -fill x -padx 20 -pady 20
9554    ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9555    bind $w <Key-Escape> [list destroy $w]
9556    pack $w.cancel -side right -fill x -padx 20 -pady 20
9557    bind $w <Visibility> "grab $w; focus $w"
9558    tkwait window $w
9559    if {!$confirm_ok} return
9560    if {[catch {set fd [open \
9561            [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9562        error_popup $err
9563    } else {
9564        dohidelocalchanges
9565        filerun $fd [list readresetstat $fd]
9566        nowbusy reset [mc "Resetting"]
9567        selbyid $rowmenuid
9568    }
9569}
9570
9571proc readresetstat {fd} {
9572    global mainhead mainheadid showlocalchanges rprogcoord
9573
9574    if {[gets $fd line] >= 0} {
9575        if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9576            set rprogcoord [expr {1.0 * $m / $n}]
9577            adjustprogress
9578        }
9579        return 1
9580    }
9581    set rprogcoord 0
9582    adjustprogress
9583    notbusy reset
9584    if {[catch {close $fd} err]} {
9585        error_popup $err
9586    }
9587    set oldhead $mainheadid
9588    set newhead [exec git rev-parse HEAD]
9589    if {$newhead ne $oldhead} {
9590        movehead $newhead $mainhead
9591        movedhead $newhead $mainhead
9592        set mainheadid $newhead
9593        redrawtags $oldhead
9594        redrawtags $newhead
9595    }
9596    if {$showlocalchanges} {
9597        doshowlocalchanges
9598    }
9599    return 0
9600}
9601
9602# context menu for a head
9603proc headmenu {x y id head} {
9604    global headmenuid headmenuhead headctxmenu mainhead
9605
9606    stopfinding
9607    set headmenuid $id
9608    set headmenuhead $head
9609    set state normal
9610    if {[string match "remotes/*" $head]} {
9611        set state disabled
9612    }
9613    if {$head eq $mainhead} {
9614        set state disabled
9615    }
9616    $headctxmenu entryconfigure 0 -state $state
9617    $headctxmenu entryconfigure 1 -state $state
9618    tk_popup $headctxmenu $x $y
9619}
9620
9621proc cobranch {} {
9622    global headmenuid headmenuhead headids
9623    global showlocalchanges
9624
9625    # check the tree is clean first??
9626    nowbusy checkout [mc "Checking out"]
9627    update
9628    dohidelocalchanges
9629    if {[catch {
9630        set fd [open [list | git checkout $headmenuhead 2>@1] r]
9631    } err]} {
9632        notbusy checkout
9633        error_popup $err
9634        if {$showlocalchanges} {
9635            dodiffindex
9636        }
9637    } else {
9638        filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9639    }
9640}
9641
9642proc readcheckoutstat {fd newhead newheadid} {
9643    global mainhead mainheadid headids showlocalchanges progresscoords
9644    global viewmainheadid curview
9645
9646    if {[gets $fd line] >= 0} {
9647        if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9648            set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9649            adjustprogress
9650        }
9651        return 1
9652    }
9653    set progresscoords {0 0}
9654    adjustprogress
9655    notbusy checkout
9656    if {[catch {close $fd} err]} {
9657        error_popup $err
9658    }
9659    set oldmainid $mainheadid
9660    set mainhead $newhead
9661    set mainheadid $newheadid
9662    set viewmainheadid($curview) $newheadid
9663    redrawtags $oldmainid
9664    redrawtags $newheadid
9665    selbyid $newheadid
9666    if {$showlocalchanges} {
9667        dodiffindex
9668    }
9669}
9670
9671proc rmbranch {} {
9672    global headmenuid headmenuhead mainhead
9673    global idheads
9674
9675    set head $headmenuhead
9676    set id $headmenuid
9677    # this check shouldn't be needed any more...
9678    if {$head eq $mainhead} {
9679        error_popup [mc "Cannot delete the currently checked-out branch"]
9680        return
9681    }
9682    set dheads [descheads $id]
9683    if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9684        # the stuff on this branch isn't on any other branch
9685        if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9686                        branch.\nReally delete branch %s?" $head $head]]} return
9687    }
9688    nowbusy rmbranch
9689    update
9690    if {[catch {exec git branch -D $head} err]} {
9691        notbusy rmbranch
9692        error_popup $err
9693        return
9694    }
9695    removehead $id $head
9696    removedhead $id $head
9697    redrawtags $id
9698    notbusy rmbranch
9699    dispneartags 0
9700    run refill_reflist
9701}
9702
9703# Display a list of tags and heads
9704proc showrefs {} {
9705    global showrefstop bgcolor fgcolor selectbgcolor NS
9706    global bglist fglist reflistfilter reflist maincursor
9707
9708    set top .showrefs
9709    set showrefstop $top
9710    if {[winfo exists $top]} {
9711        raise $top
9712        refill_reflist
9713        return
9714    }
9715    ttk_toplevel $top
9716    wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9717    make_transient $top .
9718    text $top.list -background $bgcolor -foreground $fgcolor \
9719        -selectbackground $selectbgcolor -font mainfont \
9720        -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9721        -width 30 -height 20 -cursor $maincursor \
9722        -spacing1 1 -spacing3 1 -state disabled
9723    $top.list tag configure highlight -background $selectbgcolor
9724    lappend bglist $top.list
9725    lappend fglist $top.list
9726    ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9727    ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9728    grid $top.list $top.ysb -sticky nsew
9729    grid $top.xsb x -sticky ew
9730    ${NS}::frame $top.f
9731    ${NS}::label $top.f.l -text "[mc "Filter"]: "
9732    ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9733    set reflistfilter "*"
9734    trace add variable reflistfilter write reflistfilter_change
9735    pack $top.f.e -side right -fill x -expand 1
9736    pack $top.f.l -side left
9737    grid $top.f - -sticky ew -pady 2
9738    ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9739    bind $top <Key-Escape> [list destroy $top]
9740    grid $top.close -
9741    grid columnconfigure $top 0 -weight 1
9742    grid rowconfigure $top 0 -weight 1
9743    bind $top.list <1> {break}
9744    bind $top.list <B1-Motion> {break}
9745    bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9746    set reflist {}
9747    refill_reflist
9748}
9749
9750proc sel_reflist {w x y} {
9751    global showrefstop reflist headids tagids otherrefids
9752
9753    if {![winfo exists $showrefstop]} return
9754    set l [lindex [split [$w index "@$x,$y"] "."] 0]
9755    set ref [lindex $reflist [expr {$l-1}]]
9756    set n [lindex $ref 0]
9757    switch -- [lindex $ref 1] {
9758        "H" {selbyid $headids($n)}
9759        "T" {selbyid $tagids($n)}
9760        "o" {selbyid $otherrefids($n)}
9761    }
9762    $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9763}
9764
9765proc unsel_reflist {} {
9766    global showrefstop
9767
9768    if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9769    $showrefstop.list tag remove highlight 0.0 end
9770}
9771
9772proc reflistfilter_change {n1 n2 op} {
9773    global reflistfilter
9774
9775    after cancel refill_reflist
9776    after 200 refill_reflist
9777}
9778
9779proc refill_reflist {} {
9780    global reflist reflistfilter showrefstop headids tagids otherrefids
9781    global curview
9782
9783    if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9784    set refs {}
9785    foreach n [array names headids] {
9786        if {[string match $reflistfilter $n]} {
9787            if {[commitinview $headids($n) $curview]} {
9788                lappend refs [list $n H]
9789            } else {
9790                interestedin $headids($n) {run refill_reflist}
9791            }
9792        }
9793    }
9794    foreach n [array names tagids] {
9795        if {[string match $reflistfilter $n]} {
9796            if {[commitinview $tagids($n) $curview]} {
9797                lappend refs [list $n T]
9798            } else {
9799                interestedin $tagids($n) {run refill_reflist}
9800            }
9801        }
9802    }
9803    foreach n [array names otherrefids] {
9804        if {[string match $reflistfilter $n]} {
9805            if {[commitinview $otherrefids($n) $curview]} {
9806                lappend refs [list $n o]
9807            } else {
9808                interestedin $otherrefids($n) {run refill_reflist}
9809            }
9810        }
9811    }
9812    set refs [lsort -index 0 $refs]
9813    if {$refs eq $reflist} return
9814
9815    # Update the contents of $showrefstop.list according to the
9816    # differences between $reflist (old) and $refs (new)
9817    $showrefstop.list conf -state normal
9818    $showrefstop.list insert end "\n"
9819    set i 0
9820    set j 0
9821    while {$i < [llength $reflist] || $j < [llength $refs]} {
9822        if {$i < [llength $reflist]} {
9823            if {$j < [llength $refs]} {
9824                set cmp [string compare [lindex $reflist $i 0] \
9825                             [lindex $refs $j 0]]
9826                if {$cmp == 0} {
9827                    set cmp [string compare [lindex $reflist $i 1] \
9828                                 [lindex $refs $j 1]]
9829                }
9830            } else {
9831                set cmp -1
9832            }
9833        } else {
9834            set cmp 1
9835        }
9836        switch -- $cmp {
9837            -1 {
9838                $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9839                incr i
9840            }
9841            0 {
9842                incr i
9843                incr j
9844            }
9845            1 {
9846                set l [expr {$j + 1}]
9847                $showrefstop.list image create $l.0 -align baseline \
9848                    -image reficon-[lindex $refs $j 1] -padx 2
9849                $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9850                incr j
9851            }
9852        }
9853    }
9854    set reflist $refs
9855    # delete last newline
9856    $showrefstop.list delete end-2c end-1c
9857    $showrefstop.list conf -state disabled
9858}
9859
9860# Stuff for finding nearby tags
9861proc getallcommits {} {
9862    global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9863    global idheads idtags idotherrefs allparents tagobjid
9864    global gitdir
9865
9866    if {![info exists allcommits]} {
9867        set nextarc 0
9868        set allcommits 0
9869        set seeds {}
9870        set allcwait 0
9871        set cachedarcs 0
9872        set allccache [file join $gitdir "gitk.cache"]
9873        if {![catch {
9874            set f [open $allccache r]
9875            set allcwait 1
9876            getcache $f
9877        }]} return
9878    }
9879
9880    if {$allcwait} {
9881        return
9882    }
9883    set cmd [list | git rev-list --parents]
9884    set allcupdate [expr {$seeds ne {}}]
9885    if {!$allcupdate} {
9886        set ids "--all"
9887    } else {
9888        set refs [concat [array names idheads] [array names idtags] \
9889                      [array names idotherrefs]]
9890        set ids {}
9891        set tagobjs {}
9892        foreach name [array names tagobjid] {
9893            lappend tagobjs $tagobjid($name)
9894        }
9895        foreach id [lsort -unique $refs] {
9896            if {![info exists allparents($id)] &&
9897                [lsearch -exact $tagobjs $id] < 0} {
9898                lappend ids $id
9899            }
9900        }
9901        if {$ids ne {}} {
9902            foreach id $seeds {
9903                lappend ids "^$id"
9904            }
9905        }
9906    }
9907    if {$ids ne {}} {
9908        set fd [open [concat $cmd $ids] r]
9909        fconfigure $fd -blocking 0
9910        incr allcommits
9911        nowbusy allcommits
9912        filerun $fd [list getallclines $fd]
9913    } else {
9914        dispneartags 0
9915    }
9916}
9917
9918# Since most commits have 1 parent and 1 child, we group strings of
9919# such commits into "arcs" joining branch/merge points (BMPs), which
9920# are commits that either don't have 1 parent or don't have 1 child.
9921#
9922# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9923# arcout(id) - outgoing arcs for BMP
9924# arcids(a) - list of IDs on arc including end but not start
9925# arcstart(a) - BMP ID at start of arc
9926# arcend(a) - BMP ID at end of arc
9927# growing(a) - arc a is still growing
9928# arctags(a) - IDs out of arcids (excluding end) that have tags
9929# archeads(a) - IDs out of arcids (excluding end) that have heads
9930# The start of an arc is at the descendent end, so "incoming" means
9931# coming from descendents, and "outgoing" means going towards ancestors.
9932
9933proc getallclines {fd} {
9934    global allparents allchildren idtags idheads nextarc
9935    global arcnos arcids arctags arcout arcend arcstart archeads growing
9936    global seeds allcommits cachedarcs allcupdate
9937
9938    set nid 0
9939    while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
9940        set id [lindex $line 0]
9941        if {[info exists allparents($id)]} {
9942            # seen it already
9943            continue
9944        }
9945        set cachedarcs 0
9946        set olds [lrange $line 1 end]
9947        set allparents($id) $olds
9948        if {![info exists allchildren($id)]} {
9949            set allchildren($id) {}
9950            set arcnos($id) {}
9951            lappend seeds $id
9952        } else {
9953            set a $arcnos($id)
9954            if {[llength $olds] == 1 && [llength $a] == 1} {
9955                lappend arcids($a) $id
9956                if {[info exists idtags($id)]} {
9957                    lappend arctags($a) $id
9958                }
9959                if {[info exists idheads($id)]} {
9960                    lappend archeads($a) $id
9961                }
9962                if {[info exists allparents($olds)]} {
9963                    # seen parent already
9964                    if {![info exists arcout($olds)]} {
9965                        splitarc $olds
9966                    }
9967                    lappend arcids($a) $olds
9968                    set arcend($a) $olds
9969                    unset growing($a)
9970                }
9971                lappend allchildren($olds) $id
9972                lappend arcnos($olds) $a
9973                continue
9974            }
9975        }
9976        foreach a $arcnos($id) {
9977            lappend arcids($a) $id
9978            set arcend($a) $id
9979            unset growing($a)
9980        }
9981
9982        set ao {}
9983        foreach p $olds {
9984            lappend allchildren($p) $id
9985            set a [incr nextarc]
9986            set arcstart($a) $id
9987            set archeads($a) {}
9988            set arctags($a) {}
9989            set archeads($a) {}
9990            set arcids($a) {}
9991            lappend ao $a
9992            set growing($a) 1
9993            if {[info exists allparents($p)]} {
9994                # seen it already, may need to make a new branch
9995                if {![info exists arcout($p)]} {
9996                    splitarc $p
9997                }
9998                lappend arcids($a) $p
9999                set arcend($a) $p
10000                unset growing($a)
10001            }
10002            lappend arcnos($p) $a
10003        }
10004        set arcout($id) $ao
10005    }
10006    if {$nid > 0} {
10007        global cached_dheads cached_dtags cached_atags
10008        catch {unset cached_dheads}
10009        catch {unset cached_dtags}
10010        catch {unset cached_atags}
10011    }
10012    if {![eof $fd]} {
10013        return [expr {$nid >= 1000? 2: 1}]
10014    }
10015    set cacheok 1
10016    if {[catch {
10017        fconfigure $fd -blocking 1
10018        close $fd
10019    } err]} {
10020        # got an error reading the list of commits
10021        # if we were updating, try rereading the whole thing again
10022        if {$allcupdate} {
10023            incr allcommits -1
10024            dropcache $err
10025            return
10026        }
10027        error_popup "[mc "Error reading commit topology information;\
10028                branch and preceding/following tag information\
10029                will be incomplete."]\n($err)"
10030        set cacheok 0
10031    }
10032    if {[incr allcommits -1] == 0} {
10033        notbusy allcommits
10034        if {$cacheok} {
10035            run savecache
10036        }
10037    }
10038    dispneartags 0
10039    return 0
10040}
10041
10042proc recalcarc {a} {
10043    global arctags archeads arcids idtags idheads
10044
10045    set at {}
10046    set ah {}
10047    foreach id [lrange $arcids($a) 0 end-1] {
10048        if {[info exists idtags($id)]} {
10049            lappend at $id
10050        }
10051        if {[info exists idheads($id)]} {
10052            lappend ah $id
10053        }
10054    }
10055    set arctags($a) $at
10056    set archeads($a) $ah
10057}
10058
10059proc splitarc {p} {
10060    global arcnos arcids nextarc arctags archeads idtags idheads
10061    global arcstart arcend arcout allparents growing
10062
10063    set a $arcnos($p)
10064    if {[llength $a] != 1} {
10065        puts "oops splitarc called but [llength $a] arcs already"
10066        return
10067    }
10068    set a [lindex $a 0]
10069    set i [lsearch -exact $arcids($a) $p]
10070    if {$i < 0} {
10071        puts "oops splitarc $p not in arc $a"
10072        return
10073    }
10074    set na [incr nextarc]
10075    if {[info exists arcend($a)]} {
10076        set arcend($na) $arcend($a)
10077    } else {
10078        set l [lindex $allparents([lindex $arcids($a) end]) 0]
10079        set j [lsearch -exact $arcnos($l) $a]
10080        set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10081    }
10082    set tail [lrange $arcids($a) [expr {$i+1}] end]
10083    set arcids($a) [lrange $arcids($a) 0 $i]
10084    set arcend($a) $p
10085    set arcstart($na) $p
10086    set arcout($p) $na
10087    set arcids($na) $tail
10088    if {[info exists growing($a)]} {
10089        set growing($na) 1
10090        unset growing($a)
10091    }
10092
10093    foreach id $tail {
10094        if {[llength $arcnos($id)] == 1} {
10095            set arcnos($id) $na
10096        } else {
10097            set j [lsearch -exact $arcnos($id) $a]
10098            set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10099        }
10100    }
10101
10102    # reconstruct tags and heads lists
10103    if {$arctags($a) ne {} || $archeads($a) ne {}} {
10104        recalcarc $a
10105        recalcarc $na
10106    } else {
10107        set arctags($na) {}
10108        set archeads($na) {}
10109    }
10110}
10111
10112# Update things for a new commit added that is a child of one
10113# existing commit.  Used when cherry-picking.
10114proc addnewchild {id p} {
10115    global allparents allchildren idtags nextarc
10116    global arcnos arcids arctags arcout arcend arcstart archeads growing
10117    global seeds allcommits
10118
10119    if {![info exists allcommits] || ![info exists arcnos($p)]} return
10120    set allparents($id) [list $p]
10121    set allchildren($id) {}
10122    set arcnos($id) {}
10123    lappend seeds $id
10124    lappend allchildren($p) $id
10125    set a [incr nextarc]
10126    set arcstart($a) $id
10127    set archeads($a) {}
10128    set arctags($a) {}
10129    set arcids($a) [list $p]
10130    set arcend($a) $p
10131    if {![info exists arcout($p)]} {
10132        splitarc $p
10133    }
10134    lappend arcnos($p) $a
10135    set arcout($id) [list $a]
10136}
10137
10138# This implements a cache for the topology information.
10139# The cache saves, for each arc, the start and end of the arc,
10140# the ids on the arc, and the outgoing arcs from the end.
10141proc readcache {f} {
10142    global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10143    global idtags idheads allparents cachedarcs possible_seeds seeds growing
10144    global allcwait
10145
10146    set a $nextarc
10147    set lim $cachedarcs
10148    if {$lim - $a > 500} {
10149        set lim [expr {$a + 500}]
10150    }
10151    if {[catch {
10152        if {$a == $lim} {
10153            # finish reading the cache and setting up arctags, etc.
10154            set line [gets $f]
10155            if {$line ne "1"} {error "bad final version"}
10156            close $f
10157            foreach id [array names idtags] {
10158                if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10159                    [llength $allparents($id)] == 1} {
10160                    set a [lindex $arcnos($id) 0]
10161                    if {$arctags($a) eq {}} {
10162                        recalcarc $a
10163                    }
10164                }
10165            }
10166            foreach id [array names idheads] {
10167                if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10168                    [llength $allparents($id)] == 1} {
10169                    set a [lindex $arcnos($id) 0]
10170                    if {$archeads($a) eq {}} {
10171                        recalcarc $a
10172                    }
10173                }
10174            }
10175            foreach id [lsort -unique $possible_seeds] {
10176                if {$arcnos($id) eq {}} {
10177                    lappend seeds $id
10178                }
10179            }
10180            set allcwait 0
10181        } else {
10182            while {[incr a] <= $lim} {
10183                set line [gets $f]
10184                if {[llength $line] != 3} {error "bad line"}
10185                set s [lindex $line 0]
10186                set arcstart($a) $s
10187                lappend arcout($s) $a
10188                if {![info exists arcnos($s)]} {
10189                    lappend possible_seeds $s
10190                    set arcnos($s) {}
10191                }
10192                set e [lindex $line 1]
10193                if {$e eq {}} {
10194                    set growing($a) 1
10195                } else {
10196                    set arcend($a) $e
10197                    if {![info exists arcout($e)]} {
10198                        set arcout($e) {}
10199                    }
10200                }
10201                set arcids($a) [lindex $line 2]
10202                foreach id $arcids($a) {
10203                    lappend allparents($s) $id
10204                    set s $id
10205                    lappend arcnos($id) $a
10206                }
10207                if {![info exists allparents($s)]} {
10208                    set allparents($s) {}
10209                }
10210                set arctags($a) {}
10211                set archeads($a) {}
10212            }
10213            set nextarc [expr {$a - 1}]
10214        }
10215    } err]} {
10216        dropcache $err
10217        return 0
10218    }
10219    if {!$allcwait} {
10220        getallcommits
10221    }
10222    return $allcwait
10223}
10224
10225proc getcache {f} {
10226    global nextarc cachedarcs possible_seeds
10227
10228    if {[catch {
10229        set line [gets $f]
10230        if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10231        # make sure it's an integer
10232        set cachedarcs [expr {int([lindex $line 1])}]
10233        if {$cachedarcs < 0} {error "bad number of arcs"}
10234        set nextarc 0
10235        set possible_seeds {}
10236        run readcache $f
10237    } err]} {
10238        dropcache $err
10239    }
10240    return 0
10241}
10242
10243proc dropcache {err} {
10244    global allcwait nextarc cachedarcs seeds
10245
10246    #puts "dropping cache ($err)"
10247    foreach v {arcnos arcout arcids arcstart arcend growing \
10248                   arctags archeads allparents allchildren} {
10249        global $v
10250        catch {unset $v}
10251    }
10252    set allcwait 0
10253    set nextarc 0
10254    set cachedarcs 0
10255    set seeds {}
10256    getallcommits
10257}
10258
10259proc writecache {f} {
10260    global cachearc cachedarcs allccache
10261    global arcstart arcend arcnos arcids arcout
10262
10263    set a $cachearc
10264    set lim $cachedarcs
10265    if {$lim - $a > 1000} {
10266        set lim [expr {$a + 1000}]
10267    }
10268    if {[catch {
10269        while {[incr a] <= $lim} {
10270            if {[info exists arcend($a)]} {
10271                puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10272            } else {
10273                puts $f [list $arcstart($a) {} $arcids($a)]
10274            }
10275        }
10276    } err]} {
10277        catch {close $f}
10278        catch {file delete $allccache}
10279        #puts "writing cache failed ($err)"
10280        return 0
10281    }
10282    set cachearc [expr {$a - 1}]
10283    if {$a > $cachedarcs} {
10284        puts $f "1"
10285        close $f
10286        return 0
10287    }
10288    return 1
10289}
10290
10291proc savecache {} {
10292    global nextarc cachedarcs cachearc allccache
10293
10294    if {$nextarc == $cachedarcs} return
10295    set cachearc 0
10296    set cachedarcs $nextarc
10297    catch {
10298        set f [open $allccache w]
10299        puts $f [list 1 $cachedarcs]
10300        run writecache $f
10301    }
10302}
10303
10304# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10305# or 0 if neither is true.
10306proc anc_or_desc {a b} {
10307    global arcout arcstart arcend arcnos cached_isanc
10308
10309    if {$arcnos($a) eq $arcnos($b)} {
10310        # Both are on the same arc(s); either both are the same BMP,
10311        # or if one is not a BMP, the other is also not a BMP or is
10312        # the BMP at end of the arc (and it only has 1 incoming arc).
10313        # Or both can be BMPs with no incoming arcs.
10314        if {$a eq $b || $arcnos($a) eq {}} {
10315            return 0
10316        }
10317        # assert {[llength $arcnos($a)] == 1}
10318        set arc [lindex $arcnos($a) 0]
10319        set i [lsearch -exact $arcids($arc) $a]
10320        set j [lsearch -exact $arcids($arc) $b]
10321        if {$i < 0 || $i > $j} {
10322            return 1
10323        } else {
10324            return -1
10325        }
10326    }
10327
10328    if {![info exists arcout($a)]} {
10329        set arc [lindex $arcnos($a) 0]
10330        if {[info exists arcend($arc)]} {
10331            set aend $arcend($arc)
10332        } else {
10333            set aend {}
10334        }
10335        set a $arcstart($arc)
10336    } else {
10337        set aend $a
10338    }
10339    if {![info exists arcout($b)]} {
10340        set arc [lindex $arcnos($b) 0]
10341        if {[info exists arcend($arc)]} {
10342            set bend $arcend($arc)
10343        } else {
10344            set bend {}
10345        }
10346        set b $arcstart($arc)
10347    } else {
10348        set bend $b
10349    }
10350    if {$a eq $bend} {
10351        return 1
10352    }
10353    if {$b eq $aend} {
10354        return -1
10355    }
10356    if {[info exists cached_isanc($a,$bend)]} {
10357        if {$cached_isanc($a,$bend)} {
10358            return 1
10359        }
10360    }
10361    if {[info exists cached_isanc($b,$aend)]} {
10362        if {$cached_isanc($b,$aend)} {
10363            return -1
10364        }
10365        if {[info exists cached_isanc($a,$bend)]} {
10366            return 0
10367        }
10368    }
10369
10370    set todo [list $a $b]
10371    set anc($a) a
10372    set anc($b) b
10373    for {set i 0} {$i < [llength $todo]} {incr i} {
10374        set x [lindex $todo $i]
10375        if {$anc($x) eq {}} {
10376            continue
10377        }
10378        foreach arc $arcnos($x) {
10379            set xd $arcstart($arc)
10380            if {$xd eq $bend} {
10381                set cached_isanc($a,$bend) 1
10382                set cached_isanc($b,$aend) 0
10383                return 1
10384            } elseif {$xd eq $aend} {
10385                set cached_isanc($b,$aend) 1
10386                set cached_isanc($a,$bend) 0
10387                return -1
10388            }
10389            if {![info exists anc($xd)]} {
10390                set anc($xd) $anc($x)
10391                lappend todo $xd
10392            } elseif {$anc($xd) ne $anc($x)} {
10393                set anc($xd) {}
10394            }
10395        }
10396    }
10397    set cached_isanc($a,$bend) 0
10398    set cached_isanc($b,$aend) 0
10399    return 0
10400}
10401
10402# This identifies whether $desc has an ancestor that is
10403# a growing tip of the graph and which is not an ancestor of $anc
10404# and returns 0 if so and 1 if not.
10405# If we subsequently discover a tag on such a growing tip, and that
10406# turns out to be a descendent of $anc (which it could, since we
10407# don't necessarily see children before parents), then $desc
10408# isn't a good choice to display as a descendent tag of
10409# $anc (since it is the descendent of another tag which is
10410# a descendent of $anc).  Similarly, $anc isn't a good choice to
10411# display as a ancestor tag of $desc.
10412#
10413proc is_certain {desc anc} {
10414    global arcnos arcout arcstart arcend growing problems
10415
10416    set certain {}
10417    if {[llength $arcnos($anc)] == 1} {
10418        # tags on the same arc are certain
10419        if {$arcnos($desc) eq $arcnos($anc)} {
10420            return 1
10421        }
10422        if {![info exists arcout($anc)]} {
10423            # if $anc is partway along an arc, use the start of the arc instead
10424            set a [lindex $arcnos($anc) 0]
10425            set anc $arcstart($a)
10426        }
10427    }
10428    if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10429        set x $desc
10430    } else {
10431        set a [lindex $arcnos($desc) 0]
10432        set x $arcend($a)
10433    }
10434    if {$x == $anc} {
10435        return 1
10436    }
10437    set anclist [list $x]
10438    set dl($x) 1
10439    set nnh 1
10440    set ngrowanc 0
10441    for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10442        set x [lindex $anclist $i]
10443        if {$dl($x)} {
10444            incr nnh -1
10445        }
10446        set done($x) 1
10447        foreach a $arcout($x) {
10448            if {[info exists growing($a)]} {
10449                if {![info exists growanc($x)] && $dl($x)} {
10450                    set growanc($x) 1
10451                    incr ngrowanc
10452                }
10453            } else {
10454                set y $arcend($a)
10455                if {[info exists dl($y)]} {
10456                    if {$dl($y)} {
10457                        if {!$dl($x)} {
10458                            set dl($y) 0
10459                            if {![info exists done($y)]} {
10460                                incr nnh -1
10461                            }
10462                            if {[info exists growanc($x)]} {
10463                                incr ngrowanc -1
10464                            }
10465                            set xl [list $y]
10466                            for {set k 0} {$k < [llength $xl]} {incr k} {
10467                                set z [lindex $xl $k]
10468                                foreach c $arcout($z) {
10469                                    if {[info exists arcend($c)]} {
10470                                        set v $arcend($c)
10471                                        if {[info exists dl($v)] && $dl($v)} {
10472                                            set dl($v) 0
10473                                            if {![info exists done($v)]} {
10474                                                incr nnh -1
10475                                            }
10476                                            if {[info exists growanc($v)]} {
10477                                                incr ngrowanc -1
10478                                            }
10479                                            lappend xl $v
10480                                        }
10481                                    }
10482                                }
10483                            }
10484                        }
10485                    }
10486                } elseif {$y eq $anc || !$dl($x)} {
10487                    set dl($y) 0
10488                    lappend anclist $y
10489                } else {
10490                    set dl($y) 1
10491                    lappend anclist $y
10492                    incr nnh
10493                }
10494            }
10495        }
10496    }
10497    foreach x [array names growanc] {
10498        if {$dl($x)} {
10499            return 0
10500        }
10501        return 0
10502    }
10503    return 1
10504}
10505
10506proc validate_arctags {a} {
10507    global arctags idtags
10508
10509    set i -1
10510    set na $arctags($a)
10511    foreach id $arctags($a) {
10512        incr i
10513        if {![info exists idtags($id)]} {
10514            set na [lreplace $na $i $i]
10515            incr i -1
10516        }
10517    }
10518    set arctags($a) $na
10519}
10520
10521proc validate_archeads {a} {
10522    global archeads idheads
10523
10524    set i -1
10525    set na $archeads($a)
10526    foreach id $archeads($a) {
10527        incr i
10528        if {![info exists idheads($id)]} {
10529            set na [lreplace $na $i $i]
10530            incr i -1
10531        }
10532    }
10533    set archeads($a) $na
10534}
10535
10536# Return the list of IDs that have tags that are descendents of id,
10537# ignoring IDs that are descendents of IDs already reported.
10538proc desctags {id} {
10539    global arcnos arcstart arcids arctags idtags allparents
10540    global growing cached_dtags
10541
10542    if {![info exists allparents($id)]} {
10543        return {}
10544    }
10545    set t1 [clock clicks -milliseconds]
10546    set argid $id
10547    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10548        # part-way along an arc; check that arc first
10549        set a [lindex $arcnos($id) 0]
10550        if {$arctags($a) ne {}} {
10551            validate_arctags $a
10552            set i [lsearch -exact $arcids($a) $id]
10553            set tid {}
10554            foreach t $arctags($a) {
10555                set j [lsearch -exact $arcids($a) $t]
10556                if {$j >= $i} break
10557                set tid $t
10558            }
10559            if {$tid ne {}} {
10560                return $tid
10561            }
10562        }
10563        set id $arcstart($a)
10564        if {[info exists idtags($id)]} {
10565            return $id
10566        }
10567    }
10568    if {[info exists cached_dtags($id)]} {
10569        return $cached_dtags($id)
10570    }
10571
10572    set origid $id
10573    set todo [list $id]
10574    set queued($id) 1
10575    set nc 1
10576    for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10577        set id [lindex $todo $i]
10578        set done($id) 1
10579        set ta [info exists hastaggedancestor($id)]
10580        if {!$ta} {
10581            incr nc -1
10582        }
10583        # ignore tags on starting node
10584        if {!$ta && $i > 0} {
10585            if {[info exists idtags($id)]} {
10586                set tagloc($id) $id
10587                set ta 1
10588            } elseif {[info exists cached_dtags($id)]} {
10589                set tagloc($id) $cached_dtags($id)
10590                set ta 1
10591            }
10592        }
10593        foreach a $arcnos($id) {
10594            set d $arcstart($a)
10595            if {!$ta && $arctags($a) ne {}} {
10596                validate_arctags $a
10597                if {$arctags($a) ne {}} {
10598                    lappend tagloc($id) [lindex $arctags($a) end]
10599                }
10600            }
10601            if {$ta || $arctags($a) ne {}} {
10602                set tomark [list $d]
10603                for {set j 0} {$j < [llength $tomark]} {incr j} {
10604                    set dd [lindex $tomark $j]
10605                    if {![info exists hastaggedancestor($dd)]} {
10606                        if {[info exists done($dd)]} {
10607                            foreach b $arcnos($dd) {
10608                                lappend tomark $arcstart($b)
10609                            }
10610                            if {[info exists tagloc($dd)]} {
10611                                unset tagloc($dd)
10612                            }
10613                        } elseif {[info exists queued($dd)]} {
10614                            incr nc -1
10615                        }
10616                        set hastaggedancestor($dd) 1
10617                    }
10618                }
10619            }
10620            if {![info exists queued($d)]} {
10621                lappend todo $d
10622                set queued($d) 1
10623                if {![info exists hastaggedancestor($d)]} {
10624                    incr nc
10625                }
10626            }
10627        }
10628    }
10629    set tags {}
10630    foreach id [array names tagloc] {
10631        if {![info exists hastaggedancestor($id)]} {
10632            foreach t $tagloc($id) {
10633                if {[lsearch -exact $tags $t] < 0} {
10634                    lappend tags $t
10635                }
10636            }
10637        }
10638    }
10639    set t2 [clock clicks -milliseconds]
10640    set loopix $i
10641
10642    # remove tags that are descendents of other tags
10643    for {set i 0} {$i < [llength $tags]} {incr i} {
10644        set a [lindex $tags $i]
10645        for {set j 0} {$j < $i} {incr j} {
10646            set b [lindex $tags $j]
10647            set r [anc_or_desc $a $b]
10648            if {$r == 1} {
10649                set tags [lreplace $tags $j $j]
10650                incr j -1
10651                incr i -1
10652            } elseif {$r == -1} {
10653                set tags [lreplace $tags $i $i]
10654                incr i -1
10655                break
10656            }
10657        }
10658    }
10659
10660    if {[array names growing] ne {}} {
10661        # graph isn't finished, need to check if any tag could get
10662        # eclipsed by another tag coming later.  Simply ignore any
10663        # tags that could later get eclipsed.
10664        set ctags {}
10665        foreach t $tags {
10666            if {[is_certain $t $origid]} {
10667                lappend ctags $t
10668            }
10669        }
10670        if {$tags eq $ctags} {
10671            set cached_dtags($origid) $tags
10672        } else {
10673            set tags $ctags
10674        }
10675    } else {
10676        set cached_dtags($origid) $tags
10677    }
10678    set t3 [clock clicks -milliseconds]
10679    if {0 && $t3 - $t1 >= 100} {
10680        puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10681            [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10682    }
10683    return $tags
10684}
10685
10686proc anctags {id} {
10687    global arcnos arcids arcout arcend arctags idtags allparents
10688    global growing cached_atags
10689
10690    if {![info exists allparents($id)]} {
10691        return {}
10692    }
10693    set t1 [clock clicks -milliseconds]
10694    set argid $id
10695    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10696        # part-way along an arc; check that arc first
10697        set a [lindex $arcnos($id) 0]
10698        if {$arctags($a) ne {}} {
10699            validate_arctags $a
10700            set i [lsearch -exact $arcids($a) $id]
10701            foreach t $arctags($a) {
10702                set j [lsearch -exact $arcids($a) $t]
10703                if {$j > $i} {
10704                    return $t
10705                }
10706            }
10707        }
10708        if {![info exists arcend($a)]} {
10709            return {}
10710        }
10711        set id $arcend($a)
10712        if {[info exists idtags($id)]} {
10713            return $id
10714        }
10715    }
10716    if {[info exists cached_atags($id)]} {
10717        return $cached_atags($id)
10718    }
10719
10720    set origid $id
10721    set todo [list $id]
10722    set queued($id) 1
10723    set taglist {}
10724    set nc 1
10725    for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10726        set id [lindex $todo $i]
10727        set done($id) 1
10728        set td [info exists hastaggeddescendent($id)]
10729        if {!$td} {
10730            incr nc -1
10731        }
10732        # ignore tags on starting node
10733        if {!$td && $i > 0} {
10734            if {[info exists idtags($id)]} {
10735                set tagloc($id) $id
10736                set td 1
10737            } elseif {[info exists cached_atags($id)]} {
10738                set tagloc($id) $cached_atags($id)
10739                set td 1
10740            }
10741        }
10742        foreach a $arcout($id) {
10743            if {!$td && $arctags($a) ne {}} {
10744                validate_arctags $a
10745                if {$arctags($a) ne {}} {
10746                    lappend tagloc($id) [lindex $arctags($a) 0]
10747                }
10748            }
10749            if {![info exists arcend($a)]} continue
10750            set d $arcend($a)
10751            if {$td || $arctags($a) ne {}} {
10752                set tomark [list $d]
10753                for {set j 0} {$j < [llength $tomark]} {incr j} {
10754                    set dd [lindex $tomark $j]
10755                    if {![info exists hastaggeddescendent($dd)]} {
10756                        if {[info exists done($dd)]} {
10757                            foreach b $arcout($dd) {
10758                                if {[info exists arcend($b)]} {
10759                                    lappend tomark $arcend($b)
10760                                }
10761                            }
10762                            if {[info exists tagloc($dd)]} {
10763                                unset tagloc($dd)
10764                            }
10765                        } elseif {[info exists queued($dd)]} {
10766                            incr nc -1
10767                        }
10768                        set hastaggeddescendent($dd) 1
10769                    }
10770                }
10771            }
10772            if {![info exists queued($d)]} {
10773                lappend todo $d
10774                set queued($d) 1
10775                if {![info exists hastaggeddescendent($d)]} {
10776                    incr nc
10777                }
10778            }
10779        }
10780    }
10781    set t2 [clock clicks -milliseconds]
10782    set loopix $i
10783    set tags {}
10784    foreach id [array names tagloc] {
10785        if {![info exists hastaggeddescendent($id)]} {
10786            foreach t $tagloc($id) {
10787                if {[lsearch -exact $tags $t] < 0} {
10788                    lappend tags $t
10789                }
10790            }
10791        }
10792    }
10793
10794    # remove tags that are ancestors of other tags
10795    for {set i 0} {$i < [llength $tags]} {incr i} {
10796        set a [lindex $tags $i]
10797        for {set j 0} {$j < $i} {incr j} {
10798            set b [lindex $tags $j]
10799            set r [anc_or_desc $a $b]
10800            if {$r == -1} {
10801                set tags [lreplace $tags $j $j]
10802                incr j -1
10803                incr i -1
10804            } elseif {$r == 1} {
10805                set tags [lreplace $tags $i $i]
10806                incr i -1
10807                break
10808            }
10809        }
10810    }
10811
10812    if {[array names growing] ne {}} {
10813        # graph isn't finished, need to check if any tag could get
10814        # eclipsed by another tag coming later.  Simply ignore any
10815        # tags that could later get eclipsed.
10816        set ctags {}
10817        foreach t $tags {
10818            if {[is_certain $origid $t]} {
10819                lappend ctags $t
10820            }
10821        }
10822        if {$tags eq $ctags} {
10823            set cached_atags($origid) $tags
10824        } else {
10825            set tags $ctags
10826        }
10827    } else {
10828        set cached_atags($origid) $tags
10829    }
10830    set t3 [clock clicks -milliseconds]
10831    if {0 && $t3 - $t1 >= 100} {
10832        puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10833            [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10834    }
10835    return $tags
10836}
10837
10838# Return the list of IDs that have heads that are descendents of id,
10839# including id itself if it has a head.
10840proc descheads {id} {
10841    global arcnos arcstart arcids archeads idheads cached_dheads
10842    global allparents arcout
10843
10844    if {![info exists allparents($id)]} {
10845        return {}
10846    }
10847    set aret {}
10848    if {![info exists arcout($id)]} {
10849        # part-way along an arc; check it first
10850        set a [lindex $arcnos($id) 0]
10851        if {$archeads($a) ne {}} {
10852            validate_archeads $a
10853            set i [lsearch -exact $arcids($a) $id]
10854            foreach t $archeads($a) {
10855                set j [lsearch -exact $arcids($a) $t]
10856                if {$j > $i} break
10857                lappend aret $t
10858            }
10859        }
10860        set id $arcstart($a)
10861    }
10862    set origid $id
10863    set todo [list $id]
10864    set seen($id) 1
10865    set ret {}
10866    for {set i 0} {$i < [llength $todo]} {incr i} {
10867        set id [lindex $todo $i]
10868        if {[info exists cached_dheads($id)]} {
10869            set ret [concat $ret $cached_dheads($id)]
10870        } else {
10871            if {[info exists idheads($id)]} {
10872                lappend ret $id
10873            }
10874            foreach a $arcnos($id) {
10875                if {$archeads($a) ne {}} {
10876                    validate_archeads $a
10877                    if {$archeads($a) ne {}} {
10878                        set ret [concat $ret $archeads($a)]
10879                    }
10880                }
10881                set d $arcstart($a)
10882                if {![info exists seen($d)]} {
10883                    lappend todo $d
10884                    set seen($d) 1
10885                }
10886            }
10887        }
10888    }
10889    set ret [lsort -unique $ret]
10890    set cached_dheads($origid) $ret
10891    return [concat $ret $aret]
10892}
10893
10894proc addedtag {id} {
10895    global arcnos arcout cached_dtags cached_atags
10896
10897    if {![info exists arcnos($id)]} return
10898    if {![info exists arcout($id)]} {
10899        recalcarc [lindex $arcnos($id) 0]
10900    }
10901    catch {unset cached_dtags}
10902    catch {unset cached_atags}
10903}
10904
10905proc addedhead {hid head} {
10906    global arcnos arcout cached_dheads
10907
10908    if {![info exists arcnos($hid)]} return
10909    if {![info exists arcout($hid)]} {
10910        recalcarc [lindex $arcnos($hid) 0]
10911    }
10912    catch {unset cached_dheads}
10913}
10914
10915proc removedhead {hid head} {
10916    global cached_dheads
10917
10918    catch {unset cached_dheads}
10919}
10920
10921proc movedhead {hid head} {
10922    global arcnos arcout cached_dheads
10923
10924    if {![info exists arcnos($hid)]} return
10925    if {![info exists arcout($hid)]} {
10926        recalcarc [lindex $arcnos($hid) 0]
10927    }
10928    catch {unset cached_dheads}
10929}
10930
10931proc changedrefs {} {
10932    global cached_dheads cached_dtags cached_atags cached_tagcontent
10933    global arctags archeads arcnos arcout idheads idtags
10934
10935    foreach id [concat [array names idheads] [array names idtags]] {
10936        if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
10937            set a [lindex $arcnos($id) 0]
10938            if {![info exists donearc($a)]} {
10939                recalcarc $a
10940                set donearc($a) 1
10941            }
10942        }
10943    }
10944    catch {unset cached_tagcontent}
10945    catch {unset cached_dtags}
10946    catch {unset cached_atags}
10947    catch {unset cached_dheads}
10948}
10949
10950proc rereadrefs {} {
10951    global idtags idheads idotherrefs mainheadid
10952
10953    set refids [concat [array names idtags] \
10954                    [array names idheads] [array names idotherrefs]]
10955    foreach id $refids {
10956        if {![info exists ref($id)]} {
10957            set ref($id) [listrefs $id]
10958        }
10959    }
10960    set oldmainhead $mainheadid
10961    readrefs
10962    changedrefs
10963    set refids [lsort -unique [concat $refids [array names idtags] \
10964                        [array names idheads] [array names idotherrefs]]]
10965    foreach id $refids {
10966        set v [listrefs $id]
10967        if {![info exists ref($id)] || $ref($id) != $v} {
10968            redrawtags $id
10969        }
10970    }
10971    if {$oldmainhead ne $mainheadid} {
10972        redrawtags $oldmainhead
10973        redrawtags $mainheadid
10974    }
10975    run refill_reflist
10976}
10977
10978proc listrefs {id} {
10979    global idtags idheads idotherrefs
10980
10981    set x {}
10982    if {[info exists idtags($id)]} {
10983        set x $idtags($id)
10984    }
10985    set y {}
10986    if {[info exists idheads($id)]} {
10987        set y $idheads($id)
10988    }
10989    set z {}
10990    if {[info exists idotherrefs($id)]} {
10991        set z $idotherrefs($id)
10992    }
10993    return [list $x $y $z]
10994}
10995
10996proc add_tag_ctext {tag} {
10997    global ctext cached_tagcontent tagids
10998
10999    if {![info exists cached_tagcontent($tag)]} {
11000        catch {
11001            set cached_tagcontent($tag) [exec git cat-file -p $tag]
11002        }
11003    }
11004    $ctext insert end "[mc "Tag"]: $tag\n" bold
11005    if {[info exists cached_tagcontent($tag)]} {
11006        set text $cached_tagcontent($tag)
11007    } else {
11008        set text "[mc "Id"]:  $tagids($tag)"
11009    }
11010    appendwithlinks $text {}
11011}
11012
11013proc showtag {tag isnew} {
11014    global ctext cached_tagcontent tagids linknum tagobjid
11015
11016    if {$isnew} {
11017        addtohistory [list showtag $tag 0] savectextpos
11018    }
11019    $ctext conf -state normal
11020    clear_ctext
11021    settabs 0
11022    set linknum 0
11023    add_tag_ctext $tag
11024    maybe_scroll_ctext 1
11025    $ctext conf -state disabled
11026    init_flist {}
11027}
11028
11029proc showtags {id isnew} {
11030    global idtags ctext linknum
11031
11032    if {$isnew} {
11033        addtohistory [list showtags $id 0] savectextpos
11034    }
11035    $ctext conf -state normal
11036    clear_ctext
11037    settabs 0
11038    set linknum 0
11039    set sep {}
11040    foreach tag $idtags($id) {
11041        $ctext insert end $sep
11042        add_tag_ctext $tag
11043        set sep "\n\n"
11044    }
11045    maybe_scroll_ctext 1
11046    $ctext conf -state disabled
11047    init_flist {}
11048}
11049
11050proc doquit {} {
11051    global stopped
11052    global gitktmpdir
11053
11054    set stopped 100
11055    savestuff .
11056    destroy .
11057
11058    if {[info exists gitktmpdir]} {
11059        catch {file delete -force $gitktmpdir}
11060    }
11061}
11062
11063proc mkfontdisp {font top which} {
11064    global fontattr fontpref $font NS use_ttk
11065
11066    set fontpref($font) [set $font]
11067    ${NS}::button $top.${font}but -text $which \
11068        -command [list choosefont $font $which]
11069    ${NS}::label $top.$font -relief flat -font $font \
11070        -text $fontattr($font,family) -justify left
11071    grid x $top.${font}but $top.$font -sticky w
11072}
11073
11074proc choosefont {font which} {
11075    global fontparam fontlist fonttop fontattr
11076    global prefstop NS
11077
11078    set fontparam(which) $which
11079    set fontparam(font) $font
11080    set fontparam(family) [font actual $font -family]
11081    set fontparam(size) $fontattr($font,size)
11082    set fontparam(weight) $fontattr($font,weight)
11083    set fontparam(slant) $fontattr($font,slant)
11084    set top .gitkfont
11085    set fonttop $top
11086    if {![winfo exists $top]} {
11087        font create sample
11088        eval font config sample [font actual $font]
11089        ttk_toplevel $top
11090        make_transient $top $prefstop
11091        wm title $top [mc "Gitk font chooser"]
11092        ${NS}::label $top.l -textvariable fontparam(which)
11093        pack $top.l -side top
11094        set fontlist [lsort [font families]]
11095        ${NS}::frame $top.f
11096        listbox $top.f.fam -listvariable fontlist \
11097            -yscrollcommand [list $top.f.sb set]
11098        bind $top.f.fam <<ListboxSelect>> selfontfam
11099        ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11100        pack $top.f.sb -side right -fill y
11101        pack $top.f.fam -side left -fill both -expand 1
11102        pack $top.f -side top -fill both -expand 1
11103        ${NS}::frame $top.g
11104        spinbox $top.g.size -from 4 -to 40 -width 4 \
11105            -textvariable fontparam(size) \
11106            -validatecommand {string is integer -strict %s}
11107        checkbutton $top.g.bold -padx 5 \
11108            -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11109            -variable fontparam(weight) -onvalue bold -offvalue normal
11110        checkbutton $top.g.ital -padx 5 \
11111            -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0  \
11112            -variable fontparam(slant) -onvalue italic -offvalue roman
11113        pack $top.g.size $top.g.bold $top.g.ital -side left
11114        pack $top.g -side top
11115        canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11116            -background white
11117        $top.c create text 100 25 -anchor center -text $which -font sample \
11118            -fill black -tags text
11119        bind $top.c <Configure> [list centertext $top.c]
11120        pack $top.c -side top -fill x
11121        ${NS}::frame $top.buts
11122        ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11123        ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11124        bind $top <Key-Return> fontok
11125        bind $top <Key-Escape> fontcan
11126        grid $top.buts.ok $top.buts.can
11127        grid columnconfigure $top.buts 0 -weight 1 -uniform a
11128        grid columnconfigure $top.buts 1 -weight 1 -uniform a
11129        pack $top.buts -side bottom -fill x
11130        trace add variable fontparam write chg_fontparam
11131    } else {
11132        raise $top
11133        $top.c itemconf text -text $which
11134    }
11135    set i [lsearch -exact $fontlist $fontparam(family)]
11136    if {$i >= 0} {
11137        $top.f.fam selection set $i
11138        $top.f.fam see $i
11139    }
11140}
11141
11142proc centertext {w} {
11143    $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11144}
11145
11146proc fontok {} {
11147    global fontparam fontpref prefstop
11148
11149    set f $fontparam(font)
11150    set fontpref($f) [list $fontparam(family) $fontparam(size)]
11151    if {$fontparam(weight) eq "bold"} {
11152        lappend fontpref($f) "bold"
11153    }
11154    if {$fontparam(slant) eq "italic"} {
11155        lappend fontpref($f) "italic"
11156    }
11157    set w $prefstop.notebook.fonts.$f
11158    $w conf -text $fontparam(family) -font $fontpref($f)
11159
11160    fontcan
11161}
11162
11163proc fontcan {} {
11164    global fonttop fontparam
11165
11166    if {[info exists fonttop]} {
11167        catch {destroy $fonttop}
11168        catch {font delete sample}
11169        unset fonttop
11170        unset fontparam
11171    }
11172}
11173
11174if {[package vsatisfies [package provide Tk] 8.6]} {
11175    # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11176    # function to make use of it.
11177    proc choosefont {font which} {
11178        tk fontchooser configure -title $which -font $font \
11179            -command [list on_choosefont $font $which]
11180        tk fontchooser show
11181    }
11182    proc on_choosefont {font which newfont} {
11183        global fontparam
11184        puts stderr "$font $newfont"
11185        array set f [font actual $newfont]
11186        set fontparam(which) $which
11187        set fontparam(font) $font
11188        set fontparam(family) $f(-family)
11189        set fontparam(size) $f(-size)
11190        set fontparam(weight) $f(-weight)
11191        set fontparam(slant) $f(-slant)
11192        fontok
11193    }
11194}
11195
11196proc selfontfam {} {
11197    global fonttop fontparam
11198
11199    set i [$fonttop.f.fam curselection]
11200    if {$i ne {}} {
11201        set fontparam(family) [$fonttop.f.fam get $i]
11202    }
11203}
11204
11205proc chg_fontparam {v sub op} {
11206    global fontparam
11207
11208    font config sample -$sub $fontparam($sub)
11209}
11210
11211# Create a property sheet tab page
11212proc create_prefs_page {w} {
11213    global NS
11214    set parent [join [lrange [split $w .] 0 end-1] .]
11215    if {[winfo class $parent] eq "TNotebook"} {
11216        ${NS}::frame $w
11217    } else {
11218        ${NS}::labelframe $w
11219    }
11220}
11221
11222proc prefspage_general {notebook} {
11223    global NS maxwidth maxgraphpct showneartags showlocalchanges
11224    global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11225    global hideremotes want_ttk have_ttk maxrefs
11226
11227    set page [create_prefs_page $notebook.general]
11228
11229    ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11230    grid $page.ldisp - -sticky w -pady 10
11231    ${NS}::label $page.spacer -text " "
11232    ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11233    spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11234    grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11235    ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11236    spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11237    grid x $page.maxpctl $page.maxpct -sticky w
11238    ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11239        -variable showlocalchanges
11240    grid x $page.showlocal -sticky w
11241    ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11242        -variable autoselect
11243    spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11244    grid x $page.autoselect $page.autosellen -sticky w
11245    ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11246        -variable hideremotes
11247    grid x $page.hideremotes -sticky w
11248
11249    ${NS}::label $page.ddisp -text [mc "Diff display options"]
11250    grid $page.ddisp - -sticky w -pady 10
11251    ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11252    spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11253    grid x $page.tabstopl $page.tabstop -sticky w
11254    ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11255        -variable showneartags
11256    grid x $page.ntag -sticky w
11257    ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11258    spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11259    grid x $page.maxrefsl $page.maxrefs -sticky w
11260    ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11261        -variable limitdiffs
11262    grid x $page.ldiff -sticky w
11263    ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11264        -variable perfile_attrs
11265    grid x $page.lattr -sticky w
11266
11267    ${NS}::entry $page.extdifft -textvariable extdifftool
11268    ${NS}::frame $page.extdifff
11269    ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11270    ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11271    pack $page.extdifff.l $page.extdifff.b -side left
11272    pack configure $page.extdifff.l -padx 10
11273    grid x $page.extdifff $page.extdifft -sticky ew
11274
11275    ${NS}::label $page.lgen -text [mc "General options"]
11276    grid $page.lgen - -sticky w -pady 10
11277    ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11278        -text [mc "Use themed widgets"]
11279    if {$have_ttk} {
11280        ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11281    } else {
11282        ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11283    }
11284    grid x $page.want_ttk $page.ttk_note -sticky w
11285    return $page
11286}
11287
11288proc prefspage_colors {notebook} {
11289    global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11290
11291    set page [create_prefs_page $notebook.colors]
11292
11293    ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11294    grid $page.cdisp - -sticky w -pady 10
11295    label $page.ui -padx 40 -relief sunk -background $uicolor
11296    ${NS}::button $page.uibut -text [mc "Interface"] \
11297       -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11298    grid x $page.uibut $page.ui -sticky w
11299    label $page.bg -padx 40 -relief sunk -background $bgcolor
11300    ${NS}::button $page.bgbut -text [mc "Background"] \
11301        -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11302    grid x $page.bgbut $page.bg -sticky w
11303    label $page.fg -padx 40 -relief sunk -background $fgcolor
11304    ${NS}::button $page.fgbut -text [mc "Foreground"] \
11305        -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11306    grid x $page.fgbut $page.fg -sticky w
11307    label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11308    ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11309        -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11310                      [list $ctext tag conf d0 -foreground]]
11311    grid x $page.diffoldbut $page.diffold -sticky w
11312    label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11313    ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11314        -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11315                      [list $ctext tag conf dresult -foreground]]
11316    grid x $page.diffnewbut $page.diffnew -sticky w
11317    label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11318    ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11319        -command [list choosecolor diffcolors 2 $page.hunksep \
11320                      [mc "diff hunk header"] \
11321                      [list $ctext tag conf hunksep -foreground]]
11322    grid x $page.hunksepbut $page.hunksep -sticky w
11323    label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11324    ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11325        -command [list choosecolor markbgcolor {} $page.markbgsep \
11326                      [mc "marked line background"] \
11327                      [list $ctext tag conf omark -background]]
11328    grid x $page.markbgbut $page.markbgsep -sticky w
11329    label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11330    ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11331        -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11332    grid x $page.selbgbut $page.selbgsep -sticky w
11333    return $page
11334}
11335
11336proc prefspage_fonts {notebook} {
11337    global NS
11338    set page [create_prefs_page $notebook.fonts]
11339    ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11340    grid $page.cfont - -sticky w -pady 10
11341    mkfontdisp mainfont $page [mc "Main font"]
11342    mkfontdisp textfont $page [mc "Diff display font"]
11343    mkfontdisp uifont $page [mc "User interface font"]
11344    return $page
11345}
11346
11347proc doprefs {} {
11348    global maxwidth maxgraphpct use_ttk NS
11349    global oldprefs prefstop showneartags showlocalchanges
11350    global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11351    global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11352    global hideremotes want_ttk have_ttk
11353
11354    set top .gitkprefs
11355    set prefstop $top
11356    if {[winfo exists $top]} {
11357        raise $top
11358        return
11359    }
11360    foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11361                   limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11362        set oldprefs($v) [set $v]
11363    }
11364    ttk_toplevel $top
11365    wm title $top [mc "Gitk preferences"]
11366    make_transient $top .
11367
11368    if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11369        set notebook [ttk::notebook $top.notebook]
11370    } else {
11371        set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11372    }
11373
11374    lappend pages [prefspage_general $notebook] [mc "General"]
11375    lappend pages [prefspage_colors $notebook] [mc "Colors"]
11376    lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11377    set col 0
11378    foreach {page title} $pages {
11379        if {$use_notebook} {
11380            $notebook add $page -text $title
11381        } else {
11382            set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11383                         -text $title -command [list raise $page]]
11384            $page configure -text $title
11385            grid $btn -row 0 -column [incr col] -sticky w
11386            grid $page -row 1 -column 0 -sticky news -columnspan 100
11387        }
11388    }
11389
11390    if {!$use_notebook} {
11391        grid columnconfigure $notebook 0 -weight 1
11392        grid rowconfigure $notebook 1 -weight 1
11393        raise [lindex $pages 0]
11394    }
11395
11396    grid $notebook -sticky news -padx 2 -pady 2
11397    grid rowconfigure $top 0 -weight 1
11398    grid columnconfigure $top 0 -weight 1
11399
11400    ${NS}::frame $top.buts
11401    ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11402    ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11403    bind $top <Key-Return> prefsok
11404    bind $top <Key-Escape> prefscan
11405    grid $top.buts.ok $top.buts.can
11406    grid columnconfigure $top.buts 0 -weight 1 -uniform a
11407    grid columnconfigure $top.buts 1 -weight 1 -uniform a
11408    grid $top.buts - - -pady 10 -sticky ew
11409    grid columnconfigure $top 2 -weight 1
11410    bind $top <Visibility> [list focus $top.buts.ok]
11411}
11412
11413proc choose_extdiff {} {
11414    global extdifftool
11415
11416    set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11417    if {$prog ne {}} {
11418        set extdifftool $prog
11419    }
11420}
11421
11422proc choosecolor {v vi w x cmd} {
11423    global $v
11424
11425    set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11426               -title [mc "Gitk: choose color for %s" $x]]
11427    if {$c eq {}} return
11428    $w conf -background $c
11429    lset $v $vi $c
11430    eval $cmd $c
11431}
11432
11433proc setselbg {c} {
11434    global bglist cflist
11435    foreach w $bglist {
11436        $w configure -selectbackground $c
11437    }
11438    $cflist tag configure highlight \
11439        -background [$cflist cget -selectbackground]
11440    allcanvs itemconf secsel -fill $c
11441}
11442
11443# This sets the background color and the color scheme for the whole UI.
11444# For some reason, tk_setPalette chooses a nasty dark red for selectColor
11445# if we don't specify one ourselves, which makes the checkbuttons and
11446# radiobuttons look bad.  This chooses white for selectColor if the
11447# background color is light, or black if it is dark.
11448proc setui {c} {
11449    if {[tk windowingsystem] eq "win32"} { return }
11450    set bg [winfo rgb . $c]
11451    set selc black
11452    if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11453        set selc white
11454    }
11455    tk_setPalette background $c selectColor $selc
11456}
11457
11458proc setbg {c} {
11459    global bglist
11460
11461    foreach w $bglist {
11462        $w conf -background $c
11463    }
11464}
11465
11466proc setfg {c} {
11467    global fglist canv
11468
11469    foreach w $fglist {
11470        $w conf -foreground $c
11471    }
11472    allcanvs itemconf text -fill $c
11473    $canv itemconf circle -outline $c
11474    $canv itemconf markid -outline $c
11475}
11476
11477proc prefscan {} {
11478    global oldprefs prefstop
11479
11480    foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11481                   limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11482        global $v
11483        set $v $oldprefs($v)
11484    }
11485    catch {destroy $prefstop}
11486    unset prefstop
11487    fontcan
11488}
11489
11490proc prefsok {} {
11491    global maxwidth maxgraphpct
11492    global oldprefs prefstop showneartags showlocalchanges
11493    global fontpref mainfont textfont uifont
11494    global limitdiffs treediffs perfile_attrs
11495    global hideremotes
11496
11497    catch {destroy $prefstop}
11498    unset prefstop
11499    fontcan
11500    set fontchanged 0
11501    if {$mainfont ne $fontpref(mainfont)} {
11502        set mainfont $fontpref(mainfont)
11503        parsefont mainfont $mainfont
11504        eval font configure mainfont [fontflags mainfont]
11505        eval font configure mainfontbold [fontflags mainfont 1]
11506        setcoords
11507        set fontchanged 1
11508    }
11509    if {$textfont ne $fontpref(textfont)} {
11510        set textfont $fontpref(textfont)
11511        parsefont textfont $textfont
11512        eval font configure textfont [fontflags textfont]
11513        eval font configure textfontbold [fontflags textfont 1]
11514    }
11515    if {$uifont ne $fontpref(uifont)} {
11516        set uifont $fontpref(uifont)
11517        parsefont uifont $uifont
11518        eval font configure uifont [fontflags uifont]
11519    }
11520    settabs
11521    if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11522        if {$showlocalchanges} {
11523            doshowlocalchanges
11524        } else {
11525            dohidelocalchanges
11526        }
11527    }
11528    if {$limitdiffs != $oldprefs(limitdiffs) ||
11529        ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11530        # treediffs elements are limited by path;
11531        # won't have encodings cached if perfile_attrs was just turned on
11532        catch {unset treediffs}
11533    }
11534    if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11535        || $maxgraphpct != $oldprefs(maxgraphpct)} {
11536        redisplay
11537    } elseif {$showneartags != $oldprefs(showneartags) ||
11538          $limitdiffs != $oldprefs(limitdiffs)} {
11539        reselectline
11540    }
11541    if {$hideremotes != $oldprefs(hideremotes)} {
11542        rereadrefs
11543    }
11544}
11545
11546proc formatdate {d} {
11547    global datetimeformat
11548    if {$d ne {}} {
11549        set d [clock format [lindex $d 0] -format $datetimeformat]
11550    }
11551    return $d
11552}
11553
11554# This list of encoding names and aliases is distilled from
11555# http://www.iana.org/assignments/character-sets.
11556# Not all of them are supported by Tcl.
11557set encoding_aliases {
11558    { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11559      ISO646-US US-ASCII us IBM367 cp367 csASCII }
11560    { ISO-10646-UTF-1 csISO10646UTF1 }
11561    { ISO_646.basic:1983 ref csISO646basic1983 }
11562    { INVARIANT csINVARIANT }
11563    { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11564    { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11565    { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11566    { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11567    { NATS-DANO iso-ir-9-1 csNATSDANO }
11568    { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11569    { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11570    { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11571    { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11572    { ISO-2022-KR csISO2022KR }
11573    { EUC-KR csEUCKR }
11574    { ISO-2022-JP csISO2022JP }
11575    { ISO-2022-JP-2 csISO2022JP2 }
11576    { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11577      csISO13JISC6220jp }
11578    { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11579    { IT iso-ir-15 ISO646-IT csISO15Italian }
11580    { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11581    { ES iso-ir-17 ISO646-ES csISO17Spanish }
11582    { greek7-old iso-ir-18 csISO18Greek7Old }
11583    { latin-greek iso-ir-19 csISO19LatinGreek }
11584    { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11585    { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11586    { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11587    { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11588    { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11589    { BS_viewdata iso-ir-47 csISO47BSViewdata }
11590    { INIS iso-ir-49 csISO49INIS }
11591    { INIS-8 iso-ir-50 csISO50INIS8 }
11592    { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11593    { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11594    { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11595    { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11596    { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11597    { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11598      csISO60Norwegian1 }
11599    { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11600    { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11601    { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11602    { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11603    { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11604    { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11605    { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11606    { greek7 iso-ir-88 csISO88Greek7 }
11607    { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11608    { iso-ir-90 csISO90 }
11609    { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11610    { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11611      csISO92JISC62991984b }
11612    { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11613    { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11614    { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11615      csISO95JIS62291984handadd }
11616    { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11617    { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11618    { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11619    { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11620      CP819 csISOLatin1 }
11621    { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11622    { T.61-7bit iso-ir-102 csISO102T617bit }
11623    { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11624    { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11625    { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11626    { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11627    { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11628    { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11629    { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11630    { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11631      arabic csISOLatinArabic }
11632    { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11633    { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11634    { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11635      greek greek8 csISOLatinGreek }
11636    { T.101-G2 iso-ir-128 csISO128T101G2 }
11637    { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11638      csISOLatinHebrew }
11639    { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11640    { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11641    { CSN_369103 iso-ir-139 csISO139CSN369103 }
11642    { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11643    { ISO_6937-2-add iso-ir-142 csISOTextComm }
11644    { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11645    { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11646      csISOLatinCyrillic }
11647    { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11648    { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11649    { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11650    { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11651    { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11652    { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11653    { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11654    { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11655    { ISO_10367-box iso-ir-155 csISO10367Box }
11656    { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11657    { latin-lap lap iso-ir-158 csISO158Lap }
11658    { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11659    { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11660    { us-dk csUSDK }
11661    { dk-us csDKUS }
11662    { JIS_X0201 X0201 csHalfWidthKatakana }
11663    { KSC5636 ISO646-KR csKSC5636 }
11664    { ISO-10646-UCS-2 csUnicode }
11665    { ISO-10646-UCS-4 csUCS4 }
11666    { DEC-MCS dec csDECMCS }
11667    { hp-roman8 roman8 r8 csHPRoman8 }
11668    { macintosh mac csMacintosh }
11669    { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11670      csIBM037 }
11671    { IBM038 EBCDIC-INT cp038 csIBM038 }
11672    { IBM273 CP273 csIBM273 }
11673    { IBM274 EBCDIC-BE CP274 csIBM274 }
11674    { IBM275 EBCDIC-BR cp275 csIBM275 }
11675    { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11676    { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11677    { IBM280 CP280 ebcdic-cp-it csIBM280 }
11678    { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11679    { IBM284 CP284 ebcdic-cp-es csIBM284 }
11680    { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11681    { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11682    { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11683    { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11684    { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11685    { IBM424 cp424 ebcdic-cp-he csIBM424 }
11686    { IBM437 cp437 437 csPC8CodePage437 }
11687    { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11688    { IBM775 cp775 csPC775Baltic }
11689    { IBM850 cp850 850 csPC850Multilingual }
11690    { IBM851 cp851 851 csIBM851 }
11691    { IBM852 cp852 852 csPCp852 }
11692    { IBM855 cp855 855 csIBM855 }
11693    { IBM857 cp857 857 csIBM857 }
11694    { IBM860 cp860 860 csIBM860 }
11695    { IBM861 cp861 861 cp-is csIBM861 }
11696    { IBM862 cp862 862 csPC862LatinHebrew }
11697    { IBM863 cp863 863 csIBM863 }
11698    { IBM864 cp864 csIBM864 }
11699    { IBM865 cp865 865 csIBM865 }
11700    { IBM866 cp866 866 csIBM866 }
11701    { IBM868 CP868 cp-ar csIBM868 }
11702    { IBM869 cp869 869 cp-gr csIBM869 }
11703    { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11704    { IBM871 CP871 ebcdic-cp-is csIBM871 }
11705    { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11706    { IBM891 cp891 csIBM891 }
11707    { IBM903 cp903 csIBM903 }
11708    { IBM904 cp904 904 csIBBM904 }
11709    { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11710    { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11711    { IBM1026 CP1026 csIBM1026 }
11712    { EBCDIC-AT-DE csIBMEBCDICATDE }
11713    { EBCDIC-AT-DE-A csEBCDICATDEA }
11714    { EBCDIC-CA-FR csEBCDICCAFR }
11715    { EBCDIC-DK-NO csEBCDICDKNO }
11716    { EBCDIC-DK-NO-A csEBCDICDKNOA }
11717    { EBCDIC-FI-SE csEBCDICFISE }
11718    { EBCDIC-FI-SE-A csEBCDICFISEA }
11719    { EBCDIC-FR csEBCDICFR }
11720    { EBCDIC-IT csEBCDICIT }
11721    { EBCDIC-PT csEBCDICPT }
11722    { EBCDIC-ES csEBCDICES }
11723    { EBCDIC-ES-A csEBCDICESA }
11724    { EBCDIC-ES-S csEBCDICESS }
11725    { EBCDIC-UK csEBCDICUK }
11726    { EBCDIC-US csEBCDICUS }
11727    { UNKNOWN-8BIT csUnknown8BiT }
11728    { MNEMONIC csMnemonic }
11729    { MNEM csMnem }
11730    { VISCII csVISCII }
11731    { VIQR csVIQR }
11732    { KOI8-R csKOI8R }
11733    { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11734    { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11735    { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11736    { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11737    { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11738    { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11739    { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11740    { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11741    { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11742    { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11743    { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11744    { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11745    { IBM1047 IBM-1047 }
11746    { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11747    { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11748    { UNICODE-1-1 csUnicode11 }
11749    { CESU-8 csCESU-8 }
11750    { BOCU-1 csBOCU-1 }
11751    { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11752    { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11753      l8 }
11754    { ISO-8859-15 ISO_8859-15 Latin-9 }
11755    { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11756    { GBK CP936 MS936 windows-936 }
11757    { JIS_Encoding csJISEncoding }
11758    { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11759    { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11760      EUC-JP }
11761    { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11762    { ISO-10646-UCS-Basic csUnicodeASCII }
11763    { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11764    { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11765    { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11766    { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11767    { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11768    { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11769    { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11770    { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11771    { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11772    { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11773    { Adobe-Standard-Encoding csAdobeStandardEncoding }
11774    { Ventura-US csVenturaUS }
11775    { Ventura-International csVenturaInternational }
11776    { PC8-Danish-Norwegian csPC8DanishNorwegian }
11777    { PC8-Turkish csPC8Turkish }
11778    { IBM-Symbols csIBMSymbols }
11779    { IBM-Thai csIBMThai }
11780    { HP-Legal csHPLegal }
11781    { HP-Pi-font csHPPiFont }
11782    { HP-Math8 csHPMath8 }
11783    { Adobe-Symbol-Encoding csHPPSMath }
11784    { HP-DeskTop csHPDesktop }
11785    { Ventura-Math csVenturaMath }
11786    { Microsoft-Publishing csMicrosoftPublishing }
11787    { Windows-31J csWindows31J }
11788    { GB2312 csGB2312 }
11789    { Big5 csBig5 }
11790}
11791
11792proc tcl_encoding {enc} {
11793    global encoding_aliases tcl_encoding_cache
11794    if {[info exists tcl_encoding_cache($enc)]} {
11795        return $tcl_encoding_cache($enc)
11796    }
11797    set names [encoding names]
11798    set lcnames [string tolower $names]
11799    set enc [string tolower $enc]
11800    set i [lsearch -exact $lcnames $enc]
11801    if {$i < 0} {
11802        # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11803        if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11804            set i [lsearch -exact $lcnames $encx]
11805        }
11806    }
11807    if {$i < 0} {
11808        foreach l $encoding_aliases {
11809            set ll [string tolower $l]
11810            if {[lsearch -exact $ll $enc] < 0} continue
11811            # look through the aliases for one that tcl knows about
11812            foreach e $ll {
11813                set i [lsearch -exact $lcnames $e]
11814                if {$i < 0} {
11815                    if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11816                        set i [lsearch -exact $lcnames $ex]
11817                    }
11818                }
11819                if {$i >= 0} break
11820            }
11821            break
11822        }
11823    }
11824    set tclenc {}
11825    if {$i >= 0} {
11826        set tclenc [lindex $names $i]
11827    }
11828    set tcl_encoding_cache($enc) $tclenc
11829    return $tclenc
11830}
11831
11832proc gitattr {path attr default} {
11833    global path_attr_cache
11834    if {[info exists path_attr_cache($attr,$path)]} {
11835        set r $path_attr_cache($attr,$path)
11836    } else {
11837        set r "unspecified"
11838        if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11839            regexp "(.*): $attr: (.*)" $line m f r
11840        }
11841        set path_attr_cache($attr,$path) $r
11842    }
11843    if {$r eq "unspecified"} {
11844        return $default
11845    }
11846    return $r
11847}
11848
11849proc cache_gitattr {attr pathlist} {
11850    global path_attr_cache
11851    set newlist {}
11852    foreach path $pathlist {
11853        if {![info exists path_attr_cache($attr,$path)]} {
11854            lappend newlist $path
11855        }
11856    }
11857    set lim 1000
11858    if {[tk windowingsystem] == "win32"} {
11859        # windows has a 32k limit on the arguments to a command...
11860        set lim 30
11861    }
11862    while {$newlist ne {}} {
11863        set head [lrange $newlist 0 [expr {$lim - 1}]]
11864        set newlist [lrange $newlist $lim end]
11865        if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11866            foreach row [split $rlist "\n"] {
11867                if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11868                    if {[string index $path 0] eq "\""} {
11869                        set path [encoding convertfrom [lindex $path 0]]
11870                    }
11871                    set path_attr_cache($attr,$path) $value
11872                }
11873            }
11874        }
11875    }
11876}
11877
11878proc get_path_encoding {path} {
11879    global gui_encoding perfile_attrs
11880    set tcl_enc $gui_encoding
11881    if {$path ne {} && $perfile_attrs} {
11882        set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11883        if {$enc2 ne {}} {
11884            set tcl_enc $enc2
11885        }
11886    }
11887    return $tcl_enc
11888}
11889
11890# First check that Tcl/Tk is recent enough
11891if {[catch {package require Tk 8.4} err]} {
11892    show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11893                     Gitk requires at least Tcl/Tk 8.4." list
11894    exit 1
11895}
11896
11897# on OSX bring the current Wish process window to front
11898if {[tk windowingsystem] eq "aqua"} {
11899    exec osascript -e [format {
11900        tell application "System Events"
11901            set frontmost of processes whose unix id is %d to true
11902        end tell
11903    } [pid] ]
11904}
11905
11906# Unset GIT_TRACE var if set
11907if { [info exists ::env(GIT_TRACE)] } {
11908    unset ::env(GIT_TRACE)
11909}
11910
11911# defaults...
11912set wrcomcmd "git diff-tree --stdin -p --pretty"
11913
11914set gitencoding {}
11915catch {
11916    set gitencoding [exec git config --get i18n.commitencoding]
11917}
11918catch {
11919    set gitencoding [exec git config --get i18n.logoutputencoding]
11920}
11921if {$gitencoding == ""} {
11922    set gitencoding "utf-8"
11923}
11924set tclencoding [tcl_encoding $gitencoding]
11925if {$tclencoding == {}} {
11926    puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
11927}
11928
11929set gui_encoding [encoding system]
11930catch {
11931    set enc [exec git config --get gui.encoding]
11932    if {$enc ne {}} {
11933        set tclenc [tcl_encoding $enc]
11934        if {$tclenc ne {}} {
11935            set gui_encoding $tclenc
11936        } else {
11937            puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
11938        }
11939    }
11940}
11941
11942set log_showroot true
11943catch {
11944    set log_showroot [exec git config --bool --get log.showroot]
11945}
11946
11947if {[tk windowingsystem] eq "aqua"} {
11948    set mainfont {{Lucida Grande} 9}
11949    set textfont {Monaco 9}
11950    set uifont {{Lucida Grande} 9 bold}
11951} elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
11952    # fontconfig!
11953    set mainfont {sans 9}
11954    set textfont {monospace 9}
11955    set uifont {sans 9 bold}
11956} else {
11957    set mainfont {Helvetica 9}
11958    set textfont {Courier 9}
11959    set uifont {Helvetica 9 bold}
11960}
11961set tabstop 8
11962set findmergefiles 0
11963set maxgraphpct 50
11964set maxwidth 16
11965set revlistorder 0
11966set fastdate 0
11967set uparrowlen 5
11968set downarrowlen 5
11969set mingaplen 100
11970set cmitmode "patch"
11971set wrapcomment "none"
11972set showneartags 1
11973set hideremotes 0
11974set maxrefs 20
11975set maxlinelen 200
11976set showlocalchanges 1
11977set limitdiffs 1
11978set datetimeformat "%Y-%m-%d %H:%M:%S"
11979set autoselect 1
11980set autosellen 40
11981set perfile_attrs 0
11982set want_ttk 1
11983
11984if {[tk windowingsystem] eq "aqua"} {
11985    set extdifftool "opendiff"
11986} else {
11987    set extdifftool "meld"
11988}
11989
11990set colors {green red blue magenta darkgrey brown orange}
11991if {[tk windowingsystem] eq "win32"} {
11992    set uicolor SystemButtonFace
11993    set uifgcolor SystemButtonText
11994    set uifgdisabledcolor SystemDisabledText
11995    set bgcolor SystemWindow
11996    set fgcolor SystemWindowText
11997    set selectbgcolor SystemHighlight
11998} else {
11999    set uicolor grey85
12000    set uifgcolor black
12001    set uifgdisabledcolor "#999"
12002    set bgcolor white
12003    set fgcolor black
12004    set selectbgcolor gray85
12005}
12006set diffcolors {red "#00a000" blue}
12007set diffcontext 3
12008set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12009set ignorespace 0
12010set worddiff ""
12011set markbgcolor "#e0e0ff"
12012
12013set headbgcolor green
12014set headfgcolor black
12015set headoutlinecolor black
12016set remotebgcolor #ffddaa
12017set tagbgcolor yellow
12018set tagfgcolor black
12019set tagoutlinecolor black
12020set reflinecolor black
12021set filesepbgcolor #aaaaaa
12022set filesepfgcolor black
12023set linehoverbgcolor #ffff80
12024set linehoverfgcolor black
12025set linehoveroutlinecolor black
12026set mainheadcirclecolor yellow
12027set workingfilescirclecolor red
12028set indexcirclecolor green
12029set circlecolors {white blue gray blue blue}
12030set linkfgcolor blue
12031set circleoutlinecolor $fgcolor
12032set foundbgcolor yellow
12033set currentsearchhitbgcolor orange
12034
12035# button for popping up context menus
12036if {[tk windowingsystem] eq "aqua"} {
12037    set ctxbut <Button-2>
12038} else {
12039    set ctxbut <Button-3>
12040}
12041
12042## For msgcat loading, first locate the installation location.
12043if { [info exists ::env(GITK_MSGSDIR)] } {
12044    ## Msgsdir was manually set in the environment.
12045    set gitk_msgsdir $::env(GITK_MSGSDIR)
12046} else {
12047    ## Let's guess the prefix from argv0.
12048    set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12049    set gitk_libdir [file join $gitk_prefix share gitk lib]
12050    set gitk_msgsdir [file join $gitk_libdir msgs]
12051    unset gitk_prefix
12052}
12053
12054## Internationalization (i18n) through msgcat and gettext. See
12055## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12056package require msgcat
12057namespace import ::msgcat::mc
12058## And eventually load the actual message catalog
12059::msgcat::mcload $gitk_msgsdir
12060
12061catch {source ~/.gitk}
12062
12063parsefont mainfont $mainfont
12064eval font create mainfont [fontflags mainfont]
12065eval font create mainfontbold [fontflags mainfont 1]
12066
12067parsefont textfont $textfont
12068eval font create textfont [fontflags textfont]
12069eval font create textfontbold [fontflags textfont 1]
12070
12071parsefont uifont $uifont
12072eval font create uifont [fontflags uifont]
12073
12074setui $uicolor
12075
12076setoptions
12077
12078# check that we can find a .git directory somewhere...
12079if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12080    show_error {} . [mc "Cannot find a git repository here."]
12081    exit 1
12082}
12083
12084set selecthead {}
12085set selectheadid {}
12086
12087set revtreeargs {}
12088set cmdline_files {}
12089set i 0
12090set revtreeargscmd {}
12091foreach arg $argv {
12092    switch -glob -- $arg {
12093        "" { }
12094        "--" {
12095            set cmdline_files [lrange $argv [expr {$i + 1}] end]
12096            break
12097        }
12098        "--select-commit=*" {
12099            set selecthead [string range $arg 16 end]
12100        }
12101        "--argscmd=*" {
12102            set revtreeargscmd [string range $arg 10 end]
12103        }
12104        default {
12105            lappend revtreeargs $arg
12106        }
12107    }
12108    incr i
12109}
12110
12111if {$selecthead eq "HEAD"} {
12112    set selecthead {}
12113}
12114
12115if {$i >= [llength $argv] && $revtreeargs ne {}} {
12116    # no -- on command line, but some arguments (other than --argscmd)
12117    if {[catch {
12118        set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12119        set cmdline_files [split $f "\n"]
12120        set n [llength $cmdline_files]
12121        set revtreeargs [lrange $revtreeargs 0 end-$n]
12122        # Unfortunately git rev-parse doesn't produce an error when
12123        # something is both a revision and a filename.  To be consistent
12124        # with git log and git rev-list, check revtreeargs for filenames.
12125        foreach arg $revtreeargs {
12126            if {[file exists $arg]} {
12127                show_error {} . [mc "Ambiguous argument '%s': both revision\
12128                                 and filename" $arg]
12129                exit 1
12130            }
12131        }
12132    } err]} {
12133        # unfortunately we get both stdout and stderr in $err,
12134        # so look for "fatal:".
12135        set i [string first "fatal:" $err]
12136        if {$i > 0} {
12137            set err [string range $err [expr {$i + 6}] end]
12138        }
12139        show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12140        exit 1
12141    }
12142}
12143
12144set nullid "0000000000000000000000000000000000000000"
12145set nullid2 "0000000000000000000000000000000000000001"
12146set nullfile "/dev/null"
12147
12148set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12149if {![info exists have_ttk]} {
12150    set have_ttk [llength [info commands ::ttk::style]]
12151}
12152set use_ttk [expr {$have_ttk && $want_ttk}]
12153set NS [expr {$use_ttk ? "ttk" : ""}]
12154
12155regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12156
12157set show_notes {}
12158if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12159    set show_notes "--show-notes"
12160}
12161
12162set appname "gitk"
12163
12164set runq {}
12165set history {}
12166set historyindex 0
12167set fh_serial 0
12168set nhl_names {}
12169set highlight_paths {}
12170set findpattern {}
12171set searchdirn -forwards
12172set boldids {}
12173set boldnameids {}
12174set diffelide {0 0}
12175set markingmatches 0
12176set linkentercount 0
12177set need_redisplay 0
12178set nrows_drawn 0
12179set firsttabstop 0
12180
12181set nextviewnum 1
12182set curview 0
12183set selectedview 0
12184set selectedhlview [mc "None"]
12185set highlight_related [mc "None"]
12186set highlight_files {}
12187set viewfiles(0) {}
12188set viewperm(0) 0
12189set viewargs(0) {}
12190set viewargscmd(0) {}
12191
12192set selectedline {}
12193set numcommits 0
12194set loginstance 0
12195set cmdlineok 0
12196set stopped 0
12197set stuffsaved 0
12198set patchnum 0
12199set lserial 0
12200set hasworktree [hasworktree]
12201set cdup {}
12202if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12203    set cdup [exec git rev-parse --show-cdup]
12204}
12205set worktree [exec git rev-parse --show-toplevel]
12206setcoords
12207makewindow
12208catch {
12209    image create photo gitlogo      -width 16 -height 16
12210
12211    image create photo gitlogominus -width  4 -height  2
12212    gitlogominus put #C00000 -to 0 0 4 2
12213    gitlogo copy gitlogominus -to  1 5
12214    gitlogo copy gitlogominus -to  6 5
12215    gitlogo copy gitlogominus -to 11 5
12216    image delete gitlogominus
12217
12218    image create photo gitlogoplus  -width  4 -height  4
12219    gitlogoplus  put #008000 -to 1 0 3 4
12220    gitlogoplus  put #008000 -to 0 1 4 3
12221    gitlogo copy gitlogoplus  -to  1 9
12222    gitlogo copy gitlogoplus  -to  6 9
12223    gitlogo copy gitlogoplus  -to 11 9
12224    image delete gitlogoplus
12225
12226    image create photo gitlogo32    -width 32 -height 32
12227    gitlogo32 copy gitlogo -zoom 2 2
12228
12229    wm iconphoto . -default gitlogo gitlogo32
12230}
12231# wait for the window to become visible
12232tkwait visibility .
12233wm title . "$appname: [reponame]"
12234update
12235readrefs
12236
12237if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12238    # create a view for the files/dirs specified on the command line
12239    set curview 1
12240    set selectedview 1
12241    set nextviewnum 2
12242    set viewname(1) [mc "Command line"]
12243    set viewfiles(1) $cmdline_files
12244    set viewargs(1) $revtreeargs
12245    set viewargscmd(1) $revtreeargscmd
12246    set viewperm(1) 0
12247    set vdatemode(1) 0
12248    addviewmenu 1
12249    .bar.view entryconf [mca "Edit view..."] -state normal
12250    .bar.view entryconf [mca "Delete view"] -state normal
12251}
12252
12253if {[info exists permviews]} {
12254    foreach v $permviews {
12255        set n $nextviewnum
12256        incr nextviewnum
12257        set viewname($n) [lindex $v 0]
12258        set viewfiles($n) [lindex $v 1]
12259        set viewargs($n) [lindex $v 2]
12260        set viewargscmd($n) [lindex $v 3]
12261        set viewperm($n) 1
12262        addviewmenu $n
12263    }
12264}
12265
12266if {[tk windowingsystem] eq "win32"} {
12267    focus -force .
12268}
12269
12270getcommits {}
12271
12272# Local variables:
12273# mode: tcl
12274# indent-tabs-mode: t
12275# tab-width: 8
12276# End: