gitkon commit gitk: Report errors in saving config file (1dd2960)
   1#!/bin/sh
   2# Tcl ignores the next line -*- tcl -*- \
   3exec wish "$0" -- "$@"
   4
   5# Copyright © 2005-2014 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    } elseif {[lsearch -exact $revs --all] >= 0} {
 298        lappend revs HEAD
 299    }
 300    if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
 301        # we get stdout followed by stderr in $err
 302        # for an unknown rev, git rev-parse echoes it and then errors out
 303        set errlines [split $err "\n"]
 304        set badrev {}
 305        for {set l 0} {$l < [llength $errlines]} {incr l} {
 306            set line [lindex $errlines $l]
 307            if {!([string length $line] == 40 && [string is xdigit $line])} {
 308                if {[string match "fatal:*" $line]} {
 309                    if {[string match "fatal: ambiguous argument*" $line]
 310                        && $badrev ne {}} {
 311                        if {[llength $badrev] == 1} {
 312                            set err "unknown revision $badrev"
 313                        } else {
 314                            set err "unknown revisions: [join $badrev ", "]"
 315                        }
 316                    } else {
 317                        set err [join [lrange $errlines $l end] "\n"]
 318                    }
 319                    break
 320                }
 321                lappend badrev $line
 322            }
 323        }
 324        error_popup "[mc "Error parsing revisions:"] $err"
 325        return {}
 326    }
 327    set ret {}
 328    set pos {}
 329    set neg {}
 330    set sdm 0
 331    foreach id [split $ids "\n"] {
 332        if {$id eq "--gitk-symmetric-diff-marker"} {
 333            set sdm 4
 334        } elseif {[string match "^*" $id]} {
 335            if {$sdm != 1} {
 336                lappend ret $id
 337                if {$sdm == 3} {
 338                    set sdm 0
 339                }
 340            }
 341            lappend neg [string range $id 1 end]
 342        } else {
 343            if {$sdm != 2} {
 344                lappend ret $id
 345            } else {
 346                lset ret end $id...[lindex $ret end]
 347            }
 348            lappend pos $id
 349        }
 350        incr sdm -1
 351    }
 352    set vposids($view) $pos
 353    set vnegids($view) $neg
 354    return $ret
 355}
 356
 357# Start off a git log process and arrange to read its output
 358proc start_rev_list {view} {
 359    global startmsecs commitidx viewcomplete curview
 360    global tclencoding
 361    global viewargs viewargscmd viewfiles vfilelimit
 362    global showlocalchanges
 363    global viewactive viewinstances vmergeonly
 364    global mainheadid viewmainheadid viewmainheadid_orig
 365    global vcanopt vflags vrevs vorigargs
 366    global show_notes
 367
 368    set startmsecs [clock clicks -milliseconds]
 369    set commitidx($view) 0
 370    # these are set this way for the error exits
 371    set viewcomplete($view) 1
 372    set viewactive($view) 0
 373    varcinit $view
 374
 375    set args $viewargs($view)
 376    if {$viewargscmd($view) ne {}} {
 377        if {[catch {
 378            set str [exec sh -c $viewargscmd($view)]
 379        } err]} {
 380            error_popup "[mc "Error executing --argscmd command:"] $err"
 381            return 0
 382        }
 383        set args [concat $args [split $str "\n"]]
 384    }
 385    set vcanopt($view) [parseviewargs $view $args]
 386
 387    set files $viewfiles($view)
 388    if {$vmergeonly($view)} {
 389        set files [unmerged_files $files]
 390        if {$files eq {}} {
 391            global nr_unmerged
 392            if {$nr_unmerged == 0} {
 393                error_popup [mc "No files selected: --merge specified but\
 394                             no files are unmerged."]
 395            } else {
 396                error_popup [mc "No files selected: --merge specified but\
 397                             no unmerged files are within file limit."]
 398            }
 399            return 0
 400        }
 401    }
 402    set vfilelimit($view) $files
 403
 404    if {$vcanopt($view)} {
 405        set revs [parseviewrevs $view $vrevs($view)]
 406        if {$revs eq {}} {
 407            return 0
 408        }
 409        set args [concat $vflags($view) $revs]
 410    } else {
 411        set args $vorigargs($view)
 412    }
 413
 414    if {[catch {
 415        set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
 416                        --parents --boundary $args "--" $files] r]
 417    } err]} {
 418        error_popup "[mc "Error executing git log:"] $err"
 419        return 0
 420    }
 421    set i [reg_instance $fd]
 422    set viewinstances($view) [list $i]
 423    set viewmainheadid($view) $mainheadid
 424    set viewmainheadid_orig($view) $mainheadid
 425    if {$files ne {} && $mainheadid ne {}} {
 426        get_viewmainhead $view
 427    }
 428    if {$showlocalchanges && $viewmainheadid($view) ne {}} {
 429        interestedin $viewmainheadid($view) dodiffindex
 430    }
 431    fconfigure $fd -blocking 0 -translation lf -eofchar {}
 432    if {$tclencoding != {}} {
 433        fconfigure $fd -encoding $tclencoding
 434    }
 435    filerun $fd [list getcommitlines $fd $i $view 0]
 436    nowbusy $view [mc "Reading"]
 437    set viewcomplete($view) 0
 438    set viewactive($view) 1
 439    return 1
 440}
 441
 442proc stop_instance {inst} {
 443    global commfd leftover
 444
 445    set fd $commfd($inst)
 446    catch {
 447        set pid [pid $fd]
 448
 449        if {$::tcl_platform(platform) eq {windows}} {
 450            exec taskkill /pid $pid
 451        } else {
 452            exec kill $pid
 453        }
 454    }
 455    catch {close $fd}
 456    nukefile $fd
 457    unset commfd($inst)
 458    unset leftover($inst)
 459}
 460
 461proc stop_backends {} {
 462    global commfd
 463
 464    foreach inst [array names commfd] {
 465        stop_instance $inst
 466    }
 467}
 468
 469proc stop_rev_list {view} {
 470    global viewinstances
 471
 472    foreach inst $viewinstances($view) {
 473        stop_instance $inst
 474    }
 475    set viewinstances($view) {}
 476}
 477
 478proc reset_pending_select {selid} {
 479    global pending_select mainheadid selectheadid
 480
 481    if {$selid ne {}} {
 482        set pending_select $selid
 483    } elseif {$selectheadid ne {}} {
 484        set pending_select $selectheadid
 485    } else {
 486        set pending_select $mainheadid
 487    }
 488}
 489
 490proc getcommits {selid} {
 491    global canv curview need_redisplay viewactive
 492
 493    initlayout
 494    if {[start_rev_list $curview]} {
 495        reset_pending_select $selid
 496        show_status [mc "Reading commits..."]
 497        set need_redisplay 1
 498    } else {
 499        show_status [mc "No commits selected"]
 500    }
 501}
 502
 503proc updatecommits {} {
 504    global curview vcanopt vorigargs vfilelimit viewinstances
 505    global viewactive viewcomplete tclencoding
 506    global startmsecs showneartags showlocalchanges
 507    global mainheadid viewmainheadid viewmainheadid_orig pending_select
 508    global hasworktree
 509    global varcid vposids vnegids vflags vrevs
 510    global show_notes
 511
 512    set hasworktree [hasworktree]
 513    rereadrefs
 514    set view $curview
 515    if {$mainheadid ne $viewmainheadid_orig($view)} {
 516        if {$showlocalchanges} {
 517            dohidelocalchanges
 518        }
 519        set viewmainheadid($view) $mainheadid
 520        set viewmainheadid_orig($view) $mainheadid
 521        if {$vfilelimit($view) ne {}} {
 522            get_viewmainhead $view
 523        }
 524    }
 525    if {$showlocalchanges} {
 526        doshowlocalchanges
 527    }
 528    if {$vcanopt($view)} {
 529        set oldpos $vposids($view)
 530        set oldneg $vnegids($view)
 531        set revs [parseviewrevs $view $vrevs($view)]
 532        if {$revs eq {}} {
 533            return
 534        }
 535        # note: getting the delta when negative refs change is hard,
 536        # and could require multiple git log invocations, so in that
 537        # case we ask git log for all the commits (not just the delta)
 538        if {$oldneg eq $vnegids($view)} {
 539            set newrevs {}
 540            set npos 0
 541            # take out positive refs that we asked for before or
 542            # that we have already seen
 543            foreach rev $revs {
 544                if {[string length $rev] == 40} {
 545                    if {[lsearch -exact $oldpos $rev] < 0
 546                        && ![info exists varcid($view,$rev)]} {
 547                        lappend newrevs $rev
 548                        incr npos
 549                    }
 550                } else {
 551                    lappend $newrevs $rev
 552                }
 553            }
 554            if {$npos == 0} return
 555            set revs $newrevs
 556            set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
 557        }
 558        set args [concat $vflags($view) $revs --not $oldpos]
 559    } else {
 560        set args $vorigargs($view)
 561    }
 562    if {[catch {
 563        set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
 564                        --parents --boundary $args "--" $vfilelimit($view)] r]
 565    } err]} {
 566        error_popup "[mc "Error executing git log:"] $err"
 567        return
 568    }
 569    if {$viewactive($view) == 0} {
 570        set startmsecs [clock clicks -milliseconds]
 571    }
 572    set i [reg_instance $fd]
 573    lappend viewinstances($view) $i
 574    fconfigure $fd -blocking 0 -translation lf -eofchar {}
 575    if {$tclencoding != {}} {
 576        fconfigure $fd -encoding $tclencoding
 577    }
 578    filerun $fd [list getcommitlines $fd $i $view 1]
 579    incr viewactive($view)
 580    set viewcomplete($view) 0
 581    reset_pending_select {}
 582    nowbusy $view [mc "Reading"]
 583    if {$showneartags} {
 584        getallcommits
 585    }
 586}
 587
 588proc reloadcommits {} {
 589    global curview viewcomplete selectedline currentid thickerline
 590    global showneartags treediffs commitinterest cached_commitrow
 591    global targetid
 592
 593    set selid {}
 594    if {$selectedline ne {}} {
 595        set selid $currentid
 596    }
 597
 598    if {!$viewcomplete($curview)} {
 599        stop_rev_list $curview
 600    }
 601    resetvarcs $curview
 602    set selectedline {}
 603    catch {unset currentid}
 604    catch {unset thickerline}
 605    catch {unset treediffs}
 606    readrefs
 607    changedrefs
 608    if {$showneartags} {
 609        getallcommits
 610    }
 611    clear_display
 612    catch {unset commitinterest}
 613    catch {unset cached_commitrow}
 614    catch {unset targetid}
 615    setcanvscroll
 616    getcommits $selid
 617    return 0
 618}
 619
 620# This makes a string representation of a positive integer which
 621# sorts as a string in numerical order
 622proc strrep {n} {
 623    if {$n < 16} {
 624        return [format "%x" $n]
 625    } elseif {$n < 256} {
 626        return [format "x%.2x" $n]
 627    } elseif {$n < 65536} {
 628        return [format "y%.4x" $n]
 629    }
 630    return [format "z%.8x" $n]
 631}
 632
 633# Procedures used in reordering commits from git log (without
 634# --topo-order) into the order for display.
 635
 636proc varcinit {view} {
 637    global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
 638    global vtokmod varcmod vrowmod varcix vlastins
 639
 640    set varcstart($view) {{}}
 641    set vupptr($view) {0}
 642    set vdownptr($view) {0}
 643    set vleftptr($view) {0}
 644    set vbackptr($view) {0}
 645    set varctok($view) {{}}
 646    set varcrow($view) {{}}
 647    set vtokmod($view) {}
 648    set varcmod($view) 0
 649    set vrowmod($view) 0
 650    set varcix($view) {{}}
 651    set vlastins($view) {0}
 652}
 653
 654proc resetvarcs {view} {
 655    global varcid varccommits parents children vseedcount ordertok
 656    global vshortids
 657
 658    foreach vid [array names varcid $view,*] {
 659        unset varcid($vid)
 660        unset children($vid)
 661        unset parents($vid)
 662    }
 663    foreach vid [array names vshortids $view,*] {
 664        unset vshortids($vid)
 665    }
 666    # some commits might have children but haven't been seen yet
 667    foreach vid [array names children $view,*] {
 668        unset children($vid)
 669    }
 670    foreach va [array names varccommits $view,*] {
 671        unset varccommits($va)
 672    }
 673    foreach vd [array names vseedcount $view,*] {
 674        unset vseedcount($vd)
 675    }
 676    catch {unset ordertok}
 677}
 678
 679# returns a list of the commits with no children
 680proc seeds {v} {
 681    global vdownptr vleftptr varcstart
 682
 683    set ret {}
 684    set a [lindex $vdownptr($v) 0]
 685    while {$a != 0} {
 686        lappend ret [lindex $varcstart($v) $a]
 687        set a [lindex $vleftptr($v) $a]
 688    }
 689    return $ret
 690}
 691
 692proc newvarc {view id} {
 693    global varcid varctok parents children vdatemode
 694    global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
 695    global commitdata commitinfo vseedcount varccommits vlastins
 696
 697    set a [llength $varctok($view)]
 698    set vid $view,$id
 699    if {[llength $children($vid)] == 0 || $vdatemode($view)} {
 700        if {![info exists commitinfo($id)]} {
 701            parsecommit $id $commitdata($id) 1
 702        }
 703        set cdate [lindex [lindex $commitinfo($id) 4] 0]
 704        if {![string is integer -strict $cdate]} {
 705            set cdate 0
 706        }
 707        if {![info exists vseedcount($view,$cdate)]} {
 708            set vseedcount($view,$cdate) -1
 709        }
 710        set c [incr vseedcount($view,$cdate)]
 711        set cdate [expr {$cdate ^ 0xffffffff}]
 712        set tok "s[strrep $cdate][strrep $c]"
 713    } else {
 714        set tok {}
 715    }
 716    set ka 0
 717    if {[llength $children($vid)] > 0} {
 718        set kid [lindex $children($vid) end]
 719        set k $varcid($view,$kid)
 720        if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
 721            set ki $kid
 722            set ka $k
 723            set tok [lindex $varctok($view) $k]
 724        }
 725    }
 726    if {$ka != 0} {
 727        set i [lsearch -exact $parents($view,$ki) $id]
 728        set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
 729        append tok [strrep $j]
 730    }
 731    set c [lindex $vlastins($view) $ka]
 732    if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
 733        set c $ka
 734        set b [lindex $vdownptr($view) $ka]
 735    } else {
 736        set b [lindex $vleftptr($view) $c]
 737    }
 738    while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
 739        set c $b
 740        set b [lindex $vleftptr($view) $c]
 741    }
 742    if {$c == $ka} {
 743        lset vdownptr($view) $ka $a
 744        lappend vbackptr($view) 0
 745    } else {
 746        lset vleftptr($view) $c $a
 747        lappend vbackptr($view) $c
 748    }
 749    lset vlastins($view) $ka $a
 750    lappend vupptr($view) $ka
 751    lappend vleftptr($view) $b
 752    if {$b != 0} {
 753        lset vbackptr($view) $b $a
 754    }
 755    lappend varctok($view) $tok
 756    lappend varcstart($view) $id
 757    lappend vdownptr($view) 0
 758    lappend varcrow($view) {}
 759    lappend varcix($view) {}
 760    set varccommits($view,$a) {}
 761    lappend vlastins($view) 0
 762    return $a
 763}
 764
 765proc splitvarc {p v} {
 766    global varcid varcstart varccommits varctok vtokmod
 767    global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
 768
 769    set oa $varcid($v,$p)
 770    set otok [lindex $varctok($v) $oa]
 771    set ac $varccommits($v,$oa)
 772    set i [lsearch -exact $varccommits($v,$oa) $p]
 773    if {$i <= 0} return
 774    set na [llength $varctok($v)]
 775    # "%" sorts before "0"...
 776    set tok "$otok%[strrep $i]"
 777    lappend varctok($v) $tok
 778    lappend varcrow($v) {}
 779    lappend varcix($v) {}
 780    set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
 781    set varccommits($v,$na) [lrange $ac $i end]
 782    lappend varcstart($v) $p
 783    foreach id $varccommits($v,$na) {
 784        set varcid($v,$id) $na
 785    }
 786    lappend vdownptr($v) [lindex $vdownptr($v) $oa]
 787    lappend vlastins($v) [lindex $vlastins($v) $oa]
 788    lset vdownptr($v) $oa $na
 789    lset vlastins($v) $oa 0
 790    lappend vupptr($v) $oa
 791    lappend vleftptr($v) 0
 792    lappend vbackptr($v) 0
 793    for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
 794        lset vupptr($v) $b $na
 795    }
 796    if {[string compare $otok $vtokmod($v)] <= 0} {
 797        modify_arc $v $oa
 798    }
 799}
 800
 801proc renumbervarc {a v} {
 802    global parents children varctok varcstart varccommits
 803    global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
 804
 805    set t1 [clock clicks -milliseconds]
 806    set todo {}
 807    set isrelated($a) 1
 808    set kidchanged($a) 1
 809    set ntot 0
 810    while {$a != 0} {
 811        if {[info exists isrelated($a)]} {
 812            lappend todo $a
 813            set id [lindex $varccommits($v,$a) end]
 814            foreach p $parents($v,$id) {
 815                if {[info exists varcid($v,$p)]} {
 816                    set isrelated($varcid($v,$p)) 1
 817                }
 818            }
 819        }
 820        incr ntot
 821        set b [lindex $vdownptr($v) $a]
 822        if {$b == 0} {
 823            while {$a != 0} {
 824                set b [lindex $vleftptr($v) $a]
 825                if {$b != 0} break
 826                set a [lindex $vupptr($v) $a]
 827            }
 828        }
 829        set a $b
 830    }
 831    foreach a $todo {
 832        if {![info exists kidchanged($a)]} continue
 833        set id [lindex $varcstart($v) $a]
 834        if {[llength $children($v,$id)] > 1} {
 835            set children($v,$id) [lsort -command [list vtokcmp $v] \
 836                                      $children($v,$id)]
 837        }
 838        set oldtok [lindex $varctok($v) $a]
 839        if {!$vdatemode($v)} {
 840            set tok {}
 841        } else {
 842            set tok $oldtok
 843        }
 844        set ka 0
 845        set kid [last_real_child $v,$id]
 846        if {$kid ne {}} {
 847            set k $varcid($v,$kid)
 848            if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
 849                set ki $kid
 850                set ka $k
 851                set tok [lindex $varctok($v) $k]
 852            }
 853        }
 854        if {$ka != 0} {
 855            set i [lsearch -exact $parents($v,$ki) $id]
 856            set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
 857            append tok [strrep $j]
 858        }
 859        if {$tok eq $oldtok} {
 860            continue
 861        }
 862        set id [lindex $varccommits($v,$a) end]
 863        foreach p $parents($v,$id) {
 864            if {[info exists varcid($v,$p)]} {
 865                set kidchanged($varcid($v,$p)) 1
 866            } else {
 867                set sortkids($p) 1
 868            }
 869        }
 870        lset varctok($v) $a $tok
 871        set b [lindex $vupptr($v) $a]
 872        if {$b != $ka} {
 873            if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
 874                modify_arc $v $ka
 875            }
 876            if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
 877                modify_arc $v $b
 878            }
 879            set c [lindex $vbackptr($v) $a]
 880            set d [lindex $vleftptr($v) $a]
 881            if {$c == 0} {
 882                lset vdownptr($v) $b $d
 883            } else {
 884                lset vleftptr($v) $c $d
 885            }
 886            if {$d != 0} {
 887                lset vbackptr($v) $d $c
 888            }
 889            if {[lindex $vlastins($v) $b] == $a} {
 890                lset vlastins($v) $b $c
 891            }
 892            lset vupptr($v) $a $ka
 893            set c [lindex $vlastins($v) $ka]
 894            if {$c == 0 || \
 895                    [string compare $tok [lindex $varctok($v) $c]] < 0} {
 896                set c $ka
 897                set b [lindex $vdownptr($v) $ka]
 898            } else {
 899                set b [lindex $vleftptr($v) $c]
 900            }
 901            while {$b != 0 && \
 902                      [string compare $tok [lindex $varctok($v) $b]] >= 0} {
 903                set c $b
 904                set b [lindex $vleftptr($v) $c]
 905            }
 906            if {$c == $ka} {
 907                lset vdownptr($v) $ka $a
 908                lset vbackptr($v) $a 0
 909            } else {
 910                lset vleftptr($v) $c $a
 911                lset vbackptr($v) $a $c
 912            }
 913            lset vleftptr($v) $a $b
 914            if {$b != 0} {
 915                lset vbackptr($v) $b $a
 916            }
 917            lset vlastins($v) $ka $a
 918        }
 919    }
 920    foreach id [array names sortkids] {
 921        if {[llength $children($v,$id)] > 1} {
 922            set children($v,$id) [lsort -command [list vtokcmp $v] \
 923                                      $children($v,$id)]
 924        }
 925    }
 926    set t2 [clock clicks -milliseconds]
 927    #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
 928}
 929
 930# Fix up the graph after we have found out that in view $v,
 931# $p (a commit that we have already seen) is actually the parent
 932# of the last commit in arc $a.
 933proc fix_reversal {p a v} {
 934    global varcid varcstart varctok vupptr
 935
 936    set pa $varcid($v,$p)
 937    if {$p ne [lindex $varcstart($v) $pa]} {
 938        splitvarc $p $v
 939        set pa $varcid($v,$p)
 940    }
 941    # seeds always need to be renumbered
 942    if {[lindex $vupptr($v) $pa] == 0 ||
 943        [string compare [lindex $varctok($v) $a] \
 944             [lindex $varctok($v) $pa]] > 0} {
 945        renumbervarc $pa $v
 946    }
 947}
 948
 949proc insertrow {id p v} {
 950    global cmitlisted children parents varcid varctok vtokmod
 951    global varccommits ordertok commitidx numcommits curview
 952    global targetid targetrow vshortids
 953
 954    readcommit $id
 955    set vid $v,$id
 956    set cmitlisted($vid) 1
 957    set children($vid) {}
 958    set parents($vid) [list $p]
 959    set a [newvarc $v $id]
 960    set varcid($vid) $a
 961    lappend vshortids($v,[string range $id 0 3]) $id
 962    if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
 963        modify_arc $v $a
 964    }
 965    lappend varccommits($v,$a) $id
 966    set vp $v,$p
 967    if {[llength [lappend children($vp) $id]] > 1} {
 968        set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
 969        catch {unset ordertok}
 970    }
 971    fix_reversal $p $a $v
 972    incr commitidx($v)
 973    if {$v == $curview} {
 974        set numcommits $commitidx($v)
 975        setcanvscroll
 976        if {[info exists targetid]} {
 977            if {![comes_before $targetid $p]} {
 978                incr targetrow
 979            }
 980        }
 981    }
 982}
 983
 984proc insertfakerow {id p} {
 985    global varcid varccommits parents children cmitlisted
 986    global commitidx varctok vtokmod targetid targetrow curview numcommits
 987
 988    set v $curview
 989    set a $varcid($v,$p)
 990    set i [lsearch -exact $varccommits($v,$a) $p]
 991    if {$i < 0} {
 992        puts "oops: insertfakerow can't find [shortids $p] on arc $a"
 993        return
 994    }
 995    set children($v,$id) {}
 996    set parents($v,$id) [list $p]
 997    set varcid($v,$id) $a
 998    lappend children($v,$p) $id
 999    set cmitlisted($v,$id) 1
1000    set numcommits [incr commitidx($v)]
1001    # note we deliberately don't update varcstart($v) even if $i == 0
1002    set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1003    modify_arc $v $a $i
1004    if {[info exists targetid]} {
1005        if {![comes_before $targetid $p]} {
1006            incr targetrow
1007        }
1008    }
1009    setcanvscroll
1010    drawvisible
1011}
1012
1013proc removefakerow {id} {
1014    global varcid varccommits parents children commitidx
1015    global varctok vtokmod cmitlisted currentid selectedline
1016    global targetid curview numcommits
1017
1018    set v $curview
1019    if {[llength $parents($v,$id)] != 1} {
1020        puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1021        return
1022    }
1023    set p [lindex $parents($v,$id) 0]
1024    set a $varcid($v,$id)
1025    set i [lsearch -exact $varccommits($v,$a) $id]
1026    if {$i < 0} {
1027        puts "oops: removefakerow can't find [shortids $id] on arc $a"
1028        return
1029    }
1030    unset varcid($v,$id)
1031    set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1032    unset parents($v,$id)
1033    unset children($v,$id)
1034    unset cmitlisted($v,$id)
1035    set numcommits [incr commitidx($v) -1]
1036    set j [lsearch -exact $children($v,$p) $id]
1037    if {$j >= 0} {
1038        set children($v,$p) [lreplace $children($v,$p) $j $j]
1039    }
1040    modify_arc $v $a $i
1041    if {[info exist currentid] && $id eq $currentid} {
1042        unset currentid
1043        set selectedline {}
1044    }
1045    if {[info exists targetid] && $targetid eq $id} {
1046        set targetid $p
1047    }
1048    setcanvscroll
1049    drawvisible
1050}
1051
1052proc real_children {vp} {
1053    global children nullid nullid2
1054
1055    set kids {}
1056    foreach id $children($vp) {
1057        if {$id ne $nullid && $id ne $nullid2} {
1058            lappend kids $id
1059        }
1060    }
1061    return $kids
1062}
1063
1064proc first_real_child {vp} {
1065    global children nullid nullid2
1066
1067    foreach id $children($vp) {
1068        if {$id ne $nullid && $id ne $nullid2} {
1069            return $id
1070        }
1071    }
1072    return {}
1073}
1074
1075proc last_real_child {vp} {
1076    global children nullid nullid2
1077
1078    set kids $children($vp)
1079    for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1080        set id [lindex $kids $i]
1081        if {$id ne $nullid && $id ne $nullid2} {
1082            return $id
1083        }
1084    }
1085    return {}
1086}
1087
1088proc vtokcmp {v a b} {
1089    global varctok varcid
1090
1091    return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1092                [lindex $varctok($v) $varcid($v,$b)]]
1093}
1094
1095# This assumes that if lim is not given, the caller has checked that
1096# arc a's token is less than $vtokmod($v)
1097proc modify_arc {v a {lim {}}} {
1098    global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1099
1100    if {$lim ne {}} {
1101        set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1102        if {$c > 0} return
1103        if {$c == 0} {
1104            set r [lindex $varcrow($v) $a]
1105            if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1106        }
1107    }
1108    set vtokmod($v) [lindex $varctok($v) $a]
1109    set varcmod($v) $a
1110    if {$v == $curview} {
1111        while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1112            set a [lindex $vupptr($v) $a]
1113            set lim {}
1114        }
1115        set r 0
1116        if {$a != 0} {
1117            if {$lim eq {}} {
1118                set lim [llength $varccommits($v,$a)]
1119            }
1120            set r [expr {[lindex $varcrow($v) $a] + $lim}]
1121        }
1122        set vrowmod($v) $r
1123        undolayout $r
1124    }
1125}
1126
1127proc update_arcrows {v} {
1128    global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1129    global varcid vrownum varcorder varcix varccommits
1130    global vupptr vdownptr vleftptr varctok
1131    global displayorder parentlist curview cached_commitrow
1132
1133    if {$vrowmod($v) == $commitidx($v)} return
1134    if {$v == $curview} {
1135        if {[llength $displayorder] > $vrowmod($v)} {
1136            set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1137            set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1138        }
1139        catch {unset cached_commitrow}
1140    }
1141    set narctot [expr {[llength $varctok($v)] - 1}]
1142    set a $varcmod($v)
1143    while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1144        # go up the tree until we find something that has a row number,
1145        # or we get to a seed
1146        set a [lindex $vupptr($v) $a]
1147    }
1148    if {$a == 0} {
1149        set a [lindex $vdownptr($v) 0]
1150        if {$a == 0} return
1151        set vrownum($v) {0}
1152        set varcorder($v) [list $a]
1153        lset varcix($v) $a 0
1154        lset varcrow($v) $a 0
1155        set arcn 0
1156        set row 0
1157    } else {
1158        set arcn [lindex $varcix($v) $a]
1159        if {[llength $vrownum($v)] > $arcn + 1} {
1160            set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1161            set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1162        }
1163        set row [lindex $varcrow($v) $a]
1164    }
1165    while {1} {
1166        set p $a
1167        incr row [llength $varccommits($v,$a)]
1168        # go down if possible
1169        set b [lindex $vdownptr($v) $a]
1170        if {$b == 0} {
1171            # if not, go left, or go up until we can go left
1172            while {$a != 0} {
1173                set b [lindex $vleftptr($v) $a]
1174                if {$b != 0} break
1175                set a [lindex $vupptr($v) $a]
1176            }
1177            if {$a == 0} break
1178        }
1179        set a $b
1180        incr arcn
1181        lappend vrownum($v) $row
1182        lappend varcorder($v) $a
1183        lset varcix($v) $a $arcn
1184        lset varcrow($v) $a $row
1185    }
1186    set vtokmod($v) [lindex $varctok($v) $p]
1187    set varcmod($v) $p
1188    set vrowmod($v) $row
1189    if {[info exists currentid]} {
1190        set selectedline [rowofcommit $currentid]
1191    }
1192}
1193
1194# Test whether view $v contains commit $id
1195proc commitinview {id v} {
1196    global varcid
1197
1198    return [info exists varcid($v,$id)]
1199}
1200
1201# Return the row number for commit $id in the current view
1202proc rowofcommit {id} {
1203    global varcid varccommits varcrow curview cached_commitrow
1204    global varctok vtokmod
1205
1206    set v $curview
1207    if {![info exists varcid($v,$id)]} {
1208        puts "oops rowofcommit no arc for [shortids $id]"
1209        return {}
1210    }
1211    set a $varcid($v,$id)
1212    if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1213        update_arcrows $v
1214    }
1215    if {[info exists cached_commitrow($id)]} {
1216        return $cached_commitrow($id)
1217    }
1218    set i [lsearch -exact $varccommits($v,$a) $id]
1219    if {$i < 0} {
1220        puts "oops didn't find commit [shortids $id] in arc $a"
1221        return {}
1222    }
1223    incr i [lindex $varcrow($v) $a]
1224    set cached_commitrow($id) $i
1225    return $i
1226}
1227
1228# Returns 1 if a is on an earlier row than b, otherwise 0
1229proc comes_before {a b} {
1230    global varcid varctok curview
1231
1232    set v $curview
1233    if {$a eq $b || ![info exists varcid($v,$a)] || \
1234            ![info exists varcid($v,$b)]} {
1235        return 0
1236    }
1237    if {$varcid($v,$a) != $varcid($v,$b)} {
1238        return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1239                           [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1240    }
1241    return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1242}
1243
1244proc bsearch {l elt} {
1245    if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1246        return 0
1247    }
1248    set lo 0
1249    set hi [llength $l]
1250    while {$hi - $lo > 1} {
1251        set mid [expr {int(($lo + $hi) / 2)}]
1252        set t [lindex $l $mid]
1253        if {$elt < $t} {
1254            set hi $mid
1255        } elseif {$elt > $t} {
1256            set lo $mid
1257        } else {
1258            return $mid
1259        }
1260    }
1261    return $lo
1262}
1263
1264# Make sure rows $start..$end-1 are valid in displayorder and parentlist
1265proc make_disporder {start end} {
1266    global vrownum curview commitidx displayorder parentlist
1267    global varccommits varcorder parents vrowmod varcrow
1268    global d_valid_start d_valid_end
1269
1270    if {$end > $vrowmod($curview)} {
1271        update_arcrows $curview
1272    }
1273    set ai [bsearch $vrownum($curview) $start]
1274    set start [lindex $vrownum($curview) $ai]
1275    set narc [llength $vrownum($curview)]
1276    for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1277        set a [lindex $varcorder($curview) $ai]
1278        set l [llength $displayorder]
1279        set al [llength $varccommits($curview,$a)]
1280        if {$l < $r + $al} {
1281            if {$l < $r} {
1282                set pad [ntimes [expr {$r - $l}] {}]
1283                set displayorder [concat $displayorder $pad]
1284                set parentlist [concat $parentlist $pad]
1285            } elseif {$l > $r} {
1286                set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1287                set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1288            }
1289            foreach id $varccommits($curview,$a) {
1290                lappend displayorder $id
1291                lappend parentlist $parents($curview,$id)
1292            }
1293        } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1294            set i $r
1295            foreach id $varccommits($curview,$a) {
1296                lset displayorder $i $id
1297                lset parentlist $i $parents($curview,$id)
1298                incr i
1299            }
1300        }
1301        incr r $al
1302    }
1303}
1304
1305proc commitonrow {row} {
1306    global displayorder
1307
1308    set id [lindex $displayorder $row]
1309    if {$id eq {}} {
1310        make_disporder $row [expr {$row + 1}]
1311        set id [lindex $displayorder $row]
1312    }
1313    return $id
1314}
1315
1316proc closevarcs {v} {
1317    global varctok varccommits varcid parents children
1318    global cmitlisted commitidx vtokmod
1319
1320    set missing_parents 0
1321    set scripts {}
1322    set narcs [llength $varctok($v)]
1323    for {set a 1} {$a < $narcs} {incr a} {
1324        set id [lindex $varccommits($v,$a) end]
1325        foreach p $parents($v,$id) {
1326            if {[info exists varcid($v,$p)]} continue
1327            # add p as a new commit
1328            incr missing_parents
1329            set cmitlisted($v,$p) 0
1330            set parents($v,$p) {}
1331            if {[llength $children($v,$p)] == 1 &&
1332                [llength $parents($v,$id)] == 1} {
1333                set b $a
1334            } else {
1335                set b [newvarc $v $p]
1336            }
1337            set varcid($v,$p) $b
1338            if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1339                modify_arc $v $b
1340            }
1341            lappend varccommits($v,$b) $p
1342            incr commitidx($v)
1343            set scripts [check_interest $p $scripts]
1344        }
1345    }
1346    if {$missing_parents > 0} {
1347        foreach s $scripts {
1348            eval $s
1349        }
1350    }
1351}
1352
1353# Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1354# Assumes we already have an arc for $rwid.
1355proc rewrite_commit {v id rwid} {
1356    global children parents varcid varctok vtokmod varccommits
1357
1358    foreach ch $children($v,$id) {
1359        # make $rwid be $ch's parent in place of $id
1360        set i [lsearch -exact $parents($v,$ch) $id]
1361        if {$i < 0} {
1362            puts "oops rewrite_commit didn't find $id in parent list for $ch"
1363        }
1364        set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1365        # add $ch to $rwid's children and sort the list if necessary
1366        if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1367            set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1368                                        $children($v,$rwid)]
1369        }
1370        # fix the graph after joining $id to $rwid
1371        set a $varcid($v,$ch)
1372        fix_reversal $rwid $a $v
1373        # parentlist is wrong for the last element of arc $a
1374        # even if displayorder is right, hence the 3rd arg here
1375        modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1376    }
1377}
1378
1379# Mechanism for registering a command to be executed when we come
1380# across a particular commit.  To handle the case when only the
1381# prefix of the commit is known, the commitinterest array is now
1382# indexed by the first 4 characters of the ID.  Each element is a
1383# list of id, cmd pairs.
1384proc interestedin {id cmd} {
1385    global commitinterest
1386
1387    lappend commitinterest([string range $id 0 3]) $id $cmd
1388}
1389
1390proc check_interest {id scripts} {
1391    global commitinterest
1392
1393    set prefix [string range $id 0 3]
1394    if {[info exists commitinterest($prefix)]} {
1395        set newlist {}
1396        foreach {i script} $commitinterest($prefix) {
1397            if {[string match "$i*" $id]} {
1398                lappend scripts [string map [list "%I" $id "%P" $i] $script]
1399            } else {
1400                lappend newlist $i $script
1401            }
1402        }
1403        if {$newlist ne {}} {
1404            set commitinterest($prefix) $newlist
1405        } else {
1406            unset commitinterest($prefix)
1407        }
1408    }
1409    return $scripts
1410}
1411
1412proc getcommitlines {fd inst view updating}  {
1413    global cmitlisted leftover
1414    global commitidx commitdata vdatemode
1415    global parents children curview hlview
1416    global idpending ordertok
1417    global varccommits varcid varctok vtokmod vfilelimit vshortids
1418
1419    set stuff [read $fd 500000]
1420    # git log doesn't terminate the last commit with a null...
1421    if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1422        set stuff "\0"
1423    }
1424    if {$stuff == {}} {
1425        if {![eof $fd]} {
1426            return 1
1427        }
1428        global commfd viewcomplete viewactive viewname
1429        global viewinstances
1430        unset commfd($inst)
1431        set i [lsearch -exact $viewinstances($view) $inst]
1432        if {$i >= 0} {
1433            set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1434        }
1435        # set it blocking so we wait for the process to terminate
1436        fconfigure $fd -blocking 1
1437        if {[catch {close $fd} err]} {
1438            set fv {}
1439            if {$view != $curview} {
1440                set fv " for the \"$viewname($view)\" view"
1441            }
1442            if {[string range $err 0 4] == "usage"} {
1443                set err "Gitk: error reading commits$fv:\
1444                        bad arguments to git log."
1445                if {$viewname($view) eq "Command line"} {
1446                    append err \
1447                        "  (Note: arguments to gitk are passed to git log\
1448                         to allow selection of commits to be displayed.)"
1449                }
1450            } else {
1451                set err "Error reading commits$fv: $err"
1452            }
1453            error_popup $err
1454        }
1455        if {[incr viewactive($view) -1] <= 0} {
1456            set viewcomplete($view) 1
1457            # Check if we have seen any ids listed as parents that haven't
1458            # appeared in the list
1459            closevarcs $view
1460            notbusy $view
1461        }
1462        if {$view == $curview} {
1463            run chewcommits
1464        }
1465        return 0
1466    }
1467    set start 0
1468    set gotsome 0
1469    set scripts {}
1470    while 1 {
1471        set i [string first "\0" $stuff $start]
1472        if {$i < 0} {
1473            append leftover($inst) [string range $stuff $start end]
1474            break
1475        }
1476        if {$start == 0} {
1477            set cmit $leftover($inst)
1478            append cmit [string range $stuff 0 [expr {$i - 1}]]
1479            set leftover($inst) {}
1480        } else {
1481            set cmit [string range $stuff $start [expr {$i - 1}]]
1482        }
1483        set start [expr {$i + 1}]
1484        set j [string first "\n" $cmit]
1485        set ok 0
1486        set listed 1
1487        if {$j >= 0 && [string match "commit *" $cmit]} {
1488            set ids [string range $cmit 7 [expr {$j - 1}]]
1489            if {[string match {[-^<>]*} $ids]} {
1490                switch -- [string index $ids 0] {
1491                    "-" {set listed 0}
1492                    "^" {set listed 2}
1493                    "<" {set listed 3}
1494                    ">" {set listed 4}
1495                }
1496                set ids [string range $ids 1 end]
1497            }
1498            set ok 1
1499            foreach id $ids {
1500                if {[string length $id] != 40} {
1501                    set ok 0
1502                    break
1503                }
1504            }
1505        }
1506        if {!$ok} {
1507            set shortcmit $cmit
1508            if {[string length $shortcmit] > 80} {
1509                set shortcmit "[string range $shortcmit 0 80]..."
1510            }
1511            error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1512            exit 1
1513        }
1514        set id [lindex $ids 0]
1515        set vid $view,$id
1516
1517        lappend vshortids($view,[string range $id 0 3]) $id
1518
1519        if {!$listed && $updating && ![info exists varcid($vid)] &&
1520            $vfilelimit($view) ne {}} {
1521            # git log doesn't rewrite parents for unlisted commits
1522            # when doing path limiting, so work around that here
1523            # by working out the rewritten parent with git rev-list
1524            # and if we already know about it, using the rewritten
1525            # parent as a substitute parent for $id's children.
1526            if {![catch {
1527                set rwid [exec git rev-list --first-parent --max-count=1 \
1528                              $id -- $vfilelimit($view)]
1529            }]} {
1530                if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1531                    # use $rwid in place of $id
1532                    rewrite_commit $view $id $rwid
1533                    continue
1534                }
1535            }
1536        }
1537
1538        set a 0
1539        if {[info exists varcid($vid)]} {
1540            if {$cmitlisted($vid) || !$listed} continue
1541            set a $varcid($vid)
1542        }
1543        if {$listed} {
1544            set olds [lrange $ids 1 end]
1545        } else {
1546            set olds {}
1547        }
1548        set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1549        set cmitlisted($vid) $listed
1550        set parents($vid) $olds
1551        if {![info exists children($vid)]} {
1552            set children($vid) {}
1553        } elseif {$a == 0 && [llength $children($vid)] == 1} {
1554            set k [lindex $children($vid) 0]
1555            if {[llength $parents($view,$k)] == 1 &&
1556                (!$vdatemode($view) ||
1557                 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1558                set a $varcid($view,$k)
1559            }
1560        }
1561        if {$a == 0} {
1562            # new arc
1563            set a [newvarc $view $id]
1564        }
1565        if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1566            modify_arc $view $a
1567        }
1568        if {![info exists varcid($vid)]} {
1569            set varcid($vid) $a
1570            lappend varccommits($view,$a) $id
1571            incr commitidx($view)
1572        }
1573
1574        set i 0
1575        foreach p $olds {
1576            if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1577                set vp $view,$p
1578                if {[llength [lappend children($vp) $id]] > 1 &&
1579                    [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1580                    set children($vp) [lsort -command [list vtokcmp $view] \
1581                                           $children($vp)]
1582                    catch {unset ordertok}
1583                }
1584                if {[info exists varcid($view,$p)]} {
1585                    fix_reversal $p $a $view
1586                }
1587            }
1588            incr i
1589        }
1590
1591        set scripts [check_interest $id $scripts]
1592        set gotsome 1
1593    }
1594    if {$gotsome} {
1595        global numcommits hlview
1596
1597        if {$view == $curview} {
1598            set numcommits $commitidx($view)
1599            run chewcommits
1600        }
1601        if {[info exists hlview] && $view == $hlview} {
1602            # we never actually get here...
1603            run vhighlightmore
1604        }
1605        foreach s $scripts {
1606            eval $s
1607        }
1608    }
1609    return 2
1610}
1611
1612proc chewcommits {} {
1613    global curview hlview viewcomplete
1614    global pending_select
1615
1616    layoutmore
1617    if {$viewcomplete($curview)} {
1618        global commitidx varctok
1619        global numcommits startmsecs
1620
1621        if {[info exists pending_select]} {
1622            update
1623            reset_pending_select {}
1624
1625            if {[commitinview $pending_select $curview]} {
1626                selectline [rowofcommit $pending_select] 1
1627            } else {
1628                set row [first_real_row]
1629                selectline $row 1
1630            }
1631        }
1632        if {$commitidx($curview) > 0} {
1633            #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1634            #puts "overall $ms ms for $numcommits commits"
1635            #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1636        } else {
1637            show_status [mc "No commits selected"]
1638        }
1639        notbusy layout
1640    }
1641    return 0
1642}
1643
1644proc do_readcommit {id} {
1645    global tclencoding
1646
1647    # Invoke git-log to handle automatic encoding conversion
1648    set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1649    # Read the results using i18n.logoutputencoding
1650    fconfigure $fd -translation lf -eofchar {}
1651    if {$tclencoding != {}} {
1652        fconfigure $fd -encoding $tclencoding
1653    }
1654    set contents [read $fd]
1655    close $fd
1656    # Remove the heading line
1657    regsub {^commit [0-9a-f]+\n} $contents {} contents
1658
1659    return $contents
1660}
1661
1662proc readcommit {id} {
1663    if {[catch {set contents [do_readcommit $id]}]} return
1664    parsecommit $id $contents 1
1665}
1666
1667proc parsecommit {id contents listed} {
1668    global commitinfo
1669
1670    set inhdr 1
1671    set comment {}
1672    set headline {}
1673    set auname {}
1674    set audate {}
1675    set comname {}
1676    set comdate {}
1677    set hdrend [string first "\n\n" $contents]
1678    if {$hdrend < 0} {
1679        # should never happen...
1680        set hdrend [string length $contents]
1681    }
1682    set header [string range $contents 0 [expr {$hdrend - 1}]]
1683    set comment [string range $contents [expr {$hdrend + 2}] end]
1684    foreach line [split $header "\n"] {
1685        set line [split $line " "]
1686        set tag [lindex $line 0]
1687        if {$tag == "author"} {
1688            set audate [lrange $line end-1 end]
1689            set auname [join [lrange $line 1 end-2] " "]
1690        } elseif {$tag == "committer"} {
1691            set comdate [lrange $line end-1 end]
1692            set comname [join [lrange $line 1 end-2] " "]
1693        }
1694    }
1695    set headline {}
1696    # take the first non-blank line of the comment as the headline
1697    set headline [string trimleft $comment]
1698    set i [string first "\n" $headline]
1699    if {$i >= 0} {
1700        set headline [string range $headline 0 $i]
1701    }
1702    set headline [string trimright $headline]
1703    set i [string first "\r" $headline]
1704    if {$i >= 0} {
1705        set headline [string trimright [string range $headline 0 $i]]
1706    }
1707    if {!$listed} {
1708        # git log indents the comment by 4 spaces;
1709        # if we got this via git cat-file, add the indentation
1710        set newcomment {}
1711        foreach line [split $comment "\n"] {
1712            append newcomment "    "
1713            append newcomment $line
1714            append newcomment "\n"
1715        }
1716        set comment $newcomment
1717    }
1718    set hasnote [string first "\nNotes:\n" $contents]
1719    set diff ""
1720    # If there is diff output shown in the git-log stream, split it
1721    # out.  But get rid of the empty line that always precedes the
1722    # diff.
1723    set i [string first "\n\ndiff" $comment]
1724    if {$i >= 0} {
1725        set diff [string range $comment $i+1 end]
1726        set comment [string range $comment 0 $i-1]
1727    }
1728    set commitinfo($id) [list $headline $auname $audate \
1729                             $comname $comdate $comment $hasnote $diff]
1730}
1731
1732proc getcommit {id} {
1733    global commitdata commitinfo
1734
1735    if {[info exists commitdata($id)]} {
1736        parsecommit $id $commitdata($id) 1
1737    } else {
1738        readcommit $id
1739        if {![info exists commitinfo($id)]} {
1740            set commitinfo($id) [list [mc "No commit information available"]]
1741        }
1742    }
1743    return 1
1744}
1745
1746# Expand an abbreviated commit ID to a list of full 40-char IDs that match
1747# and are present in the current view.
1748# This is fairly slow...
1749proc longid {prefix} {
1750    global varcid curview vshortids
1751
1752    set ids {}
1753    if {[string length $prefix] >= 4} {
1754        set vshortid $curview,[string range $prefix 0 3]
1755        if {[info exists vshortids($vshortid)]} {
1756            foreach id $vshortids($vshortid) {
1757                if {[string match "$prefix*" $id]} {
1758                    if {[lsearch -exact $ids $id] < 0} {
1759                        lappend ids $id
1760                        if {[llength $ids] >= 2} break
1761                    }
1762                }
1763            }
1764        }
1765    } else {
1766        foreach match [array names varcid "$curview,$prefix*"] {
1767            lappend ids [lindex [split $match ","] 1]
1768            if {[llength $ids] >= 2} break
1769        }
1770    }
1771    return $ids
1772}
1773
1774proc readrefs {} {
1775    global tagids idtags headids idheads tagobjid
1776    global otherrefids idotherrefs mainhead mainheadid
1777    global selecthead selectheadid
1778    global hideremotes
1779
1780    foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1781        catch {unset $v}
1782    }
1783    set refd [open [list | git show-ref -d] r]
1784    while {[gets $refd line] >= 0} {
1785        if {[string index $line 40] ne " "} continue
1786        set id [string range $line 0 39]
1787        set ref [string range $line 41 end]
1788        if {![string match "refs/*" $ref]} continue
1789        set name [string range $ref 5 end]
1790        if {[string match "remotes/*" $name]} {
1791            if {![string match "*/HEAD" $name] && !$hideremotes} {
1792                set headids($name) $id
1793                lappend idheads($id) $name
1794            }
1795        } elseif {[string match "heads/*" $name]} {
1796            set name [string range $name 6 end]
1797            set headids($name) $id
1798            lappend idheads($id) $name
1799        } elseif {[string match "tags/*" $name]} {
1800            # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1801            # which is what we want since the former is the commit ID
1802            set name [string range $name 5 end]
1803            if {[string match "*^{}" $name]} {
1804                set name [string range $name 0 end-3]
1805            } else {
1806                set tagobjid($name) $id
1807            }
1808            set tagids($name) $id
1809            lappend idtags($id) $name
1810        } else {
1811            set otherrefids($name) $id
1812            lappend idotherrefs($id) $name
1813        }
1814    }
1815    catch {close $refd}
1816    set mainhead {}
1817    set mainheadid {}
1818    catch {
1819        set mainheadid [exec git rev-parse HEAD]
1820        set thehead [exec git symbolic-ref HEAD]
1821        if {[string match "refs/heads/*" $thehead]} {
1822            set mainhead [string range $thehead 11 end]
1823        }
1824    }
1825    set selectheadid {}
1826    if {$selecthead ne {}} {
1827        catch {
1828            set selectheadid [exec git rev-parse --verify $selecthead]
1829        }
1830    }
1831}
1832
1833# skip over fake commits
1834proc first_real_row {} {
1835    global nullid nullid2 numcommits
1836
1837    for {set row 0} {$row < $numcommits} {incr row} {
1838        set id [commitonrow $row]
1839        if {$id ne $nullid && $id ne $nullid2} {
1840            break
1841        }
1842    }
1843    return $row
1844}
1845
1846# update things for a head moved to a child of its previous location
1847proc movehead {id name} {
1848    global headids idheads
1849
1850    removehead $headids($name) $name
1851    set headids($name) $id
1852    lappend idheads($id) $name
1853}
1854
1855# update things when a head has been removed
1856proc removehead {id name} {
1857    global headids idheads
1858
1859    if {$idheads($id) eq $name} {
1860        unset idheads($id)
1861    } else {
1862        set i [lsearch -exact $idheads($id) $name]
1863        if {$i >= 0} {
1864            set idheads($id) [lreplace $idheads($id) $i $i]
1865        }
1866    }
1867    unset headids($name)
1868}
1869
1870proc ttk_toplevel {w args} {
1871    global use_ttk
1872    eval [linsert $args 0 ::toplevel $w]
1873    if {$use_ttk} {
1874        place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1875    }
1876    return $w
1877}
1878
1879proc make_transient {window origin} {
1880    global have_tk85
1881
1882    # In MacOS Tk 8.4 transient appears to work by setting
1883    # overrideredirect, which is utterly useless, since the
1884    # windows get no border, and are not even kept above
1885    # the parent.
1886    if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1887
1888    wm transient $window $origin
1889
1890    # Windows fails to place transient windows normally, so
1891    # schedule a callback to center them on the parent.
1892    if {[tk windowingsystem] eq {win32}} {
1893        after idle [list tk::PlaceWindow $window widget $origin]
1894    }
1895}
1896
1897proc show_error {w top msg {mc mc}} {
1898    global NS
1899    if {![info exists NS]} {set NS ""}
1900    if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1901    message $w.m -text $msg -justify center -aspect 400
1902    pack $w.m -side top -fill x -padx 20 -pady 20
1903    ${NS}::button $w.ok -default active -text [$mc OK] -command "destroy $top"
1904    pack $w.ok -side bottom -fill x
1905    bind $top <Visibility> "grab $top; focus $top"
1906    bind $top <Key-Return> "destroy $top"
1907    bind $top <Key-space>  "destroy $top"
1908    bind $top <Key-Escape> "destroy $top"
1909    tkwait window $top
1910}
1911
1912proc error_popup {msg {owner .}} {
1913    if {[tk windowingsystem] eq "win32"} {
1914        tk_messageBox -icon error -type ok -title [wm title .] \
1915            -parent $owner -message $msg
1916    } else {
1917        set w .error
1918        ttk_toplevel $w
1919        make_transient $w $owner
1920        show_error $w $w $msg
1921    }
1922}
1923
1924proc confirm_popup {msg {owner .}} {
1925    global confirm_ok NS
1926    set confirm_ok 0
1927    set w .confirm
1928    ttk_toplevel $w
1929    make_transient $w $owner
1930    message $w.m -text $msg -justify center -aspect 400
1931    pack $w.m -side top -fill x -padx 20 -pady 20
1932    ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1933    pack $w.ok -side left -fill x
1934    ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1935    pack $w.cancel -side right -fill x
1936    bind $w <Visibility> "grab $w; focus $w"
1937    bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1938    bind $w <Key-space>  "set confirm_ok 1; destroy $w"
1939    bind $w <Key-Escape> "destroy $w"
1940    tk::PlaceWindow $w widget $owner
1941    tkwait window $w
1942    return $confirm_ok
1943}
1944
1945proc setoptions {} {
1946    if {[tk windowingsystem] ne "win32"} {
1947        option add *Panedwindow.showHandle 1 startupFile
1948        option add *Panedwindow.sashRelief raised startupFile
1949        if {[tk windowingsystem] ne "aqua"} {
1950            option add *Menu.font uifont startupFile
1951        }
1952    } else {
1953        option add *Menu.TearOff 0 startupFile
1954    }
1955    option add *Button.font uifont startupFile
1956    option add *Checkbutton.font uifont startupFile
1957    option add *Radiobutton.font uifont startupFile
1958    option add *Menubutton.font uifont startupFile
1959    option add *Label.font uifont startupFile
1960    option add *Message.font uifont startupFile
1961    option add *Entry.font textfont startupFile
1962    option add *Text.font textfont startupFile
1963    option add *Labelframe.font uifont startupFile
1964    option add *Spinbox.font textfont startupFile
1965    option add *Listbox.font mainfont startupFile
1966}
1967
1968# Make a menu and submenus.
1969# m is the window name for the menu, items is the list of menu items to add.
1970# Each item is a list {mc label type description options...}
1971# mc is ignored; it's so we can put mc there to alert xgettext
1972# label is the string that appears in the menu
1973# type is cascade, command or radiobutton (should add checkbutton)
1974# description depends on type; it's the sublist for cascade, the
1975# command to invoke for command, or {variable value} for radiobutton
1976proc makemenu {m items} {
1977    menu $m
1978    if {[tk windowingsystem] eq {aqua}} {
1979        set Meta1 Cmd
1980    } else {
1981        set Meta1 Ctrl
1982    }
1983    foreach i $items {
1984        set name [mc [lindex $i 1]]
1985        set type [lindex $i 2]
1986        set thing [lindex $i 3]
1987        set params [list $type]
1988        if {$name ne {}} {
1989            set u [string first "&" [string map {&& x} $name]]
1990            lappend params -label [string map {&& & & {}} $name]
1991            if {$u >= 0} {
1992                lappend params -underline $u
1993            }
1994        }
1995        switch -- $type {
1996            "cascade" {
1997                set submenu [string tolower [string map {& ""} [lindex $i 1]]]
1998                lappend params -menu $m.$submenu
1999            }
2000            "command" {
2001                lappend params -command $thing
2002            }
2003            "radiobutton" {
2004                lappend params -variable [lindex $thing 0] \
2005                    -value [lindex $thing 1]
2006            }
2007        }
2008        set tail [lrange $i 4 end]
2009        regsub -all {\yMeta1\y} $tail $Meta1 tail
2010        eval $m add $params $tail
2011        if {$type eq "cascade"} {
2012            makemenu $m.$submenu $thing
2013        }
2014    }
2015}
2016
2017# translate string and remove ampersands
2018proc mca {str} {
2019    return [string map {&& & & {}} [mc $str]]
2020}
2021
2022proc cleardropsel {w} {
2023    $w selection clear
2024}
2025proc makedroplist {w varname args} {
2026    global use_ttk
2027    if {$use_ttk} {
2028        set width 0
2029        foreach label $args {
2030            set cx [string length $label]
2031            if {$cx > $width} {set width $cx}
2032        }
2033        set gm [ttk::combobox $w -width $width -state readonly\
2034                    -textvariable $varname -values $args \
2035                    -exportselection false]
2036        bind $gm <<ComboboxSelected>> [list $gm selection clear]
2037    } else {
2038        set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2039    }
2040    return $gm
2041}
2042
2043proc makewindow {} {
2044    global canv canv2 canv3 linespc charspc ctext cflist cscroll
2045    global tabstop
2046    global findtype findtypemenu findloc findstring fstring geometry
2047    global entries sha1entry sha1string sha1but
2048    global diffcontextstring diffcontext
2049    global ignorespace
2050    global maincursor textcursor curtextcursor
2051    global rowctxmenu fakerowmenu mergemax wrapcomment
2052    global highlight_files gdttype
2053    global searchstring sstring
2054    global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2055    global uifgcolor uifgdisabledcolor
2056    global filesepbgcolor filesepfgcolor
2057    global mergecolors foundbgcolor currentsearchhitbgcolor
2058    global headctxmenu progresscanv progressitem progresscoords statusw
2059    global fprogitem fprogcoord lastprogupdate progupdatepending
2060    global rprogitem rprogcoord rownumsel numcommits
2061    global have_tk85 use_ttk NS
2062    global git_version
2063    global worddiff
2064
2065    # The "mc" arguments here are purely so that xgettext
2066    # sees the following string as needing to be translated
2067    set file {
2068        mc "File" cascade {
2069            {mc "Update" command updatecommits -accelerator F5}
2070            {mc "Reload" command reloadcommits -accelerator Shift-F5}
2071            {mc "Reread references" command rereadrefs}
2072            {mc "List references" command showrefs -accelerator F2}
2073            {xx "" separator}
2074            {mc "Start git gui" command {exec git gui &}}
2075            {xx "" separator}
2076            {mc "Quit" command doquit -accelerator Meta1-Q}
2077        }}
2078    set edit {
2079        mc "Edit" cascade {
2080            {mc "Preferences" command doprefs}
2081        }}
2082    set view {
2083        mc "View" cascade {
2084            {mc "New view..." command {newview 0} -accelerator Shift-F4}
2085            {mc "Edit view..." command editview -state disabled -accelerator F4}
2086            {mc "Delete view" command delview -state disabled}
2087            {xx "" separator}
2088            {mc "All files" radiobutton {selectedview 0} -command {showview 0}}
2089        }}
2090    if {[tk windowingsystem] ne "aqua"} {
2091        set help {
2092        mc "Help" cascade {
2093            {mc "About gitk" command about}
2094            {mc "Key bindings" command keys}
2095        }}
2096        set bar [list $file $edit $view $help]
2097    } else {
2098        proc ::tk::mac::ShowPreferences {} {doprefs}
2099        proc ::tk::mac::Quit {} {doquit}
2100        lset file end [lreplace [lindex $file end] end-1 end]
2101        set apple {
2102        xx "Apple" cascade {
2103            {mc "About gitk" command about}
2104            {xx "" separator}
2105        }}
2106        set help {
2107        mc "Help" cascade {
2108            {mc "Key bindings" command keys}
2109        }}
2110        set bar [list $apple $file $view $help]
2111    }
2112    makemenu .bar $bar
2113    . configure -menu .bar
2114
2115    if {$use_ttk} {
2116        # cover the non-themed toplevel with a themed frame.
2117        place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2118    }
2119
2120    # the gui has upper and lower half, parts of a paned window.
2121    ${NS}::panedwindow .ctop -orient vertical
2122
2123    # possibly use assumed geometry
2124    if {![info exists geometry(pwsash0)]} {
2125        set geometry(topheight) [expr {15 * $linespc}]
2126        set geometry(topwidth) [expr {80 * $charspc}]
2127        set geometry(botheight) [expr {15 * $linespc}]
2128        set geometry(botwidth) [expr {50 * $charspc}]
2129        set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2130        set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2131    }
2132
2133    # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2134    ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2135    ${NS}::frame .tf.histframe
2136    ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2137    if {!$use_ttk} {
2138        .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2139    }
2140
2141    # create three canvases
2142    set cscroll .tf.histframe.csb
2143    set canv .tf.histframe.pwclist.canv
2144    canvas $canv \
2145        -selectbackground $selectbgcolor \
2146        -background $bgcolor -bd 0 \
2147        -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2148    .tf.histframe.pwclist add $canv
2149    set canv2 .tf.histframe.pwclist.canv2
2150    canvas $canv2 \
2151        -selectbackground $selectbgcolor \
2152        -background $bgcolor -bd 0 -yscrollincr $linespc
2153    .tf.histframe.pwclist add $canv2
2154    set canv3 .tf.histframe.pwclist.canv3
2155    canvas $canv3 \
2156        -selectbackground $selectbgcolor \
2157        -background $bgcolor -bd 0 -yscrollincr $linespc
2158    .tf.histframe.pwclist add $canv3
2159    if {$use_ttk} {
2160        bind .tf.histframe.pwclist <Map> {
2161            bind %W <Map> {}
2162            .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2163            .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2164        }
2165    } else {
2166        eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2167        eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2168    }
2169
2170    # a scroll bar to rule them
2171    ${NS}::scrollbar $cscroll -command {allcanvs yview}
2172    if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2173    pack $cscroll -side right -fill y
2174    bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2175    lappend bglist $canv $canv2 $canv3
2176    pack .tf.histframe.pwclist -fill both -expand 1 -side left
2177
2178    # we have two button bars at bottom of top frame. Bar 1
2179    ${NS}::frame .tf.bar
2180    ${NS}::frame .tf.lbar -height 15
2181
2182    set sha1entry .tf.bar.sha1
2183    set entries $sha1entry
2184    set sha1but .tf.bar.sha1label
2185    button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2186        -command gotocommit -width 8
2187    $sha1but conf -disabledforeground [$sha1but cget -foreground]
2188    pack .tf.bar.sha1label -side left
2189    ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2190    trace add variable sha1string write sha1change
2191    pack $sha1entry -side left -pady 2
2192
2193    set bm_left_data {
2194        #define left_width 16
2195        #define left_height 16
2196        static unsigned char left_bits[] = {
2197        0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2198        0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2199        0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2200    }
2201    set bm_right_data {
2202        #define right_width 16
2203        #define right_height 16
2204        static unsigned char right_bits[] = {
2205        0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2206        0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2207        0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2208    }
2209    image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2210    image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2211    image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2212    image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2213
2214    ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2215    if {$use_ttk} {
2216        .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2217    } else {
2218        .tf.bar.leftbut configure -image bm-left
2219    }
2220    pack .tf.bar.leftbut -side left -fill y
2221    ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2222    if {$use_ttk} {
2223        .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2224    } else {
2225        .tf.bar.rightbut configure -image bm-right
2226    }
2227    pack .tf.bar.rightbut -side left -fill y
2228
2229    ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2230    set rownumsel {}
2231    ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2232        -relief sunken -anchor e
2233    ${NS}::label .tf.bar.rowlabel2 -text "/"
2234    ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2235        -relief sunken -anchor e
2236    pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2237        -side left
2238    if {!$use_ttk} {
2239        foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2240    }
2241    global selectedline
2242    trace add variable selectedline write selectedline_change
2243
2244    # Status label and progress bar
2245    set statusw .tf.bar.status
2246    ${NS}::label $statusw -width 15 -relief sunken
2247    pack $statusw -side left -padx 5
2248    if {$use_ttk} {
2249        set progresscanv [ttk::progressbar .tf.bar.progress]
2250    } else {
2251        set h [expr {[font metrics uifont -linespace] + 2}]
2252        set progresscanv .tf.bar.progress
2253        canvas $progresscanv -relief sunken -height $h -borderwidth 2
2254        set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
2255        set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2256        set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2257    }
2258    pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2259    set progresscoords {0 0}
2260    set fprogcoord 0
2261    set rprogcoord 0
2262    bind $progresscanv <Configure> adjustprogress
2263    set lastprogupdate [clock clicks -milliseconds]
2264    set progupdatepending 0
2265
2266    # build up the bottom bar of upper window
2267    ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2268
2269    set bm_down_data {
2270        #define down_width 16
2271        #define down_height 16
2272        static unsigned char down_bits[] = {
2273        0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2274        0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2275        0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2276        0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2277    }
2278    image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2279    ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2280    .tf.lbar.fnext configure -image bm-down
2281
2282    set bm_up_data {
2283        #define up_width 16
2284        #define up_height 16
2285        static unsigned char up_bits[] = {
2286        0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2287        0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2288        0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2289        0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2290    }
2291    image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2292    ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2293    .tf.lbar.fprev configure -image bm-up
2294
2295    ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2296
2297    pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2298        -side left -fill y
2299    set gdttype [mc "containing:"]
2300    set gm [makedroplist .tf.lbar.gdttype gdttype \
2301                [mc "containing:"] \
2302                [mc "touching paths:"] \
2303                [mc "adding/removing string:"] \
2304                [mc "changing lines matching:"]]
2305    trace add variable gdttype write gdttype_change
2306    pack .tf.lbar.gdttype -side left -fill y
2307
2308    set findstring {}
2309    set fstring .tf.lbar.findstring
2310    lappend entries $fstring
2311    ${NS}::entry $fstring -width 30 -textvariable findstring
2312    trace add variable findstring write find_change
2313    set findtype [mc "Exact"]
2314    set findtypemenu [makedroplist .tf.lbar.findtype \
2315                          findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2316    trace add variable findtype write findcom_change
2317    set findloc [mc "All fields"]
2318    makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2319        [mc "Comments"] [mc "Author"] [mc "Committer"]
2320    trace add variable findloc write find_change
2321    pack .tf.lbar.findloc -side right
2322    pack .tf.lbar.findtype -side right
2323    pack $fstring -side left -expand 1 -fill x
2324
2325    # Finish putting the upper half of the viewer together
2326    pack .tf.lbar -in .tf -side bottom -fill x
2327    pack .tf.bar -in .tf -side bottom -fill x
2328    pack .tf.histframe -fill both -side top -expand 1
2329    .ctop add .tf
2330    if {!$use_ttk} {
2331        .ctop paneconfigure .tf -height $geometry(topheight)
2332        .ctop paneconfigure .tf -width $geometry(topwidth)
2333    }
2334
2335    # now build up the bottom
2336    ${NS}::panedwindow .pwbottom -orient horizontal
2337
2338    # lower left, a text box over search bar, scroll bar to the right
2339    # if we know window height, then that will set the lower text height, otherwise
2340    # we set lower text height which will drive window height
2341    if {[info exists geometry(main)]} {
2342        ${NS}::frame .bleft -width $geometry(botwidth)
2343    } else {
2344        ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2345    }
2346    ${NS}::frame .bleft.top
2347    ${NS}::frame .bleft.mid
2348    ${NS}::frame .bleft.bottom
2349
2350    ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2351    pack .bleft.top.search -side left -padx 5
2352    set sstring .bleft.top.sstring
2353    set searchstring ""
2354    ${NS}::entry $sstring -width 20 -textvariable searchstring
2355    lappend entries $sstring
2356    trace add variable searchstring write incrsearch
2357    pack $sstring -side left -expand 1 -fill x
2358    ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2359        -command changediffdisp -variable diffelide -value {0 0}
2360    ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2361        -command changediffdisp -variable diffelide -value {0 1}
2362    ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2363        -command changediffdisp -variable diffelide -value {1 0}
2364    ${NS}::label .bleft.mid.labeldiffcontext -text "      [mc "Lines of context"]: "
2365    pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
2366    spinbox .bleft.mid.diffcontext -width 5 \
2367        -from 0 -increment 1 -to 10000000 \
2368        -validate all -validatecommand "diffcontextvalidate %P" \
2369        -textvariable diffcontextstring
2370    .bleft.mid.diffcontext set $diffcontext
2371    trace add variable diffcontextstring write diffcontextchange
2372    lappend entries .bleft.mid.diffcontext
2373    pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
2374    ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2375        -command changeignorespace -variable ignorespace
2376    pack .bleft.mid.ignspace -side left -padx 5
2377
2378    set worddiff [mc "Line diff"]
2379    if {[package vcompare $git_version "1.7.2"] >= 0} {
2380        makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2381            [mc "Markup words"] [mc "Color words"]
2382        trace add variable worddiff write changeworddiff
2383        pack .bleft.mid.worddiff -side left -padx 5
2384    }
2385
2386    set ctext .bleft.bottom.ctext
2387    text $ctext -background $bgcolor -foreground $fgcolor \
2388        -state disabled -font textfont \
2389        -yscrollcommand scrolltext -wrap none \
2390        -xscrollcommand ".bleft.bottom.sbhorizontal set"
2391    if {$have_tk85} {
2392        $ctext conf -tabstyle wordprocessor
2393    }
2394    ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2395    ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2396    pack .bleft.top -side top -fill x
2397    pack .bleft.mid -side top -fill x
2398    grid $ctext .bleft.bottom.sb -sticky nsew
2399    grid .bleft.bottom.sbhorizontal -sticky ew
2400    grid columnconfigure .bleft.bottom 0 -weight 1
2401    grid rowconfigure .bleft.bottom 0 -weight 1
2402    grid rowconfigure .bleft.bottom 1 -weight 0
2403    pack .bleft.bottom -side top -fill both -expand 1
2404    lappend bglist $ctext
2405    lappend fglist $ctext
2406
2407    $ctext tag conf comment -wrap $wrapcomment
2408    $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2409    $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2410    $ctext tag conf d0 -fore [lindex $diffcolors 0]
2411    $ctext tag conf dresult -fore [lindex $diffcolors 1]
2412    $ctext tag conf m0 -fore [lindex $mergecolors 0]
2413    $ctext tag conf m1 -fore [lindex $mergecolors 1]
2414    $ctext tag conf m2 -fore [lindex $mergecolors 2]
2415    $ctext tag conf m3 -fore [lindex $mergecolors 3]
2416    $ctext tag conf m4 -fore [lindex $mergecolors 4]
2417    $ctext tag conf m5 -fore [lindex $mergecolors 5]
2418    $ctext tag conf m6 -fore [lindex $mergecolors 6]
2419    $ctext tag conf m7 -fore [lindex $mergecolors 7]
2420    $ctext tag conf m8 -fore [lindex $mergecolors 8]
2421    $ctext tag conf m9 -fore [lindex $mergecolors 9]
2422    $ctext tag conf m10 -fore [lindex $mergecolors 10]
2423    $ctext tag conf m11 -fore [lindex $mergecolors 11]
2424    $ctext tag conf m12 -fore [lindex $mergecolors 12]
2425    $ctext tag conf m13 -fore [lindex $mergecolors 13]
2426    $ctext tag conf m14 -fore [lindex $mergecolors 14]
2427    $ctext tag conf m15 -fore [lindex $mergecolors 15]
2428    $ctext tag conf mmax -fore darkgrey
2429    set mergemax 16
2430    $ctext tag conf mresult -font textfontbold
2431    $ctext tag conf msep -font textfontbold
2432    $ctext tag conf found -back $foundbgcolor
2433    $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2434    $ctext tag conf wwrap -wrap word -lmargin2 1c
2435    $ctext tag conf bold -font textfontbold
2436
2437    .pwbottom add .bleft
2438    if {!$use_ttk} {
2439        .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2440    }
2441
2442    # lower right
2443    ${NS}::frame .bright
2444    ${NS}::frame .bright.mode
2445    ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2446        -command reselectline -variable cmitmode -value "patch"
2447    ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2448        -command reselectline -variable cmitmode -value "tree"
2449    grid .bright.mode.patch .bright.mode.tree -sticky ew
2450    pack .bright.mode -side top -fill x
2451    set cflist .bright.cfiles
2452    set indent [font measure mainfont "nn"]
2453    text $cflist \
2454        -selectbackground $selectbgcolor \
2455        -background $bgcolor -foreground $fgcolor \
2456        -font mainfont \
2457        -tabs [list $indent [expr {2 * $indent}]] \
2458        -yscrollcommand ".bright.sb set" \
2459        -cursor [. cget -cursor] \
2460        -spacing1 1 -spacing3 1
2461    lappend bglist $cflist
2462    lappend fglist $cflist
2463    ${NS}::scrollbar .bright.sb -command "$cflist yview"
2464    pack .bright.sb -side right -fill y
2465    pack $cflist -side left -fill both -expand 1
2466    $cflist tag configure highlight \
2467        -background [$cflist cget -selectbackground]
2468    $cflist tag configure bold -font mainfontbold
2469
2470    .pwbottom add .bright
2471    .ctop add .pwbottom
2472
2473    # restore window width & height if known
2474    if {[info exists geometry(main)]} {
2475        if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2476            if {$w > [winfo screenwidth .]} {
2477                set w [winfo screenwidth .]
2478            }
2479            if {$h > [winfo screenheight .]} {
2480                set h [winfo screenheight .]
2481            }
2482            wm geometry . "${w}x$h"
2483        }
2484    }
2485
2486    if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2487        wm state . $geometry(state)
2488    }
2489
2490    if {[tk windowingsystem] eq {aqua}} {
2491        set M1B M1
2492        set ::BM "3"
2493    } else {
2494        set M1B Control
2495        set ::BM "2"
2496    }
2497
2498    if {$use_ttk} {
2499        bind .ctop <Map> {
2500            bind %W <Map> {}
2501            %W sashpos 0 $::geometry(topheight)
2502        }
2503        bind .pwbottom <Map> {
2504            bind %W <Map> {}
2505            %W sashpos 0 $::geometry(botwidth)
2506        }
2507    }
2508
2509    bind .pwbottom <Configure> {resizecdetpanes %W %w}
2510    pack .ctop -fill both -expand 1
2511    bindall <1> {selcanvline %W %x %y}
2512    #bindall <B1-Motion> {selcanvline %W %x %y}
2513    if {[tk windowingsystem] == "win32"} {
2514        bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2515        bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2516    } else {
2517        bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2518        bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2519        bind $ctext <Button> {
2520            if {"%b" eq 6} {
2521                $ctext xview scroll -5 units
2522            } elseif {"%b" eq 7} {
2523                $ctext xview scroll 5 units
2524            }
2525        }
2526        if {[tk windowingsystem] eq "aqua"} {
2527            bindall <MouseWheel> {
2528                set delta [expr {- (%D)}]
2529                allcanvs yview scroll $delta units
2530            }
2531            bindall <Shift-MouseWheel> {
2532                set delta [expr {- (%D)}]
2533                $canv xview scroll $delta units
2534            }
2535        }
2536    }
2537    bindall <$::BM> "canvscan mark %W %x %y"
2538    bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2539    bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2540    bind . <$M1B-Key-w> doquit
2541    bindkey <Home> selfirstline
2542    bindkey <End> sellastline
2543    bind . <Key-Up> "selnextline -1"
2544    bind . <Key-Down> "selnextline 1"
2545    bind . <Shift-Key-Up> "dofind -1 0"
2546    bind . <Shift-Key-Down> "dofind 1 0"
2547    bindkey <Key-Right> "goforw"
2548    bindkey <Key-Left> "goback"
2549    bind . <Key-Prior> "selnextpage -1"
2550    bind . <Key-Next> "selnextpage 1"
2551    bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2552    bind . <$M1B-End> "allcanvs yview moveto 1.0"
2553    bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2554    bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2555    bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2556    bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2557    bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2558    bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2559    bindkey <Key-space> "$ctext yview scroll 1 pages"
2560    bindkey p "selnextline -1"
2561    bindkey n "selnextline 1"
2562    bindkey z "goback"
2563    bindkey x "goforw"
2564    bindkey k "selnextline -1"
2565    bindkey j "selnextline 1"
2566    bindkey h "goback"
2567    bindkey l "goforw"
2568    bindkey b prevfile
2569    bindkey d "$ctext yview scroll 18 units"
2570    bindkey u "$ctext yview scroll -18 units"
2571    bindkey / {focus $fstring}
2572    bindkey <Key-KP_Divide> {focus $fstring}
2573    bindkey <Key-Return> {dofind 1 1}
2574    bindkey ? {dofind -1 1}
2575    bindkey f nextfile
2576    bind . <F5> updatecommits
2577    bindmodfunctionkey Shift 5 reloadcommits
2578    bind . <F2> showrefs
2579    bindmodfunctionkey Shift 4 {newview 0}
2580    bind . <F4> edit_or_newview
2581    bind . <$M1B-q> doquit
2582    bind . <$M1B-f> {dofind 1 1}
2583    bind . <$M1B-g> {dofind 1 0}
2584    bind . <$M1B-r> dosearchback
2585    bind . <$M1B-s> dosearch
2586    bind . <$M1B-equal> {incrfont 1}
2587    bind . <$M1B-plus> {incrfont 1}
2588    bind . <$M1B-KP_Add> {incrfont 1}
2589    bind . <$M1B-minus> {incrfont -1}
2590    bind . <$M1B-KP_Subtract> {incrfont -1}
2591    wm protocol . WM_DELETE_WINDOW doquit
2592    bind . <Destroy> {stop_backends}
2593    bind . <Button-1> "click %W"
2594    bind $fstring <Key-Return> {dofind 1 1}
2595    bind $sha1entry <Key-Return> {gotocommit; break}
2596    bind $sha1entry <<PasteSelection>> clearsha1
2597    bind $sha1entry <<Paste>> clearsha1
2598    bind $cflist <1> {sel_flist %W %x %y; break}
2599    bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2600    bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2601    global ctxbut
2602    bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2603    bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2604    bind $ctext <Button-1> {focus %W}
2605    bind $ctext <<Selection>> rehighlight_search_results
2606    for {set i 1} {$i < 10} {incr i} {
2607        bind . <$M1B-Key-$i> [list go_to_parent $i]
2608    }
2609
2610    set maincursor [. cget -cursor]
2611    set textcursor [$ctext cget -cursor]
2612    set curtextcursor $textcursor
2613
2614    set rowctxmenu .rowctxmenu
2615    makemenu $rowctxmenu {
2616        {mc "Diff this -> selected" command {diffvssel 0}}
2617        {mc "Diff selected -> this" command {diffvssel 1}}
2618        {mc "Make patch" command mkpatch}
2619        {mc "Create tag" command mktag}
2620        {mc "Write commit to file" command writecommit}
2621        {mc "Create new branch" command mkbranch}
2622        {mc "Cherry-pick this commit" command cherrypick}
2623        {mc "Reset HEAD branch to here" command resethead}
2624        {mc "Mark this commit" command markhere}
2625        {mc "Return to mark" command gotomark}
2626        {mc "Find descendant of this and mark" command find_common_desc}
2627        {mc "Compare with marked commit" command compare_commits}
2628        {mc "Diff this -> marked commit" command {diffvsmark 0}}
2629        {mc "Diff marked commit -> this" command {diffvsmark 1}}
2630        {mc "Revert this commit" command revert}
2631    }
2632    $rowctxmenu configure -tearoff 0
2633
2634    set fakerowmenu .fakerowmenu
2635    makemenu $fakerowmenu {
2636        {mc "Diff this -> selected" command {diffvssel 0}}
2637        {mc "Diff selected -> this" command {diffvssel 1}}
2638        {mc "Make patch" command mkpatch}
2639        {mc "Diff this -> marked commit" command {diffvsmark 0}}
2640        {mc "Diff marked commit -> this" command {diffvsmark 1}}
2641    }
2642    $fakerowmenu configure -tearoff 0
2643
2644    set headctxmenu .headctxmenu
2645    makemenu $headctxmenu {
2646        {mc "Check out this branch" command cobranch}
2647        {mc "Remove this branch" command rmbranch}
2648    }
2649    $headctxmenu configure -tearoff 0
2650
2651    global flist_menu
2652    set flist_menu .flistctxmenu
2653    makemenu $flist_menu {
2654        {mc "Highlight this too" command {flist_hl 0}}
2655        {mc "Highlight this only" command {flist_hl 1}}
2656        {mc "External diff" command {external_diff}}
2657        {mc "Blame parent commit" command {external_blame 1}}
2658    }
2659    $flist_menu configure -tearoff 0
2660
2661    global diff_menu
2662    set diff_menu .diffctxmenu
2663    makemenu $diff_menu {
2664        {mc "Show origin of this line" command show_line_source}
2665        {mc "Run git gui blame on this line" command {external_blame_diff}}
2666    }
2667    $diff_menu configure -tearoff 0
2668}
2669
2670# Windows sends all mouse wheel events to the current focused window, not
2671# the one where the mouse hovers, so bind those events here and redirect
2672# to the correct window
2673proc windows_mousewheel_redirector {W X Y D} {
2674    global canv canv2 canv3
2675    set w [winfo containing -displayof $W $X $Y]
2676    if {$w ne ""} {
2677        set u [expr {$D < 0 ? 5 : -5}]
2678        if {$w == $canv || $w == $canv2 || $w == $canv3} {
2679            allcanvs yview scroll $u units
2680        } else {
2681            catch {
2682                $w yview scroll $u units
2683            }
2684        }
2685    }
2686}
2687
2688# Update row number label when selectedline changes
2689proc selectedline_change {n1 n2 op} {
2690    global selectedline rownumsel
2691
2692    if {$selectedline eq {}} {
2693        set rownumsel {}
2694    } else {
2695        set rownumsel [expr {$selectedline + 1}]
2696    }
2697}
2698
2699# mouse-2 makes all windows scan vertically, but only the one
2700# the cursor is in scans horizontally
2701proc canvscan {op w x y} {
2702    global canv canv2 canv3
2703    foreach c [list $canv $canv2 $canv3] {
2704        if {$c == $w} {
2705            $c scan $op $x $y
2706        } else {
2707            $c scan $op 0 $y
2708        }
2709    }
2710}
2711
2712proc scrollcanv {cscroll f0 f1} {
2713    $cscroll set $f0 $f1
2714    drawvisible
2715    flushhighlights
2716}
2717
2718# when we make a key binding for the toplevel, make sure
2719# it doesn't get triggered when that key is pressed in the
2720# find string entry widget.
2721proc bindkey {ev script} {
2722    global entries
2723    bind . $ev $script
2724    set escript [bind Entry $ev]
2725    if {$escript == {}} {
2726        set escript [bind Entry <Key>]
2727    }
2728    foreach e $entries {
2729        bind $e $ev "$escript; break"
2730    }
2731}
2732
2733proc bindmodfunctionkey {mod n script} {
2734    bind . <$mod-F$n> $script
2735    catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2736}
2737
2738# set the focus back to the toplevel for any click outside
2739# the entry widgets
2740proc click {w} {
2741    global ctext entries
2742    foreach e [concat $entries $ctext] {
2743        if {$w == $e} return
2744    }
2745    focus .
2746}
2747
2748# Adjust the progress bar for a change in requested extent or canvas size
2749proc adjustprogress {} {
2750    global progresscanv progressitem progresscoords
2751    global fprogitem fprogcoord lastprogupdate progupdatepending
2752    global rprogitem rprogcoord use_ttk
2753
2754    if {$use_ttk} {
2755        $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2756        return
2757    }
2758
2759    set w [expr {[winfo width $progresscanv] - 4}]
2760    set x0 [expr {$w * [lindex $progresscoords 0]}]
2761    set x1 [expr {$w * [lindex $progresscoords 1]}]
2762    set h [winfo height $progresscanv]
2763    $progresscanv coords $progressitem $x0 0 $x1 $h
2764    $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2765    $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2766    set now [clock clicks -milliseconds]
2767    if {$now >= $lastprogupdate + 100} {
2768        set progupdatepending 0
2769        update
2770    } elseif {!$progupdatepending} {
2771        set progupdatepending 1
2772        after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2773    }
2774}
2775
2776proc doprogupdate {} {
2777    global lastprogupdate progupdatepending
2778
2779    if {$progupdatepending} {
2780        set progupdatepending 0
2781        set lastprogupdate [clock clicks -milliseconds]
2782        update
2783    }
2784}
2785
2786proc config_init_trace {name} {
2787    global config_variable_changed config_variable_original
2788
2789    upvar #0 $name var
2790    set config_variable_changed($name) 0
2791    set config_variable_original($name) $var
2792}
2793
2794proc config_variable_change_cb {name name2 op} {
2795    global config_variable_changed config_variable_original
2796
2797    upvar #0 $name var
2798    if {$op eq "write" &&
2799        (![info exists config_variable_original($name)] ||
2800         $config_variable_original($name) ne $var)} {
2801        set config_variable_changed($name) 1
2802    }
2803}
2804
2805proc savestuff {w} {
2806    global stuffsaved
2807    global config_file config_file_tmp
2808    global config_variables config_variable_changed
2809    global viewchanged
2810
2811    upvar #0 viewname current_viewname
2812    upvar #0 viewfiles current_viewfiles
2813    upvar #0 viewargs current_viewargs
2814    upvar #0 viewargscmd current_viewargscmd
2815    upvar #0 viewperm current_viewperm
2816    upvar #0 nextviewnum current_nextviewnum
2817    upvar #0 use_ttk current_use_ttk
2818
2819    if {$stuffsaved} return
2820    if {![winfo viewable .]} return
2821    if {[catch {
2822        if {[file exists $config_file_tmp]} {
2823            file delete -force $config_file_tmp
2824        }
2825        set f [open $config_file_tmp w]
2826        if {$::tcl_platform(platform) eq {windows}} {
2827            file attributes $config_file_tmp -hidden true
2828        }
2829        if {[file exists $config_file]} {
2830            source $config_file
2831        }
2832        foreach var_name $config_variables {
2833            upvar #0 $var_name var
2834            upvar 0 $var_name old_var
2835            if {!$config_variable_changed($var_name) && [info exists old_var]} {
2836                puts $f [list set $var_name $old_var]
2837            } else {
2838                puts $f [list set $var_name $var]
2839            }
2840        }
2841
2842        puts $f "set geometry(main) [wm geometry .]"
2843        puts $f "set geometry(state) [wm state .]"
2844        puts $f "set geometry(topwidth) [winfo width .tf]"
2845        puts $f "set geometry(topheight) [winfo height .tf]"
2846        if {$current_use_ttk} {
2847            puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2848            puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2849        } else {
2850            puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2851            puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2852        }
2853        puts $f "set geometry(botwidth) [winfo width .bleft]"
2854        puts $f "set geometry(botheight) [winfo height .bleft]"
2855
2856        array set view_save {}
2857        array set views {}
2858        if {![info exists permviews]} { set permviews {} }
2859        foreach view $permviews {
2860            set view_save([lindex $view 0]) 1
2861            set views([lindex $view 0]) $view
2862        }
2863        puts -nonewline $f "set permviews {"
2864        for {set v 1} {$v < $current_nextviewnum} {incr v} {
2865            if {$viewchanged($v)} {
2866                if {$current_viewperm($v)} {
2867                    set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2868                } else {
2869                    set view_save($current_viewname($v)) 0
2870                }
2871            }
2872        }
2873        # write old and updated view to their places and append remaining to the end
2874        foreach view $permviews {
2875            set view_name [lindex $view 0]
2876            if {$view_save($view_name)} {
2877                puts $f "{$views($view_name)}"
2878            }
2879            unset views($view_name)
2880        }
2881        foreach view_name [array names views] {
2882            puts $f "{$views($view_name)}"
2883        }
2884        puts $f "}"
2885        close $f
2886        file rename -force $config_file_tmp $config_file
2887    } err]} {
2888        puts "Error saving config: $err"
2889    }
2890    set stuffsaved 1
2891}
2892
2893proc resizeclistpanes {win w} {
2894    global oldwidth use_ttk
2895    if {[info exists oldwidth($win)]} {
2896        if {$use_ttk} {
2897            set s0 [$win sashpos 0]
2898            set s1 [$win sashpos 1]
2899        } else {
2900            set s0 [$win sash coord 0]
2901            set s1 [$win sash coord 1]
2902        }
2903        if {$w < 60} {
2904            set sash0 [expr {int($w/2 - 2)}]
2905            set sash1 [expr {int($w*5/6 - 2)}]
2906        } else {
2907            set factor [expr {1.0 * $w / $oldwidth($win)}]
2908            set sash0 [expr {int($factor * [lindex $s0 0])}]
2909            set sash1 [expr {int($factor * [lindex $s1 0])}]
2910            if {$sash0 < 30} {
2911                set sash0 30
2912            }
2913            if {$sash1 < $sash0 + 20} {
2914                set sash1 [expr {$sash0 + 20}]
2915            }
2916            if {$sash1 > $w - 10} {
2917                set sash1 [expr {$w - 10}]
2918                if {$sash0 > $sash1 - 20} {
2919                    set sash0 [expr {$sash1 - 20}]
2920                }
2921            }
2922        }
2923        if {$use_ttk} {
2924            $win sashpos 0 $sash0
2925            $win sashpos 1 $sash1
2926        } else {
2927            $win sash place 0 $sash0 [lindex $s0 1]
2928            $win sash place 1 $sash1 [lindex $s1 1]
2929        }
2930    }
2931    set oldwidth($win) $w
2932}
2933
2934proc resizecdetpanes {win w} {
2935    global oldwidth use_ttk
2936    if {[info exists oldwidth($win)]} {
2937        if {$use_ttk} {
2938            set s0 [$win sashpos 0]
2939        } else {
2940            set s0 [$win sash coord 0]
2941        }
2942        if {$w < 60} {
2943            set sash0 [expr {int($w*3/4 - 2)}]
2944        } else {
2945            set factor [expr {1.0 * $w / $oldwidth($win)}]
2946            set sash0 [expr {int($factor * [lindex $s0 0])}]
2947            if {$sash0 < 45} {
2948                set sash0 45
2949            }
2950            if {$sash0 > $w - 15} {
2951                set sash0 [expr {$w - 15}]
2952            }
2953        }
2954        if {$use_ttk} {
2955            $win sashpos 0 $sash0
2956        } else {
2957            $win sash place 0 $sash0 [lindex $s0 1]
2958        }
2959    }
2960    set oldwidth($win) $w
2961}
2962
2963proc allcanvs args {
2964    global canv canv2 canv3
2965    eval $canv $args
2966    eval $canv2 $args
2967    eval $canv3 $args
2968}
2969
2970proc bindall {event action} {
2971    global canv canv2 canv3
2972    bind $canv $event $action
2973    bind $canv2 $event $action
2974    bind $canv3 $event $action
2975}
2976
2977proc about {} {
2978    global uifont NS
2979    set w .about
2980    if {[winfo exists $w]} {
2981        raise $w
2982        return
2983    }
2984    ttk_toplevel $w
2985    wm title $w [mc "About gitk"]
2986    make_transient $w .
2987    message $w.m -text [mc "
2988Gitk - a commit viewer for git
2989
2990Copyright \u00a9 2005-2014 Paul Mackerras
2991
2992Use and redistribute under the terms of the GNU General Public License"] \
2993            -justify center -aspect 400 -border 2 -bg white -relief groove
2994    pack $w.m -side top -fill x -padx 2 -pady 2
2995    ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
2996    pack $w.ok -side bottom
2997    bind $w <Visibility> "focus $w.ok"
2998    bind $w <Key-Escape> "destroy $w"
2999    bind $w <Key-Return> "destroy $w"
3000    tk::PlaceWindow $w widget .
3001}
3002
3003proc keys {} {
3004    global NS
3005    set w .keys
3006    if {[winfo exists $w]} {
3007        raise $w
3008        return
3009    }
3010    if {[tk windowingsystem] eq {aqua}} {
3011        set M1T Cmd
3012    } else {
3013        set M1T Ctrl
3014    }
3015    ttk_toplevel $w
3016    wm title $w [mc "Gitk key bindings"]
3017    make_transient $w .
3018    message $w.m -text "
3019[mc "Gitk key bindings:"]
3020
3021[mc "<%s-Q>             Quit" $M1T]
3022[mc "<%s-W>             Close window" $M1T]
3023[mc "<Home>             Move to first commit"]
3024[mc "<End>              Move to last commit"]
3025[mc "<Up>, p, k Move up one commit"]
3026[mc "<Down>, n, j       Move down one commit"]
3027[mc "<Left>, z, h       Go back in history list"]
3028[mc "<Right>, x, l      Go forward in history list"]
3029[mc "<%s-n>     Go to n-th parent of current commit in history list" $M1T]
3030[mc "<PageUp>   Move up one page in commit list"]
3031[mc "<PageDown> Move down one page in commit list"]
3032[mc "<%s-Home>  Scroll to top of commit list" $M1T]
3033[mc "<%s-End>   Scroll to bottom of commit list" $M1T]
3034[mc "<%s-Up>    Scroll commit list up one line" $M1T]
3035[mc "<%s-Down>  Scroll commit list down one line" $M1T]
3036[mc "<%s-PageUp>        Scroll commit list up one page" $M1T]
3037[mc "<%s-PageDown>      Scroll commit list down one page" $M1T]
3038[mc "<Shift-Up> Find backwards (upwards, later commits)"]
3039[mc "<Shift-Down>       Find forwards (downwards, earlier commits)"]
3040[mc "<Delete>, b        Scroll diff view up one page"]
3041[mc "<Backspace>        Scroll diff view up one page"]
3042[mc "<Space>            Scroll diff view down one page"]
3043[mc "u          Scroll diff view up 18 lines"]
3044[mc "d          Scroll diff view down 18 lines"]
3045[mc "<%s-F>             Find" $M1T]
3046[mc "<%s-G>             Move to next find hit" $M1T]
3047[mc "<Return>   Move to next find hit"]
3048[mc "/          Focus the search box"]
3049[mc "?          Move to previous find hit"]
3050[mc "f          Scroll diff view to next file"]
3051[mc "<%s-S>             Search for next hit in diff view" $M1T]
3052[mc "<%s-R>             Search for previous hit in diff view" $M1T]
3053[mc "<%s-KP+>   Increase font size" $M1T]
3054[mc "<%s-plus>  Increase font size" $M1T]
3055[mc "<%s-KP->   Decrease font size" $M1T]
3056[mc "<%s-minus> Decrease font size" $M1T]
3057[mc "<F5>               Update"]
3058" \
3059            -justify left -bg white -border 2 -relief groove
3060    pack $w.m -side top -fill both -padx 2 -pady 2
3061    ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3062    bind $w <Key-Escape> [list destroy $w]
3063    pack $w.ok -side bottom
3064    bind $w <Visibility> "focus $w.ok"
3065    bind $w <Key-Escape> "destroy $w"
3066    bind $w <Key-Return> "destroy $w"
3067}
3068
3069# Procedures for manipulating the file list window at the
3070# bottom right of the overall window.
3071
3072proc treeview {w l openlevs} {
3073    global treecontents treediropen treeheight treeparent treeindex
3074
3075    set ix 0
3076    set treeindex() 0
3077    set lev 0
3078    set prefix {}
3079    set prefixend -1
3080    set prefendstack {}
3081    set htstack {}
3082    set ht 0
3083    set treecontents() {}
3084    $w conf -state normal
3085    foreach f $l {
3086        while {[string range $f 0 $prefixend] ne $prefix} {
3087            if {$lev <= $openlevs} {
3088                $w mark set e:$treeindex($prefix) "end -1c"
3089                $w mark gravity e:$treeindex($prefix) left
3090            }
3091            set treeheight($prefix) $ht
3092            incr ht [lindex $htstack end]
3093            set htstack [lreplace $htstack end end]
3094            set prefixend [lindex $prefendstack end]
3095            set prefendstack [lreplace $prefendstack end end]
3096            set prefix [string range $prefix 0 $prefixend]
3097            incr lev -1
3098        }
3099        set tail [string range $f [expr {$prefixend+1}] end]
3100        while {[set slash [string first "/" $tail]] >= 0} {
3101            lappend htstack $ht
3102            set ht 0
3103            lappend prefendstack $prefixend
3104            incr prefixend [expr {$slash + 1}]
3105            set d [string range $tail 0 $slash]
3106            lappend treecontents($prefix) $d
3107            set oldprefix $prefix
3108            append prefix $d
3109            set treecontents($prefix) {}
3110            set treeindex($prefix) [incr ix]
3111            set treeparent($prefix) $oldprefix
3112            set tail [string range $tail [expr {$slash+1}] end]
3113            if {$lev <= $openlevs} {
3114                set ht 1
3115                set treediropen($prefix) [expr {$lev < $openlevs}]
3116                set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3117                $w mark set d:$ix "end -1c"
3118                $w mark gravity d:$ix left
3119                set str "\n"
3120                for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3121                $w insert end $str
3122                $w image create end -align center -image $bm -padx 1 \
3123                    -name a:$ix
3124                $w insert end $d [highlight_tag $prefix]
3125                $w mark set s:$ix "end -1c"
3126                $w mark gravity s:$ix left
3127            }
3128            incr lev
3129        }
3130        if {$tail ne {}} {
3131            if {$lev <= $openlevs} {
3132                incr ht
3133                set str "\n"
3134                for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3135                $w insert end $str
3136                $w insert end $tail [highlight_tag $f]
3137            }
3138            lappend treecontents($prefix) $tail
3139        }
3140    }
3141    while {$htstack ne {}} {
3142        set treeheight($prefix) $ht
3143        incr ht [lindex $htstack end]
3144        set htstack [lreplace $htstack end end]
3145        set prefixend [lindex $prefendstack end]
3146        set prefendstack [lreplace $prefendstack end end]
3147        set prefix [string range $prefix 0 $prefixend]
3148    }
3149    $w conf -state disabled
3150}
3151
3152proc linetoelt {l} {
3153    global treeheight treecontents
3154
3155    set y 2
3156    set prefix {}
3157    while {1} {
3158        foreach e $treecontents($prefix) {
3159            if {$y == $l} {
3160                return "$prefix$e"
3161            }
3162            set n 1
3163            if {[string index $e end] eq "/"} {
3164                set n $treeheight($prefix$e)
3165                if {$y + $n > $l} {
3166                    append prefix $e
3167                    incr y
3168                    break
3169                }
3170            }
3171            incr y $n
3172        }
3173    }
3174}
3175
3176proc highlight_tree {y prefix} {
3177    global treeheight treecontents cflist
3178
3179    foreach e $treecontents($prefix) {
3180        set path $prefix$e
3181        if {[highlight_tag $path] ne {}} {
3182            $cflist tag add bold $y.0 "$y.0 lineend"
3183        }
3184        incr y
3185        if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3186            set y [highlight_tree $y $path]
3187        }
3188    }
3189    return $y
3190}
3191
3192proc treeclosedir {w dir} {
3193    global treediropen treeheight treeparent treeindex
3194
3195    set ix $treeindex($dir)
3196    $w conf -state normal
3197    $w delete s:$ix e:$ix
3198    set treediropen($dir) 0
3199    $w image configure a:$ix -image tri-rt
3200    $w conf -state disabled
3201    set n [expr {1 - $treeheight($dir)}]
3202    while {$dir ne {}} {
3203        incr treeheight($dir) $n
3204        set dir $treeparent($dir)
3205    }
3206}
3207
3208proc treeopendir {w dir} {
3209    global treediropen treeheight treeparent treecontents treeindex
3210
3211    set ix $treeindex($dir)
3212    $w conf -state normal
3213    $w image configure a:$ix -image tri-dn
3214    $w mark set e:$ix s:$ix
3215    $w mark gravity e:$ix right
3216    set lev 0
3217    set str "\n"
3218    set n [llength $treecontents($dir)]
3219    for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3220        incr lev
3221        append str "\t"
3222        incr treeheight($x) $n
3223    }
3224    foreach e $treecontents($dir) {
3225        set de $dir$e
3226        if {[string index $e end] eq "/"} {
3227            set iy $treeindex($de)
3228            $w mark set d:$iy e:$ix
3229            $w mark gravity d:$iy left
3230            $w insert e:$ix $str
3231            set treediropen($de) 0
3232            $w image create e:$ix -align center -image tri-rt -padx 1 \
3233                -name a:$iy
3234            $w insert e:$ix $e [highlight_tag $de]
3235            $w mark set s:$iy e:$ix
3236            $w mark gravity s:$iy left
3237            set treeheight($de) 1
3238        } else {
3239            $w insert e:$ix $str
3240            $w insert e:$ix $e [highlight_tag $de]
3241        }
3242    }
3243    $w mark gravity e:$ix right
3244    $w conf -state disabled
3245    set treediropen($dir) 1
3246    set top [lindex [split [$w index @0,0] .] 0]
3247    set ht [$w cget -height]
3248    set l [lindex [split [$w index s:$ix] .] 0]
3249    if {$l < $top} {
3250        $w yview $l.0
3251    } elseif {$l + $n + 1 > $top + $ht} {
3252        set top [expr {$l + $n + 2 - $ht}]
3253        if {$l < $top} {
3254            set top $l
3255        }
3256        $w yview $top.0
3257    }
3258}
3259
3260proc treeclick {w x y} {
3261    global treediropen cmitmode ctext cflist cflist_top
3262
3263    if {$cmitmode ne "tree"} return
3264    if {![info exists cflist_top]} return
3265    set l [lindex [split [$w index "@$x,$y"] "."] 0]
3266    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3267    $cflist tag add highlight $l.0 "$l.0 lineend"
3268    set cflist_top $l
3269    if {$l == 1} {
3270        $ctext yview 1.0
3271        return
3272    }
3273    set e [linetoelt $l]
3274    if {[string index $e end] ne "/"} {
3275        showfile $e
3276    } elseif {$treediropen($e)} {
3277        treeclosedir $w $e
3278    } else {
3279        treeopendir $w $e
3280    }
3281}
3282
3283proc setfilelist {id} {
3284    global treefilelist cflist jump_to_here
3285
3286    treeview $cflist $treefilelist($id) 0
3287    if {$jump_to_here ne {}} {
3288        set f [lindex $jump_to_here 0]
3289        if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3290            showfile $f
3291        }
3292    }
3293}
3294
3295image create bitmap tri-rt -background black -foreground blue -data {
3296    #define tri-rt_width 13
3297    #define tri-rt_height 13
3298    static unsigned char tri-rt_bits[] = {
3299       0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3300       0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3301       0x00, 0x00};
3302} -maskdata {
3303    #define tri-rt-mask_width 13
3304    #define tri-rt-mask_height 13
3305    static unsigned char tri-rt-mask_bits[] = {
3306       0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3307       0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3308       0x08, 0x00};
3309}
3310image create bitmap tri-dn -background black -foreground blue -data {
3311    #define tri-dn_width 13
3312    #define tri-dn_height 13
3313    static unsigned char tri-dn_bits[] = {
3314       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3315       0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3316       0x00, 0x00};
3317} -maskdata {
3318    #define tri-dn-mask_width 13
3319    #define tri-dn-mask_height 13
3320    static unsigned char tri-dn-mask_bits[] = {
3321       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3322       0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3323       0x00, 0x00};
3324}
3325
3326image create bitmap reficon-T -background black -foreground yellow -data {
3327    #define tagicon_width 13
3328    #define tagicon_height 9
3329    static unsigned char tagicon_bits[] = {
3330       0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3331       0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3332} -maskdata {
3333    #define tagicon-mask_width 13
3334    #define tagicon-mask_height 9
3335    static unsigned char tagicon-mask_bits[] = {
3336       0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3337       0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3338}
3339set rectdata {
3340    #define headicon_width 13
3341    #define headicon_height 9
3342    static unsigned char headicon_bits[] = {
3343       0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3344       0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3345}
3346set rectmask {
3347    #define headicon-mask_width 13
3348    #define headicon-mask_height 9
3349    static unsigned char headicon-mask_bits[] = {
3350       0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3351       0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3352}
3353image create bitmap reficon-H -background black -foreground green \
3354    -data $rectdata -maskdata $rectmask
3355image create bitmap reficon-o -background black -foreground "#ddddff" \
3356    -data $rectdata -maskdata $rectmask
3357
3358proc init_flist {first} {
3359    global cflist cflist_top difffilestart
3360
3361    $cflist conf -state normal
3362    $cflist delete 0.0 end
3363    if {$first ne {}} {
3364        $cflist insert end $first
3365        set cflist_top 1
3366        $cflist tag add highlight 1.0 "1.0 lineend"
3367    } else {
3368        catch {unset cflist_top}
3369    }
3370    $cflist conf -state disabled
3371    set difffilestart {}
3372}
3373
3374proc highlight_tag {f} {
3375    global highlight_paths
3376
3377    foreach p $highlight_paths {
3378        if {[string match $p $f]} {
3379            return "bold"
3380        }
3381    }
3382    return {}
3383}
3384
3385proc highlight_filelist {} {
3386    global cmitmode cflist
3387
3388    $cflist conf -state normal
3389    if {$cmitmode ne "tree"} {
3390        set end [lindex [split [$cflist index end] .] 0]
3391        for {set l 2} {$l < $end} {incr l} {
3392            set line [$cflist get $l.0 "$l.0 lineend"]
3393            if {[highlight_tag $line] ne {}} {
3394                $cflist tag add bold $l.0 "$l.0 lineend"
3395            }
3396        }
3397    } else {
3398        highlight_tree 2 {}
3399    }
3400    $cflist conf -state disabled
3401}
3402
3403proc unhighlight_filelist {} {
3404    global cflist
3405
3406    $cflist conf -state normal
3407    $cflist tag remove bold 1.0 end
3408    $cflist conf -state disabled
3409}
3410
3411proc add_flist {fl} {
3412    global cflist
3413
3414    $cflist conf -state normal
3415    foreach f $fl {
3416        $cflist insert end "\n"
3417        $cflist insert end $f [highlight_tag $f]
3418    }
3419    $cflist conf -state disabled
3420}
3421
3422proc sel_flist {w x y} {
3423    global ctext difffilestart cflist cflist_top cmitmode
3424
3425    if {$cmitmode eq "tree"} return
3426    if {![info exists cflist_top]} return
3427    set l [lindex [split [$w index "@$x,$y"] "."] 0]
3428    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3429    $cflist tag add highlight $l.0 "$l.0 lineend"
3430    set cflist_top $l
3431    if {$l == 1} {
3432        $ctext yview 1.0
3433    } else {
3434        catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3435    }
3436    suppress_highlighting_file_for_current_scrollpos
3437}
3438
3439proc pop_flist_menu {w X Y x y} {
3440    global ctext cflist cmitmode flist_menu flist_menu_file
3441    global treediffs diffids
3442
3443    stopfinding
3444    set l [lindex [split [$w index "@$x,$y"] "."] 0]
3445    if {$l <= 1} return
3446    if {$cmitmode eq "tree"} {
3447        set e [linetoelt $l]
3448        if {[string index $e end] eq "/"} return
3449    } else {
3450        set e [lindex $treediffs($diffids) [expr {$l-2}]]
3451    }
3452    set flist_menu_file $e
3453    set xdiffstate "normal"
3454    if {$cmitmode eq "tree"} {
3455        set xdiffstate "disabled"
3456    }
3457    # Disable "External diff" item in tree mode
3458    $flist_menu entryconf 2 -state $xdiffstate
3459    tk_popup $flist_menu $X $Y
3460}
3461
3462proc find_ctext_fileinfo {line} {
3463    global ctext_file_names ctext_file_lines
3464
3465    set ok [bsearch $ctext_file_lines $line]
3466    set tline [lindex $ctext_file_lines $ok]
3467
3468    if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3469        return {}
3470    } else {
3471        return [list [lindex $ctext_file_names $ok] $tline]
3472    }
3473}
3474
3475proc pop_diff_menu {w X Y x y} {
3476    global ctext diff_menu flist_menu_file
3477    global diff_menu_txtpos diff_menu_line
3478    global diff_menu_filebase
3479
3480    set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3481    set diff_menu_line [lindex $diff_menu_txtpos 0]
3482    # don't pop up the menu on hunk-separator or file-separator lines
3483    if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3484        return
3485    }
3486    stopfinding
3487    set f [find_ctext_fileinfo $diff_menu_line]
3488    if {$f eq {}} return
3489    set flist_menu_file [lindex $f 0]
3490    set diff_menu_filebase [lindex $f 1]
3491    tk_popup $diff_menu $X $Y
3492}
3493
3494proc flist_hl {only} {
3495    global flist_menu_file findstring gdttype
3496
3497    set x [shellquote $flist_menu_file]
3498    if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3499        set findstring $x
3500    } else {
3501        append findstring " " $x
3502    }
3503    set gdttype [mc "touching paths:"]
3504}
3505
3506proc gitknewtmpdir {} {
3507    global diffnum gitktmpdir gitdir env
3508
3509    if {![info exists gitktmpdir]} {
3510        if {[info exists env(GITK_TMPDIR)]} {
3511            set tmpdir $env(GITK_TMPDIR)
3512        } elseif {[info exists env(TMPDIR)]} {
3513            set tmpdir $env(TMPDIR)
3514        } else {
3515            set tmpdir $gitdir
3516        }
3517        set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3518        if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3519            set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3520        }
3521        if {[catch {file mkdir $gitktmpdir} err]} {
3522            error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3523            unset gitktmpdir
3524            return {}
3525        }
3526        set diffnum 0
3527    }
3528    incr diffnum
3529    set diffdir [file join $gitktmpdir $diffnum]
3530    if {[catch {file mkdir $diffdir} err]} {
3531        error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3532        return {}
3533    }
3534    return $diffdir
3535}
3536
3537proc save_file_from_commit {filename output what} {
3538    global nullfile
3539
3540    if {[catch {exec git show $filename -- > $output} err]} {
3541        if {[string match "fatal: bad revision *" $err]} {
3542            return $nullfile
3543        }
3544        error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3545        return {}
3546    }
3547    return $output
3548}
3549
3550proc external_diff_get_one_file {diffid filename diffdir} {
3551    global nullid nullid2 nullfile
3552    global worktree
3553
3554    if {$diffid == $nullid} {
3555        set difffile [file join $worktree $filename]
3556        if {[file exists $difffile]} {
3557            return $difffile
3558        }
3559        return $nullfile
3560    }
3561    if {$diffid == $nullid2} {
3562        set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3563        return [save_file_from_commit :$filename $difffile index]
3564    }
3565    set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3566    return [save_file_from_commit $diffid:$filename $difffile \
3567               "revision $diffid"]
3568}
3569
3570proc external_diff {} {
3571    global nullid nullid2
3572    global flist_menu_file
3573    global diffids
3574    global extdifftool
3575
3576    if {[llength $diffids] == 1} {
3577        # no reference commit given
3578        set diffidto [lindex $diffids 0]
3579        if {$diffidto eq $nullid} {
3580            # diffing working copy with index
3581            set diffidfrom $nullid2
3582        } elseif {$diffidto eq $nullid2} {
3583            # diffing index with HEAD
3584            set diffidfrom "HEAD"
3585        } else {
3586            # use first parent commit
3587            global parentlist selectedline
3588            set diffidfrom [lindex $parentlist $selectedline 0]
3589        }
3590    } else {
3591        set diffidfrom [lindex $diffids 0]
3592        set diffidto [lindex $diffids 1]
3593    }
3594
3595    # make sure that several diffs wont collide
3596    set diffdir [gitknewtmpdir]
3597    if {$diffdir eq {}} return
3598
3599    # gather files to diff
3600    set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3601    set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3602
3603    if {$difffromfile ne {} && $difftofile ne {}} {
3604        set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3605        if {[catch {set fl [open |$cmd r]} err]} {
3606            file delete -force $diffdir
3607            error_popup "$extdifftool: [mc "command failed:"] $err"
3608        } else {
3609            fconfigure $fl -blocking 0
3610            filerun $fl [list delete_at_eof $fl $diffdir]
3611        }
3612    }
3613}
3614
3615proc find_hunk_blamespec {base line} {
3616    global ctext
3617
3618    # Find and parse the hunk header
3619    set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3620    if {$s_lix eq {}} return
3621
3622    set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3623    if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3624            s_line old_specs osz osz1 new_line nsz]} {
3625        return
3626    }
3627
3628    # base lines for the parents
3629    set base_lines [list $new_line]
3630    foreach old_spec [lrange [split $old_specs " "] 1 end] {
3631        if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3632                old_spec old_line osz]} {
3633            return
3634        }
3635        lappend base_lines $old_line
3636    }
3637
3638    # Now scan the lines to determine offset within the hunk
3639    set max_parent [expr {[llength $base_lines]-2}]
3640    set dline 0
3641    set s_lno [lindex [split $s_lix "."] 0]
3642
3643    # Determine if the line is removed
3644    set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3645    if {[string match {[-+ ]*} $chunk]} {
3646        set removed_idx [string first "-" $chunk]
3647        # Choose a parent index
3648        if {$removed_idx >= 0} {
3649            set parent $removed_idx
3650        } else {
3651            set unchanged_idx [string first " " $chunk]
3652            if {$unchanged_idx >= 0} {
3653                set parent $unchanged_idx
3654            } else {
3655                # blame the current commit
3656                set parent -1
3657            }
3658        }
3659        # then count other lines that belong to it
3660        for {set i $line} {[incr i -1] > $s_lno} {} {
3661            set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3662            # Determine if the line is removed
3663            set removed_idx [string first "-" $chunk]
3664            if {$parent >= 0} {
3665                set code [string index $chunk $parent]
3666                if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3667                    incr dline
3668                }
3669            } else {
3670                if {$removed_idx < 0} {
3671                    incr dline
3672                }
3673            }
3674        }
3675        incr parent
3676    } else {
3677        set parent 0
3678    }
3679
3680    incr dline [lindex $base_lines $parent]
3681    return [list $parent $dline]
3682}
3683
3684proc external_blame_diff {} {
3685    global currentid cmitmode
3686    global diff_menu_txtpos diff_menu_line
3687    global diff_menu_filebase flist_menu_file
3688
3689    if {$cmitmode eq "tree"} {
3690        set parent_idx 0
3691        set line [expr {$diff_menu_line - $diff_menu_filebase}]
3692    } else {
3693        set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3694        if {$hinfo ne {}} {
3695            set parent_idx [lindex $hinfo 0]
3696            set line [lindex $hinfo 1]
3697        } else {
3698            set parent_idx 0
3699            set line 0
3700        }
3701    }
3702
3703    external_blame $parent_idx $line
3704}
3705
3706# Find the SHA1 ID of the blob for file $fname in the index
3707# at stage 0 or 2
3708proc index_sha1 {fname} {
3709    set f [open [list | git ls-files -s $fname] r]
3710    while {[gets $f line] >= 0} {
3711        set info [lindex [split $line "\t"] 0]
3712        set stage [lindex $info 2]
3713        if {$stage eq "0" || $stage eq "2"} {
3714            close $f
3715            return [lindex $info 1]
3716        }
3717    }
3718    close $f
3719    return {}
3720}
3721
3722# Turn an absolute path into one relative to the current directory
3723proc make_relative {f} {
3724    if {[file pathtype $f] eq "relative"} {
3725        return $f
3726    }
3727    set elts [file split $f]
3728    set here [file split [pwd]]
3729    set ei 0
3730    set hi 0
3731    set res {}
3732    foreach d $here {
3733        if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3734            lappend res ".."
3735        } else {
3736            incr ei
3737        }
3738        incr hi
3739    }
3740    set elts [concat $res [lrange $elts $ei end]]
3741    return [eval file join $elts]
3742}
3743
3744proc external_blame {parent_idx {line {}}} {
3745    global flist_menu_file cdup
3746    global nullid nullid2
3747    global parentlist selectedline currentid
3748
3749    if {$parent_idx > 0} {
3750        set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3751    } else {
3752        set base_commit $currentid
3753    }
3754
3755    if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3756        error_popup [mc "No such commit"]
3757        return
3758    }
3759
3760    set cmdline [list git gui blame]
3761    if {$line ne {} && $line > 1} {
3762        lappend cmdline "--line=$line"
3763    }
3764    set f [file join $cdup $flist_menu_file]
3765    # Unfortunately it seems git gui blame doesn't like
3766    # being given an absolute path...
3767    set f [make_relative $f]
3768    lappend cmdline $base_commit $f
3769    if {[catch {eval exec $cmdline &} err]} {
3770        error_popup "[mc "git gui blame: command failed:"] $err"
3771    }
3772}
3773
3774proc show_line_source {} {
3775    global cmitmode currentid parents curview blamestuff blameinst
3776    global diff_menu_line diff_menu_filebase flist_menu_file
3777    global nullid nullid2 gitdir cdup
3778
3779    set from_index {}
3780    if {$cmitmode eq "tree"} {
3781        set id $currentid
3782        set line [expr {$diff_menu_line - $diff_menu_filebase}]
3783    } else {
3784        set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3785        if {$h eq {}} return
3786        set pi [lindex $h 0]
3787        if {$pi == 0} {
3788            mark_ctext_line $diff_menu_line
3789            return
3790        }
3791        incr pi -1
3792        if {$currentid eq $nullid} {
3793            if {$pi > 0} {
3794                # must be a merge in progress...
3795                if {[catch {
3796                    # get the last line from .git/MERGE_HEAD
3797                    set f [open [file join $gitdir MERGE_HEAD] r]
3798                    set id [lindex [split [read $f] "\n"] end-1]
3799                    close $f
3800                } err]} {
3801                    error_popup [mc "Couldn't read merge head: %s" $err]
3802                    return
3803                }
3804            } elseif {$parents($curview,$currentid) eq $nullid2} {
3805                # need to do the blame from the index
3806                if {[catch {
3807                    set from_index [index_sha1 $flist_menu_file]
3808                } err]} {
3809                    error_popup [mc "Error reading index: %s" $err]
3810                    return
3811                }
3812            } else {
3813                set id $parents($curview,$currentid)
3814            }
3815        } else {
3816            set id [lindex $parents($curview,$currentid) $pi]
3817        }
3818        set line [lindex $h 1]
3819    }
3820    set blameargs {}
3821    if {$from_index ne {}} {
3822        lappend blameargs | git cat-file blob $from_index
3823    }
3824    lappend blameargs | git blame -p -L$line,+1
3825    if {$from_index ne {}} {
3826        lappend blameargs --contents -
3827    } else {
3828        lappend blameargs $id
3829    }
3830    lappend blameargs -- [file join $cdup $flist_menu_file]
3831    if {[catch {
3832        set f [open $blameargs r]
3833    } err]} {
3834        error_popup [mc "Couldn't start git blame: %s" $err]
3835        return
3836    }
3837    nowbusy blaming [mc "Searching"]
3838    fconfigure $f -blocking 0
3839    set i [reg_instance $f]
3840    set blamestuff($i) {}
3841    set blameinst $i
3842    filerun $f [list read_line_source $f $i]
3843}
3844
3845proc stopblaming {} {
3846    global blameinst
3847
3848    if {[info exists blameinst]} {
3849        stop_instance $blameinst
3850        unset blameinst
3851        notbusy blaming
3852    }
3853}
3854
3855proc read_line_source {fd inst} {
3856    global blamestuff curview commfd blameinst nullid nullid2
3857
3858    while {[gets $fd line] >= 0} {
3859        lappend blamestuff($inst) $line
3860    }
3861    if {![eof $fd]} {
3862        return 1
3863    }
3864    unset commfd($inst)
3865    unset blameinst
3866    notbusy blaming
3867    fconfigure $fd -blocking 1
3868    if {[catch {close $fd} err]} {
3869        error_popup [mc "Error running git blame: %s" $err]
3870        return 0
3871    }
3872
3873    set fname {}
3874    set line [split [lindex $blamestuff($inst) 0] " "]
3875    set id [lindex $line 0]
3876    set lnum [lindex $line 1]
3877    if {[string length $id] == 40 && [string is xdigit $id] &&
3878        [string is digit -strict $lnum]} {
3879        # look for "filename" line
3880        foreach l $blamestuff($inst) {
3881            if {[string match "filename *" $l]} {
3882                set fname [string range $l 9 end]
3883                break
3884            }
3885        }
3886    }
3887    if {$fname ne {}} {
3888        # all looks good, select it
3889        if {$id eq $nullid} {
3890            # blame uses all-zeroes to mean not committed,
3891            # which would mean a change in the index
3892            set id $nullid2
3893        }
3894        if {[commitinview $id $curview]} {
3895            selectline [rowofcommit $id] 1 [list $fname $lnum] 1
3896        } else {
3897            error_popup [mc "That line comes from commit %s, \
3898                             which is not in this view" [shortids $id]]
3899        }
3900    } else {
3901        puts "oops couldn't parse git blame output"
3902    }
3903    return 0
3904}
3905
3906# delete $dir when we see eof on $f (presumably because the child has exited)
3907proc delete_at_eof {f dir} {
3908    while {[gets $f line] >= 0} {}
3909    if {[eof $f]} {
3910        if {[catch {close $f} err]} {
3911            error_popup "[mc "External diff viewer failed:"] $err"
3912        }
3913        file delete -force $dir
3914        return 0
3915    }
3916    return 1
3917}
3918
3919# Functions for adding and removing shell-type quoting
3920
3921proc shellquote {str} {
3922    if {![string match "*\['\"\\ \t]*" $str]} {
3923        return $str
3924    }
3925    if {![string match "*\['\"\\]*" $str]} {
3926        return "\"$str\""
3927    }
3928    if {![string match "*'*" $str]} {
3929        return "'$str'"
3930    }
3931    return "\"[string map {\" \\\" \\ \\\\} $str]\""
3932}
3933
3934proc shellarglist {l} {
3935    set str {}
3936    foreach a $l {
3937        if {$str ne {}} {
3938            append str " "
3939        }
3940        append str [shellquote $a]
3941    }
3942    return $str
3943}
3944
3945proc shelldequote {str} {
3946    set ret {}
3947    set used -1
3948    while {1} {
3949        incr used
3950        if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
3951            append ret [string range $str $used end]
3952            set used [string length $str]
3953            break
3954        }
3955        set first [lindex $first 0]
3956        set ch [string index $str $first]
3957        if {$first > $used} {
3958            append ret [string range $str $used [expr {$first - 1}]]
3959            set used $first
3960        }
3961        if {$ch eq " " || $ch eq "\t"} break
3962        incr used
3963        if {$ch eq "'"} {
3964            set first [string first "'" $str $used]
3965            if {$first < 0} {
3966                error "unmatched single-quote"
3967            }
3968            append ret [string range $str $used [expr {$first - 1}]]
3969            set used $first
3970            continue
3971        }
3972        if {$ch eq "\\"} {
3973            if {$used >= [string length $str]} {
3974                error "trailing backslash"
3975            }
3976            append ret [string index $str $used]
3977            continue
3978        }
3979        # here ch == "\""
3980        while {1} {
3981            if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
3982                error "unmatched double-quote"
3983            }
3984            set first [lindex $first 0]
3985            set ch [string index $str $first]
3986            if {$first > $used} {
3987                append ret [string range $str $used [expr {$first - 1}]]
3988                set used $first
3989            }
3990            if {$ch eq "\""} break
3991            incr used
3992            append ret [string index $str $used]
3993            incr used
3994        }
3995    }
3996    return [list $used $ret]
3997}
3998
3999proc shellsplit {str} {
4000    set l {}
4001    while {1} {
4002        set str [string trimleft $str]
4003        if {$str eq {}} break
4004        set dq [shelldequote $str]
4005        set n [lindex $dq 0]
4006        set word [lindex $dq 1]
4007        set str [string range $str $n end]
4008        lappend l $word
4009    }
4010    return $l
4011}
4012
4013# Code to implement multiple views
4014
4015proc newview {ishighlight} {
4016    global nextviewnum newviewname newishighlight
4017    global revtreeargs viewargscmd newviewopts curview
4018
4019    set newishighlight $ishighlight
4020    set top .gitkview
4021    if {[winfo exists $top]} {
4022        raise $top
4023        return
4024    }
4025    decode_view_opts $nextviewnum $revtreeargs
4026    set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4027    set newviewopts($nextviewnum,perm) 0
4028    set newviewopts($nextviewnum,cmd)  $viewargscmd($curview)
4029    vieweditor $top $nextviewnum [mc "Gitk view definition"]
4030}
4031
4032set known_view_options {
4033    {perm      b    .  {}               {mc "Remember this view"}}
4034    {reflabel  l    +  {}               {mc "References (space separated list):"}}
4035    {refs      t15  .. {}               {mc "Branches & tags:"}}
4036    {allrefs   b    *. "--all"          {mc "All refs"}}
4037    {branches  b    .  "--branches"     {mc "All (local) branches"}}
4038    {tags      b    .  "--tags"         {mc "All tags"}}
4039    {remotes   b    .  "--remotes"      {mc "All remote-tracking branches"}}
4040    {commitlbl l    +  {}               {mc "Commit Info (regular expressions):"}}
4041    {author    t15  .. "--author=*"     {mc "Author:"}}
4042    {committer t15  .  "--committer=*"  {mc "Committer:"}}
4043    {loginfo   t15  .. "--grep=*"       {mc "Commit Message:"}}
4044    {allmatch  b    .. "--all-match"    {mc "Matches all Commit Info criteria"}}
4045    {changes_l l    +  {}               {mc "Changes to Files:"}}
4046    {pickaxe_s r0   .  {}               {mc "Fixed String"}}
4047    {pickaxe_t r1   .  "--pickaxe-regex"  {mc "Regular Expression"}}
4048    {pickaxe   t15  .. "-S*"            {mc "Search string:"}}
4049    {datelabel l    +  {}               {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4050    {since     t15  ..  {"--since=*" "--after=*"}  {mc "Since:"}}
4051    {until     t15  .   {"--until=*" "--before=*"} {mc "Until:"}}
4052    {limit_lbl l    +  {}               {mc "Limit and/or skip a number of revisions (positive integer):"}}
4053    {limit     t10  *. "--max-count=*"  {mc "Number to show:"}}
4054    {skip      t10  .  "--skip=*"       {mc "Number to skip:"}}
4055    {misc_lbl  l    +  {}               {mc "Miscellaneous options:"}}
4056    {dorder    b    *. {"--date-order" "-d"}      {mc "Strictly sort by date"}}
4057    {lright    b    .  "--left-right"   {mc "Mark branch sides"}}
4058    {first     b    .  "--first-parent" {mc "Limit to first parent"}}
4059    {smplhst   b    .  "--simplify-by-decoration"   {mc "Simple history"}}
4060    {args      t50  *. {}               {mc "Additional arguments to git log:"}}
4061    {allpaths  path +  {}               {mc "Enter files and directories to include, one per line:"}}
4062    {cmd       t50= +  {}               {mc "Command to generate more commits to include:"}}
4063    }
4064
4065# Convert $newviewopts($n, ...) into args for git log.
4066proc encode_view_opts {n} {
4067    global known_view_options newviewopts
4068
4069    set rargs [list]
4070    foreach opt $known_view_options {
4071        set patterns [lindex $opt 3]
4072        if {$patterns eq {}} continue
4073        set pattern [lindex $patterns 0]
4074
4075        if {[lindex $opt 1] eq "b"} {
4076            set val $newviewopts($n,[lindex $opt 0])
4077            if {$val} {
4078                lappend rargs $pattern
4079            }
4080        } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4081            regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4082            set val $newviewopts($n,$button_id)
4083            if {$val eq $value} {
4084                lappend rargs $pattern
4085            }
4086        } else {
4087            set val $newviewopts($n,[lindex $opt 0])
4088            set val [string trim $val]
4089            if {$val ne {}} {
4090                set pfix [string range $pattern 0 end-1]
4091                lappend rargs $pfix$val
4092            }
4093        }
4094    }
4095    set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4096    return [concat $rargs [shellsplit $newviewopts($n,args)]]
4097}
4098
4099# Fill $newviewopts($n, ...) based on args for git log.
4100proc decode_view_opts {n view_args} {
4101    global known_view_options newviewopts
4102
4103    foreach opt $known_view_options {
4104        set id [lindex $opt 0]
4105        if {[lindex $opt 1] eq "b"} {
4106            # Checkboxes
4107            set val 0
4108        } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4109            # Radiobuttons
4110            regexp {^(.*_)} $id uselessvar id
4111            set val 0
4112        } else {
4113            # Text fields
4114            set val {}
4115        }
4116        set newviewopts($n,$id) $val
4117    }
4118    set oargs [list]
4119    set refargs [list]
4120    foreach arg $view_args {
4121        if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4122            && ![info exists found(limit)]} {
4123            set newviewopts($n,limit) $cnt
4124            set found(limit) 1
4125            continue
4126        }
4127        catch { unset val }
4128        foreach opt $known_view_options {
4129            set id [lindex $opt 0]
4130            if {[info exists found($id)]} continue
4131            foreach pattern [lindex $opt 3] {
4132                if {![string match $pattern $arg]} continue
4133                if {[lindex $opt 1] eq "b"} {
4134                    # Check buttons
4135                    set val 1
4136                } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4137                    # Radio buttons
4138                    regexp {^(.*_)} $id uselessvar id
4139                    set val $num
4140                } else {
4141                    # Text input fields
4142                    set size [string length $pattern]
4143                    set val [string range $arg [expr {$size-1}] end]
4144                }
4145                set newviewopts($n,$id) $val
4146                set found($id) 1
4147                break
4148            }
4149            if {[info exists val]} break
4150        }
4151        if {[info exists val]} continue
4152        if {[regexp {^-} $arg]} {
4153            lappend oargs $arg
4154        } else {
4155            lappend refargs $arg
4156        }
4157    }
4158    set newviewopts($n,refs) [shellarglist $refargs]
4159    set newviewopts($n,args) [shellarglist $oargs]
4160}
4161
4162proc edit_or_newview {} {
4163    global curview
4164
4165    if {$curview > 0} {
4166        editview
4167    } else {
4168        newview 0
4169    }
4170}
4171
4172proc editview {} {
4173    global curview
4174    global viewname viewperm newviewname newviewopts
4175    global viewargs viewargscmd
4176
4177    set top .gitkvedit-$curview
4178    if {[winfo exists $top]} {
4179        raise $top
4180        return
4181    }
4182    decode_view_opts $curview $viewargs($curview)
4183    set newviewname($curview)      $viewname($curview)
4184    set newviewopts($curview,perm) $viewperm($curview)
4185    set newviewopts($curview,cmd)  $viewargscmd($curview)
4186    vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4187}
4188
4189proc vieweditor {top n title} {
4190    global newviewname newviewopts viewfiles bgcolor
4191    global known_view_options NS
4192
4193    ttk_toplevel $top
4194    wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4195    make_transient $top .
4196
4197    # View name
4198    ${NS}::frame $top.nfr
4199    ${NS}::label $top.nl -text [mc "View Name"]
4200    ${NS}::entry $top.name -width 20 -textvariable newviewname($n)
4201    pack $top.nfr -in $top -fill x -pady 5 -padx 3
4202    pack $top.nl -in $top.nfr -side left -padx {0 5}
4203    pack $top.name -in $top.nfr -side left -padx {0 25}
4204
4205    # View options
4206    set cframe $top.nfr
4207    set cexpand 0
4208    set cnt 0
4209    foreach opt $known_view_options {
4210        set id [lindex $opt 0]
4211        set type [lindex $opt 1]
4212        set flags [lindex $opt 2]
4213        set title [eval [lindex $opt 4]]
4214        set lxpad 0
4215
4216        if {$flags eq "+" || $flags eq "*"} {
4217            set cframe $top.fr$cnt
4218            incr cnt
4219            ${NS}::frame $cframe
4220            pack $cframe -in $top -fill x -pady 3 -padx 3
4221            set cexpand [expr {$flags eq "*"}]
4222        } elseif {$flags eq ".." || $flags eq "*."} {
4223            set cframe $top.fr$cnt
4224            incr cnt
4225            ${NS}::frame $cframe
4226            pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4227            set cexpand [expr {$flags eq "*."}]
4228        } else {
4229            set lxpad 5
4230        }
4231
4232        if {$type eq "l"} {
4233            ${NS}::label $cframe.l_$id -text $title
4234            pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4235        } elseif {$type eq "b"} {
4236            ${NS}::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4237            pack $cframe.c_$id -in $cframe -side left \
4238                -padx [list $lxpad 0] -expand $cexpand -anchor w
4239        } elseif {[regexp {^r(\d+)$} $type type sz]} {
4240            regexp {^(.*_)} $id uselessvar button_id
4241            ${NS}::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4242            pack $cframe.c_$id -in $cframe -side left \
4243                -padx [list $lxpad 0] -expand $cexpand -anchor w
4244        } elseif {[regexp {^t(\d+)$} $type type sz]} {
4245            ${NS}::label $cframe.l_$id -text $title
4246            ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4247                -textvariable newviewopts($n,$id)
4248            pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4249            pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4250        } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4251            ${NS}::label $cframe.l_$id -text $title
4252            ${NS}::entry $cframe.e_$id -width $sz -background $bgcolor \
4253                -textvariable newviewopts($n,$id)
4254            pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4255            pack $cframe.e_$id -in $cframe -side top -fill x
4256        } elseif {$type eq "path"} {
4257            ${NS}::label $top.l -text $title
4258            pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4259            text $top.t -width 40 -height 5 -background $bgcolor
4260            if {[info exists viewfiles($n)]} {
4261                foreach f $viewfiles($n) {
4262                    $top.t insert end $f
4263                    $top.t insert end "\n"
4264                }
4265                $top.t delete {end - 1c} end
4266                $top.t mark set insert 0.0
4267            }
4268            pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4269        }
4270    }
4271
4272    ${NS}::frame $top.buts
4273    ${NS}::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4274    ${NS}::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4275    ${NS}::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4276    bind $top <Control-Return> [list newviewok $top $n]
4277    bind $top <F5> [list newviewok $top $n 1]
4278    bind $top <Escape> [list destroy $top]
4279    grid $top.buts.ok $top.buts.apply $top.buts.can
4280    grid columnconfigure $top.buts 0 -weight 1 -uniform a
4281    grid columnconfigure $top.buts 1 -weight 1 -uniform a
4282    grid columnconfigure $top.buts 2 -weight 1 -uniform a
4283    pack $top.buts -in $top -side top -fill x
4284    focus $top.t
4285}
4286
4287proc doviewmenu {m first cmd op argv} {
4288    set nmenu [$m index end]
4289    for {set i $first} {$i <= $nmenu} {incr i} {
4290        if {[$m entrycget $i -command] eq $cmd} {
4291            eval $m $op $i $argv
4292            break
4293        }
4294    }
4295}
4296
4297proc allviewmenus {n op args} {
4298    # global viewhlmenu
4299
4300    doviewmenu .bar.view 5 [list showview $n] $op $args
4301    # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4302}
4303
4304proc newviewok {top n {apply 0}} {
4305    global nextviewnum newviewperm newviewname newishighlight
4306    global viewname viewfiles viewperm viewchanged selectedview curview
4307    global viewargs viewargscmd newviewopts viewhlmenu
4308
4309    if {[catch {
4310        set newargs [encode_view_opts $n]
4311    } err]} {
4312        error_popup "[mc "Error in commit selection arguments:"] $err" $top
4313        return
4314    }
4315    set files {}
4316    foreach f [split [$top.t get 0.0 end] "\n"] {
4317        set ft [string trim $f]
4318        if {$ft ne {}} {
4319            lappend files $ft
4320        }
4321    }
4322    if {![info exists viewfiles($n)]} {
4323        # creating a new view
4324        incr nextviewnum
4325        set viewname($n) $newviewname($n)
4326        set viewperm($n) $newviewopts($n,perm)
4327        set viewchanged($n) 1
4328        set viewfiles($n) $files
4329        set viewargs($n) $newargs
4330        set viewargscmd($n) $newviewopts($n,cmd)
4331        addviewmenu $n
4332        if {!$newishighlight} {
4333            run showview $n
4334        } else {
4335            run addvhighlight $n
4336        }
4337    } else {
4338        # editing an existing view
4339        set viewperm($n) $newviewopts($n,perm)
4340        set viewchanged($n) 1
4341        if {$newviewname($n) ne $viewname($n)} {
4342            set viewname($n) $newviewname($n)
4343            doviewmenu .bar.view 5 [list showview $n] \
4344                entryconf [list -label $viewname($n)]
4345            # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4346                # entryconf [list -label $viewname($n) -value $viewname($n)]
4347        }
4348        if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4349                $newviewopts($n,cmd) ne $viewargscmd($n)} {
4350            set viewfiles($n) $files
4351            set viewargs($n) $newargs
4352            set viewargscmd($n) $newviewopts($n,cmd)
4353            if {$curview == $n} {
4354                run reloadcommits
4355            }
4356        }
4357    }
4358    if {$apply} return
4359    catch {destroy $top}
4360}
4361
4362proc delview {} {
4363    global curview viewperm hlview selectedhlview viewchanged
4364
4365    if {$curview == 0} return
4366    if {[info exists hlview] && $hlview == $curview} {
4367        set selectedhlview [mc "None"]
4368        unset hlview
4369    }
4370    allviewmenus $curview delete
4371    set viewperm($curview) 0
4372    set viewchanged($curview) 1
4373    showview 0
4374}
4375
4376proc addviewmenu {n} {
4377    global viewname viewhlmenu
4378
4379    .bar.view add radiobutton -label $viewname($n) \
4380        -command [list showview $n] -variable selectedview -value $n
4381    #$viewhlmenu add radiobutton -label $viewname($n) \
4382    #   -command [list addvhighlight $n] -variable selectedhlview
4383}
4384
4385proc showview {n} {
4386    global curview cached_commitrow ordertok
4387    global displayorder parentlist rowidlist rowisopt rowfinal
4388    global colormap rowtextx nextcolor canvxmax
4389    global numcommits viewcomplete
4390    global selectedline currentid canv canvy0
4391    global treediffs
4392    global pending_select mainheadid
4393    global commitidx
4394    global selectedview
4395    global hlview selectedhlview commitinterest
4396
4397    if {$n == $curview} return
4398    set selid {}
4399    set ymax [lindex [$canv cget -scrollregion] 3]
4400    set span [$canv yview]
4401    set ytop [expr {[lindex $span 0] * $ymax}]
4402    set ybot [expr {[lindex $span 1] * $ymax}]
4403    set yscreen [expr {($ybot - $ytop) / 2}]
4404    if {$selectedline ne {}} {
4405        set selid $currentid
4406        set y [yc $selectedline]
4407        if {$ytop < $y && $y < $ybot} {
4408            set yscreen [expr {$y - $ytop}]
4409        }
4410    } elseif {[info exists pending_select]} {
4411        set selid $pending_select
4412        unset pending_select
4413    }
4414    unselectline
4415    normalline
4416    catch {unset treediffs}
4417    clear_display
4418    if {[info exists hlview] && $hlview == $n} {
4419        unset hlview
4420        set selectedhlview [mc "None"]
4421    }
4422    catch {unset commitinterest}
4423    catch {unset cached_commitrow}
4424    catch {unset ordertok}
4425
4426    set curview $n
4427    set selectedview $n
4428    .bar.view entryconf [mca "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4429    .bar.view entryconf [mca "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4430
4431    run refill_reflist
4432    if {![info exists viewcomplete($n)]} {
4433        getcommits $selid
4434        return
4435    }
4436
4437    set displayorder {}
4438    set parentlist {}
4439    set rowidlist {}
4440    set rowisopt {}
4441    set rowfinal {}
4442    set numcommits $commitidx($n)
4443
4444    catch {unset colormap}
4445    catch {unset rowtextx}
4446    set nextcolor 0
4447    set canvxmax [$canv cget -width]
4448    set curview $n
4449    set row 0
4450    setcanvscroll
4451    set yf 0
4452    set row {}
4453    if {$selid ne {} && [commitinview $selid $n]} {
4454        set row [rowofcommit $selid]
4455        # try to get the selected row in the same position on the screen
4456        set ymax [lindex [$canv cget -scrollregion] 3]
4457        set ytop [expr {[yc $row] - $yscreen}]
4458        if {$ytop < 0} {
4459            set ytop 0
4460        }
4461        set yf [expr {$ytop * 1.0 / $ymax}]
4462    }
4463    allcanvs yview moveto $yf
4464    drawvisible
4465    if {$row ne {}} {
4466        selectline $row 0
4467    } elseif {!$viewcomplete($n)} {
4468        reset_pending_select $selid
4469    } else {
4470        reset_pending_select {}
4471
4472        if {[commitinview $pending_select $curview]} {
4473            selectline [rowofcommit $pending_select] 1
4474        } else {
4475            set row [first_real_row]
4476            if {$row < $numcommits} {
4477                selectline $row 0
4478            }
4479        }
4480    }
4481    if {!$viewcomplete($n)} {
4482        if {$numcommits == 0} {
4483            show_status [mc "Reading commits..."]
4484        }
4485    } elseif {$numcommits == 0} {
4486        show_status [mc "No commits selected"]
4487    }
4488}
4489
4490# Stuff relating to the highlighting facility
4491
4492proc ishighlighted {id} {
4493    global vhighlights fhighlights nhighlights rhighlights
4494
4495    if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4496        return $nhighlights($id)
4497    }
4498    if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4499        return $vhighlights($id)
4500    }
4501    if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4502        return $fhighlights($id)
4503    }
4504    if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4505        return $rhighlights($id)
4506    }
4507    return 0
4508}
4509
4510proc bolden {id font} {
4511    global canv linehtag currentid boldids need_redisplay markedid
4512
4513    # need_redisplay = 1 means the display is stale and about to be redrawn
4514    if {$need_redisplay} return
4515    lappend boldids $id
4516    $canv itemconf $linehtag($id) -font $font
4517    if {[info exists currentid] && $id eq $currentid} {
4518        $canv delete secsel
4519        set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4520                   -outline {{}} -tags secsel \
4521                   -fill [$canv cget -selectbackground]]
4522        $canv lower $t
4523    }
4524    if {[info exists markedid] && $id eq $markedid} {
4525        make_idmark $id
4526    }
4527}
4528
4529proc bolden_name {id font} {
4530    global canv2 linentag currentid boldnameids need_redisplay
4531
4532    if {$need_redisplay} return
4533    lappend boldnameids $id
4534    $canv2 itemconf $linentag($id) -font $font
4535    if {[info exists currentid] && $id eq $currentid} {
4536        $canv2 delete secsel
4537        set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4538                   -outline {{}} -tags secsel \
4539                   -fill [$canv2 cget -selectbackground]]
4540        $canv2 lower $t
4541    }
4542}
4543
4544proc unbolden {} {
4545    global boldids
4546
4547    set stillbold {}
4548    foreach id $boldids {
4549        if {![ishighlighted $id]} {
4550            bolden $id mainfont
4551        } else {
4552            lappend stillbold $id
4553        }
4554    }
4555    set boldids $stillbold
4556}
4557
4558proc addvhighlight {n} {
4559    global hlview viewcomplete curview vhl_done commitidx
4560
4561    if {[info exists hlview]} {
4562        delvhighlight
4563    }
4564    set hlview $n
4565    if {$n != $curview && ![info exists viewcomplete($n)]} {
4566        start_rev_list $n
4567    }
4568    set vhl_done $commitidx($hlview)
4569    if {$vhl_done > 0} {
4570        drawvisible
4571    }
4572}
4573
4574proc delvhighlight {} {
4575    global hlview vhighlights
4576
4577    if {![info exists hlview]} return
4578    unset hlview
4579    catch {unset vhighlights}
4580    unbolden
4581}
4582
4583proc vhighlightmore {} {
4584    global hlview vhl_done commitidx vhighlights curview
4585
4586    set max $commitidx($hlview)
4587    set vr [visiblerows]
4588    set r0 [lindex $vr 0]
4589    set r1 [lindex $vr 1]
4590    for {set i $vhl_done} {$i < $max} {incr i} {
4591        set id [commitonrow $i $hlview]
4592        if {[commitinview $id $curview]} {
4593            set row [rowofcommit $id]
4594            if {$r0 <= $row && $row <= $r1} {
4595                if {![highlighted $row]} {
4596                    bolden $id mainfontbold
4597                }
4598                set vhighlights($id) 1
4599            }
4600        }
4601    }
4602    set vhl_done $max
4603    return 0
4604}
4605
4606proc askvhighlight {row id} {
4607    global hlview vhighlights iddrawn
4608
4609    if {[commitinview $id $hlview]} {
4610        if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4611            bolden $id mainfontbold
4612        }
4613        set vhighlights($id) 1
4614    } else {
4615        set vhighlights($id) 0
4616    }
4617}
4618
4619proc hfiles_change {} {
4620    global highlight_files filehighlight fhighlights fh_serial
4621    global highlight_paths
4622
4623    if {[info exists filehighlight]} {
4624        # delete previous highlights
4625        catch {close $filehighlight}
4626        unset filehighlight
4627        catch {unset fhighlights}
4628        unbolden
4629        unhighlight_filelist
4630    }
4631    set highlight_paths {}
4632    after cancel do_file_hl $fh_serial
4633    incr fh_serial
4634    if {$highlight_files ne {}} {
4635        after 300 do_file_hl $fh_serial
4636    }
4637}
4638
4639proc gdttype_change {name ix op} {
4640    global gdttype highlight_files findstring findpattern
4641
4642    stopfinding
4643    if {$findstring ne {}} {
4644        if {$gdttype eq [mc "containing:"]} {
4645            if {$highlight_files ne {}} {
4646                set highlight_files {}
4647                hfiles_change
4648            }
4649            findcom_change
4650        } else {
4651            if {$findpattern ne {}} {
4652                set findpattern {}
4653                findcom_change
4654            }
4655            set highlight_files $findstring
4656            hfiles_change
4657        }
4658        drawvisible
4659    }
4660    # enable/disable findtype/findloc menus too
4661}
4662
4663proc find_change {name ix op} {
4664    global gdttype findstring highlight_files
4665
4666    stopfinding
4667    if {$gdttype eq [mc "containing:"]} {
4668        findcom_change
4669    } else {
4670        if {$highlight_files ne $findstring} {
4671            set highlight_files $findstring
4672            hfiles_change
4673        }
4674    }
4675    drawvisible
4676}
4677
4678proc findcom_change args {
4679    global nhighlights boldnameids
4680    global findpattern findtype findstring gdttype
4681
4682    stopfinding
4683    # delete previous highlights, if any
4684    foreach id $boldnameids {
4685        bolden_name $id mainfont
4686    }
4687    set boldnameids {}
4688    catch {unset nhighlights}
4689    unbolden
4690    unmarkmatches
4691    if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4692        set findpattern {}
4693    } elseif {$findtype eq [mc "Regexp"]} {
4694        set findpattern $findstring
4695    } else {
4696        set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4697                   $findstring]
4698        set findpattern "*$e*"
4699    }
4700}
4701
4702proc makepatterns {l} {
4703    set ret {}
4704    foreach e $l {
4705        set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4706        if {[string index $ee end] eq "/"} {
4707            lappend ret "$ee*"
4708        } else {
4709            lappend ret $ee
4710            lappend ret "$ee/*"
4711        }
4712    }
4713    return $ret
4714}
4715
4716proc do_file_hl {serial} {
4717    global highlight_files filehighlight highlight_paths gdttype fhl_list
4718    global cdup findtype
4719
4720    if {$gdttype eq [mc "touching paths:"]} {
4721        # If "exact" match then convert backslashes to forward slashes.
4722        # Most useful to support Windows-flavoured file paths.
4723        if {$findtype eq [mc "Exact"]} {
4724            set highlight_files [string map {"\\" "/"} $highlight_files]
4725        }
4726        if {[catch {set paths [shellsplit $highlight_files]}]} return
4727        set highlight_paths [makepatterns $paths]
4728        highlight_filelist
4729        set relative_paths {}
4730        foreach path $paths {
4731            lappend relative_paths [file join $cdup $path]
4732        }
4733        set gdtargs [concat -- $relative_paths]
4734    } elseif {$gdttype eq [mc "adding/removing string:"]} {
4735        set gdtargs [list "-S$highlight_files"]
4736    } elseif {$gdttype eq [mc "changing lines matching:"]} {
4737        set gdtargs [list "-G$highlight_files"]
4738    } else {
4739        # must be "containing:", i.e. we're searching commit info
4740        return
4741    }
4742    set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
4743    set filehighlight [open $cmd r+]
4744    fconfigure $filehighlight -blocking 0
4745    filerun $filehighlight readfhighlight
4746    set fhl_list {}
4747    drawvisible
4748    flushhighlights
4749}
4750
4751proc flushhighlights {} {
4752    global filehighlight fhl_list
4753
4754    if {[info exists filehighlight]} {
4755        lappend fhl_list {}
4756        puts $filehighlight ""
4757        flush $filehighlight
4758    }
4759}
4760
4761proc askfilehighlight {row id} {
4762    global filehighlight fhighlights fhl_list
4763
4764    lappend fhl_list $id
4765    set fhighlights($id) -1
4766    puts $filehighlight $id
4767}
4768
4769proc readfhighlight {} {
4770    global filehighlight fhighlights curview iddrawn
4771    global fhl_list find_dirn
4772
4773    if {![info exists filehighlight]} {
4774        return 0
4775    }
4776    set nr 0
4777    while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
4778        set line [string trim $line]
4779        set i [lsearch -exact $fhl_list $line]
4780        if {$i < 0} continue
4781        for {set j 0} {$j < $i} {incr j} {
4782            set id [lindex $fhl_list $j]
4783            set fhighlights($id) 0
4784        }
4785        set fhl_list [lrange $fhl_list [expr {$i+1}] end]
4786        if {$line eq {}} continue
4787        if {![commitinview $line $curview]} continue
4788        if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
4789            bolden $line mainfontbold
4790        }
4791        set fhighlights($line) 1
4792    }
4793    if {[eof $filehighlight]} {
4794        # strange...
4795        puts "oops, git diff-tree died"
4796        catch {close $filehighlight}
4797        unset filehighlight
4798        return 0
4799    }
4800    if {[info exists find_dirn]} {
4801        run findmore
4802    }
4803    return 1
4804}
4805
4806proc doesmatch {f} {
4807    global findtype findpattern
4808
4809    if {$findtype eq [mc "Regexp"]} {
4810        return [regexp $findpattern $f]
4811    } elseif {$findtype eq [mc "IgnCase"]} {
4812        return [string match -nocase $findpattern $f]
4813    } else {
4814        return [string match $findpattern $f]
4815    }
4816}
4817
4818proc askfindhighlight {row id} {
4819    global nhighlights commitinfo iddrawn
4820    global findloc
4821    global markingmatches
4822
4823    if {![info exists commitinfo($id)]} {
4824        getcommit $id
4825    }
4826    set info $commitinfo($id)
4827    set isbold 0
4828    set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
4829    foreach f $info ty $fldtypes {
4830        if {$ty eq ""} continue
4831        if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4832            [doesmatch $f]} {
4833            if {$ty eq [mc "Author"]} {
4834                set isbold 2
4835                break
4836            }
4837            set isbold 1
4838        }
4839    }
4840    if {$isbold && [info exists iddrawn($id)]} {
4841        if {![ishighlighted $id]} {
4842            bolden $id mainfontbold
4843            if {$isbold > 1} {
4844                bolden_name $id mainfontbold
4845            }
4846        }
4847        if {$markingmatches} {
4848            markrowmatches $row $id
4849        }
4850    }
4851    set nhighlights($id) $isbold
4852}
4853
4854proc markrowmatches {row id} {
4855    global canv canv2 linehtag linentag commitinfo findloc
4856
4857    set headline [lindex $commitinfo($id) 0]
4858    set author [lindex $commitinfo($id) 1]
4859    $canv delete match$row
4860    $canv2 delete match$row
4861    if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
4862        set m [findmatches $headline]
4863        if {$m ne {}} {
4864            markmatches $canv $row $headline $linehtag($id) $m \
4865                [$canv itemcget $linehtag($id) -font] $row
4866        }
4867    }
4868    if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
4869        set m [findmatches $author]
4870        if {$m ne {}} {
4871            markmatches $canv2 $row $author $linentag($id) $m \
4872                [$canv2 itemcget $linentag($id) -font] $row
4873        }
4874    }
4875}
4876
4877proc vrel_change {name ix op} {
4878    global highlight_related
4879
4880    rhighlight_none
4881    if {$highlight_related ne [mc "None"]} {
4882        run drawvisible
4883    }
4884}
4885
4886# prepare for testing whether commits are descendents or ancestors of a
4887proc rhighlight_sel {a} {
4888    global descendent desc_todo ancestor anc_todo
4889    global highlight_related
4890
4891    catch {unset descendent}
4892    set desc_todo [list $a]
4893    catch {unset ancestor}
4894    set anc_todo [list $a]
4895    if {$highlight_related ne [mc "None"]} {
4896        rhighlight_none
4897        run drawvisible
4898    }
4899}
4900
4901proc rhighlight_none {} {
4902    global rhighlights
4903
4904    catch {unset rhighlights}
4905    unbolden
4906}
4907
4908proc is_descendent {a} {
4909    global curview children descendent desc_todo
4910
4911    set v $curview
4912    set la [rowofcommit $a]
4913    set todo $desc_todo
4914    set leftover {}
4915    set done 0
4916    for {set i 0} {$i < [llength $todo]} {incr i} {
4917        set do [lindex $todo $i]
4918        if {[rowofcommit $do] < $la} {
4919            lappend leftover $do
4920            continue
4921        }
4922        foreach nk $children($v,$do) {
4923            if {![info exists descendent($nk)]} {
4924                set descendent($nk) 1
4925                lappend todo $nk
4926                if {$nk eq $a} {
4927                    set done 1
4928                }
4929            }
4930        }
4931        if {$done} {
4932            set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4933            return
4934        }
4935    }
4936    set descendent($a) 0
4937    set desc_todo $leftover
4938}
4939
4940proc is_ancestor {a} {
4941    global curview parents ancestor anc_todo
4942
4943    set v $curview
4944    set la [rowofcommit $a]
4945    set todo $anc_todo
4946    set leftover {}
4947    set done 0
4948    for {set i 0} {$i < [llength $todo]} {incr i} {
4949        set do [lindex $todo $i]
4950        if {![commitinview $do $v] || [rowofcommit $do] > $la} {
4951            lappend leftover $do
4952            continue
4953        }
4954        foreach np $parents($v,$do) {
4955            if {![info exists ancestor($np)]} {
4956                set ancestor($np) 1
4957                lappend todo $np
4958                if {$np eq $a} {
4959                    set done 1
4960                }
4961            }
4962        }
4963        if {$done} {
4964            set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
4965            return
4966        }
4967    }
4968    set ancestor($a) 0
4969    set anc_todo $leftover
4970}
4971
4972proc askrelhighlight {row id} {
4973    global descendent highlight_related iddrawn rhighlights
4974    global selectedline ancestor
4975
4976    if {$selectedline eq {}} return
4977    set isbold 0
4978    if {$highlight_related eq [mc "Descendant"] ||
4979        $highlight_related eq [mc "Not descendant"]} {
4980        if {![info exists descendent($id)]} {
4981            is_descendent $id
4982        }
4983        if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
4984            set isbold 1
4985        }
4986    } elseif {$highlight_related eq [mc "Ancestor"] ||
4987              $highlight_related eq [mc "Not ancestor"]} {
4988        if {![info exists ancestor($id)]} {
4989            is_ancestor $id
4990        }
4991        if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
4992            set isbold 1
4993        }
4994    }
4995    if {[info exists iddrawn($id)]} {
4996        if {$isbold && ![ishighlighted $id]} {
4997            bolden $id mainfontbold
4998        }
4999    }
5000    set rhighlights($id) $isbold
5001}
5002
5003# Graph layout functions
5004
5005proc shortids {ids} {
5006    set res {}
5007    foreach id $ids {
5008        if {[llength $id] > 1} {
5009            lappend res [shortids $id]
5010        } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
5011            lappend res [string range $id 0 7]
5012        } else {
5013            lappend res $id
5014        }
5015    }
5016    return $res
5017}
5018
5019proc ntimes {n o} {
5020    set ret {}
5021    set o [list $o]
5022    for {set mask 1} {$mask <= $n} {incr mask $mask} {
5023        if {($n & $mask) != 0} {
5024            set ret [concat $ret $o]
5025        }
5026        set o [concat $o $o]
5027    }
5028    return $ret
5029}
5030
5031proc ordertoken {id} {
5032    global ordertok curview varcid varcstart varctok curview parents children
5033    global nullid nullid2
5034
5035    if {[info exists ordertok($id)]} {
5036        return $ordertok($id)
5037    }
5038    set origid $id
5039    set todo {}
5040    while {1} {
5041        if {[info exists varcid($curview,$id)]} {
5042            set a $varcid($curview,$id)
5043            set p [lindex $varcstart($curview) $a]
5044        } else {
5045            set p [lindex $children($curview,$id) 0]
5046        }
5047        if {[info exists ordertok($p)]} {
5048            set tok $ordertok($p)
5049            break
5050        }
5051        set id [first_real_child $curview,$p]
5052        if {$id eq {}} {
5053            # it's a root
5054            set tok [lindex $varctok($curview) $varcid($curview,$p)]
5055            break
5056        }
5057        if {[llength $parents($curview,$id)] == 1} {
5058            lappend todo [list $p {}]
5059        } else {
5060            set j [lsearch -exact $parents($curview,$id) $p]
5061            if {$j < 0} {
5062                puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5063            }
5064            lappend todo [list $p [strrep $j]]
5065        }
5066    }
5067    for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5068        set p [lindex $todo $i 0]
5069        append tok [lindex $todo $i 1]
5070        set ordertok($p) $tok
5071    }
5072    set ordertok($origid) $tok
5073    return $tok
5074}
5075
5076# Work out where id should go in idlist so that order-token
5077# values increase from left to right
5078proc idcol {idlist id {i 0}} {
5079    set t [ordertoken $id]
5080    if {$i < 0} {
5081        set i 0
5082    }
5083    if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5084        if {$i > [llength $idlist]} {
5085            set i [llength $idlist]
5086        }
5087        while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5088        incr i
5089    } else {
5090        if {$t > [ordertoken [lindex $idlist $i]]} {
5091            while {[incr i] < [llength $idlist] &&
5092                   $t >= [ordertoken [lindex $idlist $i]]} {}
5093        }
5094    }
5095    return $i
5096}
5097
5098proc initlayout {} {
5099    global rowidlist rowisopt rowfinal displayorder parentlist
5100    global numcommits canvxmax canv
5101    global nextcolor
5102    global colormap rowtextx
5103
5104    set numcommits 0
5105    set displayorder {}
5106    set parentlist {}
5107    set nextcolor 0
5108    set rowidlist {}
5109    set rowisopt {}
5110    set rowfinal {}
5111    set canvxmax [$canv cget -width]
5112    catch {unset colormap}
5113    catch {unset rowtextx}
5114    setcanvscroll
5115}
5116
5117proc setcanvscroll {} {
5118    global canv canv2 canv3 numcommits linespc canvxmax canvy0
5119    global lastscrollset lastscrollrows
5120
5121    set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5122    $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5123    $canv2 conf -scrollregion [list 0 0 0 $ymax]
5124    $canv3 conf -scrollregion [list 0 0 0 $ymax]
5125    set lastscrollset [clock clicks -milliseconds]
5126    set lastscrollrows $numcommits
5127}
5128
5129proc visiblerows {} {
5130    global canv numcommits linespc
5131
5132    set ymax [lindex [$canv cget -scrollregion] 3]
5133    if {$ymax eq {} || $ymax == 0} return
5134    set f [$canv yview]
5135    set y0 [expr {int([lindex $f 0] * $ymax)}]
5136    set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5137    if {$r0 < 0} {
5138        set r0 0
5139    }
5140    set y1 [expr {int([lindex $f 1] * $ymax)}]
5141    set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5142    if {$r1 >= $numcommits} {
5143        set r1 [expr {$numcommits - 1}]
5144    }
5145    return [list $r0 $r1]
5146}
5147
5148proc layoutmore {} {
5149    global commitidx viewcomplete curview
5150    global numcommits pending_select curview
5151    global lastscrollset lastscrollrows
5152
5153    if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5154        [clock clicks -milliseconds] - $lastscrollset > 500} {
5155        setcanvscroll
5156    }
5157    if {[info exists pending_select] &&
5158        [commitinview $pending_select $curview]} {
5159        update
5160        selectline [rowofcommit $pending_select] 1
5161    }
5162    drawvisible
5163}
5164
5165# With path limiting, we mightn't get the actual HEAD commit,
5166# so ask git rev-list what is the first ancestor of HEAD that
5167# touches a file in the path limit.
5168proc get_viewmainhead {view} {
5169    global viewmainheadid vfilelimit viewinstances mainheadid
5170
5171    catch {
5172        set rfd [open [concat | git rev-list -1 $mainheadid \
5173                           -- $vfilelimit($view)] r]
5174        set j [reg_instance $rfd]
5175        lappend viewinstances($view) $j
5176        fconfigure $rfd -blocking 0
5177        filerun $rfd [list getviewhead $rfd $j $view]
5178        set viewmainheadid($curview) {}
5179    }
5180}
5181
5182# git rev-list should give us just 1 line to use as viewmainheadid($view)
5183proc getviewhead {fd inst view} {
5184    global viewmainheadid commfd curview viewinstances showlocalchanges
5185
5186    set id {}
5187    if {[gets $fd line] < 0} {
5188        if {![eof $fd]} {
5189            return 1
5190        }
5191    } elseif {[string length $line] == 40 && [string is xdigit $line]} {
5192        set id $line
5193    }
5194    set viewmainheadid($view) $id
5195    close $fd
5196    unset commfd($inst)
5197    set i [lsearch -exact $viewinstances($view) $inst]
5198    if {$i >= 0} {
5199        set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5200    }
5201    if {$showlocalchanges && $id ne {} && $view == $curview} {
5202        doshowlocalchanges
5203    }
5204    return 0
5205}
5206
5207proc doshowlocalchanges {} {
5208    global curview viewmainheadid
5209
5210    if {$viewmainheadid($curview) eq {}} return
5211    if {[commitinview $viewmainheadid($curview) $curview]} {
5212        dodiffindex
5213    } else {
5214        interestedin $viewmainheadid($curview) dodiffindex
5215    }
5216}
5217
5218proc dohidelocalchanges {} {
5219    global nullid nullid2 lserial curview
5220
5221    if {[commitinview $nullid $curview]} {
5222        removefakerow $nullid
5223    }
5224    if {[commitinview $nullid2 $curview]} {
5225        removefakerow $nullid2
5226    }
5227    incr lserial
5228}
5229
5230# spawn off a process to do git diff-index --cached HEAD
5231proc dodiffindex {} {
5232    global lserial showlocalchanges vfilelimit curview
5233    global hasworktree git_version
5234
5235    if {!$showlocalchanges || !$hasworktree} return
5236    incr lserial
5237    if {[package vcompare $git_version "1.7.2"] >= 0} {
5238        set cmd "|git diff-index --cached --ignore-submodules=dirty HEAD"
5239    } else {
5240        set cmd "|git diff-index --cached HEAD"
5241    }
5242    if {$vfilelimit($curview) ne {}} {
5243        set cmd [concat $cmd -- $vfilelimit($curview)]
5244    }
5245    set fd [open $cmd r]
5246    fconfigure $fd -blocking 0
5247    set i [reg_instance $fd]
5248    filerun $fd [list readdiffindex $fd $lserial $i]
5249}
5250
5251proc readdiffindex {fd serial inst} {
5252    global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5253    global vfilelimit
5254
5255    set isdiff 1
5256    if {[gets $fd line] < 0} {
5257        if {![eof $fd]} {
5258            return 1
5259        }
5260        set isdiff 0
5261    }
5262    # we only need to see one line and we don't really care what it says...
5263    stop_instance $inst
5264
5265    if {$serial != $lserial} {
5266        return 0
5267    }
5268
5269    # now see if there are any local changes not checked in to the index
5270    set cmd "|git diff-files"
5271    if {$vfilelimit($curview) ne {}} {
5272        set cmd [concat $cmd -- $vfilelimit($curview)]
5273    }
5274    set fd [open $cmd r]
5275    fconfigure $fd -blocking 0
5276    set i [reg_instance $fd]
5277    filerun $fd [list readdifffiles $fd $serial $i]
5278
5279    if {$isdiff && ![commitinview $nullid2 $curview]} {
5280        # add the line for the changes in the index to the graph
5281        set hl [mc "Local changes checked in to index but not committed"]
5282        set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
5283        set commitdata($nullid2) "\n    $hl\n"
5284        if {[commitinview $nullid $curview]} {
5285            removefakerow $nullid
5286        }
5287        insertfakerow $nullid2 $viewmainheadid($curview)
5288    } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5289        if {[commitinview $nullid $curview]} {
5290            removefakerow $nullid
5291        }
5292        removefakerow $nullid2
5293    }
5294    return 0
5295}
5296
5297proc readdifffiles {fd serial inst} {
5298    global viewmainheadid nullid nullid2 curview
5299    global commitinfo commitdata lserial
5300
5301    set isdiff 1
5302    if {[gets $fd line] < 0} {
5303        if {![eof $fd]} {
5304            return 1
5305        }
5306        set isdiff 0
5307    }
5308    # we only need to see one line and we don't really care what it says...
5309    stop_instance $inst
5310
5311    if {$serial != $lserial} {
5312        return 0
5313    }
5314
5315    if {$isdiff && ![commitinview $nullid $curview]} {
5316        # add the line for the local diff to the graph
5317        set hl [mc "Local uncommitted changes, not checked in to index"]
5318        set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
5319        set commitdata($nullid) "\n    $hl\n"
5320        if {[commitinview $nullid2 $curview]} {
5321            set p $nullid2
5322        } else {
5323            set p $viewmainheadid($curview)
5324        }
5325        insertfakerow $nullid $p
5326    } elseif {!$isdiff && [commitinview $nullid $curview]} {
5327        removefakerow $nullid
5328    }
5329    return 0
5330}
5331
5332proc nextuse {id row} {
5333    global curview children
5334
5335    if {[info exists children($curview,$id)]} {
5336        foreach kid $children($curview,$id) {
5337            if {![commitinview $kid $curview]} {
5338                return -1
5339            }
5340            if {[rowofcommit $kid] > $row} {
5341                return [rowofcommit $kid]
5342            }
5343        }
5344    }
5345    if {[commitinview $id $curview]} {
5346        return [rowofcommit $id]
5347    }
5348    return -1
5349}
5350
5351proc prevuse {id row} {
5352    global curview children
5353
5354    set ret -1
5355    if {[info exists children($curview,$id)]} {
5356        foreach kid $children($curview,$id) {
5357            if {![commitinview $kid $curview]} break
5358            if {[rowofcommit $kid] < $row} {
5359                set ret [rowofcommit $kid]
5360            }
5361        }
5362    }
5363    return $ret
5364}
5365
5366proc make_idlist {row} {
5367    global displayorder parentlist uparrowlen downarrowlen mingaplen
5368    global commitidx curview children
5369
5370    set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5371    if {$r < 0} {
5372        set r 0
5373    }
5374    set ra [expr {$row - $downarrowlen}]
5375    if {$ra < 0} {
5376        set ra 0
5377    }
5378    set rb [expr {$row + $uparrowlen}]
5379    if {$rb > $commitidx($curview)} {
5380        set rb $commitidx($curview)
5381    }
5382    make_disporder $r [expr {$rb + 1}]
5383    set ids {}
5384    for {} {$r < $ra} {incr r} {
5385        set nextid [lindex $displayorder [expr {$r + 1}]]
5386        foreach p [lindex $parentlist $r] {
5387            if {$p eq $nextid} continue
5388            set rn [nextuse $p $r]
5389            if {$rn >= $row &&
5390                $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5391                lappend ids [list [ordertoken $p] $p]
5392            }
5393        }
5394    }
5395    for {} {$r < $row} {incr r} {
5396        set nextid [lindex $displayorder [expr {$r + 1}]]
5397        foreach p [lindex $parentlist $r] {
5398            if {$p eq $nextid} continue
5399            set rn [nextuse $p $r]
5400            if {$rn < 0 || $rn >= $row} {
5401                lappend ids [list [ordertoken $p] $p]
5402            }
5403        }
5404    }
5405    set id [lindex $displayorder $row]
5406    lappend ids [list [ordertoken $id] $id]
5407    while {$r < $rb} {
5408        foreach p [lindex $parentlist $r] {
5409            set firstkid [lindex $children($curview,$p) 0]
5410            if {[rowofcommit $firstkid] < $row} {
5411                lappend ids [list [ordertoken $p] $p]
5412            }
5413        }
5414        incr r
5415        set id [lindex $displayorder $r]
5416        if {$id ne {}} {
5417            set firstkid [lindex $children($curview,$id) 0]
5418            if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5419                lappend ids [list [ordertoken $id] $id]
5420            }
5421        }
5422    }
5423    set idlist {}
5424    foreach idx [lsort -unique $ids] {
5425        lappend idlist [lindex $idx 1]
5426    }
5427    return $idlist
5428}
5429
5430proc rowsequal {a b} {
5431    while {[set i [lsearch -exact $a {}]] >= 0} {
5432        set a [lreplace $a $i $i]
5433    }
5434    while {[set i [lsearch -exact $b {}]] >= 0} {
5435        set b [lreplace $b $i $i]
5436    }
5437    return [expr {$a eq $b}]
5438}
5439
5440proc makeupline {id row rend col} {
5441    global rowidlist uparrowlen downarrowlen mingaplen
5442
5443    for {set r $rend} {1} {set r $rstart} {
5444        set rstart [prevuse $id $r]
5445        if {$rstart < 0} return
5446        if {$rstart < $row} break
5447    }
5448    if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5449        set rstart [expr {$rend - $uparrowlen - 1}]
5450    }
5451    for {set r $rstart} {[incr r] <= $row} {} {
5452        set idlist [lindex $rowidlist $r]
5453        if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5454            set col [idcol $idlist $id $col]
5455            lset rowidlist $r [linsert $idlist $col $id]
5456            changedrow $r
5457        }
5458    }
5459}
5460
5461proc layoutrows {row endrow} {
5462    global rowidlist rowisopt rowfinal displayorder
5463    global uparrowlen downarrowlen maxwidth mingaplen
5464    global children parentlist
5465    global commitidx viewcomplete curview
5466
5467    make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5468    set idlist {}
5469    if {$row > 0} {
5470        set rm1 [expr {$row - 1}]
5471        foreach id [lindex $rowidlist $rm1] {
5472            if {$id ne {}} {
5473                lappend idlist $id
5474            }
5475        }
5476        set final [lindex $rowfinal $rm1]
5477    }
5478    for {} {$row < $endrow} {incr row} {
5479        set rm1 [expr {$row - 1}]
5480        if {$rm1 < 0 || $idlist eq {}} {
5481            set idlist [make_idlist $row]
5482            set final 1
5483        } else {
5484            set id [lindex $displayorder $rm1]
5485            set col [lsearch -exact $idlist $id]
5486            set idlist [lreplace $idlist $col $col]
5487            foreach p [lindex $parentlist $rm1] {
5488                if {[lsearch -exact $idlist $p] < 0} {
5489                    set col [idcol $idlist $p $col]
5490                    set idlist [linsert $idlist $col $p]
5491                    # if not the first child, we have to insert a line going up
5492                    if {$id ne [lindex $children($curview,$p) 0]} {
5493                        makeupline $p $rm1 $row $col
5494                    }
5495                }
5496            }
5497            set id [lindex $displayorder $row]
5498            if {$row > $downarrowlen} {
5499                set termrow [expr {$row - $downarrowlen - 1}]
5500                foreach p [lindex $parentlist $termrow] {
5501                    set i [lsearch -exact $idlist $p]
5502                    if {$i < 0} continue
5503                    set nr [nextuse $p $termrow]
5504                    if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5505                        set idlist [lreplace $idlist $i $i]
5506                    }
5507                }
5508            }
5509            set col [lsearch -exact $idlist $id]
5510            if {$col < 0} {
5511                set col [idcol $idlist $id]
5512                set idlist [linsert $idlist $col $id]
5513                if {$children($curview,$id) ne {}} {
5514                    makeupline $id $rm1 $row $col
5515                }
5516            }
5517            set r [expr {$row + $uparrowlen - 1}]
5518            if {$r < $commitidx($curview)} {
5519                set x $col
5520                foreach p [lindex $parentlist $r] {
5521                    if {[lsearch -exact $idlist $p] >= 0} continue
5522                    set fk [lindex $children($curview,$p) 0]
5523                    if {[rowofcommit $fk] < $row} {
5524                        set x [idcol $idlist $p $x]
5525                        set idlist [linsert $idlist $x $p]
5526                    }
5527                }
5528                if {[incr r] < $commitidx($curview)} {
5529                    set p [lindex $displayorder $r]
5530                    if {[lsearch -exact $idlist $p] < 0} {
5531                        set fk [lindex $children($curview,$p) 0]
5532                        if {$fk ne {} && [rowofcommit $fk] < $row} {
5533                            set x [idcol $idlist $p $x]
5534                            set idlist [linsert $idlist $x $p]
5535                        }
5536                    }
5537                }
5538            }
5539        }
5540        if {$final && !$viewcomplete($curview) &&
5541            $row + $uparrowlen + $mingaplen + $downarrowlen
5542                >= $commitidx($curview)} {
5543            set final 0
5544        }
5545        set l [llength $rowidlist]
5546        if {$row == $l} {
5547            lappend rowidlist $idlist
5548            lappend rowisopt 0
5549            lappend rowfinal $final
5550        } elseif {$row < $l} {
5551            if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5552                lset rowidlist $row $idlist
5553                changedrow $row
5554            }
5555            lset rowfinal $row $final
5556        } else {
5557            set pad [ntimes [expr {$row - $l}] {}]
5558            set rowidlist [concat $rowidlist $pad]
5559            lappend rowidlist $idlist
5560            set rowfinal [concat $rowfinal $pad]
5561            lappend rowfinal $final
5562            set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5563        }
5564    }
5565    return $row
5566}
5567
5568proc changedrow {row} {
5569    global displayorder iddrawn rowisopt need_redisplay
5570
5571    set l [llength $rowisopt]
5572    if {$row < $l} {
5573        lset rowisopt $row 0
5574        if {$row + 1 < $l} {
5575            lset rowisopt [expr {$row + 1}] 0
5576            if {$row + 2 < $l} {
5577                lset rowisopt [expr {$row + 2}] 0
5578            }
5579        }
5580    }
5581    set id [lindex $displayorder $row]
5582    if {[info exists iddrawn($id)]} {
5583        set need_redisplay 1
5584    }
5585}
5586
5587proc insert_pad {row col npad} {
5588    global rowidlist
5589
5590    set pad [ntimes $npad {}]
5591    set idlist [lindex $rowidlist $row]
5592    set bef [lrange $idlist 0 [expr {$col - 1}]]
5593    set aft [lrange $idlist $col end]
5594    set i [lsearch -exact $aft {}]
5595    if {$i > 0} {
5596        set aft [lreplace $aft $i $i]
5597    }
5598    lset rowidlist $row [concat $bef $pad $aft]
5599    changedrow $row
5600}
5601
5602proc optimize_rows {row col endrow} {
5603    global rowidlist rowisopt displayorder curview children
5604
5605    if {$row < 1} {
5606        set row 1
5607    }
5608    for {} {$row < $endrow} {incr row; set col 0} {
5609        if {[lindex $rowisopt $row]} continue
5610        set haspad 0
5611        set y0 [expr {$row - 1}]
5612        set ym [expr {$row - 2}]
5613        set idlist [lindex $rowidlist $row]
5614        set previdlist [lindex $rowidlist $y0]
5615        if {$idlist eq {} || $previdlist eq {}} continue
5616        if {$ym >= 0} {
5617            set pprevidlist [lindex $rowidlist $ym]
5618            if {$pprevidlist eq {}} continue
5619        } else {
5620            set pprevidlist {}
5621        }
5622        set x0 -1
5623        set xm -1
5624        for {} {$col < [llength $idlist]} {incr col} {
5625            set id [lindex $idlist $col]
5626            if {[lindex $previdlist $col] eq $id} continue
5627            if {$id eq {}} {
5628                set haspad 1
5629                continue
5630            }
5631            set x0 [lsearch -exact $previdlist $id]
5632            if {$x0 < 0} continue
5633            set z [expr {$x0 - $col}]
5634            set isarrow 0
5635            set z0 {}
5636            if {$ym >= 0} {
5637                set xm [lsearch -exact $pprevidlist $id]
5638                if {$xm >= 0} {
5639                    set z0 [expr {$xm - $x0}]
5640                }
5641            }
5642            if {$z0 eq {}} {
5643                # if row y0 is the first child of $id then it's not an arrow
5644                if {[lindex $children($curview,$id) 0] ne
5645                    [lindex $displayorder $y0]} {
5646                    set isarrow 1
5647                }
5648            }
5649            if {!$isarrow && $id ne [lindex $displayorder $row] &&
5650                [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5651                set isarrow 1
5652            }
5653            # Looking at lines from this row to the previous row,
5654            # make them go straight up if they end in an arrow on
5655            # the previous row; otherwise make them go straight up
5656            # or at 45 degrees.
5657            if {$z < -1 || ($z < 0 && $isarrow)} {
5658                # Line currently goes left too much;
5659                # insert pads in the previous row, then optimize it
5660                set npad [expr {-1 - $z + $isarrow}]
5661                insert_pad $y0 $x0 $npad
5662                if {$y0 > 0} {
5663                    optimize_rows $y0 $x0 $row
5664                }
5665                set previdlist [lindex $rowidlist $y0]
5666                set x0 [lsearch -exact $previdlist $id]
5667                set z [expr {$x0 - $col}]
5668                if {$z0 ne {}} {
5669                    set pprevidlist [lindex $rowidlist $ym]
5670                    set xm [lsearch -exact $pprevidlist $id]
5671                    set z0 [expr {$xm - $x0}]
5672                }
5673            } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5674                # Line currently goes right too much;
5675                # insert pads in this line
5676                set npad [expr {$z - 1 + $isarrow}]
5677                insert_pad $row $col $npad
5678                set idlist [lindex $rowidlist $row]
5679                incr col $npad
5680                set z [expr {$x0 - $col}]
5681                set haspad 1
5682            }
5683            if {$z0 eq {} && !$isarrow && $ym >= 0} {
5684                # this line links to its first child on row $row-2
5685                set id [lindex $displayorder $ym]
5686                set xc [lsearch -exact $pprevidlist $id]
5687                if {$xc >= 0} {
5688                    set z0 [expr {$xc - $x0}]
5689                }
5690            }
5691            # avoid lines jigging left then immediately right
5692            if {$z0 ne {} && $z < 0 && $z0 > 0} {
5693                insert_pad $y0 $x0 1
5694                incr x0
5695                optimize_rows $y0 $x0 $row
5696                set previdlist [lindex $rowidlist $y0]
5697            }
5698        }
5699        if {!$haspad} {
5700            # Find the first column that doesn't have a line going right
5701            for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5702                set id [lindex $idlist $col]
5703                if {$id eq {}} break
5704                set x0 [lsearch -exact $previdlist $id]
5705                if {$x0 < 0} {
5706                    # check if this is the link to the first child
5707                    set kid [lindex $displayorder $y0]
5708                    if {[lindex $children($curview,$id) 0] eq $kid} {
5709                        # it is, work out offset to child
5710                        set x0 [lsearch -exact $previdlist $kid]
5711                    }
5712                }
5713                if {$x0 <= $col} break
5714            }
5715            # Insert a pad at that column as long as it has a line and
5716            # isn't the last column
5717            if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5718                set idlist [linsert $idlist $col {}]
5719                lset rowidlist $row $idlist
5720                changedrow $row
5721            }
5722        }
5723    }
5724}
5725
5726proc xc {row col} {
5727    global canvx0 linespc
5728    return [expr {$canvx0 + $col * $linespc}]
5729}
5730
5731proc yc {row} {
5732    global canvy0 linespc
5733    return [expr {$canvy0 + $row * $linespc}]
5734}
5735
5736proc linewidth {id} {
5737    global thickerline lthickness
5738
5739    set wid $lthickness
5740    if {[info exists thickerline] && $id eq $thickerline} {
5741        set wid [expr {2 * $lthickness}]
5742    }
5743    return $wid
5744}
5745
5746proc rowranges {id} {
5747    global curview children uparrowlen downarrowlen
5748    global rowidlist
5749
5750    set kids $children($curview,$id)
5751    if {$kids eq {}} {
5752        return {}
5753    }
5754    set ret {}
5755    lappend kids $id
5756    foreach child $kids {
5757        if {![commitinview $child $curview]} break
5758        set row [rowofcommit $child]
5759        if {![info exists prev]} {
5760            lappend ret [expr {$row + 1}]
5761        } else {
5762            if {$row <= $prevrow} {
5763                puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5764            }
5765            # see if the line extends the whole way from prevrow to row
5766            if {$row > $prevrow + $uparrowlen + $downarrowlen &&
5767                [lsearch -exact [lindex $rowidlist \
5768                            [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
5769                # it doesn't, see where it ends
5770                set r [expr {$prevrow + $downarrowlen}]
5771                if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5772                    while {[incr r -1] > $prevrow &&
5773                           [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5774                } else {
5775                    while {[incr r] <= $row &&
5776                           [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5777                    incr r -1
5778                }
5779                lappend ret $r
5780                # see where it starts up again
5781                set r [expr {$row - $uparrowlen}]
5782                if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
5783                    while {[incr r] < $row &&
5784                           [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
5785                } else {
5786                    while {[incr r -1] >= $prevrow &&
5787                           [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
5788                    incr r
5789                }
5790                lappend ret $r
5791            }
5792        }
5793        if {$child eq $id} {
5794            lappend ret $row
5795        }
5796        set prev $child
5797        set prevrow $row
5798    }
5799    return $ret
5800}
5801
5802proc drawlineseg {id row endrow arrowlow} {
5803    global rowidlist displayorder iddrawn linesegs
5804    global canv colormap linespc curview maxlinelen parentlist
5805
5806    set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
5807    set le [expr {$row + 1}]
5808    set arrowhigh 1
5809    while {1} {
5810        set c [lsearch -exact [lindex $rowidlist $le] $id]
5811        if {$c < 0} {
5812            incr le -1
5813            break
5814        }
5815        lappend cols $c
5816        set x [lindex $displayorder $le]
5817        if {$x eq $id} {
5818            set arrowhigh 0
5819            break
5820        }
5821        if {[info exists iddrawn($x)] || $le == $endrow} {
5822            set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
5823            if {$c >= 0} {
5824                lappend cols $c
5825                set arrowhigh 0
5826            }
5827            break
5828        }
5829        incr le
5830    }
5831    if {$le <= $row} {
5832        return $row
5833    }
5834
5835    set lines {}
5836    set i 0
5837    set joinhigh 0
5838    if {[info exists linesegs($id)]} {
5839        set lines $linesegs($id)
5840        foreach li $lines {
5841            set r0 [lindex $li 0]
5842            if {$r0 > $row} {
5843                if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
5844                    set joinhigh 1
5845                }
5846                break
5847            }
5848            incr i
5849        }
5850    }
5851    set joinlow 0
5852    if {$i > 0} {
5853        set li [lindex $lines [expr {$i-1}]]
5854        set r1 [lindex $li 1]
5855        if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
5856            set joinlow 1
5857        }
5858    }
5859
5860    set x [lindex $cols [expr {$le - $row}]]
5861    set xp [lindex $cols [expr {$le - 1 - $row}]]
5862    set dir [expr {$xp - $x}]
5863    if {$joinhigh} {
5864        set ith [lindex $lines $i 2]
5865        set coords [$canv coords $ith]
5866        set ah [$canv itemcget $ith -arrow]
5867        set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
5868        set x2 [lindex $cols [expr {$le + 1 - $row}]]
5869        if {$x2 ne {} && $x - $x2 == $dir} {
5870            set coords [lrange $coords 0 end-2]
5871        }
5872    } else {
5873        set coords [list [xc $le $x] [yc $le]]
5874    }
5875    if {$joinlow} {
5876        set itl [lindex $lines [expr {$i-1}] 2]
5877        set al [$canv itemcget $itl -arrow]
5878        set arrowlow [expr {$al eq "last" || $al eq "both"}]
5879    } elseif {$arrowlow} {
5880        if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
5881            [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
5882            set arrowlow 0
5883        }
5884    }
5885    set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
5886    for {set y $le} {[incr y -1] > $row} {} {
5887        set x $xp
5888        set xp [lindex $cols [expr {$y - 1 - $row}]]
5889        set ndir [expr {$xp - $x}]
5890        if {$dir != $ndir || $xp < 0} {
5891            lappend coords [xc $y $x] [yc $y]
5892        }
5893        set dir $ndir
5894    }
5895    if {!$joinlow} {
5896        if {$xp < 0} {
5897            # join parent line to first child
5898            set ch [lindex $displayorder $row]
5899            set xc [lsearch -exact [lindex $rowidlist $row] $ch]
5900            if {$xc < 0} {
5901                puts "oops: drawlineseg: child $ch not on row $row"
5902            } elseif {$xc != $x} {
5903                if {($arrowhigh && $le == $row + 1) || $dir == 0} {
5904                    set d [expr {int(0.5 * $linespc)}]
5905                    set x1 [xc $row $x]
5906                    if {$xc < $x} {
5907                        set x2 [expr {$x1 - $d}]
5908                    } else {
5909                        set x2 [expr {$x1 + $d}]
5910                    }
5911                    set y2 [yc $row]
5912                    set y1 [expr {$y2 + $d}]
5913                    lappend coords $x1 $y1 $x2 $y2
5914                } elseif {$xc < $x - 1} {
5915                    lappend coords [xc $row [expr {$x-1}]] [yc $row]
5916                } elseif {$xc > $x + 1} {
5917                    lappend coords [xc $row [expr {$x+1}]] [yc $row]
5918                }
5919                set x $xc
5920            }
5921            lappend coords [xc $row $x] [yc $row]
5922        } else {
5923            set xn [xc $row $xp]
5924            set yn [yc $row]
5925            lappend coords $xn $yn
5926        }
5927        if {!$joinhigh} {
5928            assigncolor $id
5929            set t [$canv create line $coords -width [linewidth $id] \
5930                       -fill $colormap($id) -tags lines.$id -arrow $arrow]
5931            $canv lower $t
5932            bindline $t $id
5933            set lines [linsert $lines $i [list $row $le $t]]
5934        } else {
5935            $canv coords $ith $coords
5936            if {$arrow ne $ah} {
5937                $canv itemconf $ith -arrow $arrow
5938            }
5939            lset lines $i 0 $row
5940        }
5941    } else {
5942        set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
5943        set ndir [expr {$xo - $xp}]
5944        set clow [$canv coords $itl]
5945        if {$dir == $ndir} {
5946            set clow [lrange $clow 2 end]
5947        }
5948        set coords [concat $coords $clow]
5949        if {!$joinhigh} {
5950            lset lines [expr {$i-1}] 1 $le
5951        } else {
5952            # coalesce two pieces
5953            $canv delete $ith
5954            set b [lindex $lines [expr {$i-1}] 0]
5955            set e [lindex $lines $i 1]
5956            set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
5957        }
5958        $canv coords $itl $coords
5959        if {$arrow ne $al} {
5960            $canv itemconf $itl -arrow $arrow
5961        }
5962    }
5963
5964    set linesegs($id) $lines
5965    return $le
5966}
5967
5968proc drawparentlinks {id row} {
5969    global rowidlist canv colormap curview parentlist
5970    global idpos linespc
5971
5972    set rowids [lindex $rowidlist $row]
5973    set col [lsearch -exact $rowids $id]
5974    if {$col < 0} return
5975    set olds [lindex $parentlist $row]
5976    set row2 [expr {$row + 1}]
5977    set x [xc $row $col]
5978    set y [yc $row]
5979    set y2 [yc $row2]
5980    set d [expr {int(0.5 * $linespc)}]
5981    set ymid [expr {$y + $d}]
5982    set ids [lindex $rowidlist $row2]
5983    # rmx = right-most X coord used
5984    set rmx 0
5985    foreach p $olds {
5986        set i [lsearch -exact $ids $p]
5987        if {$i < 0} {
5988            puts "oops, parent $p of $id not in list"
5989            continue
5990        }
5991        set x2 [xc $row2 $i]
5992        if {$x2 > $rmx} {
5993            set rmx $x2
5994        }
5995        set j [lsearch -exact $rowids $p]
5996        if {$j < 0} {
5997            # drawlineseg will do this one for us
5998            continue
5999        }
6000        assigncolor $p
6001        # should handle duplicated parents here...
6002        set coords [list $x $y]
6003        if {$i != $col} {
6004            # if attaching to a vertical segment, draw a smaller
6005            # slant for visual distinctness
6006            if {$i == $j} {
6007                if {$i < $col} {
6008                    lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6009                } else {
6010                    lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6011                }
6012            } elseif {$i < $col && $i < $j} {
6013                # segment slants towards us already
6014                lappend coords [xc $row $j] $y
6015            } else {
6016                if {$i < $col - 1} {
6017                    lappend coords [expr {$x2 + $linespc}] $y
6018                } elseif {$i > $col + 1} {
6019                    lappend coords [expr {$x2 - $linespc}] $y
6020                }
6021                lappend coords $x2 $y2
6022            }
6023        } else {
6024            lappend coords $x2 $y2
6025        }
6026        set t [$canv create line $coords -width [linewidth $p] \
6027                   -fill $colormap($p) -tags lines.$p]
6028        $canv lower $t
6029        bindline $t $p
6030    }
6031    if {$rmx > [lindex $idpos($id) 1]} {
6032        lset idpos($id) 1 $rmx
6033        redrawtags $id
6034    }
6035}
6036
6037proc drawlines {id} {
6038    global canv
6039
6040    $canv itemconf lines.$id -width [linewidth $id]
6041}
6042
6043proc drawcmittext {id row col} {
6044    global linespc canv canv2 canv3 fgcolor curview
6045    global cmitlisted commitinfo rowidlist parentlist
6046    global rowtextx idpos idtags idheads idotherrefs
6047    global linehtag linentag linedtag selectedline
6048    global canvxmax boldids boldnameids fgcolor markedid
6049    global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6050    global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6051    global circleoutlinecolor
6052
6053    # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6054    set listed $cmitlisted($curview,$id)
6055    if {$id eq $nullid} {
6056        set ofill $workingfilescirclecolor
6057    } elseif {$id eq $nullid2} {
6058        set ofill $indexcirclecolor
6059    } elseif {$id eq $mainheadid} {
6060        set ofill $mainheadcirclecolor
6061    } else {
6062        set ofill [lindex $circlecolors $listed]
6063    }
6064    set x [xc $row $col]
6065    set y [yc $row]
6066    set orad [expr {$linespc / 3}]
6067    if {$listed <= 2} {
6068        set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6069                   [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6070                   -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6071    } elseif {$listed == 3} {
6072        # triangle pointing left for left-side commits
6073        set t [$canv create polygon \
6074                   [expr {$x - $orad}] $y \
6075                   [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6076                   [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6077                   -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6078    } else {
6079        # triangle pointing right for right-side commits
6080        set t [$canv create polygon \
6081                   [expr {$x + $orad - 1}] $y \
6082                   [expr {$x - $orad}] [expr {$y - $orad}] \
6083                   [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6084                   -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6085    }
6086    set circleitem($row) $t
6087    $canv raise $t
6088    $canv bind $t <1> {selcanvline {} %x %y}
6089    set rmx [llength [lindex $rowidlist $row]]
6090    set olds [lindex $parentlist $row]
6091    if {$olds ne {}} {
6092        set nextids [lindex $rowidlist [expr {$row + 1}]]
6093        foreach p $olds {
6094            set i [lsearch -exact $nextids $p]
6095            if {$i > $rmx} {
6096                set rmx $i
6097            }
6098        }
6099    }
6100    set xt [xc $row $rmx]
6101    set rowtextx($row) $xt
6102    set idpos($id) [list $x $xt $y]
6103    if {[info exists idtags($id)] || [info exists idheads($id)]
6104        || [info exists idotherrefs($id)]} {
6105        set xt [drawtags $id $x $xt $y]
6106    }
6107    if {[lindex $commitinfo($id) 6] > 0} {
6108        set xt [drawnotesign $xt $y]
6109    }
6110    set headline [lindex $commitinfo($id) 0]
6111    set name [lindex $commitinfo($id) 1]
6112    set date [lindex $commitinfo($id) 2]
6113    set date [formatdate $date]
6114    set font mainfont
6115    set nfont mainfont
6116    set isbold [ishighlighted $id]
6117    if {$isbold > 0} {
6118        lappend boldids $id
6119        set font mainfontbold
6120        if {$isbold > 1} {
6121            lappend boldnameids $id
6122            set nfont mainfontbold
6123        }
6124    }
6125    set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6126                           -text $headline -font $font -tags text]
6127    $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6128    set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6129                           -text $name -font $nfont -tags text]
6130    set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6131                           -text $date -font mainfont -tags text]
6132    if {$selectedline == $row} {
6133        make_secsel $id
6134    }
6135    if {[info exists markedid] && $markedid eq $id} {
6136        make_idmark $id
6137    }
6138    set xr [expr {$xt + [font measure $font $headline]}]
6139    if {$xr > $canvxmax} {
6140        set canvxmax $xr
6141        setcanvscroll
6142    }
6143}
6144
6145proc drawcmitrow {row} {
6146    global displayorder rowidlist nrows_drawn
6147    global iddrawn markingmatches
6148    global commitinfo numcommits
6149    global filehighlight fhighlights findpattern nhighlights
6150    global hlview vhighlights
6151    global highlight_related rhighlights
6152
6153    if {$row >= $numcommits} return
6154
6155    set id [lindex $displayorder $row]
6156    if {[info exists hlview] && ![info exists vhighlights($id)]} {
6157        askvhighlight $row $id
6158    }
6159    if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6160        askfilehighlight $row $id
6161    }
6162    if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6163        askfindhighlight $row $id
6164    }
6165    if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6166        askrelhighlight $row $id
6167    }
6168    if {![info exists iddrawn($id)]} {
6169        set col [lsearch -exact [lindex $rowidlist $row] $id]
6170        if {$col < 0} {
6171            puts "oops, row $row id $id not in list"
6172            return
6173        }
6174        if {![info exists commitinfo($id)]} {
6175            getcommit $id
6176        }
6177        assigncolor $id
6178        drawcmittext $id $row $col
6179        set iddrawn($id) 1
6180        incr nrows_drawn
6181    }
6182    if {$markingmatches} {
6183        markrowmatches $row $id
6184    }
6185}
6186
6187proc drawcommits {row {endrow {}}} {
6188    global numcommits iddrawn displayorder curview need_redisplay
6189    global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6190
6191    if {$row < 0} {
6192        set row 0
6193    }
6194    if {$endrow eq {}} {
6195        set endrow $row
6196    }
6197    if {$endrow >= $numcommits} {
6198        set endrow [expr {$numcommits - 1}]
6199    }
6200
6201    set rl1 [expr {$row - $downarrowlen - 3}]
6202    if {$rl1 < 0} {
6203        set rl1 0
6204    }
6205    set ro1 [expr {$row - 3}]
6206    if {$ro1 < 0} {
6207        set ro1 0
6208    }
6209    set r2 [expr {$endrow + $uparrowlen + 3}]
6210    if {$r2 > $numcommits} {
6211        set r2 $numcommits
6212    }
6213    for {set r $rl1} {$r < $r2} {incr r} {
6214        if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6215            if {$rl1 < $r} {
6216                layoutrows $rl1 $r
6217            }
6218            set rl1 [expr {$r + 1}]
6219        }
6220    }
6221    if {$rl1 < $r} {
6222        layoutrows $rl1 $r
6223    }
6224    optimize_rows $ro1 0 $r2
6225    if {$need_redisplay || $nrows_drawn > 2000} {
6226        clear_display
6227    }
6228
6229    # make the lines join to already-drawn rows either side
6230    set r [expr {$row - 1}]
6231    if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6232        set r $row
6233    }
6234    set er [expr {$endrow + 1}]
6235    if {$er >= $numcommits ||
6236        ![info exists iddrawn([lindex $displayorder $er])]} {
6237        set er $endrow
6238    }
6239    for {} {$r <= $er} {incr r} {
6240        set id [lindex $displayorder $r]
6241        set wasdrawn [info exists iddrawn($id)]
6242        drawcmitrow $r
6243        if {$r == $er} break
6244        set nextid [lindex $displayorder [expr {$r + 1}]]
6245        if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6246        drawparentlinks $id $r
6247
6248        set rowids [lindex $rowidlist $r]
6249        foreach lid $rowids {
6250            if {$lid eq {}} continue
6251            if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6252            if {$lid eq $id} {
6253                # see if this is the first child of any of its parents
6254                foreach p [lindex $parentlist $r] {
6255                    if {[lsearch -exact $rowids $p] < 0} {
6256                        # make this line extend up to the child
6257                        set lineend($p) [drawlineseg $p $r $er 0]
6258                    }
6259                }
6260            } else {
6261                set lineend($lid) [drawlineseg $lid $r $er 1]
6262            }
6263        }
6264    }
6265}
6266
6267proc undolayout {row} {
6268    global uparrowlen mingaplen downarrowlen
6269    global rowidlist rowisopt rowfinal need_redisplay
6270
6271    set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6272    if {$r < 0} {
6273        set r 0
6274    }
6275    if {[llength $rowidlist] > $r} {
6276        incr r -1
6277        set rowidlist [lrange $rowidlist 0 $r]
6278        set rowfinal [lrange $rowfinal 0 $r]
6279        set rowisopt [lrange $rowisopt 0 $r]
6280        set need_redisplay 1
6281        run drawvisible
6282    }
6283}
6284
6285proc drawvisible {} {
6286    global canv linespc curview vrowmod selectedline targetrow targetid
6287    global need_redisplay cscroll numcommits
6288
6289    set fs [$canv yview]
6290    set ymax [lindex [$canv cget -scrollregion] 3]
6291    if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6292    set f0 [lindex $fs 0]
6293    set f1 [lindex $fs 1]
6294    set y0 [expr {int($f0 * $ymax)}]
6295    set y1 [expr {int($f1 * $ymax)}]
6296
6297    if {[info exists targetid]} {
6298        if {[commitinview $targetid $curview]} {
6299            set r [rowofcommit $targetid]
6300            if {$r != $targetrow} {
6301                # Fix up the scrollregion and change the scrolling position
6302                # now that our target row has moved.
6303                set diff [expr {($r - $targetrow) * $linespc}]
6304                set targetrow $r
6305                setcanvscroll
6306                set ymax [lindex [$canv cget -scrollregion] 3]
6307                incr y0 $diff
6308                incr y1 $diff
6309                set f0 [expr {$y0 / $ymax}]
6310                set f1 [expr {$y1 / $ymax}]
6311                allcanvs yview moveto $f0
6312                $cscroll set $f0 $f1
6313                set need_redisplay 1
6314            }
6315        } else {
6316            unset targetid
6317        }
6318    }
6319
6320    set row [expr {int(($y0 - 3) / $linespc) - 1}]
6321    set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6322    if {$endrow >= $vrowmod($curview)} {
6323        update_arcrows $curview
6324    }
6325    if {$selectedline ne {} &&
6326        $row <= $selectedline && $selectedline <= $endrow} {
6327        set targetrow $selectedline
6328    } elseif {[info exists targetid]} {
6329        set targetrow [expr {int(($row + $endrow) / 2)}]
6330    }
6331    if {[info exists targetrow]} {
6332        if {$targetrow >= $numcommits} {
6333            set targetrow [expr {$numcommits - 1}]
6334        }
6335        set targetid [commitonrow $targetrow]
6336    }
6337    drawcommits $row $endrow
6338}
6339
6340proc clear_display {} {
6341    global iddrawn linesegs need_redisplay nrows_drawn
6342    global vhighlights fhighlights nhighlights rhighlights
6343    global linehtag linentag linedtag boldids boldnameids
6344
6345    allcanvs delete all
6346    catch {unset iddrawn}
6347    catch {unset linesegs}
6348    catch {unset linehtag}
6349    catch {unset linentag}
6350    catch {unset linedtag}
6351    set boldids {}
6352    set boldnameids {}
6353    catch {unset vhighlights}
6354    catch {unset fhighlights}
6355    catch {unset nhighlights}
6356    catch {unset rhighlights}
6357    set need_redisplay 0
6358    set nrows_drawn 0
6359}
6360
6361proc findcrossings {id} {
6362    global rowidlist parentlist numcommits displayorder
6363
6364    set cross {}
6365    set ccross {}
6366    foreach {s e} [rowranges $id] {
6367        if {$e >= $numcommits} {
6368            set e [expr {$numcommits - 1}]
6369        }
6370        if {$e <= $s} continue
6371        for {set row $e} {[incr row -1] >= $s} {} {
6372            set x [lsearch -exact [lindex $rowidlist $row] $id]
6373            if {$x < 0} break
6374            set olds [lindex $parentlist $row]
6375            set kid [lindex $displayorder $row]
6376            set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6377            if {$kidx < 0} continue
6378            set nextrow [lindex $rowidlist [expr {$row + 1}]]
6379            foreach p $olds {
6380                set px [lsearch -exact $nextrow $p]
6381                if {$px < 0} continue
6382                if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6383                    if {[lsearch -exact $ccross $p] >= 0} continue
6384                    if {$x == $px + ($kidx < $px? -1: 1)} {
6385                        lappend ccross $p
6386                    } elseif {[lsearch -exact $cross $p] < 0} {
6387                        lappend cross $p
6388                    }
6389                }
6390            }
6391        }
6392    }
6393    return [concat $ccross {{}} $cross]
6394}
6395
6396proc assigncolor {id} {
6397    global colormap colors nextcolor
6398    global parents children children curview
6399
6400    if {[info exists colormap($id)]} return
6401    set ncolors [llength $colors]
6402    if {[info exists children($curview,$id)]} {
6403        set kids $children($curview,$id)
6404    } else {
6405        set kids {}
6406    }
6407    if {[llength $kids] == 1} {
6408        set child [lindex $kids 0]
6409        if {[info exists colormap($child)]
6410            && [llength $parents($curview,$child)] == 1} {
6411            set colormap($id) $colormap($child)
6412            return
6413        }
6414    }
6415    set badcolors {}
6416    set origbad {}
6417    foreach x [findcrossings $id] {
6418        if {$x eq {}} {
6419            # delimiter between corner crossings and other crossings
6420            if {[llength $badcolors] >= $ncolors - 1} break
6421            set origbad $badcolors
6422        }
6423        if {[info exists colormap($x)]
6424            && [lsearch -exact $badcolors $colormap($x)] < 0} {
6425            lappend badcolors $colormap($x)
6426        }
6427    }
6428    if {[llength $badcolors] >= $ncolors} {
6429        set badcolors $origbad
6430    }
6431    set origbad $badcolors
6432    if {[llength $badcolors] < $ncolors - 1} {
6433        foreach child $kids {
6434            if {[info exists colormap($child)]
6435                && [lsearch -exact $badcolors $colormap($child)] < 0} {
6436                lappend badcolors $colormap($child)
6437            }
6438            foreach p $parents($curview,$child) {
6439                if {[info exists colormap($p)]
6440                    && [lsearch -exact $badcolors $colormap($p)] < 0} {
6441                    lappend badcolors $colormap($p)
6442                }
6443            }
6444        }
6445        if {[llength $badcolors] >= $ncolors} {
6446            set badcolors $origbad
6447        }
6448    }
6449    for {set i 0} {$i <= $ncolors} {incr i} {
6450        set c [lindex $colors $nextcolor]
6451        if {[incr nextcolor] >= $ncolors} {
6452            set nextcolor 0
6453        }
6454        if {[lsearch -exact $badcolors $c]} break
6455    }
6456    set colormap($id) $c
6457}
6458
6459proc bindline {t id} {
6460    global canv
6461
6462    $canv bind $t <Enter> "lineenter %x %y $id"
6463    $canv bind $t <Motion> "linemotion %x %y $id"
6464    $canv bind $t <Leave> "lineleave $id"
6465    $canv bind $t <Button-1> "lineclick %x %y $id 1"
6466}
6467
6468proc graph_pane_width {} {
6469    global use_ttk
6470
6471    if {$use_ttk} {
6472        set g [.tf.histframe.pwclist sashpos 0]
6473    } else {
6474        set g [.tf.histframe.pwclist sash coord 0]
6475    }
6476    return [lindex $g 0]
6477}
6478
6479proc totalwidth {l font extra} {
6480    set tot 0
6481    foreach str $l {
6482        set tot [expr {$tot + [font measure $font $str] + $extra}]
6483    }
6484    return $tot
6485}
6486
6487proc drawtags {id x xt y1} {
6488    global idtags idheads idotherrefs mainhead
6489    global linespc lthickness
6490    global canv rowtextx curview fgcolor bgcolor ctxbut
6491    global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6492    global tagbgcolor tagfgcolor tagoutlinecolor
6493    global reflinecolor
6494
6495    set marks {}
6496    set ntags 0
6497    set nheads 0
6498    set singletag 0
6499    set maxtags 3
6500    set maxtagpct 25
6501    set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6502    set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6503    set extra [expr {$delta + $lthickness + $linespc}]
6504
6505    if {[info exists idtags($id)]} {
6506        set marks $idtags($id)
6507        set ntags [llength $marks]
6508        if {$ntags > $maxtags ||
6509            [totalwidth $marks mainfont $extra] > $maxwidth} {
6510            # show just a single "n tags..." tag
6511            set singletag 1
6512            if {$ntags == 1} {
6513                set marks [list "tag..."]
6514            } else {
6515                set marks [list [format "%d tags..." $ntags]]
6516            }
6517            set ntags 1
6518        }
6519    }
6520    if {[info exists idheads($id)]} {
6521        set marks [concat $marks $idheads($id)]
6522        set nheads [llength $idheads($id)]
6523    }
6524    if {[info exists idotherrefs($id)]} {
6525        set marks [concat $marks $idotherrefs($id)]
6526    }
6527    if {$marks eq {}} {
6528        return $xt
6529    }
6530
6531    set yt [expr {$y1 - 0.5 * $linespc}]
6532    set yb [expr {$yt + $linespc - 1}]
6533    set xvals {}
6534    set wvals {}
6535    set i -1
6536    foreach tag $marks {
6537        incr i
6538        if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6539            set wid [font measure mainfontbold $tag]
6540        } else {
6541            set wid [font measure mainfont $tag]
6542        }
6543        lappend xvals $xt
6544        lappend wvals $wid
6545        set xt [expr {$xt + $wid + $extra}]
6546    }
6547    set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6548               -width $lthickness -fill $reflinecolor -tags tag.$id]
6549    $canv lower $t
6550    foreach tag $marks x $xvals wid $wvals {
6551        set tag_quoted [string map {% %%} $tag]
6552        set xl [expr {$x + $delta}]
6553        set xr [expr {$x + $delta + $wid + $lthickness}]
6554        set font mainfont
6555        if {[incr ntags -1] >= 0} {
6556            # draw a tag
6557            set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6558                       $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6559                       -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6560                       -tags tag.$id]
6561            if {$singletag} {
6562                set tagclick [list showtags $id 1]
6563            } else {
6564                set tagclick [list showtag $tag_quoted 1]
6565            }
6566            $canv bind $t <1> $tagclick
6567            set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6568        } else {
6569            # draw a head or other ref
6570            if {[incr nheads -1] >= 0} {
6571                set col $headbgcolor
6572                if {$tag eq $mainhead} {
6573                    set font mainfontbold
6574                }
6575            } else {
6576                set col "#ddddff"
6577            }
6578            set xl [expr {$xl - $delta/2}]
6579            $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6580                -width 1 -outline black -fill $col -tags tag.$id
6581            if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6582                set rwid [font measure mainfont $remoteprefix]
6583                set xi [expr {$x + 1}]
6584                set yti [expr {$yt + 1}]
6585                set xri [expr {$x + $rwid}]
6586                $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6587                        -width 0 -fill $remotebgcolor -tags tag.$id
6588            }
6589        }
6590        set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6591                   -font $font -tags [list tag.$id text]]
6592        if {$ntags >= 0} {
6593            $canv bind $t <1> $tagclick
6594        } elseif {$nheads >= 0} {
6595            $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6596        }
6597    }
6598    return $xt
6599}
6600
6601proc drawnotesign {xt y} {
6602    global linespc canv fgcolor
6603
6604    set orad [expr {$linespc / 3}]
6605    set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6606               [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6607               -fill yellow -outline $fgcolor -width 1 -tags circle]
6608    set xt [expr {$xt + $orad * 3}]
6609    return $xt
6610}
6611
6612proc xcoord {i level ln} {
6613    global canvx0 xspc1 xspc2
6614
6615    set x [expr {$canvx0 + $i * $xspc1($ln)}]
6616    if {$i > 0 && $i == $level} {
6617        set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6618    } elseif {$i > $level} {
6619        set x [expr {$x + $xspc2 - $xspc1($ln)}]
6620    }
6621    return $x
6622}
6623
6624proc show_status {msg} {
6625    global canv fgcolor
6626
6627    clear_display
6628    $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6629        -tags text -fill $fgcolor
6630}
6631
6632# Don't change the text pane cursor if it is currently the hand cursor,
6633# showing that we are over a sha1 ID link.
6634proc settextcursor {c} {
6635    global ctext curtextcursor
6636
6637    if {[$ctext cget -cursor] == $curtextcursor} {
6638        $ctext config -cursor $c
6639    }
6640    set curtextcursor $c
6641}
6642
6643proc nowbusy {what {name {}}} {
6644    global isbusy busyname statusw
6645
6646    if {[array names isbusy] eq {}} {
6647        . config -cursor watch
6648        settextcursor watch
6649    }
6650    set isbusy($what) 1
6651    set busyname($what) $name
6652    if {$name ne {}} {
6653        $statusw conf -text $name
6654    }
6655}
6656
6657proc notbusy {what} {
6658    global isbusy maincursor textcursor busyname statusw
6659
6660    catch {
6661        unset isbusy($what)
6662        if {$busyname($what) ne {} &&
6663            [$statusw cget -text] eq $busyname($what)} {
6664            $statusw conf -text {}
6665        }
6666    }
6667    if {[array names isbusy] eq {}} {
6668        . config -cursor $maincursor
6669        settextcursor $textcursor
6670    }
6671}
6672
6673proc findmatches {f} {
6674    global findtype findstring
6675    if {$findtype == [mc "Regexp"]} {
6676        set matches [regexp -indices -all -inline $findstring $f]
6677    } else {
6678        set fs $findstring
6679        if {$findtype == [mc "IgnCase"]} {
6680            set f [string tolower $f]
6681            set fs [string tolower $fs]
6682        }
6683        set matches {}
6684        set i 0
6685        set l [string length $fs]
6686        while {[set j [string first $fs $f $i]] >= 0} {
6687            lappend matches [list $j [expr {$j+$l-1}]]
6688            set i [expr {$j + $l}]
6689        }
6690    }
6691    return $matches
6692}
6693
6694proc dofind {{dirn 1} {wrap 1}} {
6695    global findstring findstartline findcurline selectedline numcommits
6696    global gdttype filehighlight fh_serial find_dirn findallowwrap
6697
6698    if {[info exists find_dirn]} {
6699        if {$find_dirn == $dirn} return
6700        stopfinding
6701    }
6702    focus .
6703    if {$findstring eq {} || $numcommits == 0} return
6704    if {$selectedline eq {}} {
6705        set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6706    } else {
6707        set findstartline $selectedline
6708    }
6709    set findcurline $findstartline
6710    nowbusy finding [mc "Searching"]
6711    if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6712        after cancel do_file_hl $fh_serial
6713        do_file_hl $fh_serial
6714    }
6715    set find_dirn $dirn
6716    set findallowwrap $wrap
6717    run findmore
6718}
6719
6720proc stopfinding {} {
6721    global find_dirn findcurline fprogcoord
6722
6723    if {[info exists find_dirn]} {
6724        unset find_dirn
6725        unset findcurline
6726        notbusy finding
6727        set fprogcoord 0
6728        adjustprogress
6729    }
6730    stopblaming
6731}
6732
6733proc findmore {} {
6734    global commitdata commitinfo numcommits findpattern findloc
6735    global findstartline findcurline findallowwrap
6736    global find_dirn gdttype fhighlights fprogcoord
6737    global curview varcorder vrownum varccommits vrowmod
6738
6739    if {![info exists find_dirn]} {
6740        return 0
6741    }
6742    set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6743    set l $findcurline
6744    set moretodo 0
6745    if {$find_dirn > 0} {
6746        incr l
6747        if {$l >= $numcommits} {
6748            set l 0
6749        }
6750        if {$l <= $findstartline} {
6751            set lim [expr {$findstartline + 1}]
6752        } else {
6753            set lim $numcommits
6754            set moretodo $findallowwrap
6755        }
6756    } else {
6757        if {$l == 0} {
6758            set l $numcommits
6759        }
6760        incr l -1
6761        if {$l >= $findstartline} {
6762            set lim [expr {$findstartline - 1}]
6763        } else {
6764            set lim -1
6765            set moretodo $findallowwrap
6766        }
6767    }
6768    set n [expr {($lim - $l) * $find_dirn}]
6769    if {$n > 500} {
6770        set n 500
6771        set moretodo 1
6772    }
6773    if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
6774        update_arcrows $curview
6775    }
6776    set found 0
6777    set domore 1
6778    set ai [bsearch $vrownum($curview) $l]
6779    set a [lindex $varcorder($curview) $ai]
6780    set arow [lindex $vrownum($curview) $ai]
6781    set ids [lindex $varccommits($curview,$a)]
6782    set arowend [expr {$arow + [llength $ids]}]
6783    if {$gdttype eq [mc "containing:"]} {
6784        for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6785            if {$l < $arow || $l >= $arowend} {
6786                incr ai $find_dirn
6787                set a [lindex $varcorder($curview) $ai]
6788                set arow [lindex $vrownum($curview) $ai]
6789                set ids [lindex $varccommits($curview,$a)]
6790                set arowend [expr {$arow + [llength $ids]}]
6791            }
6792            set id [lindex $ids [expr {$l - $arow}]]
6793            # shouldn't happen unless git log doesn't give all the commits...
6794            if {![info exists commitdata($id)] ||
6795                ![doesmatch $commitdata($id)]} {
6796                continue
6797            }
6798            if {![info exists commitinfo($id)]} {
6799                getcommit $id
6800            }
6801            set info $commitinfo($id)
6802            foreach f $info ty $fldtypes {
6803                if {$ty eq ""} continue
6804                if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
6805                    [doesmatch $f]} {
6806                    set found 1
6807                    break
6808                }
6809            }
6810            if {$found} break
6811        }
6812    } else {
6813        for {} {$n > 0} {incr n -1; incr l $find_dirn} {
6814            if {$l < $arow || $l >= $arowend} {
6815                incr ai $find_dirn
6816                set a [lindex $varcorder($curview) $ai]
6817                set arow [lindex $vrownum($curview) $ai]
6818                set ids [lindex $varccommits($curview,$a)]
6819                set arowend [expr {$arow + [llength $ids]}]
6820            }
6821            set id [lindex $ids [expr {$l - $arow}]]
6822            if {![info exists fhighlights($id)]} {
6823                # this sets fhighlights($id) to -1
6824                askfilehighlight $l $id
6825            }
6826            if {$fhighlights($id) > 0} {
6827                set found $domore
6828                break
6829            }
6830            if {$fhighlights($id) < 0} {
6831                if {$domore} {
6832                    set domore 0
6833                    set findcurline [expr {$l - $find_dirn}]
6834                }
6835            }
6836        }
6837    }
6838    if {$found || ($domore && !$moretodo)} {
6839        unset findcurline
6840        unset find_dirn
6841        notbusy finding
6842        set fprogcoord 0
6843        adjustprogress
6844        if {$found} {
6845            findselectline $l
6846        } else {
6847            bell
6848        }
6849        return 0
6850    }
6851    if {!$domore} {
6852        flushhighlights
6853    } else {
6854        set findcurline [expr {$l - $find_dirn}]
6855    }
6856    set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
6857    if {$n < 0} {
6858        incr n $numcommits
6859    }
6860    set fprogcoord [expr {$n * 1.0 / $numcommits}]
6861    adjustprogress
6862    return $domore
6863}
6864
6865proc findselectline {l} {
6866    global findloc commentend ctext findcurline markingmatches gdttype
6867
6868    set markingmatches [expr {$gdttype eq [mc "containing:"]}]
6869    set findcurline $l
6870    selectline $l 1
6871    if {$markingmatches &&
6872        ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
6873        # highlight the matches in the comments
6874        set f [$ctext get 1.0 $commentend]
6875        set matches [findmatches $f]
6876        foreach match $matches {
6877            set start [lindex $match 0]
6878            set end [expr {[lindex $match 1] + 1}]
6879            $ctext tag add found "1.0 + $start c" "1.0 + $end c"
6880        }
6881    }
6882    drawvisible
6883}
6884
6885# mark the bits of a headline or author that match a find string
6886proc markmatches {canv l str tag matches font row} {
6887    global selectedline
6888
6889    set bbox [$canv bbox $tag]
6890    set x0 [lindex $bbox 0]
6891    set y0 [lindex $bbox 1]
6892    set y1 [lindex $bbox 3]
6893    foreach match $matches {
6894        set start [lindex $match 0]
6895        set end [lindex $match 1]
6896        if {$start > $end} continue
6897        set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
6898        set xlen [font measure $font [string range $str 0 [expr {$end}]]]
6899        set t [$canv create rect [expr {$x0+$xoff}] $y0 \
6900                   [expr {$x0+$xlen+2}] $y1 \
6901                   -outline {} -tags [list match$l matches] -fill yellow]
6902        $canv lower $t
6903        if {$row == $selectedline} {
6904            $canv raise $t secsel
6905        }
6906    }
6907}
6908
6909proc unmarkmatches {} {
6910    global markingmatches
6911
6912    allcanvs delete matches
6913    set markingmatches 0
6914    stopfinding
6915}
6916
6917proc selcanvline {w x y} {
6918    global canv canvy0 ctext linespc
6919    global rowtextx
6920    set ymax [lindex [$canv cget -scrollregion] 3]
6921    if {$ymax == {}} return
6922    set yfrac [lindex [$canv yview] 0]
6923    set y [expr {$y + $yfrac * $ymax}]
6924    set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
6925    if {$l < 0} {
6926        set l 0
6927    }
6928    if {$w eq $canv} {
6929        set xmax [lindex [$canv cget -scrollregion] 2]
6930        set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
6931        if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
6932    }
6933    unmarkmatches
6934    selectline $l 1
6935}
6936
6937proc commit_descriptor {p} {
6938    global commitinfo
6939    if {![info exists commitinfo($p)]} {
6940        getcommit $p
6941    }
6942    set l "..."
6943    if {[llength $commitinfo($p)] > 1} {
6944        set l [lindex $commitinfo($p) 0]
6945    }
6946    return "$p ($l)\n"
6947}
6948
6949# append some text to the ctext widget, and make any SHA1 ID
6950# that we know about be a clickable link.
6951proc appendwithlinks {text tags} {
6952    global ctext linknum curview
6953
6954    set start [$ctext index "end - 1c"]
6955    $ctext insert end $text $tags
6956    set links [regexp -indices -all -inline {(?:\m|-g)[0-9a-f]{6,40}\M} $text]
6957    foreach l $links {
6958        set s [lindex $l 0]
6959        set e [lindex $l 1]
6960        set linkid [string range $text $s $e]
6961        incr e
6962        $ctext tag delete link$linknum
6963        $ctext tag add link$linknum "$start + $s c" "$start + $e c"
6964        setlink $linkid link$linknum
6965        incr linknum
6966    }
6967}
6968
6969proc setlink {id lk} {
6970    global curview ctext pendinglinks
6971    global linkfgcolor
6972
6973    if {[string range $id 0 1] eq "-g"} {
6974      set id [string range $id 2 end]
6975    }
6976
6977    set known 0
6978    if {[string length $id] < 40} {
6979        set matches [longid $id]
6980        if {[llength $matches] > 0} {
6981            if {[llength $matches] > 1} return
6982            set known 1
6983            set id [lindex $matches 0]
6984        }
6985    } else {
6986        set known [commitinview $id $curview]
6987    }
6988    if {$known} {
6989        $ctext tag conf $lk -foreground $linkfgcolor -underline 1
6990        $ctext tag bind $lk <1> [list selbyid $id]
6991        $ctext tag bind $lk <Enter> {linkcursor %W 1}
6992        $ctext tag bind $lk <Leave> {linkcursor %W -1}
6993    } else {
6994        lappend pendinglinks($id) $lk
6995        interestedin $id {makelink %P}
6996    }
6997}
6998
6999proc appendshortlink {id {pre {}} {post {}}} {
7000    global ctext linknum
7001
7002    $ctext insert end $pre
7003    $ctext tag delete link$linknum
7004    $ctext insert end [string range $id 0 7] link$linknum
7005    $ctext insert end $post
7006    setlink $id link$linknum
7007    incr linknum
7008}
7009
7010proc makelink {id} {
7011    global pendinglinks
7012
7013    if {![info exists pendinglinks($id)]} return
7014    foreach lk $pendinglinks($id) {
7015        setlink $id $lk
7016    }
7017    unset pendinglinks($id)
7018}
7019
7020proc linkcursor {w inc} {
7021    global linkentercount curtextcursor
7022
7023    if {[incr linkentercount $inc] > 0} {
7024        $w configure -cursor hand2
7025    } else {
7026        $w configure -cursor $curtextcursor
7027        if {$linkentercount < 0} {
7028            set linkentercount 0
7029        }
7030    }
7031}
7032
7033proc viewnextline {dir} {
7034    global canv linespc
7035
7036    $canv delete hover
7037    set ymax [lindex [$canv cget -scrollregion] 3]
7038    set wnow [$canv yview]
7039    set wtop [expr {[lindex $wnow 0] * $ymax}]
7040    set newtop [expr {$wtop + $dir * $linespc}]
7041    if {$newtop < 0} {
7042        set newtop 0
7043    } elseif {$newtop > $ymax} {
7044        set newtop $ymax
7045    }
7046    allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7047}
7048
7049# add a list of tag or branch names at position pos
7050# returns the number of names inserted
7051proc appendrefs {pos ids var} {
7052    global ctext linknum curview $var maxrefs visiblerefs mainheadid
7053
7054    if {[catch {$ctext index $pos}]} {
7055        return 0
7056    }
7057    $ctext conf -state normal
7058    $ctext delete $pos "$pos lineend"
7059    set tags {}
7060    foreach id $ids {
7061        foreach tag [set $var\($id\)] {
7062            lappend tags [list $tag $id]
7063        }
7064    }
7065
7066    set sep {}
7067    set tags [lsort -index 0 -decreasing $tags]
7068    set nutags 0
7069
7070    if {[llength $tags] > $maxrefs} {
7071        # If we are displaying heads, and there are too many,
7072        # see if there are some important heads to display.
7073        # Currently that are the current head and heads listed in $visiblerefs option
7074        set itags {}
7075        if {$var eq "idheads"} {
7076            set utags {}
7077            foreach ti $tags {
7078                set hname [lindex $ti 0]
7079                set id [lindex $ti 1]
7080                if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7081                    [llength $itags] < $maxrefs} {
7082                    lappend itags $ti
7083                } else {
7084                    lappend utags $ti
7085                }
7086            }
7087            set tags $utags
7088        }
7089        if {$itags ne {}} {
7090            set str [mc "and many more"]
7091            set sep " "
7092        } else {
7093            set str [mc "many"]
7094        }
7095        $ctext insert $pos "$str ([llength $tags])"
7096        set nutags [llength $tags]
7097        set tags $itags
7098    }
7099
7100    foreach ti $tags {
7101        set id [lindex $ti 1]
7102        set lk link$linknum
7103        incr linknum
7104        $ctext tag delete $lk
7105        $ctext insert $pos $sep
7106        $ctext insert $pos [lindex $ti 0] $lk
7107        setlink $id $lk
7108        set sep ", "
7109    }
7110    $ctext tag add wwrap "$pos linestart" "$pos lineend"
7111    $ctext conf -state disabled
7112    return [expr {[llength $tags] + $nutags}]
7113}
7114
7115# called when we have finished computing the nearby tags
7116proc dispneartags {delay} {
7117    global selectedline currentid showneartags tagphase
7118
7119    if {$selectedline eq {} || !$showneartags} return
7120    after cancel dispnexttag
7121    if {$delay} {
7122        after 200 dispnexttag
7123        set tagphase -1
7124    } else {
7125        after idle dispnexttag
7126        set tagphase 0
7127    }
7128}
7129
7130proc dispnexttag {} {
7131    global selectedline currentid showneartags tagphase ctext
7132
7133    if {$selectedline eq {} || !$showneartags} return
7134    switch -- $tagphase {
7135        0 {
7136            set dtags [desctags $currentid]
7137            if {$dtags ne {}} {
7138                appendrefs precedes $dtags idtags
7139            }
7140        }
7141        1 {
7142            set atags [anctags $currentid]
7143            if {$atags ne {}} {
7144                appendrefs follows $atags idtags
7145            }
7146        }
7147        2 {
7148            set dheads [descheads $currentid]
7149            if {$dheads ne {}} {
7150                if {[appendrefs branch $dheads idheads] > 1
7151                    && [$ctext get "branch -3c"] eq "h"} {
7152                    # turn "Branch" into "Branches"
7153                    $ctext conf -state normal
7154                    $ctext insert "branch -2c" "es"
7155                    $ctext conf -state disabled
7156                }
7157            }
7158        }
7159    }
7160    if {[incr tagphase] <= 2} {
7161        after idle dispnexttag
7162    }
7163}
7164
7165proc make_secsel {id} {
7166    global linehtag linentag linedtag canv canv2 canv3
7167
7168    if {![info exists linehtag($id)]} return
7169    $canv delete secsel
7170    set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7171               -tags secsel -fill [$canv cget -selectbackground]]
7172    $canv lower $t
7173    $canv2 delete secsel
7174    set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7175               -tags secsel -fill [$canv2 cget -selectbackground]]
7176    $canv2 lower $t
7177    $canv3 delete secsel
7178    set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7179               -tags secsel -fill [$canv3 cget -selectbackground]]
7180    $canv3 lower $t
7181}
7182
7183proc make_idmark {id} {
7184    global linehtag canv fgcolor
7185
7186    if {![info exists linehtag($id)]} return
7187    $canv delete markid
7188    set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7189               -tags markid -outline $fgcolor]
7190    $canv raise $t
7191}
7192
7193proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7194    global canv ctext commitinfo selectedline
7195    global canvy0 linespc parents children curview
7196    global currentid sha1entry
7197    global commentend idtags linknum
7198    global mergemax numcommits pending_select
7199    global cmitmode showneartags allcommits
7200    global targetrow targetid lastscrollrows
7201    global autoselect autosellen jump_to_here
7202    global vinlinediff
7203
7204    catch {unset pending_select}
7205    $canv delete hover
7206    normalline
7207    unsel_reflist
7208    stopfinding
7209    if {$l < 0 || $l >= $numcommits} return
7210    set id [commitonrow $l]
7211    set targetid $id
7212    set targetrow $l
7213    set selectedline $l
7214    set currentid $id
7215    if {$lastscrollrows < $numcommits} {
7216        setcanvscroll
7217    }
7218
7219    if {$cmitmode ne "patch" && $switch_to_patch} {
7220        set cmitmode "patch"
7221    }
7222
7223    set y [expr {$canvy0 + $l * $linespc}]
7224    set ymax [lindex [$canv cget -scrollregion] 3]
7225    set ytop [expr {$y - $linespc - 1}]
7226    set ybot [expr {$y + $linespc + 1}]
7227    set wnow [$canv yview]
7228    set wtop [expr {[lindex $wnow 0] * $ymax}]
7229    set wbot [expr {[lindex $wnow 1] * $ymax}]
7230    set wh [expr {$wbot - $wtop}]
7231    set newtop $wtop
7232    if {$ytop < $wtop} {
7233        if {$ybot < $wtop} {
7234            set newtop [expr {$y - $wh / 2.0}]
7235        } else {
7236            set newtop $ytop
7237            if {$newtop > $wtop - $linespc} {
7238                set newtop [expr {$wtop - $linespc}]
7239            }
7240        }
7241    } elseif {$ybot > $wbot} {
7242        if {$ytop > $wbot} {
7243            set newtop [expr {$y - $wh / 2.0}]
7244        } else {
7245            set newtop [expr {$ybot - $wh}]
7246            if {$newtop < $wtop + $linespc} {
7247                set newtop [expr {$wtop + $linespc}]
7248            }
7249        }
7250    }
7251    if {$newtop != $wtop} {
7252        if {$newtop < 0} {
7253            set newtop 0
7254        }
7255        allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7256        drawvisible
7257    }
7258
7259    make_secsel $id
7260
7261    if {$isnew} {
7262        addtohistory [list selbyid $id 0] savecmitpos
7263    }
7264
7265    $sha1entry delete 0 end
7266    $sha1entry insert 0 $id
7267    if {$autoselect} {
7268        $sha1entry selection range 0 $autosellen
7269    }
7270    rhighlight_sel $id
7271
7272    $ctext conf -state normal
7273    clear_ctext
7274    set linknum 0
7275    if {![info exists commitinfo($id)]} {
7276        getcommit $id
7277    }
7278    set info $commitinfo($id)
7279    set date [formatdate [lindex $info 2]]
7280    $ctext insert end "[mc "Author"]: [lindex $info 1]  $date\n"
7281    set date [formatdate [lindex $info 4]]
7282    $ctext insert end "[mc "Committer"]: [lindex $info 3]  $date\n"
7283    if {[info exists idtags($id)]} {
7284        $ctext insert end [mc "Tags:"]
7285        foreach tag $idtags($id) {
7286            $ctext insert end " $tag"
7287        }
7288        $ctext insert end "\n"
7289    }
7290
7291    set headers {}
7292    set olds $parents($curview,$id)
7293    if {[llength $olds] > 1} {
7294        set np 0
7295        foreach p $olds {
7296            if {$np >= $mergemax} {
7297                set tag mmax
7298            } else {
7299                set tag m$np
7300            }
7301            $ctext insert end "[mc "Parent"]: " $tag
7302            appendwithlinks [commit_descriptor $p] {}
7303            incr np
7304        }
7305    } else {
7306        foreach p $olds {
7307            append headers "[mc "Parent"]: [commit_descriptor $p]"
7308        }
7309    }
7310
7311    foreach c $children($curview,$id) {
7312        append headers "[mc "Child"]:  [commit_descriptor $c]"
7313    }
7314
7315    # make anything that looks like a SHA1 ID be a clickable link
7316    appendwithlinks $headers {}
7317    if {$showneartags} {
7318        if {![info exists allcommits]} {
7319            getallcommits
7320        }
7321        $ctext insert end "[mc "Branch"]: "
7322        $ctext mark set branch "end -1c"
7323        $ctext mark gravity branch left
7324        $ctext insert end "\n[mc "Follows"]: "
7325        $ctext mark set follows "end -1c"
7326        $ctext mark gravity follows left
7327        $ctext insert end "\n[mc "Precedes"]: "
7328        $ctext mark set precedes "end -1c"
7329        $ctext mark gravity precedes left
7330        $ctext insert end "\n"
7331        dispneartags 1
7332    }
7333    $ctext insert end "\n"
7334    set comment [lindex $info 5]
7335    if {[string first "\r" $comment] >= 0} {
7336        set comment [string map {"\r" "\n    "} $comment]
7337    }
7338    appendwithlinks $comment {comment}
7339
7340    $ctext tag remove found 1.0 end
7341    $ctext conf -state disabled
7342    set commentend [$ctext index "end - 1c"]
7343
7344    set jump_to_here $desired_loc
7345    init_flist [mc "Comments"]
7346    if {$cmitmode eq "tree"} {
7347        gettree $id
7348    } elseif {$vinlinediff($curview) == 1} {
7349        showinlinediff $id
7350    } elseif {[llength $olds] <= 1} {
7351        startdiff $id
7352    } else {
7353        mergediff $id
7354    }
7355}
7356
7357proc selfirstline {} {
7358    unmarkmatches
7359    selectline 0 1
7360}
7361
7362proc sellastline {} {
7363    global numcommits
7364    unmarkmatches
7365    set l [expr {$numcommits - 1}]
7366    selectline $l 1
7367}
7368
7369proc selnextline {dir} {
7370    global selectedline
7371    focus .
7372    if {$selectedline eq {}} return
7373    set l [expr {$selectedline + $dir}]
7374    unmarkmatches
7375    selectline $l 1
7376}
7377
7378proc selnextpage {dir} {
7379    global canv linespc selectedline numcommits
7380
7381    set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7382    if {$lpp < 1} {
7383        set lpp 1
7384    }
7385    allcanvs yview scroll [expr {$dir * $lpp}] units
7386    drawvisible
7387    if {$selectedline eq {}} return
7388    set l [expr {$selectedline + $dir * $lpp}]
7389    if {$l < 0} {
7390        set l 0
7391    } elseif {$l >= $numcommits} {
7392        set l [expr $numcommits - 1]
7393    }
7394    unmarkmatches
7395    selectline $l 1
7396}
7397
7398proc unselectline {} {
7399    global selectedline currentid
7400
7401    set selectedline {}
7402    catch {unset currentid}
7403    allcanvs delete secsel
7404    rhighlight_none
7405}
7406
7407proc reselectline {} {
7408    global selectedline
7409
7410    if {$selectedline ne {}} {
7411        selectline $selectedline 0
7412    }
7413}
7414
7415proc addtohistory {cmd {saveproc {}}} {
7416    global history historyindex curview
7417
7418    unset_posvars
7419    save_position
7420    set elt [list $curview $cmd $saveproc {}]
7421    if {$historyindex > 0
7422        && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7423        return
7424    }
7425
7426    if {$historyindex < [llength $history]} {
7427        set history [lreplace $history $historyindex end $elt]
7428    } else {
7429        lappend history $elt
7430    }
7431    incr historyindex
7432    if {$historyindex > 1} {
7433        .tf.bar.leftbut conf -state normal
7434    } else {
7435        .tf.bar.leftbut conf -state disabled
7436    }
7437    .tf.bar.rightbut conf -state disabled
7438}
7439
7440# save the scrolling position of the diff display pane
7441proc save_position {} {
7442    global historyindex history
7443
7444    if {$historyindex < 1} return
7445    set hi [expr {$historyindex - 1}]
7446    set fn [lindex $history $hi 2]
7447    if {$fn ne {}} {
7448        lset history $hi 3 [eval $fn]
7449    }
7450}
7451
7452proc unset_posvars {} {
7453    global last_posvars
7454
7455    if {[info exists last_posvars]} {
7456        foreach {var val} $last_posvars {
7457            global $var
7458            catch {unset $var}
7459        }
7460        unset last_posvars
7461    }
7462}
7463
7464proc godo {elt} {
7465    global curview last_posvars
7466
7467    set view [lindex $elt 0]
7468    set cmd [lindex $elt 1]
7469    set pv [lindex $elt 3]
7470    if {$curview != $view} {
7471        showview $view
7472    }
7473    unset_posvars
7474    foreach {var val} $pv {
7475        global $var
7476        set $var $val
7477    }
7478    set last_posvars $pv
7479    eval $cmd
7480}
7481
7482proc goback {} {
7483    global history historyindex
7484    focus .
7485
7486    if {$historyindex > 1} {
7487        save_position
7488        incr historyindex -1
7489        godo [lindex $history [expr {$historyindex - 1}]]
7490        .tf.bar.rightbut conf -state normal
7491    }
7492    if {$historyindex <= 1} {
7493        .tf.bar.leftbut conf -state disabled
7494    }
7495}
7496
7497proc goforw {} {
7498    global history historyindex
7499    focus .
7500
7501    if {$historyindex < [llength $history]} {
7502        save_position
7503        set cmd [lindex $history $historyindex]
7504        incr historyindex
7505        godo $cmd
7506        .tf.bar.leftbut conf -state normal
7507    }
7508    if {$historyindex >= [llength $history]} {
7509        .tf.bar.rightbut conf -state disabled
7510    }
7511}
7512
7513proc go_to_parent {i} {
7514    global parents curview targetid
7515    set ps $parents($curview,$targetid)
7516    if {[llength $ps] >= $i} {
7517        selbyid [lindex $ps [expr $i - 1]]
7518    }
7519}
7520
7521proc gettree {id} {
7522    global treefilelist treeidlist diffids diffmergeid treepending
7523    global nullid nullid2
7524
7525    set diffids $id
7526    catch {unset diffmergeid}
7527    if {![info exists treefilelist($id)]} {
7528        if {![info exists treepending]} {
7529            if {$id eq $nullid} {
7530                set cmd [list | git ls-files]
7531            } elseif {$id eq $nullid2} {
7532                set cmd [list | git ls-files --stage -t]
7533            } else {
7534                set cmd [list | git ls-tree -r $id]
7535            }
7536            if {[catch {set gtf [open $cmd r]}]} {
7537                return
7538            }
7539            set treepending $id
7540            set treefilelist($id) {}
7541            set treeidlist($id) {}
7542            fconfigure $gtf -blocking 0 -encoding binary
7543            filerun $gtf [list gettreeline $gtf $id]
7544        }
7545    } else {
7546        setfilelist $id
7547    }
7548}
7549
7550proc gettreeline {gtf id} {
7551    global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7552
7553    set nl 0
7554    while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7555        if {$diffids eq $nullid} {
7556            set fname $line
7557        } else {
7558            set i [string first "\t" $line]
7559            if {$i < 0} continue
7560            set fname [string range $line [expr {$i+1}] end]
7561            set line [string range $line 0 [expr {$i-1}]]
7562            if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7563            set sha1 [lindex $line 2]
7564            lappend treeidlist($id) $sha1
7565        }
7566        if {[string index $fname 0] eq "\""} {
7567            set fname [lindex $fname 0]
7568        }
7569        set fname [encoding convertfrom $fname]
7570        lappend treefilelist($id) $fname
7571    }
7572    if {![eof $gtf]} {
7573        return [expr {$nl >= 1000? 2: 1}]
7574    }
7575    close $gtf
7576    unset treepending
7577    if {$cmitmode ne "tree"} {
7578        if {![info exists diffmergeid]} {
7579            gettreediffs $diffids
7580        }
7581    } elseif {$id ne $diffids} {
7582        gettree $diffids
7583    } else {
7584        setfilelist $id
7585    }
7586    return 0
7587}
7588
7589proc showfile {f} {
7590    global treefilelist treeidlist diffids nullid nullid2
7591    global ctext_file_names ctext_file_lines
7592    global ctext commentend
7593
7594    set i [lsearch -exact $treefilelist($diffids) $f]
7595    if {$i < 0} {
7596        puts "oops, $f not in list for id $diffids"
7597        return
7598    }
7599    if {$diffids eq $nullid} {
7600        if {[catch {set bf [open $f r]} err]} {
7601            puts "oops, can't read $f: $err"
7602            return
7603        }
7604    } else {
7605        set blob [lindex $treeidlist($diffids) $i]
7606        if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
7607            puts "oops, error reading blob $blob: $err"
7608            return
7609        }
7610    }
7611    fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7612    filerun $bf [list getblobline $bf $diffids]
7613    $ctext config -state normal
7614    clear_ctext $commentend
7615    lappend ctext_file_names $f
7616    lappend ctext_file_lines [lindex [split $commentend "."] 0]
7617    $ctext insert end "\n"
7618    $ctext insert end "$f\n" filesep
7619    $ctext config -state disabled
7620    $ctext yview $commentend
7621    settabs 0
7622}
7623
7624proc getblobline {bf id} {
7625    global diffids cmitmode ctext
7626
7627    if {$id ne $diffids || $cmitmode ne "tree"} {
7628        catch {close $bf}
7629        return 0
7630    }
7631    $ctext config -state normal
7632    set nl 0
7633    while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7634        $ctext insert end "$line\n"
7635    }
7636    if {[eof $bf]} {
7637        global jump_to_here ctext_file_names commentend
7638
7639        # delete last newline
7640        $ctext delete "end - 2c" "end - 1c"
7641        close $bf
7642        if {$jump_to_here ne {} &&
7643            [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7644            set lnum [expr {[lindex $jump_to_here 1] +
7645                            [lindex [split $commentend .] 0]}]
7646            mark_ctext_line $lnum
7647        }
7648        $ctext config -state disabled
7649        return 0
7650    }
7651    $ctext config -state disabled
7652    return [expr {$nl >= 1000? 2: 1}]
7653}
7654
7655proc mark_ctext_line {lnum} {
7656    global ctext markbgcolor
7657
7658    $ctext tag delete omark
7659    $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7660    $ctext tag conf omark -background $markbgcolor
7661    $ctext see $lnum.0
7662}
7663
7664proc mergediff {id} {
7665    global diffmergeid
7666    global diffids treediffs
7667    global parents curview
7668
7669    set diffmergeid $id
7670    set diffids $id
7671    set treediffs($id) {}
7672    set np [llength $parents($curview,$id)]
7673    settabs $np
7674    getblobdiffs $id
7675}
7676
7677proc startdiff {ids} {
7678    global treediffs diffids treepending diffmergeid nullid nullid2
7679
7680    settabs 1
7681    set diffids $ids
7682    catch {unset diffmergeid}
7683    if {![info exists treediffs($ids)] ||
7684        [lsearch -exact $ids $nullid] >= 0 ||
7685        [lsearch -exact $ids $nullid2] >= 0} {
7686        if {![info exists treepending]} {
7687            gettreediffs $ids
7688        }
7689    } else {
7690        addtocflist $ids
7691    }
7692}
7693
7694proc showinlinediff {ids} {
7695    global commitinfo commitdata ctext
7696    global treediffs
7697
7698    set info $commitinfo($ids)
7699    set diff [lindex $info 7]
7700    set difflines [split $diff "\n"]
7701
7702    initblobdiffvars
7703    set treediff {}
7704
7705    set inhdr 0
7706    foreach line $difflines {
7707        if {![string compare -length 5 "diff " $line]} {
7708            set inhdr 1
7709        } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7710            # offset also accounts for the b/ prefix
7711            lappend treediff [string range $line 6 end]
7712            set inhdr 0
7713        }
7714    }
7715
7716    set treediffs($ids) $treediff
7717    add_flist $treediff
7718
7719    $ctext conf -state normal
7720    foreach line $difflines {
7721        parseblobdiffline $ids $line
7722    }
7723    maybe_scroll_ctext 1
7724    $ctext conf -state disabled
7725}
7726
7727# If the filename (name) is under any of the passed filter paths
7728# then return true to include the file in the listing.
7729proc path_filter {filter name} {
7730    set worktree [gitworktree]
7731    foreach p $filter {
7732        set fq_p [file normalize $p]
7733        set fq_n [file normalize [file join $worktree $name]]
7734        if {[string match [file normalize $fq_p]* $fq_n]} {
7735            return 1
7736        }
7737    }
7738    return 0
7739}
7740
7741proc addtocflist {ids} {
7742    global treediffs
7743
7744    add_flist $treediffs($ids)
7745    getblobdiffs $ids
7746}
7747
7748proc diffcmd {ids flags} {
7749    global log_showroot nullid nullid2 git_version
7750
7751    set i [lsearch -exact $ids $nullid]
7752    set j [lsearch -exact $ids $nullid2]
7753    if {$i >= 0} {
7754        if {[llength $ids] > 1 && $j < 0} {
7755            # comparing working directory with some specific revision
7756            set cmd [concat | git diff-index $flags]
7757            if {$i == 0} {
7758                lappend cmd -R [lindex $ids 1]
7759            } else {
7760                lappend cmd [lindex $ids 0]
7761            }
7762        } else {
7763            # comparing working directory with index
7764            set cmd [concat | git diff-files $flags]
7765            if {$j == 1} {
7766                lappend cmd -R
7767            }
7768        }
7769    } elseif {$j >= 0} {
7770        if {[package vcompare $git_version "1.7.2"] >= 0} {
7771            set flags "$flags --ignore-submodules=dirty"
7772        }
7773        set cmd [concat | git diff-index --cached $flags]
7774        if {[llength $ids] > 1} {
7775            # comparing index with specific revision
7776            if {$j == 0} {
7777                lappend cmd -R [lindex $ids 1]
7778            } else {
7779                lappend cmd [lindex $ids 0]
7780            }
7781        } else {
7782            # comparing index with HEAD
7783            lappend cmd HEAD
7784        }
7785    } else {
7786        if {$log_showroot} {
7787            lappend flags --root
7788        }
7789        set cmd [concat | git diff-tree -r $flags $ids]
7790    }
7791    return $cmd
7792}
7793
7794proc gettreediffs {ids} {
7795    global treediff treepending limitdiffs vfilelimit curview
7796
7797    set cmd [diffcmd $ids {--no-commit-id}]
7798    if {$limitdiffs && $vfilelimit($curview) ne {}} {
7799            set cmd [concat $cmd -- $vfilelimit($curview)]
7800    }
7801    if {[catch {set gdtf [open $cmd r]}]} return
7802
7803    set treepending $ids
7804    set treediff {}
7805    fconfigure $gdtf -blocking 0 -encoding binary
7806    filerun $gdtf [list gettreediffline $gdtf $ids]
7807}
7808
7809proc gettreediffline {gdtf ids} {
7810    global treediff treediffs treepending diffids diffmergeid
7811    global cmitmode vfilelimit curview limitdiffs perfile_attrs
7812
7813    set nr 0
7814    set sublist {}
7815    set max 1000
7816    if {$perfile_attrs} {
7817        # cache_gitattr is slow, and even slower on win32 where we
7818        # have to invoke it for only about 30 paths at a time
7819        set max 500
7820        if {[tk windowingsystem] == "win32"} {
7821            set max 120
7822        }
7823    }
7824    while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
7825        set i [string first "\t" $line]
7826        if {$i >= 0} {
7827            set file [string range $line [expr {$i+1}] end]
7828            if {[string index $file 0] eq "\""} {
7829                set file [lindex $file 0]
7830            }
7831            set file [encoding convertfrom $file]
7832            if {$file ne [lindex $treediff end]} {
7833                lappend treediff $file
7834                lappend sublist $file
7835            }
7836        }
7837    }
7838    if {$perfile_attrs} {
7839        cache_gitattr encoding $sublist
7840    }
7841    if {![eof $gdtf]} {
7842        return [expr {$nr >= $max? 2: 1}]
7843    }
7844    close $gdtf
7845    set treediffs($ids) $treediff
7846    unset treepending
7847    if {$cmitmode eq "tree" && [llength $diffids] == 1} {
7848        gettree $diffids
7849    } elseif {$ids != $diffids} {
7850        if {![info exists diffmergeid]} {
7851            gettreediffs $diffids
7852        }
7853    } else {
7854        addtocflist $ids
7855    }
7856    return 0
7857}
7858
7859# empty string or positive integer
7860proc diffcontextvalidate {v} {
7861    return [regexp {^(|[1-9][0-9]*)$} $v]
7862}
7863
7864proc diffcontextchange {n1 n2 op} {
7865    global diffcontextstring diffcontext
7866
7867    if {[string is integer -strict $diffcontextstring]} {
7868        if {$diffcontextstring >= 0} {
7869            set diffcontext $diffcontextstring
7870            reselectline
7871        }
7872    }
7873}
7874
7875proc changeignorespace {} {
7876    reselectline
7877}
7878
7879proc changeworddiff {name ix op} {
7880    reselectline
7881}
7882
7883proc initblobdiffvars {} {
7884    global diffencoding targetline diffnparents
7885    global diffinhdr currdiffsubmod diffseehere
7886    set targetline {}
7887    set diffnparents 0
7888    set diffinhdr 0
7889    set diffencoding [get_path_encoding {}]
7890    set currdiffsubmod ""
7891    set diffseehere -1
7892}
7893
7894proc getblobdiffs {ids} {
7895    global blobdifffd diffids env
7896    global treediffs
7897    global diffcontext
7898    global ignorespace
7899    global worddiff
7900    global limitdiffs vfilelimit curview
7901    global git_version
7902
7903    set textconv {}
7904    if {[package vcompare $git_version "1.6.1"] >= 0} {
7905        set textconv "--textconv"
7906    }
7907    set submodule {}
7908    if {[package vcompare $git_version "1.6.6"] >= 0} {
7909        set submodule "--submodule"
7910    }
7911    set cmd [diffcmd $ids "-p $textconv $submodule  -C --cc --no-commit-id -U$diffcontext"]
7912    if {$ignorespace} {
7913        append cmd " -w"
7914    }
7915    if {$worddiff ne [mc "Line diff"]} {
7916        append cmd " --word-diff=porcelain"
7917    }
7918    if {$limitdiffs && $vfilelimit($curview) ne {}} {
7919        set cmd [concat $cmd -- $vfilelimit($curview)]
7920    }
7921    if {[catch {set bdf [open $cmd r]} err]} {
7922        error_popup [mc "Error getting diffs: %s" $err]
7923        return
7924    }
7925    fconfigure $bdf -blocking 0 -encoding binary -eofchar {}
7926    set blobdifffd($ids) $bdf
7927    initblobdiffvars
7928    filerun $bdf [list getblobdiffline $bdf $diffids]
7929}
7930
7931proc savecmitpos {} {
7932    global ctext cmitmode
7933
7934    if {$cmitmode eq "tree"} {
7935        return {}
7936    }
7937    return [list target_scrollpos [$ctext index @0,0]]
7938}
7939
7940proc savectextpos {} {
7941    global ctext
7942
7943    return [list target_scrollpos [$ctext index @0,0]]
7944}
7945
7946proc maybe_scroll_ctext {ateof} {
7947    global ctext target_scrollpos
7948
7949    if {![info exists target_scrollpos]} return
7950    if {!$ateof} {
7951        set nlines [expr {[winfo height $ctext]
7952                          / [font metrics textfont -linespace]}]
7953        if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
7954    }
7955    $ctext yview $target_scrollpos
7956    unset target_scrollpos
7957}
7958
7959proc setinlist {var i val} {
7960    global $var
7961
7962    while {[llength [set $var]] < $i} {
7963        lappend $var {}
7964    }
7965    if {[llength [set $var]] == $i} {
7966        lappend $var $val
7967    } else {
7968        lset $var $i $val
7969    }
7970}
7971
7972proc makediffhdr {fname ids} {
7973    global ctext curdiffstart treediffs diffencoding
7974    global ctext_file_names jump_to_here targetline diffline
7975
7976    set fname [encoding convertfrom $fname]
7977    set diffencoding [get_path_encoding $fname]
7978    set i [lsearch -exact $treediffs($ids) $fname]
7979    if {$i >= 0} {
7980        setinlist difffilestart $i $curdiffstart
7981    }
7982    lset ctext_file_names end $fname
7983    set l [expr {(78 - [string length $fname]) / 2}]
7984    set pad [string range "----------------------------------------" 1 $l]
7985    $ctext insert $curdiffstart "$pad $fname $pad" filesep
7986    set targetline {}
7987    if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
7988        set targetline [lindex $jump_to_here 1]
7989    }
7990    set diffline 0
7991}
7992
7993proc blobdiffmaybeseehere {ateof} {
7994    global diffseehere
7995    if {$diffseehere >= 0} {
7996        mark_ctext_line [lindex [split $diffseehere .] 0]
7997    }
7998    maybe_scroll_ctext $ateof
7999}
8000
8001proc getblobdiffline {bdf ids} {
8002    global diffids blobdifffd
8003    global ctext
8004
8005    set nr 0
8006    $ctext conf -state normal
8007    while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8008        if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8009            catch {close $bdf}
8010            return 0
8011        }
8012        parseblobdiffline $ids $line
8013    }
8014    $ctext conf -state disabled
8015    blobdiffmaybeseehere [eof $bdf]
8016    if {[eof $bdf]} {
8017        catch {close $bdf}
8018        return 0
8019    }
8020    return [expr {$nr >= 1000? 2: 1}]
8021}
8022
8023proc parseblobdiffline {ids line} {
8024    global ctext curdiffstart
8025    global diffnexthead diffnextnote difffilestart
8026    global ctext_file_names ctext_file_lines
8027    global diffinhdr treediffs mergemax diffnparents
8028    global diffencoding jump_to_here targetline diffline currdiffsubmod
8029    global worddiff diffseehere
8030
8031    if {![string compare -length 5 "diff " $line]} {
8032        if {![regexp {^diff (--cc|--git) } $line m type]} {
8033            set line [encoding convertfrom $line]
8034            $ctext insert end "$line\n" hunksep
8035            continue
8036        }
8037        # start of a new file
8038        set diffinhdr 1
8039        $ctext insert end "\n"
8040        set curdiffstart [$ctext index "end - 1c"]
8041        lappend ctext_file_names ""
8042        lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8043        $ctext insert end "\n" filesep
8044
8045        if {$type eq "--cc"} {
8046            # start of a new file in a merge diff
8047            set fname [string range $line 10 end]
8048            if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8049                lappend treediffs($ids) $fname
8050                add_flist [list $fname]
8051            }
8052
8053        } else {
8054            set line [string range $line 11 end]
8055            # If the name hasn't changed the length will be odd,
8056            # the middle char will be a space, and the two bits either
8057            # side will be a/name and b/name, or "a/name" and "b/name".
8058            # If the name has changed we'll get "rename from" and
8059            # "rename to" or "copy from" and "copy to" lines following
8060            # this, and we'll use them to get the filenames.
8061            # This complexity is necessary because spaces in the
8062            # filename(s) don't get escaped.
8063            set l [string length $line]
8064            set i [expr {$l / 2}]
8065            if {!(($l & 1) && [string index $line $i] eq " " &&
8066                  [string range $line 2 [expr {$i - 1}]] eq \
8067                      [string range $line [expr {$i + 3}] end])} {
8068                return
8069            }
8070            # unescape if quoted and chop off the a/ from the front
8071            if {[string index $line 0] eq "\""} {
8072                set fname [string range [lindex $line 0] 2 end]
8073            } else {
8074                set fname [string range $line 2 [expr {$i - 1}]]
8075            }
8076        }
8077        makediffhdr $fname $ids
8078
8079    } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8080        set fname [encoding convertfrom [string range $line 16 end]]
8081        $ctext insert end "\n"
8082        set curdiffstart [$ctext index "end - 1c"]
8083        lappend ctext_file_names $fname
8084        lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8085        $ctext insert end "$line\n" filesep
8086        set i [lsearch -exact $treediffs($ids) $fname]
8087        if {$i >= 0} {
8088            setinlist difffilestart $i $curdiffstart
8089        }
8090
8091    } elseif {![string compare -length 2 "@@" $line]} {
8092        regexp {^@@+} $line ats
8093        set line [encoding convertfrom $diffencoding $line]
8094        $ctext insert end "$line\n" hunksep
8095        if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8096            set diffline $nl
8097        }
8098        set diffnparents [expr {[string length $ats] - 1}]
8099        set diffinhdr 0
8100
8101    } elseif {![string compare -length 10 "Submodule " $line]} {
8102        # start of a new submodule
8103        if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8104            set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8105        } else {
8106            set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8107        }
8108        if {$currdiffsubmod != $fname} {
8109            $ctext insert end "\n";     # Add newline after commit message
8110        }
8111        set curdiffstart [$ctext index "end - 1c"]
8112        lappend ctext_file_names ""
8113        if {$currdiffsubmod != $fname} {
8114            lappend ctext_file_lines $fname
8115            makediffhdr $fname $ids
8116            set currdiffsubmod $fname
8117            $ctext insert end "\n$line\n" filesep
8118        } else {
8119            $ctext insert end "$line\n" filesep
8120        }
8121    } elseif {![string compare -length 3 "  >" $line]} {
8122        set $currdiffsubmod ""
8123        set line [encoding convertfrom $diffencoding $line]
8124        $ctext insert end "$line\n" dresult
8125    } elseif {![string compare -length 3 "  <" $line]} {
8126        set $currdiffsubmod ""
8127        set line [encoding convertfrom $diffencoding $line]
8128        $ctext insert end "$line\n" d0
8129    } elseif {$diffinhdr} {
8130        if {![string compare -length 12 "rename from " $line]} {
8131            set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8132            if {[string index $fname 0] eq "\""} {
8133                set fname [lindex $fname 0]
8134            }
8135            set fname [encoding convertfrom $fname]
8136            set i [lsearch -exact $treediffs($ids) $fname]
8137            if {$i >= 0} {
8138                setinlist difffilestart $i $curdiffstart
8139            }
8140        } elseif {![string compare -length 10 $line "rename to "] ||
8141                  ![string compare -length 8 $line "copy to "]} {
8142            set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8143            if {[string index $fname 0] eq "\""} {
8144                set fname [lindex $fname 0]
8145            }
8146            makediffhdr $fname $ids
8147        } elseif {[string compare -length 3 $line "---"] == 0} {
8148            # do nothing
8149            return
8150        } elseif {[string compare -length 3 $line "+++"] == 0} {
8151            set diffinhdr 0
8152            return
8153        }
8154        $ctext insert end "$line\n" filesep
8155
8156    } else {
8157        set line [string map {\x1A ^Z} \
8158                      [encoding convertfrom $diffencoding $line]]
8159        # parse the prefix - one ' ', '-' or '+' for each parent
8160        set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8161        set tag [expr {$diffnparents > 1? "m": "d"}]
8162        set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8163        set words_pre_markup ""
8164        set words_post_markup ""
8165        if {[string trim $prefix " -+"] eq {}} {
8166            # prefix only has " ", "-" and "+" in it: normal diff line
8167            set num [string first "-" $prefix]
8168            if {$dowords} {
8169                set line [string range $line 1 end]
8170            }
8171            if {$num >= 0} {
8172                # removed line, first parent with line is $num
8173                if {$num >= $mergemax} {
8174                    set num "max"
8175                }
8176                if {$dowords && $worddiff eq [mc "Markup words"]} {
8177                    $ctext insert end "\[-$line-\]" $tag$num
8178                } else {
8179                    $ctext insert end "$line" $tag$num
8180                }
8181                if {!$dowords} {
8182                    $ctext insert end "\n" $tag$num
8183                }
8184            } else {
8185                set tags {}
8186                if {[string first "+" $prefix] >= 0} {
8187                    # added line
8188                    lappend tags ${tag}result
8189                    if {$diffnparents > 1} {
8190                        set num [string first " " $prefix]
8191                        if {$num >= 0} {
8192                            if {$num >= $mergemax} {
8193                                set num "max"
8194                            }
8195                            lappend tags m$num
8196                        }
8197                    }
8198                    set words_pre_markup "{+"
8199                    set words_post_markup "+}"
8200                }
8201                if {$targetline ne {}} {
8202                    if {$diffline == $targetline} {
8203                        set diffseehere [$ctext index "end - 1 chars"]
8204                        set targetline {}
8205                    } else {
8206                        incr diffline
8207                    }
8208                }
8209                if {$dowords && $worddiff eq [mc "Markup words"]} {
8210                    $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8211                } else {
8212                    $ctext insert end "$line" $tags
8213                }
8214                if {!$dowords} {
8215                    $ctext insert end "\n" $tags
8216                }
8217            }
8218        } elseif {$dowords && $prefix eq "~"} {
8219            $ctext insert end "\n" {}
8220        } else {
8221            # "\ No newline at end of file",
8222            # or something else we don't recognize
8223            $ctext insert end "$line\n" hunksep
8224        }
8225    }
8226}
8227
8228proc changediffdisp {} {
8229    global ctext diffelide
8230
8231    $ctext tag conf d0 -elide [lindex $diffelide 0]
8232    $ctext tag conf dresult -elide [lindex $diffelide 1]
8233}
8234
8235proc highlightfile {cline} {
8236    global cflist cflist_top
8237
8238    if {![info exists cflist_top]} return
8239
8240    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8241    $cflist tag add highlight $cline.0 "$cline.0 lineend"
8242    $cflist see $cline.0
8243    set cflist_top $cline
8244}
8245
8246proc highlightfile_for_scrollpos {topidx} {
8247    global cmitmode difffilestart
8248
8249    if {$cmitmode eq "tree"} return
8250    if {![info exists difffilestart]} return
8251
8252    set top [lindex [split $topidx .] 0]
8253    if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8254        highlightfile 0
8255    } else {
8256        highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8257    }
8258}
8259
8260proc prevfile {} {
8261    global difffilestart ctext cmitmode
8262
8263    if {$cmitmode eq "tree"} return
8264    set prev 0.0
8265    set here [$ctext index @0,0]
8266    foreach loc $difffilestart {
8267        if {[$ctext compare $loc >= $here]} {
8268            $ctext yview $prev
8269            return
8270        }
8271        set prev $loc
8272    }
8273    $ctext yview $prev
8274}
8275
8276proc nextfile {} {
8277    global difffilestart ctext cmitmode
8278
8279    if {$cmitmode eq "tree"} return
8280    set here [$ctext index @0,0]
8281    foreach loc $difffilestart {
8282        if {[$ctext compare $loc > $here]} {
8283            $ctext yview $loc
8284            return
8285        }
8286    }
8287}
8288
8289proc clear_ctext {{first 1.0}} {
8290    global ctext smarktop smarkbot
8291    global ctext_file_names ctext_file_lines
8292    global pendinglinks
8293
8294    set l [lindex [split $first .] 0]
8295    if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8296        set smarktop $l
8297    }
8298    if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8299        set smarkbot $l
8300    }
8301    $ctext delete $first end
8302    if {$first eq "1.0"} {
8303        catch {unset pendinglinks}
8304    }
8305    set ctext_file_names {}
8306    set ctext_file_lines {}
8307}
8308
8309proc settabs {{firstab {}}} {
8310    global firsttabstop tabstop ctext have_tk85
8311
8312    if {$firstab ne {} && $have_tk85} {
8313        set firsttabstop $firstab
8314    }
8315    set w [font measure textfont "0"]
8316    if {$firsttabstop != 0} {
8317        $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8318                               [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8319    } elseif {$have_tk85 || $tabstop != 8} {
8320        $ctext conf -tabs [expr {$tabstop * $w}]
8321    } else {
8322        $ctext conf -tabs {}
8323    }
8324}
8325
8326proc incrsearch {name ix op} {
8327    global ctext searchstring searchdirn
8328
8329    if {[catch {$ctext index anchor}]} {
8330        # no anchor set, use start of selection, or of visible area
8331        set sel [$ctext tag ranges sel]
8332        if {$sel ne {}} {
8333            $ctext mark set anchor [lindex $sel 0]
8334        } elseif {$searchdirn eq "-forwards"} {
8335            $ctext mark set anchor @0,0
8336        } else {
8337            $ctext mark set anchor @0,[winfo height $ctext]
8338        }
8339    }
8340    if {$searchstring ne {}} {
8341        set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8342        if {$here ne {}} {
8343            $ctext see $here
8344            set mend "$here + $mlen c"
8345            $ctext tag remove sel 1.0 end
8346            $ctext tag add sel $here $mend
8347            suppress_highlighting_file_for_current_scrollpos
8348            highlightfile_for_scrollpos $here
8349        }
8350    }
8351    rehighlight_search_results
8352}
8353
8354proc dosearch {} {
8355    global sstring ctext searchstring searchdirn
8356
8357    focus $sstring
8358    $sstring icursor end
8359    set searchdirn -forwards
8360    if {$searchstring ne {}} {
8361        set sel [$ctext tag ranges sel]
8362        if {$sel ne {}} {
8363            set start "[lindex $sel 0] + 1c"
8364        } elseif {[catch {set start [$ctext index anchor]}]} {
8365            set start "@0,0"
8366        }
8367        set match [$ctext search -count mlen -- $searchstring $start]
8368        $ctext tag remove sel 1.0 end
8369        if {$match eq {}} {
8370            bell
8371            return
8372        }
8373        $ctext see $match
8374        suppress_highlighting_file_for_current_scrollpos
8375        highlightfile_for_scrollpos $match
8376        set mend "$match + $mlen c"
8377        $ctext tag add sel $match $mend
8378        $ctext mark unset anchor
8379        rehighlight_search_results
8380    }
8381}
8382
8383proc dosearchback {} {
8384    global sstring ctext searchstring searchdirn
8385
8386    focus $sstring
8387    $sstring icursor end
8388    set searchdirn -backwards
8389    if {$searchstring ne {}} {
8390        set sel [$ctext tag ranges sel]
8391        if {$sel ne {}} {
8392            set start [lindex $sel 0]
8393        } elseif {[catch {set start [$ctext index anchor]}]} {
8394            set start @0,[winfo height $ctext]
8395        }
8396        set match [$ctext search -backwards -count ml -- $searchstring $start]
8397        $ctext tag remove sel 1.0 end
8398        if {$match eq {}} {
8399            bell
8400            return
8401        }
8402        $ctext see $match
8403        suppress_highlighting_file_for_current_scrollpos
8404        highlightfile_for_scrollpos $match
8405        set mend "$match + $ml c"
8406        $ctext tag add sel $match $mend
8407        $ctext mark unset anchor
8408        rehighlight_search_results
8409    }
8410}
8411
8412proc rehighlight_search_results {} {
8413    global ctext searchstring
8414
8415    $ctext tag remove found 1.0 end
8416    $ctext tag remove currentsearchhit 1.0 end
8417
8418    if {$searchstring ne {}} {
8419        searchmarkvisible 1
8420    }
8421}
8422
8423proc searchmark {first last} {
8424    global ctext searchstring
8425
8426    set sel [$ctext tag ranges sel]
8427
8428    set mend $first.0
8429    while {1} {
8430        set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8431        if {$match eq {}} break
8432        set mend "$match + $mlen c"
8433        if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8434            $ctext tag add currentsearchhit $match $mend
8435        } else {
8436            $ctext tag add found $match $mend
8437        }
8438    }
8439}
8440
8441proc searchmarkvisible {doall} {
8442    global ctext smarktop smarkbot
8443
8444    set topline [lindex [split [$ctext index @0,0] .] 0]
8445    set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8446    if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8447        # no overlap with previous
8448        searchmark $topline $botline
8449        set smarktop $topline
8450        set smarkbot $botline
8451    } else {
8452        if {$topline < $smarktop} {
8453            searchmark $topline [expr {$smarktop-1}]
8454            set smarktop $topline
8455        }
8456        if {$botline > $smarkbot} {
8457            searchmark [expr {$smarkbot+1}] $botline
8458            set smarkbot $botline
8459        }
8460    }
8461}
8462
8463proc suppress_highlighting_file_for_current_scrollpos {} {
8464    global ctext suppress_highlighting_file_for_this_scrollpos
8465
8466    set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8467}
8468
8469proc scrolltext {f0 f1} {
8470    global searchstring cmitmode ctext
8471    global suppress_highlighting_file_for_this_scrollpos
8472
8473    set topidx [$ctext index @0,0]
8474    if {![info exists suppress_highlighting_file_for_this_scrollpos]
8475        || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8476        highlightfile_for_scrollpos $topidx
8477    }
8478
8479    catch {unset suppress_highlighting_file_for_this_scrollpos}
8480
8481    .bleft.bottom.sb set $f0 $f1
8482    if {$searchstring ne {}} {
8483        searchmarkvisible 0
8484    }
8485}
8486
8487proc setcoords {} {
8488    global linespc charspc canvx0 canvy0
8489    global xspc1 xspc2 lthickness
8490
8491    set linespc [font metrics mainfont -linespace]
8492    set charspc [font measure mainfont "m"]
8493    set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8494    set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8495    set lthickness [expr {int($linespc / 9) + 1}]
8496    set xspc1(0) $linespc
8497    set xspc2 $linespc
8498}
8499
8500proc redisplay {} {
8501    global canv
8502    global selectedline
8503
8504    set ymax [lindex [$canv cget -scrollregion] 3]
8505    if {$ymax eq {} || $ymax == 0} return
8506    set span [$canv yview]
8507    clear_display
8508    setcanvscroll
8509    allcanvs yview moveto [lindex $span 0]
8510    drawvisible
8511    if {$selectedline ne {}} {
8512        selectline $selectedline 0
8513        allcanvs yview moveto [lindex $span 0]
8514    }
8515}
8516
8517proc parsefont {f n} {
8518    global fontattr
8519
8520    set fontattr($f,family) [lindex $n 0]
8521    set s [lindex $n 1]
8522    if {$s eq {} || $s == 0} {
8523        set s 10
8524    } elseif {$s < 0} {
8525        set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8526    }
8527    set fontattr($f,size) $s
8528    set fontattr($f,weight) normal
8529    set fontattr($f,slant) roman
8530    foreach style [lrange $n 2 end] {
8531        switch -- $style {
8532            "normal" -
8533            "bold"   {set fontattr($f,weight) $style}
8534            "roman" -
8535            "italic" {set fontattr($f,slant) $style}
8536        }
8537    }
8538}
8539
8540proc fontflags {f {isbold 0}} {
8541    global fontattr
8542
8543    return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8544                -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8545                -slant $fontattr($f,slant)]
8546}
8547
8548proc fontname {f} {
8549    global fontattr
8550
8551    set n [list $fontattr($f,family) $fontattr($f,size)]
8552    if {$fontattr($f,weight) eq "bold"} {
8553        lappend n "bold"
8554    }
8555    if {$fontattr($f,slant) eq "italic"} {
8556        lappend n "italic"
8557    }
8558    return $n
8559}
8560
8561proc incrfont {inc} {
8562    global mainfont textfont ctext canv cflist showrefstop
8563    global stopped entries fontattr
8564
8565    unmarkmatches
8566    set s $fontattr(mainfont,size)
8567    incr s $inc
8568    if {$s < 1} {
8569        set s 1
8570    }
8571    set fontattr(mainfont,size) $s
8572    font config mainfont -size $s
8573    font config mainfontbold -size $s
8574    set mainfont [fontname mainfont]
8575    set s $fontattr(textfont,size)
8576    incr s $inc
8577    if {$s < 1} {
8578        set s 1
8579    }
8580    set fontattr(textfont,size) $s
8581    font config textfont -size $s
8582    font config textfontbold -size $s
8583    set textfont [fontname textfont]
8584    setcoords
8585    settabs
8586    redisplay
8587}
8588
8589proc clearsha1 {} {
8590    global sha1entry sha1string
8591    if {[string length $sha1string] == 40} {
8592        $sha1entry delete 0 end
8593    }
8594}
8595
8596proc sha1change {n1 n2 op} {
8597    global sha1string currentid sha1but
8598    if {$sha1string == {}
8599        || ([info exists currentid] && $sha1string == $currentid)} {
8600        set state disabled
8601    } else {
8602        set state normal
8603    }
8604    if {[$sha1but cget -state] == $state} return
8605    if {$state == "normal"} {
8606        $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
8607    } else {
8608        $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
8609    }
8610}
8611
8612proc gotocommit {} {
8613    global sha1string tagids headids curview varcid
8614
8615    if {$sha1string == {}
8616        || ([info exists currentid] && $sha1string == $currentid)} return
8617    if {[info exists tagids($sha1string)]} {
8618        set id $tagids($sha1string)
8619    } elseif {[info exists headids($sha1string)]} {
8620        set id $headids($sha1string)
8621    } else {
8622        set id [string tolower $sha1string]
8623        if {[regexp {^[0-9a-f]{4,39}$} $id]} {
8624            set matches [longid $id]
8625            if {$matches ne {}} {
8626                if {[llength $matches] > 1} {
8627                    error_popup [mc "Short SHA1 id %s is ambiguous" $id]
8628                    return
8629                }
8630                set id [lindex $matches 0]
8631            }
8632        } else {
8633            if {[catch {set id [exec git rev-parse --verify $sha1string]}]} {
8634                error_popup [mc "Revision %s is not known" $sha1string]
8635                return
8636            }
8637        }
8638    }
8639    if {[commitinview $id $curview]} {
8640        selectline [rowofcommit $id] 1
8641        return
8642    }
8643    if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8644        set msg [mc "SHA1 id %s is not known" $sha1string]
8645    } else {
8646        set msg [mc "Revision %s is not in the current view" $sha1string]
8647    }
8648    error_popup $msg
8649}
8650
8651proc lineenter {x y id} {
8652    global hoverx hovery hoverid hovertimer
8653    global commitinfo canv
8654
8655    if {![info exists commitinfo($id)] && ![getcommit $id]} return
8656    set hoverx $x
8657    set hovery $y
8658    set hoverid $id
8659    if {[info exists hovertimer]} {
8660        after cancel $hovertimer
8661    }
8662    set hovertimer [after 500 linehover]
8663    $canv delete hover
8664}
8665
8666proc linemotion {x y id} {
8667    global hoverx hovery hoverid hovertimer
8668
8669    if {[info exists hoverid] && $id == $hoverid} {
8670        set hoverx $x
8671        set hovery $y
8672        if {[info exists hovertimer]} {
8673            after cancel $hovertimer
8674        }
8675        set hovertimer [after 500 linehover]
8676    }
8677}
8678
8679proc lineleave {id} {
8680    global hoverid hovertimer canv
8681
8682    if {[info exists hoverid] && $id == $hoverid} {
8683        $canv delete hover
8684        if {[info exists hovertimer]} {
8685            after cancel $hovertimer
8686            unset hovertimer
8687        }
8688        unset hoverid
8689    }
8690}
8691
8692proc linehover {} {
8693    global hoverx hovery hoverid hovertimer
8694    global canv linespc lthickness
8695    global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8696
8697    global commitinfo
8698
8699    set text [lindex $commitinfo($hoverid) 0]
8700    set ymax [lindex [$canv cget -scrollregion] 3]
8701    if {$ymax == {}} return
8702    set yfrac [lindex [$canv yview] 0]
8703    set x [expr {$hoverx + 2 * $linespc}]
8704    set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8705    set x0 [expr {$x - 2 * $lthickness}]
8706    set y0 [expr {$y - 2 * $lthickness}]
8707    set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8708    set y1 [expr {$y + $linespc + 2 * $lthickness}]
8709    set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8710               -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8711               -width 1 -tags hover]
8712    $canv raise $t
8713    set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8714               -font mainfont -fill $linehoverfgcolor]
8715    $canv raise $t
8716}
8717
8718proc clickisonarrow {id y} {
8719    global lthickness
8720
8721    set ranges [rowranges $id]
8722    set thresh [expr {2 * $lthickness + 6}]
8723    set n [expr {[llength $ranges] - 1}]
8724    for {set i 1} {$i < $n} {incr i} {
8725        set row [lindex $ranges $i]
8726        if {abs([yc $row] - $y) < $thresh} {
8727            return $i
8728        }
8729    }
8730    return {}
8731}
8732
8733proc arrowjump {id n y} {
8734    global canv
8735
8736    # 1 <-> 2, 3 <-> 4, etc...
8737    set n [expr {(($n - 1) ^ 1) + 1}]
8738    set row [lindex [rowranges $id] $n]
8739    set yt [yc $row]
8740    set ymax [lindex [$canv cget -scrollregion] 3]
8741    if {$ymax eq {} || $ymax <= 0} return
8742    set view [$canv yview]
8743    set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
8744    set yfrac [expr {$yt / $ymax - $yspan / 2}]
8745    if {$yfrac < 0} {
8746        set yfrac 0
8747    }
8748    allcanvs yview moveto $yfrac
8749}
8750
8751proc lineclick {x y id isnew} {
8752    global ctext commitinfo children canv thickerline curview
8753
8754    if {![info exists commitinfo($id)] && ![getcommit $id]} return
8755    unmarkmatches
8756    unselectline
8757    normalline
8758    $canv delete hover
8759    # draw this line thicker than normal
8760    set thickerline $id
8761    drawlines $id
8762    if {$isnew} {
8763        set ymax [lindex [$canv cget -scrollregion] 3]
8764        if {$ymax eq {}} return
8765        set yfrac [lindex [$canv yview] 0]
8766        set y [expr {$y + $yfrac * $ymax}]
8767    }
8768    set dirn [clickisonarrow $id $y]
8769    if {$dirn ne {}} {
8770        arrowjump $id $dirn $y
8771        return
8772    }
8773
8774    if {$isnew} {
8775        addtohistory [list lineclick $x $y $id 0] savectextpos
8776    }
8777    # fill the details pane with info about this line
8778    $ctext conf -state normal
8779    clear_ctext
8780    settabs 0
8781    $ctext insert end "[mc "Parent"]:\t"
8782    $ctext insert end $id link0
8783    setlink $id link0
8784    set info $commitinfo($id)
8785    $ctext insert end "\n\t[lindex $info 0]\n"
8786    $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
8787    set date [formatdate [lindex $info 2]]
8788    $ctext insert end "\t[mc "Date"]:\t$date\n"
8789    set kids $children($curview,$id)
8790    if {$kids ne {}} {
8791        $ctext insert end "\n[mc "Children"]:"
8792        set i 0
8793        foreach child $kids {
8794            incr i
8795            if {![info exists commitinfo($child)] && ![getcommit $child]} continue
8796            set info $commitinfo($child)
8797            $ctext insert end "\n\t"
8798            $ctext insert end $child link$i
8799            setlink $child link$i
8800            $ctext insert end "\n\t[lindex $info 0]"
8801            $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
8802            set date [formatdate [lindex $info 2]]
8803            $ctext insert end "\n\t[mc "Date"]:\t$date\n"
8804        }
8805    }
8806    maybe_scroll_ctext 1
8807    $ctext conf -state disabled
8808    init_flist {}
8809}
8810
8811proc normalline {} {
8812    global thickerline
8813    if {[info exists thickerline]} {
8814        set id $thickerline
8815        unset thickerline
8816        drawlines $id
8817    }
8818}
8819
8820proc selbyid {id {isnew 1}} {
8821    global curview
8822    if {[commitinview $id $curview]} {
8823        selectline [rowofcommit $id] $isnew
8824    }
8825}
8826
8827proc mstime {} {
8828    global startmstime
8829    if {![info exists startmstime]} {
8830        set startmstime [clock clicks -milliseconds]
8831    }
8832    return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
8833}
8834
8835proc rowmenu {x y id} {
8836    global rowctxmenu selectedline rowmenuid curview
8837    global nullid nullid2 fakerowmenu mainhead markedid
8838
8839    stopfinding
8840    set rowmenuid $id
8841    if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
8842        set state disabled
8843    } else {
8844        set state normal
8845    }
8846    if {[info exists markedid] && $markedid ne $id} {
8847        set mstate normal
8848    } else {
8849        set mstate disabled
8850    }
8851    if {$id ne $nullid && $id ne $nullid2} {
8852        set menu $rowctxmenu
8853        if {$mainhead ne {}} {
8854            $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead] -state normal
8855        } else {
8856            $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
8857        }
8858        $menu entryconfigure 9 -state $mstate
8859        $menu entryconfigure 10 -state $mstate
8860        $menu entryconfigure 11 -state $mstate
8861    } else {
8862        set menu $fakerowmenu
8863    }
8864    $menu entryconfigure [mca "Diff this -> selected"] -state $state
8865    $menu entryconfigure [mca "Diff selected -> this"] -state $state
8866    $menu entryconfigure [mca "Make patch"] -state $state
8867    $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
8868    $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
8869    tk_popup $menu $x $y
8870}
8871
8872proc markhere {} {
8873    global rowmenuid markedid canv
8874
8875    set markedid $rowmenuid
8876    make_idmark $markedid
8877}
8878
8879proc gotomark {} {
8880    global markedid
8881
8882    if {[info exists markedid]} {
8883        selbyid $markedid
8884    }
8885}
8886
8887proc replace_by_kids {l r} {
8888    global curview children
8889
8890    set id [commitonrow $r]
8891    set l [lreplace $l 0 0]
8892    foreach kid $children($curview,$id) {
8893        lappend l [rowofcommit $kid]
8894    }
8895    return [lsort -integer -decreasing -unique $l]
8896}
8897
8898proc find_common_desc {} {
8899    global markedid rowmenuid curview children
8900
8901    if {![info exists markedid]} return
8902    if {![commitinview $markedid $curview] ||
8903        ![commitinview $rowmenuid $curview]} return
8904    #set t1 [clock clicks -milliseconds]
8905    set l1 [list [rowofcommit $markedid]]
8906    set l2 [list [rowofcommit $rowmenuid]]
8907    while 1 {
8908        set r1 [lindex $l1 0]
8909        set r2 [lindex $l2 0]
8910        if {$r1 eq {} || $r2 eq {}} break
8911        if {$r1 == $r2} {
8912            selectline $r1 1
8913            break
8914        }
8915        if {$r1 > $r2} {
8916            set l1 [replace_by_kids $l1 $r1]
8917        } else {
8918            set l2 [replace_by_kids $l2 $r2]
8919        }
8920    }
8921    #set t2 [clock clicks -milliseconds]
8922    #puts "took [expr {$t2-$t1}]ms"
8923}
8924
8925proc compare_commits {} {
8926    global markedid rowmenuid curview children
8927
8928    if {![info exists markedid]} return
8929    if {![commitinview $markedid $curview]} return
8930    addtohistory [list do_cmp_commits $markedid $rowmenuid]
8931    do_cmp_commits $markedid $rowmenuid
8932}
8933
8934proc getpatchid {id} {
8935    global patchids
8936
8937    if {![info exists patchids($id)]} {
8938        set cmd [diffcmd [list $id] {-p --root}]
8939        # trim off the initial "|"
8940        set cmd [lrange $cmd 1 end]
8941        if {[catch {
8942            set x [eval exec $cmd | git patch-id]
8943            set patchids($id) [lindex $x 0]
8944        }]} {
8945            set patchids($id) "error"
8946        }
8947    }
8948    return $patchids($id)
8949}
8950
8951proc do_cmp_commits {a b} {
8952    global ctext curview parents children patchids commitinfo
8953
8954    $ctext conf -state normal
8955    clear_ctext
8956    init_flist {}
8957    for {set i 0} {$i < 100} {incr i} {
8958        set skipa 0
8959        set skipb 0
8960        if {[llength $parents($curview,$a)] > 1} {
8961            appendshortlink $a [mc "Skipping merge commit "] "\n"
8962            set skipa 1
8963        } else {
8964            set patcha [getpatchid $a]
8965        }
8966        if {[llength $parents($curview,$b)] > 1} {
8967            appendshortlink $b [mc "Skipping merge commit "] "\n"
8968            set skipb 1
8969        } else {
8970            set patchb [getpatchid $b]
8971        }
8972        if {!$skipa && !$skipb} {
8973            set heada [lindex $commitinfo($a) 0]
8974            set headb [lindex $commitinfo($b) 0]
8975            if {$patcha eq "error"} {
8976                appendshortlink $a [mc "Error getting patch ID for "] \
8977                    [mc " - stopping\n"]
8978                break
8979            }
8980            if {$patchb eq "error"} {
8981                appendshortlink $b [mc "Error getting patch ID for "] \
8982                    [mc " - stopping\n"]
8983                break
8984            }
8985            if {$patcha eq $patchb} {
8986                if {$heada eq $headb} {
8987                    appendshortlink $a [mc "Commit "]
8988                    appendshortlink $b " == " "  $heada\n"
8989                } else {
8990                    appendshortlink $a [mc "Commit "] "  $heada\n"
8991                    appendshortlink $b [mc " is the same patch as\n       "] \
8992                        "  $headb\n"
8993                }
8994                set skipa 1
8995                set skipb 1
8996            } else {
8997                $ctext insert end "\n"
8998                appendshortlink $a [mc "Commit "] "  $heada\n"
8999                appendshortlink $b [mc " differs from\n       "] \
9000                    "  $headb\n"
9001                $ctext insert end [mc "Diff of commits:\n\n"]
9002                $ctext conf -state disabled
9003                update
9004                diffcommits $a $b
9005                return
9006            }
9007        }
9008        if {$skipa} {
9009            set kids [real_children $curview,$a]
9010            if {[llength $kids] != 1} {
9011                $ctext insert end "\n"
9012                appendshortlink $a [mc "Commit "] \
9013                    [mc " has %s children - stopping\n" [llength $kids]]
9014                break
9015            }
9016            set a [lindex $kids 0]
9017        }
9018        if {$skipb} {
9019            set kids [real_children $curview,$b]
9020            if {[llength $kids] != 1} {
9021                appendshortlink $b [mc "Commit "] \
9022                    [mc " has %s children - stopping\n" [llength $kids]]
9023                break
9024            }
9025            set b [lindex $kids 0]
9026        }
9027    }
9028    $ctext conf -state disabled
9029}
9030
9031proc diffcommits {a b} {
9032    global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9033
9034    set tmpdir [gitknewtmpdir]
9035    set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9036    set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9037    if {[catch {
9038        exec git diff-tree -p --pretty $a >$fna
9039        exec git diff-tree -p --pretty $b >$fnb
9040    } err]} {
9041        error_popup [mc "Error writing commit to file: %s" $err]
9042        return
9043    }
9044    if {[catch {
9045        set fd [open "| diff -U$diffcontext $fna $fnb" r]
9046    } err]} {
9047        error_popup [mc "Error diffing commits: %s" $err]
9048        return
9049    }
9050    set diffids [list commits $a $b]
9051    set blobdifffd($diffids) $fd
9052    set diffinhdr 0
9053    set currdiffsubmod ""
9054    filerun $fd [list getblobdiffline $fd $diffids]
9055}
9056
9057proc diffvssel {dirn} {
9058    global rowmenuid selectedline
9059
9060    if {$selectedline eq {}} return
9061    if {$dirn} {
9062        set oldid [commitonrow $selectedline]
9063        set newid $rowmenuid
9064    } else {
9065        set oldid $rowmenuid
9066        set newid [commitonrow $selectedline]
9067    }
9068    addtohistory [list doseldiff $oldid $newid] savectextpos
9069    doseldiff $oldid $newid
9070}
9071
9072proc diffvsmark {dirn} {
9073    global rowmenuid markedid
9074
9075    if {![info exists markedid]} return
9076    if {$dirn} {
9077        set oldid $markedid
9078        set newid $rowmenuid
9079    } else {
9080        set oldid $rowmenuid
9081        set newid $markedid
9082    }
9083    addtohistory [list doseldiff $oldid $newid] savectextpos
9084    doseldiff $oldid $newid
9085}
9086
9087proc doseldiff {oldid newid} {
9088    global ctext
9089    global commitinfo
9090
9091    $ctext conf -state normal
9092    clear_ctext
9093    init_flist [mc "Top"]
9094    $ctext insert end "[mc "From"] "
9095    $ctext insert end $oldid link0
9096    setlink $oldid link0
9097    $ctext insert end "\n     "
9098    $ctext insert end [lindex $commitinfo($oldid) 0]
9099    $ctext insert end "\n\n[mc "To"]   "
9100    $ctext insert end $newid link1
9101    setlink $newid link1
9102    $ctext insert end "\n     "
9103    $ctext insert end [lindex $commitinfo($newid) 0]
9104    $ctext insert end "\n"
9105    $ctext conf -state disabled
9106    $ctext tag remove found 1.0 end
9107    startdiff [list $oldid $newid]
9108}
9109
9110proc mkpatch {} {
9111    global rowmenuid currentid commitinfo patchtop patchnum NS
9112
9113    if {![info exists currentid]} return
9114    set oldid $currentid
9115    set oldhead [lindex $commitinfo($oldid) 0]
9116    set newid $rowmenuid
9117    set newhead [lindex $commitinfo($newid) 0]
9118    set top .patch
9119    set patchtop $top
9120    catch {destroy $top}
9121    ttk_toplevel $top
9122    make_transient $top .
9123    ${NS}::label $top.title -text [mc "Generate patch"]
9124    grid $top.title - -pady 10
9125    ${NS}::label $top.from -text [mc "From:"]
9126    ${NS}::entry $top.fromsha1 -width 40
9127    $top.fromsha1 insert 0 $oldid
9128    $top.fromsha1 conf -state readonly
9129    grid $top.from $top.fromsha1 -sticky w
9130    ${NS}::entry $top.fromhead -width 60
9131    $top.fromhead insert 0 $oldhead
9132    $top.fromhead conf -state readonly
9133    grid x $top.fromhead -sticky w
9134    ${NS}::label $top.to -text [mc "To:"]
9135    ${NS}::entry $top.tosha1 -width 40
9136    $top.tosha1 insert 0 $newid
9137    $top.tosha1 conf -state readonly
9138    grid $top.to $top.tosha1 -sticky w
9139    ${NS}::entry $top.tohead -width 60
9140    $top.tohead insert 0 $newhead
9141    $top.tohead conf -state readonly
9142    grid x $top.tohead -sticky w
9143    ${NS}::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9144    grid $top.rev x -pady 10 -padx 5
9145    ${NS}::label $top.flab -text [mc "Output file:"]
9146    ${NS}::entry $top.fname -width 60
9147    $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9148    incr patchnum
9149    grid $top.flab $top.fname -sticky w
9150    ${NS}::frame $top.buts
9151    ${NS}::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9152    ${NS}::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9153    bind $top <Key-Return> mkpatchgo
9154    bind $top <Key-Escape> mkpatchcan
9155    grid $top.buts.gen $top.buts.can
9156    grid columnconfigure $top.buts 0 -weight 1 -uniform a
9157    grid columnconfigure $top.buts 1 -weight 1 -uniform a
9158    grid $top.buts - -pady 10 -sticky ew
9159    focus $top.fname
9160}
9161
9162proc mkpatchrev {} {
9163    global patchtop
9164
9165    set oldid [$patchtop.fromsha1 get]
9166    set oldhead [$patchtop.fromhead get]
9167    set newid [$patchtop.tosha1 get]
9168    set newhead [$patchtop.tohead get]
9169    foreach e [list fromsha1 fromhead tosha1 tohead] \
9170            v [list $newid $newhead $oldid $oldhead] {
9171        $patchtop.$e conf -state normal
9172        $patchtop.$e delete 0 end
9173        $patchtop.$e insert 0 $v
9174        $patchtop.$e conf -state readonly
9175    }
9176}
9177
9178proc mkpatchgo {} {
9179    global patchtop nullid nullid2
9180
9181    set oldid [$patchtop.fromsha1 get]
9182    set newid [$patchtop.tosha1 get]
9183    set fname [$patchtop.fname get]
9184    set cmd [diffcmd [list $oldid $newid] -p]
9185    # trim off the initial "|"
9186    set cmd [lrange $cmd 1 end]
9187    lappend cmd >$fname &
9188    if {[catch {eval exec $cmd} err]} {
9189        error_popup "[mc "Error creating patch:"] $err" $patchtop
9190    }
9191    catch {destroy $patchtop}
9192    unset patchtop
9193}
9194
9195proc mkpatchcan {} {
9196    global patchtop
9197
9198    catch {destroy $patchtop}
9199    unset patchtop
9200}
9201
9202proc mktag {} {
9203    global rowmenuid mktagtop commitinfo NS
9204
9205    set top .maketag
9206    set mktagtop $top
9207    catch {destroy $top}
9208    ttk_toplevel $top
9209    make_transient $top .
9210    ${NS}::label $top.title -text [mc "Create tag"]
9211    grid $top.title - -pady 10
9212    ${NS}::label $top.id -text [mc "ID:"]
9213    ${NS}::entry $top.sha1 -width 40
9214    $top.sha1 insert 0 $rowmenuid
9215    $top.sha1 conf -state readonly
9216    grid $top.id $top.sha1 -sticky w
9217    ${NS}::entry $top.head -width 60
9218    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9219    $top.head conf -state readonly
9220    grid x $top.head -sticky w
9221    ${NS}::label $top.tlab -text [mc "Tag name:"]
9222    ${NS}::entry $top.tag -width 60
9223    grid $top.tlab $top.tag -sticky w
9224    ${NS}::label $top.op -text [mc "Tag message is optional"]
9225    grid $top.op -columnspan 2 -sticky we
9226    ${NS}::label $top.mlab -text [mc "Tag message:"]
9227    ${NS}::entry $top.msg -width 60
9228    grid $top.mlab $top.msg -sticky w
9229    ${NS}::frame $top.buts
9230    ${NS}::button $top.buts.gen -text [mc "Create"] -command mktaggo
9231    ${NS}::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9232    bind $top <Key-Return> mktaggo
9233    bind $top <Key-Escape> mktagcan
9234    grid $top.buts.gen $top.buts.can
9235    grid columnconfigure $top.buts 0 -weight 1 -uniform a
9236    grid columnconfigure $top.buts 1 -weight 1 -uniform a
9237    grid $top.buts - -pady 10 -sticky ew
9238    focus $top.tag
9239}
9240
9241proc domktag {} {
9242    global mktagtop env tagids idtags
9243
9244    set id [$mktagtop.sha1 get]
9245    set tag [$mktagtop.tag get]
9246    set msg [$mktagtop.msg get]
9247    if {$tag == {}} {
9248        error_popup [mc "No tag name specified"] $mktagtop
9249        return 0
9250    }
9251    if {[info exists tagids($tag)]} {
9252        error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9253        return 0
9254    }
9255    if {[catch {
9256        if {$msg != {}} {
9257            exec git tag -a -m $msg $tag $id
9258        } else {
9259            exec git tag $tag $id
9260        }
9261    } err]} {
9262        error_popup "[mc "Error creating tag:"] $err" $mktagtop
9263        return 0
9264    }
9265
9266    set tagids($tag) $id
9267    lappend idtags($id) $tag
9268    redrawtags $id
9269    addedtag $id
9270    dispneartags 0
9271    run refill_reflist
9272    return 1
9273}
9274
9275proc redrawtags {id} {
9276    global canv linehtag idpos currentid curview cmitlisted markedid
9277    global canvxmax iddrawn circleitem mainheadid circlecolors
9278    global mainheadcirclecolor
9279
9280    if {![commitinview $id $curview]} return
9281    if {![info exists iddrawn($id)]} return
9282    set row [rowofcommit $id]
9283    if {$id eq $mainheadid} {
9284        set ofill $mainheadcirclecolor
9285    } else {
9286        set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9287    }
9288    $canv itemconf $circleitem($row) -fill $ofill
9289    $canv delete tag.$id
9290    set xt [eval drawtags $id $idpos($id)]
9291    $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9292    set text [$canv itemcget $linehtag($id) -text]
9293    set font [$canv itemcget $linehtag($id) -font]
9294    set xr [expr {$xt + [font measure $font $text]}]
9295    if {$xr > $canvxmax} {
9296        set canvxmax $xr
9297        setcanvscroll
9298    }
9299    if {[info exists currentid] && $currentid == $id} {
9300        make_secsel $id
9301    }
9302    if {[info exists markedid] && $markedid eq $id} {
9303        make_idmark $id
9304    }
9305}
9306
9307proc mktagcan {} {
9308    global mktagtop
9309
9310    catch {destroy $mktagtop}
9311    unset mktagtop
9312}
9313
9314proc mktaggo {} {
9315    if {![domktag]} return
9316    mktagcan
9317}
9318
9319proc writecommit {} {
9320    global rowmenuid wrcomtop commitinfo wrcomcmd NS
9321
9322    set top .writecommit
9323    set wrcomtop $top
9324    catch {destroy $top}
9325    ttk_toplevel $top
9326    make_transient $top .
9327    ${NS}::label $top.title -text [mc "Write commit to file"]
9328    grid $top.title - -pady 10
9329    ${NS}::label $top.id -text [mc "ID:"]
9330    ${NS}::entry $top.sha1 -width 40
9331    $top.sha1 insert 0 $rowmenuid
9332    $top.sha1 conf -state readonly
9333    grid $top.id $top.sha1 -sticky w
9334    ${NS}::entry $top.head -width 60
9335    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9336    $top.head conf -state readonly
9337    grid x $top.head -sticky w
9338    ${NS}::label $top.clab -text [mc "Command:"]
9339    ${NS}::entry $top.cmd -width 60 -textvariable wrcomcmd
9340    grid $top.clab $top.cmd -sticky w -pady 10
9341    ${NS}::label $top.flab -text [mc "Output file:"]
9342    ${NS}::entry $top.fname -width 60
9343    $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9344    grid $top.flab $top.fname -sticky w
9345    ${NS}::frame $top.buts
9346    ${NS}::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9347    ${NS}::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9348    bind $top <Key-Return> wrcomgo
9349    bind $top <Key-Escape> wrcomcan
9350    grid $top.buts.gen $top.buts.can
9351    grid columnconfigure $top.buts 0 -weight 1 -uniform a
9352    grid columnconfigure $top.buts 1 -weight 1 -uniform a
9353    grid $top.buts - -pady 10 -sticky ew
9354    focus $top.fname
9355}
9356
9357proc wrcomgo {} {
9358    global wrcomtop
9359
9360    set id [$wrcomtop.sha1 get]
9361    set cmd "echo $id | [$wrcomtop.cmd get]"
9362    set fname [$wrcomtop.fname get]
9363    if {[catch {exec sh -c $cmd >$fname &} err]} {
9364        error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9365    }
9366    catch {destroy $wrcomtop}
9367    unset wrcomtop
9368}
9369
9370proc wrcomcan {} {
9371    global wrcomtop
9372
9373    catch {destroy $wrcomtop}
9374    unset wrcomtop
9375}
9376
9377proc mkbranch {} {
9378    global rowmenuid mkbrtop NS
9379
9380    set top .makebranch
9381    catch {destroy $top}
9382    ttk_toplevel $top
9383    make_transient $top .
9384    ${NS}::label $top.title -text [mc "Create new branch"]
9385    grid $top.title - -pady 10
9386    ${NS}::label $top.id -text [mc "ID:"]
9387    ${NS}::entry $top.sha1 -width 40
9388    $top.sha1 insert 0 $rowmenuid
9389    $top.sha1 conf -state readonly
9390    grid $top.id $top.sha1 -sticky w
9391    ${NS}::label $top.nlab -text [mc "Name:"]
9392    ${NS}::entry $top.name -width 40
9393    grid $top.nlab $top.name -sticky w
9394    ${NS}::frame $top.buts
9395    ${NS}::button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
9396    ${NS}::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9397    bind $top <Key-Return> [list mkbrgo $top]
9398    bind $top <Key-Escape> "catch {destroy $top}"
9399    grid $top.buts.go $top.buts.can
9400    grid columnconfigure $top.buts 0 -weight 1 -uniform a
9401    grid columnconfigure $top.buts 1 -weight 1 -uniform a
9402    grid $top.buts - -pady 10 -sticky ew
9403    focus $top.name
9404}
9405
9406proc mkbrgo {top} {
9407    global headids idheads
9408
9409    set name [$top.name get]
9410    set id [$top.sha1 get]
9411    set cmdargs {}
9412    set old_id {}
9413    if {$name eq {}} {
9414        error_popup [mc "Please specify a name for the new branch"] $top
9415        return
9416    }
9417    if {[info exists headids($name)]} {
9418        if {![confirm_popup [mc \
9419                "Branch '%s' already exists. Overwrite?" $name] $top]} {
9420            return
9421        }
9422        set old_id $headids($name)
9423        lappend cmdargs -f
9424    }
9425    catch {destroy $top}
9426    lappend cmdargs $name $id
9427    nowbusy newbranch
9428    update
9429    if {[catch {
9430        eval exec git branch $cmdargs
9431    } err]} {
9432        notbusy newbranch
9433        error_popup $err
9434    } else {
9435        notbusy newbranch
9436        if {$old_id ne {}} {
9437            movehead $id $name
9438            movedhead $id $name
9439            redrawtags $old_id
9440            redrawtags $id
9441        } else {
9442            set headids($name) $id
9443            lappend idheads($id) $name
9444            addedhead $id $name
9445            redrawtags $id
9446        }
9447        dispneartags 0
9448        run refill_reflist
9449    }
9450}
9451
9452proc exec_citool {tool_args {baseid {}}} {
9453    global commitinfo env
9454
9455    set save_env [array get env GIT_AUTHOR_*]
9456
9457    if {$baseid ne {}} {
9458        if {![info exists commitinfo($baseid)]} {
9459            getcommit $baseid
9460        }
9461        set author [lindex $commitinfo($baseid) 1]
9462        set date [lindex $commitinfo($baseid) 2]
9463        if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9464                    $author author name email]
9465            && $date ne {}} {
9466            set env(GIT_AUTHOR_NAME) $name
9467            set env(GIT_AUTHOR_EMAIL) $email
9468            set env(GIT_AUTHOR_DATE) $date
9469        }
9470    }
9471
9472    eval exec git citool $tool_args &
9473
9474    array unset env GIT_AUTHOR_*
9475    array set env $save_env
9476}
9477
9478proc cherrypick {} {
9479    global rowmenuid curview
9480    global mainhead mainheadid
9481    global gitdir
9482
9483    set oldhead [exec git rev-parse HEAD]
9484    set dheads [descheads $rowmenuid]
9485    if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9486        set ok [confirm_popup [mc "Commit %s is already\
9487                included in branch %s -- really re-apply it?" \
9488                                   [string range $rowmenuid 0 7] $mainhead]]
9489        if {!$ok} return
9490    }
9491    nowbusy cherrypick [mc "Cherry-picking"]
9492    update
9493    # Unfortunately git-cherry-pick writes stuff to stderr even when
9494    # no error occurs, and exec takes that as an indication of error...
9495    if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
9496        notbusy cherrypick
9497        if {[regexp -line \
9498                 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9499                 $err msg fname]} {
9500            error_popup [mc "Cherry-pick failed because of local changes\
9501                        to file '%s'.\nPlease commit, reset or stash\
9502                        your changes and try again." $fname]
9503        } elseif {[regexp -line \
9504                       {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9505                       $err]} {
9506            if {[confirm_popup [mc "Cherry-pick failed because of merge\
9507                        conflict.\nDo you wish to run git citool to\
9508                        resolve it?"]]} {
9509                # Force citool to read MERGE_MSG
9510                file delete [file join $gitdir "GITGUI_MSG"]
9511                exec_citool {} $rowmenuid
9512            }
9513        } else {
9514            error_popup $err
9515        }
9516        run updatecommits
9517        return
9518    }
9519    set newhead [exec git rev-parse HEAD]
9520    if {$newhead eq $oldhead} {
9521        notbusy cherrypick
9522        error_popup [mc "No changes committed"]
9523        return
9524    }
9525    addnewchild $newhead $oldhead
9526    if {[commitinview $oldhead $curview]} {
9527        # XXX this isn't right if we have a path limit...
9528        insertrow $newhead $oldhead $curview
9529        if {$mainhead ne {}} {
9530            movehead $newhead $mainhead
9531            movedhead $newhead $mainhead
9532        }
9533        set mainheadid $newhead
9534        redrawtags $oldhead
9535        redrawtags $newhead
9536        selbyid $newhead
9537    }
9538    notbusy cherrypick
9539}
9540
9541proc revert {} {
9542    global rowmenuid curview
9543    global mainhead mainheadid
9544    global gitdir
9545
9546    set oldhead [exec git rev-parse HEAD]
9547    set dheads [descheads $rowmenuid]
9548    if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9549       set ok [confirm_popup [mc "Commit %s is not\
9550           included in branch %s -- really revert it?" \
9551                      [string range $rowmenuid 0 7] $mainhead]]
9552       if {!$ok} return
9553    }
9554    nowbusy revert [mc "Reverting"]
9555    update
9556
9557    if [catch {exec git revert --no-edit $rowmenuid} err] {
9558        notbusy revert
9559        if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9560                $err match files] {
9561            regsub {\n( |\t)+} $files "\n" files
9562            error_popup [mc "Revert failed because of local changes to\
9563                the following files:%s Please commit, reset or stash \
9564                your changes and try again." $files]
9565        } elseif [regexp {error: could not revert} $err] {
9566            if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9567                Do you wish to run git citool to resolve it?"]] {
9568                # Force citool to read MERGE_MSG
9569                file delete [file join $gitdir "GITGUI_MSG"]
9570                exec_citool {} $rowmenuid
9571            }
9572        } else { error_popup $err }
9573        run updatecommits
9574        return
9575    }
9576
9577    set newhead [exec git rev-parse HEAD]
9578    if { $newhead eq $oldhead } {
9579        notbusy revert
9580        error_popup [mc "No changes committed"]
9581        return
9582    }
9583
9584    addnewchild $newhead $oldhead
9585
9586    if [commitinview $oldhead $curview] {
9587        # XXX this isn't right if we have a path limit...
9588        insertrow $newhead $oldhead $curview
9589        if {$mainhead ne {}} {
9590            movehead $newhead $mainhead
9591            movedhead $newhead $mainhead
9592        }
9593        set mainheadid $newhead
9594        redrawtags $oldhead
9595        redrawtags $newhead
9596        selbyid $newhead
9597    }
9598
9599    notbusy revert
9600}
9601
9602proc resethead {} {
9603    global mainhead rowmenuid confirm_ok resettype NS
9604
9605    set confirm_ok 0
9606    set w ".confirmreset"
9607    ttk_toplevel $w
9608    make_transient $w .
9609    wm title $w [mc "Confirm reset"]
9610    ${NS}::label $w.m -text \
9611        [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9612    pack $w.m -side top -fill x -padx 20 -pady 20
9613    ${NS}::labelframe $w.f -text [mc "Reset type:"]
9614    set resettype mixed
9615    ${NS}::radiobutton $w.f.soft -value soft -variable resettype \
9616        -text [mc "Soft: Leave working tree and index untouched"]
9617    grid $w.f.soft -sticky w
9618    ${NS}::radiobutton $w.f.mixed -value mixed -variable resettype \
9619        -text [mc "Mixed: Leave working tree untouched, reset index"]
9620    grid $w.f.mixed -sticky w
9621    ${NS}::radiobutton $w.f.hard -value hard -variable resettype \
9622        -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9623    grid $w.f.hard -sticky w
9624    pack $w.f -side top -fill x -padx 4
9625    ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9626    pack $w.ok -side left -fill x -padx 20 -pady 20
9627    ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
9628    bind $w <Key-Escape> [list destroy $w]
9629    pack $w.cancel -side right -fill x -padx 20 -pady 20
9630    bind $w <Visibility> "grab $w; focus $w"
9631    tkwait window $w
9632    if {!$confirm_ok} return
9633    if {[catch {set fd [open \
9634            [list | git reset --$resettype $rowmenuid 2>@1] r]} err]} {
9635        error_popup $err
9636    } else {
9637        dohidelocalchanges
9638        filerun $fd [list readresetstat $fd]
9639        nowbusy reset [mc "Resetting"]
9640        selbyid $rowmenuid
9641    }
9642}
9643
9644proc readresetstat {fd} {
9645    global mainhead mainheadid showlocalchanges rprogcoord
9646
9647    if {[gets $fd line] >= 0} {
9648        if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9649            set rprogcoord [expr {1.0 * $m / $n}]
9650            adjustprogress
9651        }
9652        return 1
9653    }
9654    set rprogcoord 0
9655    adjustprogress
9656    notbusy reset
9657    if {[catch {close $fd} err]} {
9658        error_popup $err
9659    }
9660    set oldhead $mainheadid
9661    set newhead [exec git rev-parse HEAD]
9662    if {$newhead ne $oldhead} {
9663        movehead $newhead $mainhead
9664        movedhead $newhead $mainhead
9665        set mainheadid $newhead
9666        redrawtags $oldhead
9667        redrawtags $newhead
9668    }
9669    if {$showlocalchanges} {
9670        doshowlocalchanges
9671    }
9672    return 0
9673}
9674
9675# context menu for a head
9676proc headmenu {x y id head} {
9677    global headmenuid headmenuhead headctxmenu mainhead
9678
9679    stopfinding
9680    set headmenuid $id
9681    set headmenuhead $head
9682    set state normal
9683    if {[string match "remotes/*" $head]} {
9684        set state disabled
9685    }
9686    if {$head eq $mainhead} {
9687        set state disabled
9688    }
9689    $headctxmenu entryconfigure 0 -state $state
9690    $headctxmenu entryconfigure 1 -state $state
9691    tk_popup $headctxmenu $x $y
9692}
9693
9694proc cobranch {} {
9695    global headmenuid headmenuhead headids
9696    global showlocalchanges
9697
9698    # check the tree is clean first??
9699    nowbusy checkout [mc "Checking out"]
9700    update
9701    dohidelocalchanges
9702    if {[catch {
9703        set fd [open [list | git checkout $headmenuhead 2>@1] r]
9704    } err]} {
9705        notbusy checkout
9706        error_popup $err
9707        if {$showlocalchanges} {
9708            dodiffindex
9709        }
9710    } else {
9711        filerun $fd [list readcheckoutstat $fd $headmenuhead $headmenuid]
9712    }
9713}
9714
9715proc readcheckoutstat {fd newhead newheadid} {
9716    global mainhead mainheadid headids showlocalchanges progresscoords
9717    global viewmainheadid curview
9718
9719    if {[gets $fd line] >= 0} {
9720        if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
9721            set progresscoords [list 0 [expr {1.0 * $m / $n}]]
9722            adjustprogress
9723        }
9724        return 1
9725    }
9726    set progresscoords {0 0}
9727    adjustprogress
9728    notbusy checkout
9729    if {[catch {close $fd} err]} {
9730        error_popup $err
9731    }
9732    set oldmainid $mainheadid
9733    set mainhead $newhead
9734    set mainheadid $newheadid
9735    set viewmainheadid($curview) $newheadid
9736    redrawtags $oldmainid
9737    redrawtags $newheadid
9738    selbyid $newheadid
9739    if {$showlocalchanges} {
9740        dodiffindex
9741    }
9742}
9743
9744proc rmbranch {} {
9745    global headmenuid headmenuhead mainhead
9746    global idheads
9747
9748    set head $headmenuhead
9749    set id $headmenuid
9750    # this check shouldn't be needed any more...
9751    if {$head eq $mainhead} {
9752        error_popup [mc "Cannot delete the currently checked-out branch"]
9753        return
9754    }
9755    set dheads [descheads $id]
9756    if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
9757        # the stuff on this branch isn't on any other branch
9758        if {![confirm_popup [mc "The commits on branch %s aren't on any other\
9759                        branch.\nReally delete branch %s?" $head $head]]} return
9760    }
9761    nowbusy rmbranch
9762    update
9763    if {[catch {exec git branch -D $head} err]} {
9764        notbusy rmbranch
9765        error_popup $err
9766        return
9767    }
9768    removehead $id $head
9769    removedhead $id $head
9770    redrawtags $id
9771    notbusy rmbranch
9772    dispneartags 0
9773    run refill_reflist
9774}
9775
9776# Display a list of tags and heads
9777proc showrefs {} {
9778    global showrefstop bgcolor fgcolor selectbgcolor NS
9779    global bglist fglist reflistfilter reflist maincursor
9780
9781    set top .showrefs
9782    set showrefstop $top
9783    if {[winfo exists $top]} {
9784        raise $top
9785        refill_reflist
9786        return
9787    }
9788    ttk_toplevel $top
9789    wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
9790    make_transient $top .
9791    text $top.list -background $bgcolor -foreground $fgcolor \
9792        -selectbackground $selectbgcolor -font mainfont \
9793        -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
9794        -width 30 -height 20 -cursor $maincursor \
9795        -spacing1 1 -spacing3 1 -state disabled
9796    $top.list tag configure highlight -background $selectbgcolor
9797    lappend bglist $top.list
9798    lappend fglist $top.list
9799    ${NS}::scrollbar $top.ysb -command "$top.list yview" -orient vertical
9800    ${NS}::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
9801    grid $top.list $top.ysb -sticky nsew
9802    grid $top.xsb x -sticky ew
9803    ${NS}::frame $top.f
9804    ${NS}::label $top.f.l -text "[mc "Filter"]: "
9805    ${NS}::entry $top.f.e -width 20 -textvariable reflistfilter
9806    set reflistfilter "*"
9807    trace add variable reflistfilter write reflistfilter_change
9808    pack $top.f.e -side right -fill x -expand 1
9809    pack $top.f.l -side left
9810    grid $top.f - -sticky ew -pady 2
9811    ${NS}::button $top.close -command [list destroy $top] -text [mc "Close"]
9812    bind $top <Key-Escape> [list destroy $top]
9813    grid $top.close -
9814    grid columnconfigure $top 0 -weight 1
9815    grid rowconfigure $top 0 -weight 1
9816    bind $top.list <1> {break}
9817    bind $top.list <B1-Motion> {break}
9818    bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
9819    set reflist {}
9820    refill_reflist
9821}
9822
9823proc sel_reflist {w x y} {
9824    global showrefstop reflist headids tagids otherrefids
9825
9826    if {![winfo exists $showrefstop]} return
9827    set l [lindex [split [$w index "@$x,$y"] "."] 0]
9828    set ref [lindex $reflist [expr {$l-1}]]
9829    set n [lindex $ref 0]
9830    switch -- [lindex $ref 1] {
9831        "H" {selbyid $headids($n)}
9832        "T" {selbyid $tagids($n)}
9833        "o" {selbyid $otherrefids($n)}
9834    }
9835    $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
9836}
9837
9838proc unsel_reflist {} {
9839    global showrefstop
9840
9841    if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9842    $showrefstop.list tag remove highlight 0.0 end
9843}
9844
9845proc reflistfilter_change {n1 n2 op} {
9846    global reflistfilter
9847
9848    after cancel refill_reflist
9849    after 200 refill_reflist
9850}
9851
9852proc refill_reflist {} {
9853    global reflist reflistfilter showrefstop headids tagids otherrefids
9854    global curview
9855
9856    if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
9857    set refs {}
9858    foreach n [array names headids] {
9859        if {[string match $reflistfilter $n]} {
9860            if {[commitinview $headids($n) $curview]} {
9861                lappend refs [list $n H]
9862            } else {
9863                interestedin $headids($n) {run refill_reflist}
9864            }
9865        }
9866    }
9867    foreach n [array names tagids] {
9868        if {[string match $reflistfilter $n]} {
9869            if {[commitinview $tagids($n) $curview]} {
9870                lappend refs [list $n T]
9871            } else {
9872                interestedin $tagids($n) {run refill_reflist}
9873            }
9874        }
9875    }
9876    foreach n [array names otherrefids] {
9877        if {[string match $reflistfilter $n]} {
9878            if {[commitinview $otherrefids($n) $curview]} {
9879                lappend refs [list $n o]
9880            } else {
9881                interestedin $otherrefids($n) {run refill_reflist}
9882            }
9883        }
9884    }
9885    set refs [lsort -index 0 $refs]
9886    if {$refs eq $reflist} return
9887
9888    # Update the contents of $showrefstop.list according to the
9889    # differences between $reflist (old) and $refs (new)
9890    $showrefstop.list conf -state normal
9891    $showrefstop.list insert end "\n"
9892    set i 0
9893    set j 0
9894    while {$i < [llength $reflist] || $j < [llength $refs]} {
9895        if {$i < [llength $reflist]} {
9896            if {$j < [llength $refs]} {
9897                set cmp [string compare [lindex $reflist $i 0] \
9898                             [lindex $refs $j 0]]
9899                if {$cmp == 0} {
9900                    set cmp [string compare [lindex $reflist $i 1] \
9901                                 [lindex $refs $j 1]]
9902                }
9903            } else {
9904                set cmp -1
9905            }
9906        } else {
9907            set cmp 1
9908        }
9909        switch -- $cmp {
9910            -1 {
9911                $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
9912                incr i
9913            }
9914            0 {
9915                incr i
9916                incr j
9917            }
9918            1 {
9919                set l [expr {$j + 1}]
9920                $showrefstop.list image create $l.0 -align baseline \
9921                    -image reficon-[lindex $refs $j 1] -padx 2
9922                $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
9923                incr j
9924            }
9925        }
9926    }
9927    set reflist $refs
9928    # delete last newline
9929    $showrefstop.list delete end-2c end-1c
9930    $showrefstop.list conf -state disabled
9931}
9932
9933# Stuff for finding nearby tags
9934proc getallcommits {} {
9935    global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
9936    global idheads idtags idotherrefs allparents tagobjid
9937    global gitdir
9938
9939    if {![info exists allcommits]} {
9940        set nextarc 0
9941        set allcommits 0
9942        set seeds {}
9943        set allcwait 0
9944        set cachedarcs 0
9945        set allccache [file join $gitdir "gitk.cache"]
9946        if {![catch {
9947            set f [open $allccache r]
9948            set allcwait 1
9949            getcache $f
9950        }]} return
9951    }
9952
9953    if {$allcwait} {
9954        return
9955    }
9956    set cmd [list | git rev-list --parents]
9957    set allcupdate [expr {$seeds ne {}}]
9958    if {!$allcupdate} {
9959        set ids "--all"
9960    } else {
9961        set refs [concat [array names idheads] [array names idtags] \
9962                      [array names idotherrefs]]
9963        set ids {}
9964        set tagobjs {}
9965        foreach name [array names tagobjid] {
9966            lappend tagobjs $tagobjid($name)
9967        }
9968        foreach id [lsort -unique $refs] {
9969            if {![info exists allparents($id)] &&
9970                [lsearch -exact $tagobjs $id] < 0} {
9971                lappend ids $id
9972            }
9973        }
9974        if {$ids ne {}} {
9975            foreach id $seeds {
9976                lappend ids "^$id"
9977            }
9978        }
9979    }
9980    if {$ids ne {}} {
9981        set fd [open [concat $cmd $ids] r]
9982        fconfigure $fd -blocking 0
9983        incr allcommits
9984        nowbusy allcommits
9985        filerun $fd [list getallclines $fd]
9986    } else {
9987        dispneartags 0
9988    }
9989}
9990
9991# Since most commits have 1 parent and 1 child, we group strings of
9992# such commits into "arcs" joining branch/merge points (BMPs), which
9993# are commits that either don't have 1 parent or don't have 1 child.
9994#
9995# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
9996# arcout(id) - outgoing arcs for BMP
9997# arcids(a) - list of IDs on arc including end but not start
9998# arcstart(a) - BMP ID at start of arc
9999# arcend(a) - BMP ID at end of arc
10000# growing(a) - arc a is still growing
10001# arctags(a) - IDs out of arcids (excluding end) that have tags
10002# archeads(a) - IDs out of arcids (excluding end) that have heads
10003# The start of an arc is at the descendent end, so "incoming" means
10004# coming from descendents, and "outgoing" means going towards ancestors.
10005
10006proc getallclines {fd} {
10007    global allparents allchildren idtags idheads nextarc
10008    global arcnos arcids arctags arcout arcend arcstart archeads growing
10009    global seeds allcommits cachedarcs allcupdate
10010
10011    set nid 0
10012    while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10013        set id [lindex $line 0]
10014        if {[info exists allparents($id)]} {
10015            # seen it already
10016            continue
10017        }
10018        set cachedarcs 0
10019        set olds [lrange $line 1 end]
10020        set allparents($id) $olds
10021        if {![info exists allchildren($id)]} {
10022            set allchildren($id) {}
10023            set arcnos($id) {}
10024            lappend seeds $id
10025        } else {
10026            set a $arcnos($id)
10027            if {[llength $olds] == 1 && [llength $a] == 1} {
10028                lappend arcids($a) $id
10029                if {[info exists idtags($id)]} {
10030                    lappend arctags($a) $id
10031                }
10032                if {[info exists idheads($id)]} {
10033                    lappend archeads($a) $id
10034                }
10035                if {[info exists allparents($olds)]} {
10036                    # seen parent already
10037                    if {![info exists arcout($olds)]} {
10038                        splitarc $olds
10039                    }
10040                    lappend arcids($a) $olds
10041                    set arcend($a) $olds
10042                    unset growing($a)
10043                }
10044                lappend allchildren($olds) $id
10045                lappend arcnos($olds) $a
10046                continue
10047            }
10048        }
10049        foreach a $arcnos($id) {
10050            lappend arcids($a) $id
10051            set arcend($a) $id
10052            unset growing($a)
10053        }
10054
10055        set ao {}
10056        foreach p $olds {
10057            lappend allchildren($p) $id
10058            set a [incr nextarc]
10059            set arcstart($a) $id
10060            set archeads($a) {}
10061            set arctags($a) {}
10062            set archeads($a) {}
10063            set arcids($a) {}
10064            lappend ao $a
10065            set growing($a) 1
10066            if {[info exists allparents($p)]} {
10067                # seen it already, may need to make a new branch
10068                if {![info exists arcout($p)]} {
10069                    splitarc $p
10070                }
10071                lappend arcids($a) $p
10072                set arcend($a) $p
10073                unset growing($a)
10074            }
10075            lappend arcnos($p) $a
10076        }
10077        set arcout($id) $ao
10078    }
10079    if {$nid > 0} {
10080        global cached_dheads cached_dtags cached_atags
10081        catch {unset cached_dheads}
10082        catch {unset cached_dtags}
10083        catch {unset cached_atags}
10084    }
10085    if {![eof $fd]} {
10086        return [expr {$nid >= 1000? 2: 1}]
10087    }
10088    set cacheok 1
10089    if {[catch {
10090        fconfigure $fd -blocking 1
10091        close $fd
10092    } err]} {
10093        # got an error reading the list of commits
10094        # if we were updating, try rereading the whole thing again
10095        if {$allcupdate} {
10096            incr allcommits -1
10097            dropcache $err
10098            return
10099        }
10100        error_popup "[mc "Error reading commit topology information;\
10101                branch and preceding/following tag information\
10102                will be incomplete."]\n($err)"
10103        set cacheok 0
10104    }
10105    if {[incr allcommits -1] == 0} {
10106        notbusy allcommits
10107        if {$cacheok} {
10108            run savecache
10109        }
10110    }
10111    dispneartags 0
10112    return 0
10113}
10114
10115proc recalcarc {a} {
10116    global arctags archeads arcids idtags idheads
10117
10118    set at {}
10119    set ah {}
10120    foreach id [lrange $arcids($a) 0 end-1] {
10121        if {[info exists idtags($id)]} {
10122            lappend at $id
10123        }
10124        if {[info exists idheads($id)]} {
10125            lappend ah $id
10126        }
10127    }
10128    set arctags($a) $at
10129    set archeads($a) $ah
10130}
10131
10132proc splitarc {p} {
10133    global arcnos arcids nextarc arctags archeads idtags idheads
10134    global arcstart arcend arcout allparents growing
10135
10136    set a $arcnos($p)
10137    if {[llength $a] != 1} {
10138        puts "oops splitarc called but [llength $a] arcs already"
10139        return
10140    }
10141    set a [lindex $a 0]
10142    set i [lsearch -exact $arcids($a) $p]
10143    if {$i < 0} {
10144        puts "oops splitarc $p not in arc $a"
10145        return
10146    }
10147    set na [incr nextarc]
10148    if {[info exists arcend($a)]} {
10149        set arcend($na) $arcend($a)
10150    } else {
10151        set l [lindex $allparents([lindex $arcids($a) end]) 0]
10152        set j [lsearch -exact $arcnos($l) $a]
10153        set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10154    }
10155    set tail [lrange $arcids($a) [expr {$i+1}] end]
10156    set arcids($a) [lrange $arcids($a) 0 $i]
10157    set arcend($a) $p
10158    set arcstart($na) $p
10159    set arcout($p) $na
10160    set arcids($na) $tail
10161    if {[info exists growing($a)]} {
10162        set growing($na) 1
10163        unset growing($a)
10164    }
10165
10166    foreach id $tail {
10167        if {[llength $arcnos($id)] == 1} {
10168            set arcnos($id) $na
10169        } else {
10170            set j [lsearch -exact $arcnos($id) $a]
10171            set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10172        }
10173    }
10174
10175    # reconstruct tags and heads lists
10176    if {$arctags($a) ne {} || $archeads($a) ne {}} {
10177        recalcarc $a
10178        recalcarc $na
10179    } else {
10180        set arctags($na) {}
10181        set archeads($na) {}
10182    }
10183}
10184
10185# Update things for a new commit added that is a child of one
10186# existing commit.  Used when cherry-picking.
10187proc addnewchild {id p} {
10188    global allparents allchildren idtags nextarc
10189    global arcnos arcids arctags arcout arcend arcstart archeads growing
10190    global seeds allcommits
10191
10192    if {![info exists allcommits] || ![info exists arcnos($p)]} return
10193    set allparents($id) [list $p]
10194    set allchildren($id) {}
10195    set arcnos($id) {}
10196    lappend seeds $id
10197    lappend allchildren($p) $id
10198    set a [incr nextarc]
10199    set arcstart($a) $id
10200    set archeads($a) {}
10201    set arctags($a) {}
10202    set arcids($a) [list $p]
10203    set arcend($a) $p
10204    if {![info exists arcout($p)]} {
10205        splitarc $p
10206    }
10207    lappend arcnos($p) $a
10208    set arcout($id) [list $a]
10209}
10210
10211# This implements a cache for the topology information.
10212# The cache saves, for each arc, the start and end of the arc,
10213# the ids on the arc, and the outgoing arcs from the end.
10214proc readcache {f} {
10215    global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10216    global idtags idheads allparents cachedarcs possible_seeds seeds growing
10217    global allcwait
10218
10219    set a $nextarc
10220    set lim $cachedarcs
10221    if {$lim - $a > 500} {
10222        set lim [expr {$a + 500}]
10223    }
10224    if {[catch {
10225        if {$a == $lim} {
10226            # finish reading the cache and setting up arctags, etc.
10227            set line [gets $f]
10228            if {$line ne "1"} {error "bad final version"}
10229            close $f
10230            foreach id [array names idtags] {
10231                if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10232                    [llength $allparents($id)] == 1} {
10233                    set a [lindex $arcnos($id) 0]
10234                    if {$arctags($a) eq {}} {
10235                        recalcarc $a
10236                    }
10237                }
10238            }
10239            foreach id [array names idheads] {
10240                if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10241                    [llength $allparents($id)] == 1} {
10242                    set a [lindex $arcnos($id) 0]
10243                    if {$archeads($a) eq {}} {
10244                        recalcarc $a
10245                    }
10246                }
10247            }
10248            foreach id [lsort -unique $possible_seeds] {
10249                if {$arcnos($id) eq {}} {
10250                    lappend seeds $id
10251                }
10252            }
10253            set allcwait 0
10254        } else {
10255            while {[incr a] <= $lim} {
10256                set line [gets $f]
10257                if {[llength $line] != 3} {error "bad line"}
10258                set s [lindex $line 0]
10259                set arcstart($a) $s
10260                lappend arcout($s) $a
10261                if {![info exists arcnos($s)]} {
10262                    lappend possible_seeds $s
10263                    set arcnos($s) {}
10264                }
10265                set e [lindex $line 1]
10266                if {$e eq {}} {
10267                    set growing($a) 1
10268                } else {
10269                    set arcend($a) $e
10270                    if {![info exists arcout($e)]} {
10271                        set arcout($e) {}
10272                    }
10273                }
10274                set arcids($a) [lindex $line 2]
10275                foreach id $arcids($a) {
10276                    lappend allparents($s) $id
10277                    set s $id
10278                    lappend arcnos($id) $a
10279                }
10280                if {![info exists allparents($s)]} {
10281                    set allparents($s) {}
10282                }
10283                set arctags($a) {}
10284                set archeads($a) {}
10285            }
10286            set nextarc [expr {$a - 1}]
10287        }
10288    } err]} {
10289        dropcache $err
10290        return 0
10291    }
10292    if {!$allcwait} {
10293        getallcommits
10294    }
10295    return $allcwait
10296}
10297
10298proc getcache {f} {
10299    global nextarc cachedarcs possible_seeds
10300
10301    if {[catch {
10302        set line [gets $f]
10303        if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10304        # make sure it's an integer
10305        set cachedarcs [expr {int([lindex $line 1])}]
10306        if {$cachedarcs < 0} {error "bad number of arcs"}
10307        set nextarc 0
10308        set possible_seeds {}
10309        run readcache $f
10310    } err]} {
10311        dropcache $err
10312    }
10313    return 0
10314}
10315
10316proc dropcache {err} {
10317    global allcwait nextarc cachedarcs seeds
10318
10319    #puts "dropping cache ($err)"
10320    foreach v {arcnos arcout arcids arcstart arcend growing \
10321                   arctags archeads allparents allchildren} {
10322        global $v
10323        catch {unset $v}
10324    }
10325    set allcwait 0
10326    set nextarc 0
10327    set cachedarcs 0
10328    set seeds {}
10329    getallcommits
10330}
10331
10332proc writecache {f} {
10333    global cachearc cachedarcs allccache
10334    global arcstart arcend arcnos arcids arcout
10335
10336    set a $cachearc
10337    set lim $cachedarcs
10338    if {$lim - $a > 1000} {
10339        set lim [expr {$a + 1000}]
10340    }
10341    if {[catch {
10342        while {[incr a] <= $lim} {
10343            if {[info exists arcend($a)]} {
10344                puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10345            } else {
10346                puts $f [list $arcstart($a) {} $arcids($a)]
10347            }
10348        }
10349    } err]} {
10350        catch {close $f}
10351        catch {file delete $allccache}
10352        #puts "writing cache failed ($err)"
10353        return 0
10354    }
10355    set cachearc [expr {$a - 1}]
10356    if {$a > $cachedarcs} {
10357        puts $f "1"
10358        close $f
10359        return 0
10360    }
10361    return 1
10362}
10363
10364proc savecache {} {
10365    global nextarc cachedarcs cachearc allccache
10366
10367    if {$nextarc == $cachedarcs} return
10368    set cachearc 0
10369    set cachedarcs $nextarc
10370    catch {
10371        set f [open $allccache w]
10372        puts $f [list 1 $cachedarcs]
10373        run writecache $f
10374    }
10375}
10376
10377# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10378# or 0 if neither is true.
10379proc anc_or_desc {a b} {
10380    global arcout arcstart arcend arcnos cached_isanc
10381
10382    if {$arcnos($a) eq $arcnos($b)} {
10383        # Both are on the same arc(s); either both are the same BMP,
10384        # or if one is not a BMP, the other is also not a BMP or is
10385        # the BMP at end of the arc (and it only has 1 incoming arc).
10386        # Or both can be BMPs with no incoming arcs.
10387        if {$a eq $b || $arcnos($a) eq {}} {
10388            return 0
10389        }
10390        # assert {[llength $arcnos($a)] == 1}
10391        set arc [lindex $arcnos($a) 0]
10392        set i [lsearch -exact $arcids($arc) $a]
10393        set j [lsearch -exact $arcids($arc) $b]
10394        if {$i < 0 || $i > $j} {
10395            return 1
10396        } else {
10397            return -1
10398        }
10399    }
10400
10401    if {![info exists arcout($a)]} {
10402        set arc [lindex $arcnos($a) 0]
10403        if {[info exists arcend($arc)]} {
10404            set aend $arcend($arc)
10405        } else {
10406            set aend {}
10407        }
10408        set a $arcstart($arc)
10409    } else {
10410        set aend $a
10411    }
10412    if {![info exists arcout($b)]} {
10413        set arc [lindex $arcnos($b) 0]
10414        if {[info exists arcend($arc)]} {
10415            set bend $arcend($arc)
10416        } else {
10417            set bend {}
10418        }
10419        set b $arcstart($arc)
10420    } else {
10421        set bend $b
10422    }
10423    if {$a eq $bend} {
10424        return 1
10425    }
10426    if {$b eq $aend} {
10427        return -1
10428    }
10429    if {[info exists cached_isanc($a,$bend)]} {
10430        if {$cached_isanc($a,$bend)} {
10431            return 1
10432        }
10433    }
10434    if {[info exists cached_isanc($b,$aend)]} {
10435        if {$cached_isanc($b,$aend)} {
10436            return -1
10437        }
10438        if {[info exists cached_isanc($a,$bend)]} {
10439            return 0
10440        }
10441    }
10442
10443    set todo [list $a $b]
10444    set anc($a) a
10445    set anc($b) b
10446    for {set i 0} {$i < [llength $todo]} {incr i} {
10447        set x [lindex $todo $i]
10448        if {$anc($x) eq {}} {
10449            continue
10450        }
10451        foreach arc $arcnos($x) {
10452            set xd $arcstart($arc)
10453            if {$xd eq $bend} {
10454                set cached_isanc($a,$bend) 1
10455                set cached_isanc($b,$aend) 0
10456                return 1
10457            } elseif {$xd eq $aend} {
10458                set cached_isanc($b,$aend) 1
10459                set cached_isanc($a,$bend) 0
10460                return -1
10461            }
10462            if {![info exists anc($xd)]} {
10463                set anc($xd) $anc($x)
10464                lappend todo $xd
10465            } elseif {$anc($xd) ne $anc($x)} {
10466                set anc($xd) {}
10467            }
10468        }
10469    }
10470    set cached_isanc($a,$bend) 0
10471    set cached_isanc($b,$aend) 0
10472    return 0
10473}
10474
10475# This identifies whether $desc has an ancestor that is
10476# a growing tip of the graph and which is not an ancestor of $anc
10477# and returns 0 if so and 1 if not.
10478# If we subsequently discover a tag on such a growing tip, and that
10479# turns out to be a descendent of $anc (which it could, since we
10480# don't necessarily see children before parents), then $desc
10481# isn't a good choice to display as a descendent tag of
10482# $anc (since it is the descendent of another tag which is
10483# a descendent of $anc).  Similarly, $anc isn't a good choice to
10484# display as a ancestor tag of $desc.
10485#
10486proc is_certain {desc anc} {
10487    global arcnos arcout arcstart arcend growing problems
10488
10489    set certain {}
10490    if {[llength $arcnos($anc)] == 1} {
10491        # tags on the same arc are certain
10492        if {$arcnos($desc) eq $arcnos($anc)} {
10493            return 1
10494        }
10495        if {![info exists arcout($anc)]} {
10496            # if $anc is partway along an arc, use the start of the arc instead
10497            set a [lindex $arcnos($anc) 0]
10498            set anc $arcstart($a)
10499        }
10500    }
10501    if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10502        set x $desc
10503    } else {
10504        set a [lindex $arcnos($desc) 0]
10505        set x $arcend($a)
10506    }
10507    if {$x == $anc} {
10508        return 1
10509    }
10510    set anclist [list $x]
10511    set dl($x) 1
10512    set nnh 1
10513    set ngrowanc 0
10514    for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10515        set x [lindex $anclist $i]
10516        if {$dl($x)} {
10517            incr nnh -1
10518        }
10519        set done($x) 1
10520        foreach a $arcout($x) {
10521            if {[info exists growing($a)]} {
10522                if {![info exists growanc($x)] && $dl($x)} {
10523                    set growanc($x) 1
10524                    incr ngrowanc
10525                }
10526            } else {
10527                set y $arcend($a)
10528                if {[info exists dl($y)]} {
10529                    if {$dl($y)} {
10530                        if {!$dl($x)} {
10531                            set dl($y) 0
10532                            if {![info exists done($y)]} {
10533                                incr nnh -1
10534                            }
10535                            if {[info exists growanc($x)]} {
10536                                incr ngrowanc -1
10537                            }
10538                            set xl [list $y]
10539                            for {set k 0} {$k < [llength $xl]} {incr k} {
10540                                set z [lindex $xl $k]
10541                                foreach c $arcout($z) {
10542                                    if {[info exists arcend($c)]} {
10543                                        set v $arcend($c)
10544                                        if {[info exists dl($v)] && $dl($v)} {
10545                                            set dl($v) 0
10546                                            if {![info exists done($v)]} {
10547                                                incr nnh -1
10548                                            }
10549                                            if {[info exists growanc($v)]} {
10550                                                incr ngrowanc -1
10551                                            }
10552                                            lappend xl $v
10553                                        }
10554                                    }
10555                                }
10556                            }
10557                        }
10558                    }
10559                } elseif {$y eq $anc || !$dl($x)} {
10560                    set dl($y) 0
10561                    lappend anclist $y
10562                } else {
10563                    set dl($y) 1
10564                    lappend anclist $y
10565                    incr nnh
10566                }
10567            }
10568        }
10569    }
10570    foreach x [array names growanc] {
10571        if {$dl($x)} {
10572            return 0
10573        }
10574        return 0
10575    }
10576    return 1
10577}
10578
10579proc validate_arctags {a} {
10580    global arctags idtags
10581
10582    set i -1
10583    set na $arctags($a)
10584    foreach id $arctags($a) {
10585        incr i
10586        if {![info exists idtags($id)]} {
10587            set na [lreplace $na $i $i]
10588            incr i -1
10589        }
10590    }
10591    set arctags($a) $na
10592}
10593
10594proc validate_archeads {a} {
10595    global archeads idheads
10596
10597    set i -1
10598    set na $archeads($a)
10599    foreach id $archeads($a) {
10600        incr i
10601        if {![info exists idheads($id)]} {
10602            set na [lreplace $na $i $i]
10603            incr i -1
10604        }
10605    }
10606    set archeads($a) $na
10607}
10608
10609# Return the list of IDs that have tags that are descendents of id,
10610# ignoring IDs that are descendents of IDs already reported.
10611proc desctags {id} {
10612    global arcnos arcstart arcids arctags idtags allparents
10613    global growing cached_dtags
10614
10615    if {![info exists allparents($id)]} {
10616        return {}
10617    }
10618    set t1 [clock clicks -milliseconds]
10619    set argid $id
10620    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10621        # part-way along an arc; check that arc first
10622        set a [lindex $arcnos($id) 0]
10623        if {$arctags($a) ne {}} {
10624            validate_arctags $a
10625            set i [lsearch -exact $arcids($a) $id]
10626            set tid {}
10627            foreach t $arctags($a) {
10628                set j [lsearch -exact $arcids($a) $t]
10629                if {$j >= $i} break
10630                set tid $t
10631            }
10632            if {$tid ne {}} {
10633                return $tid
10634            }
10635        }
10636        set id $arcstart($a)
10637        if {[info exists idtags($id)]} {
10638            return $id
10639        }
10640    }
10641    if {[info exists cached_dtags($id)]} {
10642        return $cached_dtags($id)
10643    }
10644
10645    set origid $id
10646    set todo [list $id]
10647    set queued($id) 1
10648    set nc 1
10649    for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10650        set id [lindex $todo $i]
10651        set done($id) 1
10652        set ta [info exists hastaggedancestor($id)]
10653        if {!$ta} {
10654            incr nc -1
10655        }
10656        # ignore tags on starting node
10657        if {!$ta && $i > 0} {
10658            if {[info exists idtags($id)]} {
10659                set tagloc($id) $id
10660                set ta 1
10661            } elseif {[info exists cached_dtags($id)]} {
10662                set tagloc($id) $cached_dtags($id)
10663                set ta 1
10664            }
10665        }
10666        foreach a $arcnos($id) {
10667            set d $arcstart($a)
10668            if {!$ta && $arctags($a) ne {}} {
10669                validate_arctags $a
10670                if {$arctags($a) ne {}} {
10671                    lappend tagloc($id) [lindex $arctags($a) end]
10672                }
10673            }
10674            if {$ta || $arctags($a) ne {}} {
10675                set tomark [list $d]
10676                for {set j 0} {$j < [llength $tomark]} {incr j} {
10677                    set dd [lindex $tomark $j]
10678                    if {![info exists hastaggedancestor($dd)]} {
10679                        if {[info exists done($dd)]} {
10680                            foreach b $arcnos($dd) {
10681                                lappend tomark $arcstart($b)
10682                            }
10683                            if {[info exists tagloc($dd)]} {
10684                                unset tagloc($dd)
10685                            }
10686                        } elseif {[info exists queued($dd)]} {
10687                            incr nc -1
10688                        }
10689                        set hastaggedancestor($dd) 1
10690                    }
10691                }
10692            }
10693            if {![info exists queued($d)]} {
10694                lappend todo $d
10695                set queued($d) 1
10696                if {![info exists hastaggedancestor($d)]} {
10697                    incr nc
10698                }
10699            }
10700        }
10701    }
10702    set tags {}
10703    foreach id [array names tagloc] {
10704        if {![info exists hastaggedancestor($id)]} {
10705            foreach t $tagloc($id) {
10706                if {[lsearch -exact $tags $t] < 0} {
10707                    lappend tags $t
10708                }
10709            }
10710        }
10711    }
10712    set t2 [clock clicks -milliseconds]
10713    set loopix $i
10714
10715    # remove tags that are descendents of other tags
10716    for {set i 0} {$i < [llength $tags]} {incr i} {
10717        set a [lindex $tags $i]
10718        for {set j 0} {$j < $i} {incr j} {
10719            set b [lindex $tags $j]
10720            set r [anc_or_desc $a $b]
10721            if {$r == 1} {
10722                set tags [lreplace $tags $j $j]
10723                incr j -1
10724                incr i -1
10725            } elseif {$r == -1} {
10726                set tags [lreplace $tags $i $i]
10727                incr i -1
10728                break
10729            }
10730        }
10731    }
10732
10733    if {[array names growing] ne {}} {
10734        # graph isn't finished, need to check if any tag could get
10735        # eclipsed by another tag coming later.  Simply ignore any
10736        # tags that could later get eclipsed.
10737        set ctags {}
10738        foreach t $tags {
10739            if {[is_certain $t $origid]} {
10740                lappend ctags $t
10741            }
10742        }
10743        if {$tags eq $ctags} {
10744            set cached_dtags($origid) $tags
10745        } else {
10746            set tags $ctags
10747        }
10748    } else {
10749        set cached_dtags($origid) $tags
10750    }
10751    set t3 [clock clicks -milliseconds]
10752    if {0 && $t3 - $t1 >= 100} {
10753        puts "iterating descendents ($loopix/[llength $todo] nodes) took\
10754            [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10755    }
10756    return $tags
10757}
10758
10759proc anctags {id} {
10760    global arcnos arcids arcout arcend arctags idtags allparents
10761    global growing cached_atags
10762
10763    if {![info exists allparents($id)]} {
10764        return {}
10765    }
10766    set t1 [clock clicks -milliseconds]
10767    set argid $id
10768    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
10769        # part-way along an arc; check that arc first
10770        set a [lindex $arcnos($id) 0]
10771        if {$arctags($a) ne {}} {
10772            validate_arctags $a
10773            set i [lsearch -exact $arcids($a) $id]
10774            foreach t $arctags($a) {
10775                set j [lsearch -exact $arcids($a) $t]
10776                if {$j > $i} {
10777                    return $t
10778                }
10779            }
10780        }
10781        if {![info exists arcend($a)]} {
10782            return {}
10783        }
10784        set id $arcend($a)
10785        if {[info exists idtags($id)]} {
10786            return $id
10787        }
10788    }
10789    if {[info exists cached_atags($id)]} {
10790        return $cached_atags($id)
10791    }
10792
10793    set origid $id
10794    set todo [list $id]
10795    set queued($id) 1
10796    set taglist {}
10797    set nc 1
10798    for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
10799        set id [lindex $todo $i]
10800        set done($id) 1
10801        set td [info exists hastaggeddescendent($id)]
10802        if {!$td} {
10803            incr nc -1
10804        }
10805        # ignore tags on starting node
10806        if {!$td && $i > 0} {
10807            if {[info exists idtags($id)]} {
10808                set tagloc($id) $id
10809                set td 1
10810            } elseif {[info exists cached_atags($id)]} {
10811                set tagloc($id) $cached_atags($id)
10812                set td 1
10813            }
10814        }
10815        foreach a $arcout($id) {
10816            if {!$td && $arctags($a) ne {}} {
10817                validate_arctags $a
10818                if {$arctags($a) ne {}} {
10819                    lappend tagloc($id) [lindex $arctags($a) 0]
10820                }
10821            }
10822            if {![info exists arcend($a)]} continue
10823            set d $arcend($a)
10824            if {$td || $arctags($a) ne {}} {
10825                set tomark [list $d]
10826                for {set j 0} {$j < [llength $tomark]} {incr j} {
10827                    set dd [lindex $tomark $j]
10828                    if {![info exists hastaggeddescendent($dd)]} {
10829                        if {[info exists done($dd)]} {
10830                            foreach b $arcout($dd) {
10831                                if {[info exists arcend($b)]} {
10832                                    lappend tomark $arcend($b)
10833                                }
10834                            }
10835                            if {[info exists tagloc($dd)]} {
10836                                unset tagloc($dd)
10837                            }
10838                        } elseif {[info exists queued($dd)]} {
10839                            incr nc -1
10840                        }
10841                        set hastaggeddescendent($dd) 1
10842                    }
10843                }
10844            }
10845            if {![info exists queued($d)]} {
10846                lappend todo $d
10847                set queued($d) 1
10848                if {![info exists hastaggeddescendent($d)]} {
10849                    incr nc
10850                }
10851            }
10852        }
10853    }
10854    set t2 [clock clicks -milliseconds]
10855    set loopix $i
10856    set tags {}
10857    foreach id [array names tagloc] {
10858        if {![info exists hastaggeddescendent($id)]} {
10859            foreach t $tagloc($id) {
10860                if {[lsearch -exact $tags $t] < 0} {
10861                    lappend tags $t
10862                }
10863            }
10864        }
10865    }
10866
10867    # remove tags that are ancestors of other tags
10868    for {set i 0} {$i < [llength $tags]} {incr i} {
10869        set a [lindex $tags $i]
10870        for {set j 0} {$j < $i} {incr j} {
10871            set b [lindex $tags $j]
10872            set r [anc_or_desc $a $b]
10873            if {$r == -1} {
10874                set tags [lreplace $tags $j $j]
10875                incr j -1
10876                incr i -1
10877            } elseif {$r == 1} {
10878                set tags [lreplace $tags $i $i]
10879                incr i -1
10880                break
10881            }
10882        }
10883    }
10884
10885    if {[array names growing] ne {}} {
10886        # graph isn't finished, need to check if any tag could get
10887        # eclipsed by another tag coming later.  Simply ignore any
10888        # tags that could later get eclipsed.
10889        set ctags {}
10890        foreach t $tags {
10891            if {[is_certain $origid $t]} {
10892                lappend ctags $t
10893            }
10894        }
10895        if {$tags eq $ctags} {
10896            set cached_atags($origid) $tags
10897        } else {
10898            set tags $ctags
10899        }
10900    } else {
10901        set cached_atags($origid) $tags
10902    }
10903    set t3 [clock clicks -milliseconds]
10904    if {0 && $t3 - $t1 >= 100} {
10905        puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
10906            [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
10907    }
10908    return $tags
10909}
10910
10911# Return the list of IDs that have heads that are descendents of id,
10912# including id itself if it has a head.
10913proc descheads {id} {
10914    global arcnos arcstart arcids archeads idheads cached_dheads
10915    global allparents arcout
10916
10917    if {![info exists allparents($id)]} {
10918        return {}
10919    }
10920    set aret {}
10921    if {![info exists arcout($id)]} {
10922        # part-way along an arc; check it first
10923        set a [lindex $arcnos($id) 0]
10924        if {$archeads($a) ne {}} {
10925            validate_archeads $a
10926            set i [lsearch -exact $arcids($a) $id]
10927            foreach t $archeads($a) {
10928                set j [lsearch -exact $arcids($a) $t]
10929                if {$j > $i} break
10930                lappend aret $t
10931            }
10932        }
10933        set id $arcstart($a)
10934    }
10935    set origid $id
10936    set todo [list $id]
10937    set seen($id) 1
10938    set ret {}
10939    for {set i 0} {$i < [llength $todo]} {incr i} {
10940        set id [lindex $todo $i]
10941        if {[info exists cached_dheads($id)]} {
10942            set ret [concat $ret $cached_dheads($id)]
10943        } else {
10944            if {[info exists idheads($id)]} {
10945                lappend ret $id
10946            }
10947            foreach a $arcnos($id) {
10948                if {$archeads($a) ne {}} {
10949                    validate_archeads $a
10950                    if {$archeads($a) ne {}} {
10951                        set ret [concat $ret $archeads($a)]
10952                    }
10953                }
10954                set d $arcstart($a)
10955                if {![info exists seen($d)]} {
10956                    lappend todo $d
10957                    set seen($d) 1
10958                }
10959            }
10960        }
10961    }
10962    set ret [lsort -unique $ret]
10963    set cached_dheads($origid) $ret
10964    return [concat $ret $aret]
10965}
10966
10967proc addedtag {id} {
10968    global arcnos arcout cached_dtags cached_atags
10969
10970    if {![info exists arcnos($id)]} return
10971    if {![info exists arcout($id)]} {
10972        recalcarc [lindex $arcnos($id) 0]
10973    }
10974    catch {unset cached_dtags}
10975    catch {unset cached_atags}
10976}
10977
10978proc addedhead {hid head} {
10979    global arcnos arcout cached_dheads
10980
10981    if {![info exists arcnos($hid)]} return
10982    if {![info exists arcout($hid)]} {
10983        recalcarc [lindex $arcnos($hid) 0]
10984    }
10985    catch {unset cached_dheads}
10986}
10987
10988proc removedhead {hid head} {
10989    global cached_dheads
10990
10991    catch {unset cached_dheads}
10992}
10993
10994proc movedhead {hid head} {
10995    global arcnos arcout cached_dheads
10996
10997    if {![info exists arcnos($hid)]} return
10998    if {![info exists arcout($hid)]} {
10999        recalcarc [lindex $arcnos($hid) 0]
11000    }
11001    catch {unset cached_dheads}
11002}
11003
11004proc changedrefs {} {
11005    global cached_dheads cached_dtags cached_atags cached_tagcontent
11006    global arctags archeads arcnos arcout idheads idtags
11007
11008    foreach id [concat [array names idheads] [array names idtags]] {
11009        if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11010            set a [lindex $arcnos($id) 0]
11011            if {![info exists donearc($a)]} {
11012                recalcarc $a
11013                set donearc($a) 1
11014            }
11015        }
11016    }
11017    catch {unset cached_tagcontent}
11018    catch {unset cached_dtags}
11019    catch {unset cached_atags}
11020    catch {unset cached_dheads}
11021}
11022
11023proc rereadrefs {} {
11024    global idtags idheads idotherrefs mainheadid
11025
11026    set refids [concat [array names idtags] \
11027                    [array names idheads] [array names idotherrefs]]
11028    foreach id $refids {
11029        if {![info exists ref($id)]} {
11030            set ref($id) [listrefs $id]
11031        }
11032    }
11033    set oldmainhead $mainheadid
11034    readrefs
11035    changedrefs
11036    set refids [lsort -unique [concat $refids [array names idtags] \
11037                        [array names idheads] [array names idotherrefs]]]
11038    foreach id $refids {
11039        set v [listrefs $id]
11040        if {![info exists ref($id)] || $ref($id) != $v} {
11041            redrawtags $id
11042        }
11043    }
11044    if {$oldmainhead ne $mainheadid} {
11045        redrawtags $oldmainhead
11046        redrawtags $mainheadid
11047    }
11048    run refill_reflist
11049}
11050
11051proc listrefs {id} {
11052    global idtags idheads idotherrefs
11053
11054    set x {}
11055    if {[info exists idtags($id)]} {
11056        set x $idtags($id)
11057    }
11058    set y {}
11059    if {[info exists idheads($id)]} {
11060        set y $idheads($id)
11061    }
11062    set z {}
11063    if {[info exists idotherrefs($id)]} {
11064        set z $idotherrefs($id)
11065    }
11066    return [list $x $y $z]
11067}
11068
11069proc add_tag_ctext {tag} {
11070    global ctext cached_tagcontent tagids
11071
11072    if {![info exists cached_tagcontent($tag)]} {
11073        catch {
11074            set cached_tagcontent($tag) [exec git cat-file -p $tag]
11075        }
11076    }
11077    $ctext insert end "[mc "Tag"]: $tag\n" bold
11078    if {[info exists cached_tagcontent($tag)]} {
11079        set text $cached_tagcontent($tag)
11080    } else {
11081        set text "[mc "Id"]:  $tagids($tag)"
11082    }
11083    appendwithlinks $text {}
11084}
11085
11086proc showtag {tag isnew} {
11087    global ctext cached_tagcontent tagids linknum tagobjid
11088
11089    if {$isnew} {
11090        addtohistory [list showtag $tag 0] savectextpos
11091    }
11092    $ctext conf -state normal
11093    clear_ctext
11094    settabs 0
11095    set linknum 0
11096    add_tag_ctext $tag
11097    maybe_scroll_ctext 1
11098    $ctext conf -state disabled
11099    init_flist {}
11100}
11101
11102proc showtags {id isnew} {
11103    global idtags ctext linknum
11104
11105    if {$isnew} {
11106        addtohistory [list showtags $id 0] savectextpos
11107    }
11108    $ctext conf -state normal
11109    clear_ctext
11110    settabs 0
11111    set linknum 0
11112    set sep {}
11113    foreach tag $idtags($id) {
11114        $ctext insert end $sep
11115        add_tag_ctext $tag
11116        set sep "\n\n"
11117    }
11118    maybe_scroll_ctext 1
11119    $ctext conf -state disabled
11120    init_flist {}
11121}
11122
11123proc doquit {} {
11124    global stopped
11125    global gitktmpdir
11126
11127    set stopped 100
11128    savestuff .
11129    destroy .
11130
11131    if {[info exists gitktmpdir]} {
11132        catch {file delete -force $gitktmpdir}
11133    }
11134}
11135
11136proc mkfontdisp {font top which} {
11137    global fontattr fontpref $font NS use_ttk
11138
11139    set fontpref($font) [set $font]
11140    ${NS}::button $top.${font}but -text $which \
11141        -command [list choosefont $font $which]
11142    ${NS}::label $top.$font -relief flat -font $font \
11143        -text $fontattr($font,family) -justify left
11144    grid x $top.${font}but $top.$font -sticky w
11145}
11146
11147proc choosefont {font which} {
11148    global fontparam fontlist fonttop fontattr
11149    global prefstop NS
11150
11151    set fontparam(which) $which
11152    set fontparam(font) $font
11153    set fontparam(family) [font actual $font -family]
11154    set fontparam(size) $fontattr($font,size)
11155    set fontparam(weight) $fontattr($font,weight)
11156    set fontparam(slant) $fontattr($font,slant)
11157    set top .gitkfont
11158    set fonttop $top
11159    if {![winfo exists $top]} {
11160        font create sample
11161        eval font config sample [font actual $font]
11162        ttk_toplevel $top
11163        make_transient $top $prefstop
11164        wm title $top [mc "Gitk font chooser"]
11165        ${NS}::label $top.l -textvariable fontparam(which)
11166        pack $top.l -side top
11167        set fontlist [lsort [font families]]
11168        ${NS}::frame $top.f
11169        listbox $top.f.fam -listvariable fontlist \
11170            -yscrollcommand [list $top.f.sb set]
11171        bind $top.f.fam <<ListboxSelect>> selfontfam
11172        ${NS}::scrollbar $top.f.sb -command [list $top.f.fam yview]
11173        pack $top.f.sb -side right -fill y
11174        pack $top.f.fam -side left -fill both -expand 1
11175        pack $top.f -side top -fill both -expand 1
11176        ${NS}::frame $top.g
11177        spinbox $top.g.size -from 4 -to 40 -width 4 \
11178            -textvariable fontparam(size) \
11179            -validatecommand {string is integer -strict %s}
11180        checkbutton $top.g.bold -padx 5 \
11181            -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
11182            -variable fontparam(weight) -onvalue bold -offvalue normal
11183        checkbutton $top.g.ital -padx 5 \
11184            -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0  \
11185            -variable fontparam(slant) -onvalue italic -offvalue roman
11186        pack $top.g.size $top.g.bold $top.g.ital -side left
11187        pack $top.g -side top
11188        canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
11189            -background white
11190        $top.c create text 100 25 -anchor center -text $which -font sample \
11191            -fill black -tags text
11192        bind $top.c <Configure> [list centertext $top.c]
11193        pack $top.c -side top -fill x
11194        ${NS}::frame $top.buts
11195        ${NS}::button $top.buts.ok -text [mc "OK"] -command fontok -default active
11196        ${NS}::button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
11197        bind $top <Key-Return> fontok
11198        bind $top <Key-Escape> fontcan
11199        grid $top.buts.ok $top.buts.can
11200        grid columnconfigure $top.buts 0 -weight 1 -uniform a
11201        grid columnconfigure $top.buts 1 -weight 1 -uniform a
11202        pack $top.buts -side bottom -fill x
11203        trace add variable fontparam write chg_fontparam
11204    } else {
11205        raise $top
11206        $top.c itemconf text -text $which
11207    }
11208    set i [lsearch -exact $fontlist $fontparam(family)]
11209    if {$i >= 0} {
11210        $top.f.fam selection set $i
11211        $top.f.fam see $i
11212    }
11213}
11214
11215proc centertext {w} {
11216    $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11217}
11218
11219proc fontok {} {
11220    global fontparam fontpref prefstop
11221
11222    set f $fontparam(font)
11223    set fontpref($f) [list $fontparam(family) $fontparam(size)]
11224    if {$fontparam(weight) eq "bold"} {
11225        lappend fontpref($f) "bold"
11226    }
11227    if {$fontparam(slant) eq "italic"} {
11228        lappend fontpref($f) "italic"
11229    }
11230    set w $prefstop.notebook.fonts.$f
11231    $w conf -text $fontparam(family) -font $fontpref($f)
11232
11233    fontcan
11234}
11235
11236proc fontcan {} {
11237    global fonttop fontparam
11238
11239    if {[info exists fonttop]} {
11240        catch {destroy $fonttop}
11241        catch {font delete sample}
11242        unset fonttop
11243        unset fontparam
11244    }
11245}
11246
11247if {[package vsatisfies [package provide Tk] 8.6]} {
11248    # In Tk 8.6 we have a native font chooser dialog. Overwrite the above
11249    # function to make use of it.
11250    proc choosefont {font which} {
11251        tk fontchooser configure -title $which -font $font \
11252            -command [list on_choosefont $font $which]
11253        tk fontchooser show
11254    }
11255    proc on_choosefont {font which newfont} {
11256        global fontparam
11257        puts stderr "$font $newfont"
11258        array set f [font actual $newfont]
11259        set fontparam(which) $which
11260        set fontparam(font) $font
11261        set fontparam(family) $f(-family)
11262        set fontparam(size) $f(-size)
11263        set fontparam(weight) $f(-weight)
11264        set fontparam(slant) $f(-slant)
11265        fontok
11266    }
11267}
11268
11269proc selfontfam {} {
11270    global fonttop fontparam
11271
11272    set i [$fonttop.f.fam curselection]
11273    if {$i ne {}} {
11274        set fontparam(family) [$fonttop.f.fam get $i]
11275    }
11276}
11277
11278proc chg_fontparam {v sub op} {
11279    global fontparam
11280
11281    font config sample -$sub $fontparam($sub)
11282}
11283
11284# Create a property sheet tab page
11285proc create_prefs_page {w} {
11286    global NS
11287    set parent [join [lrange [split $w .] 0 end-1] .]
11288    if {[winfo class $parent] eq "TNotebook"} {
11289        ${NS}::frame $w
11290    } else {
11291        ${NS}::labelframe $w
11292    }
11293}
11294
11295proc prefspage_general {notebook} {
11296    global NS maxwidth maxgraphpct showneartags showlocalchanges
11297    global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11298    global hideremotes want_ttk have_ttk maxrefs
11299
11300    set page [create_prefs_page $notebook.general]
11301
11302    ${NS}::label $page.ldisp -text [mc "Commit list display options"]
11303    grid $page.ldisp - -sticky w -pady 10
11304    ${NS}::label $page.spacer -text " "
11305    ${NS}::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11306    spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11307    grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11308    ${NS}::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11309    spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11310    grid x $page.maxpctl $page.maxpct -sticky w
11311    ${NS}::checkbutton $page.showlocal -text [mc "Show local changes"] \
11312        -variable showlocalchanges
11313    grid x $page.showlocal -sticky w
11314    ${NS}::checkbutton $page.autoselect -text [mc "Auto-select SHA1 (length)"] \
11315        -variable autoselect
11316    spinbox $page.autosellen -from 1 -to 40 -width 4 -textvariable autosellen
11317    grid x $page.autoselect $page.autosellen -sticky w
11318    ${NS}::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11319        -variable hideremotes
11320    grid x $page.hideremotes -sticky w
11321
11322    ${NS}::label $page.ddisp -text [mc "Diff display options"]
11323    grid $page.ddisp - -sticky w -pady 10
11324    ${NS}::label $page.tabstopl -text [mc "Tab spacing"]
11325    spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11326    grid x $page.tabstopl $page.tabstop -sticky w
11327    ${NS}::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11328        -variable showneartags
11329    grid x $page.ntag -sticky w
11330    ${NS}::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11331    spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11332    grid x $page.maxrefsl $page.maxrefs -sticky w
11333    ${NS}::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11334        -variable limitdiffs
11335    grid x $page.ldiff -sticky w
11336    ${NS}::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11337        -variable perfile_attrs
11338    grid x $page.lattr -sticky w
11339
11340    ${NS}::entry $page.extdifft -textvariable extdifftool
11341    ${NS}::frame $page.extdifff
11342    ${NS}::label $page.extdifff.l -text [mc "External diff tool" ]
11343    ${NS}::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11344    pack $page.extdifff.l $page.extdifff.b -side left
11345    pack configure $page.extdifff.l -padx 10
11346    grid x $page.extdifff $page.extdifft -sticky ew
11347
11348    ${NS}::label $page.lgen -text [mc "General options"]
11349    grid $page.lgen - -sticky w -pady 10
11350    ${NS}::checkbutton $page.want_ttk -variable want_ttk \
11351        -text [mc "Use themed widgets"]
11352    if {$have_ttk} {
11353        ${NS}::label $page.ttk_note -text [mc "(change requires restart)"]
11354    } else {
11355        ${NS}::label $page.ttk_note -text [mc "(currently unavailable)"]
11356    }
11357    grid x $page.want_ttk $page.ttk_note -sticky w
11358    return $page
11359}
11360
11361proc prefspage_colors {notebook} {
11362    global NS uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11363
11364    set page [create_prefs_page $notebook.colors]
11365
11366    ${NS}::label $page.cdisp -text [mc "Colors: press to choose"]
11367    grid $page.cdisp - -sticky w -pady 10
11368    label $page.ui -padx 40 -relief sunk -background $uicolor
11369    ${NS}::button $page.uibut -text [mc "Interface"] \
11370       -command [list choosecolor uicolor {} $page.ui [mc "interface"] setui]
11371    grid x $page.uibut $page.ui -sticky w
11372    label $page.bg -padx 40 -relief sunk -background $bgcolor
11373    ${NS}::button $page.bgbut -text [mc "Background"] \
11374        -command [list choosecolor bgcolor {} $page.bg [mc "background"] setbg]
11375    grid x $page.bgbut $page.bg -sticky w
11376    label $page.fg -padx 40 -relief sunk -background $fgcolor
11377    ${NS}::button $page.fgbut -text [mc "Foreground"] \
11378        -command [list choosecolor fgcolor {} $page.fg [mc "foreground"] setfg]
11379    grid x $page.fgbut $page.fg -sticky w
11380    label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11381    ${NS}::button $page.diffoldbut -text [mc "Diff: old lines"] \
11382        -command [list choosecolor diffcolors 0 $page.diffold [mc "diff old lines"] \
11383                      [list $ctext tag conf d0 -foreground]]
11384    grid x $page.diffoldbut $page.diffold -sticky w
11385    label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11386    ${NS}::button $page.diffnewbut -text [mc "Diff: new lines"] \
11387        -command [list choosecolor diffcolors 1 $page.diffnew [mc "diff new lines"] \
11388                      [list $ctext tag conf dresult -foreground]]
11389    grid x $page.diffnewbut $page.diffnew -sticky w
11390    label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11391    ${NS}::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11392        -command [list choosecolor diffcolors 2 $page.hunksep \
11393                      [mc "diff hunk header"] \
11394                      [list $ctext tag conf hunksep -foreground]]
11395    grid x $page.hunksepbut $page.hunksep -sticky w
11396    label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11397    ${NS}::button $page.markbgbut -text [mc "Marked line bg"] \
11398        -command [list choosecolor markbgcolor {} $page.markbgsep \
11399                      [mc "marked line background"] \
11400                      [list $ctext tag conf omark -background]]
11401    grid x $page.markbgbut $page.markbgsep -sticky w
11402    label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11403    ${NS}::button $page.selbgbut -text [mc "Select bg"] \
11404        -command [list choosecolor selectbgcolor {} $page.selbgsep [mc "background"] setselbg]
11405    grid x $page.selbgbut $page.selbgsep -sticky w
11406    return $page
11407}
11408
11409proc prefspage_fonts {notebook} {
11410    global NS
11411    set page [create_prefs_page $notebook.fonts]
11412    ${NS}::label $page.cfont -text [mc "Fonts: press to choose"]
11413    grid $page.cfont - -sticky w -pady 10
11414    mkfontdisp mainfont $page [mc "Main font"]
11415    mkfontdisp textfont $page [mc "Diff display font"]
11416    mkfontdisp uifont $page [mc "User interface font"]
11417    return $page
11418}
11419
11420proc doprefs {} {
11421    global maxwidth maxgraphpct use_ttk NS
11422    global oldprefs prefstop showneartags showlocalchanges
11423    global uicolor bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11424    global tabstop limitdiffs autoselect autosellen extdifftool perfile_attrs
11425    global hideremotes want_ttk have_ttk
11426
11427    set top .gitkprefs
11428    set prefstop $top
11429    if {[winfo exists $top]} {
11430        raise $top
11431        return
11432    }
11433    foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11434                   limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11435        set oldprefs($v) [set $v]
11436    }
11437    ttk_toplevel $top
11438    wm title $top [mc "Gitk preferences"]
11439    make_transient $top .
11440
11441    if {[set use_notebook [expr {$use_ttk && [info command ::ttk::notebook] ne ""}]]} {
11442        set notebook [ttk::notebook $top.notebook]
11443    } else {
11444        set notebook [${NS}::frame $top.notebook -borderwidth 0 -relief flat]
11445    }
11446
11447    lappend pages [prefspage_general $notebook] [mc "General"]
11448    lappend pages [prefspage_colors $notebook] [mc "Colors"]
11449    lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11450    set col 0
11451    foreach {page title} $pages {
11452        if {$use_notebook} {
11453            $notebook add $page -text $title
11454        } else {
11455            set btn [${NS}::button $notebook.b_[string map {. X} $page] \
11456                         -text $title -command [list raise $page]]
11457            $page configure -text $title
11458            grid $btn -row 0 -column [incr col] -sticky w
11459            grid $page -row 1 -column 0 -sticky news -columnspan 100
11460        }
11461    }
11462
11463    if {!$use_notebook} {
11464        grid columnconfigure $notebook 0 -weight 1
11465        grid rowconfigure $notebook 1 -weight 1
11466        raise [lindex $pages 0]
11467    }
11468
11469    grid $notebook -sticky news -padx 2 -pady 2
11470    grid rowconfigure $top 0 -weight 1
11471    grid columnconfigure $top 0 -weight 1
11472
11473    ${NS}::frame $top.buts
11474    ${NS}::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11475    ${NS}::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11476    bind $top <Key-Return> prefsok
11477    bind $top <Key-Escape> prefscan
11478    grid $top.buts.ok $top.buts.can
11479    grid columnconfigure $top.buts 0 -weight 1 -uniform a
11480    grid columnconfigure $top.buts 1 -weight 1 -uniform a
11481    grid $top.buts - - -pady 10 -sticky ew
11482    grid columnconfigure $top 2 -weight 1
11483    bind $top <Visibility> [list focus $top.buts.ok]
11484}
11485
11486proc choose_extdiff {} {
11487    global extdifftool
11488
11489    set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11490    if {$prog ne {}} {
11491        set extdifftool $prog
11492    }
11493}
11494
11495proc choosecolor {v vi w x cmd} {
11496    global $v
11497
11498    set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11499               -title [mc "Gitk: choose color for %s" $x]]
11500    if {$c eq {}} return
11501    $w conf -background $c
11502    lset $v $vi $c
11503    eval $cmd $c
11504}
11505
11506proc setselbg {c} {
11507    global bglist cflist
11508    foreach w $bglist {
11509        $w configure -selectbackground $c
11510    }
11511    $cflist tag configure highlight \
11512        -background [$cflist cget -selectbackground]
11513    allcanvs itemconf secsel -fill $c
11514}
11515
11516# This sets the background color and the color scheme for the whole UI.
11517# For some reason, tk_setPalette chooses a nasty dark red for selectColor
11518# if we don't specify one ourselves, which makes the checkbuttons and
11519# radiobuttons look bad.  This chooses white for selectColor if the
11520# background color is light, or black if it is dark.
11521proc setui {c} {
11522    if {[tk windowingsystem] eq "win32"} { return }
11523    set bg [winfo rgb . $c]
11524    set selc black
11525    if {[lindex $bg 0] + 1.5 * [lindex $bg 1] + 0.5 * [lindex $bg 2] > 100000} {
11526        set selc white
11527    }
11528    tk_setPalette background $c selectColor $selc
11529}
11530
11531proc setbg {c} {
11532    global bglist
11533
11534    foreach w $bglist {
11535        $w conf -background $c
11536    }
11537}
11538
11539proc setfg {c} {
11540    global fglist canv
11541
11542    foreach w $fglist {
11543        $w conf -foreground $c
11544    }
11545    allcanvs itemconf text -fill $c
11546    $canv itemconf circle -outline $c
11547    $canv itemconf markid -outline $c
11548}
11549
11550proc prefscan {} {
11551    global oldprefs prefstop
11552
11553    foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
11554                   limitdiffs tabstop perfile_attrs hideremotes want_ttk} {
11555        global $v
11556        set $v $oldprefs($v)
11557    }
11558    catch {destroy $prefstop}
11559    unset prefstop
11560    fontcan
11561}
11562
11563proc prefsok {} {
11564    global maxwidth maxgraphpct
11565    global oldprefs prefstop showneartags showlocalchanges
11566    global fontpref mainfont textfont uifont
11567    global limitdiffs treediffs perfile_attrs
11568    global hideremotes
11569
11570    catch {destroy $prefstop}
11571    unset prefstop
11572    fontcan
11573    set fontchanged 0
11574    if {$mainfont ne $fontpref(mainfont)} {
11575        set mainfont $fontpref(mainfont)
11576        parsefont mainfont $mainfont
11577        eval font configure mainfont [fontflags mainfont]
11578        eval font configure mainfontbold [fontflags mainfont 1]
11579        setcoords
11580        set fontchanged 1
11581    }
11582    if {$textfont ne $fontpref(textfont)} {
11583        set textfont $fontpref(textfont)
11584        parsefont textfont $textfont
11585        eval font configure textfont [fontflags textfont]
11586        eval font configure textfontbold [fontflags textfont 1]
11587    }
11588    if {$uifont ne $fontpref(uifont)} {
11589        set uifont $fontpref(uifont)
11590        parsefont uifont $uifont
11591        eval font configure uifont [fontflags uifont]
11592    }
11593    settabs
11594    if {$showlocalchanges != $oldprefs(showlocalchanges)} {
11595        if {$showlocalchanges} {
11596            doshowlocalchanges
11597        } else {
11598            dohidelocalchanges
11599        }
11600    }
11601    if {$limitdiffs != $oldprefs(limitdiffs) ||
11602        ($perfile_attrs && !$oldprefs(perfile_attrs))} {
11603        # treediffs elements are limited by path;
11604        # won't have encodings cached if perfile_attrs was just turned on
11605        catch {unset treediffs}
11606    }
11607    if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
11608        || $maxgraphpct != $oldprefs(maxgraphpct)} {
11609        redisplay
11610    } elseif {$showneartags != $oldprefs(showneartags) ||
11611          $limitdiffs != $oldprefs(limitdiffs)} {
11612        reselectline
11613    }
11614    if {$hideremotes != $oldprefs(hideremotes)} {
11615        rereadrefs
11616    }
11617}
11618
11619proc formatdate {d} {
11620    global datetimeformat
11621    if {$d ne {}} {
11622        # If $datetimeformat includes a timezone, display in the
11623        # timezone of the argument.  Otherwise, display in local time.
11624        if {[string match {*%[zZ]*} $datetimeformat]} {
11625            if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
11626                # Tcl < 8.5 does not support -timezone.  Emulate it by
11627                # setting TZ (e.g. TZ=<-0430>+04:30).
11628                global env
11629                if {[info exists env(TZ)]} {
11630                    set savedTZ $env(TZ)
11631                }
11632                set zone [lindex $d 1]
11633                set sign [string map {+ - - +} [string index $zone 0]]
11634                set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
11635                set d [clock format [lindex $d 0] -format $datetimeformat]
11636                if {[info exists savedTZ]} {
11637                    set env(TZ) $savedTZ
11638                } else {
11639                    unset env(TZ)
11640                }
11641            }
11642        } else {
11643            set d [clock format [lindex $d 0] -format $datetimeformat]
11644        }
11645    }
11646    return $d
11647}
11648
11649# This list of encoding names and aliases is distilled from
11650# http://www.iana.org/assignments/character-sets.
11651# Not all of them are supported by Tcl.
11652set encoding_aliases {
11653    { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
11654      ISO646-US US-ASCII us IBM367 cp367 csASCII }
11655    { ISO-10646-UTF-1 csISO10646UTF1 }
11656    { ISO_646.basic:1983 ref csISO646basic1983 }
11657    { INVARIANT csINVARIANT }
11658    { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
11659    { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
11660    { NATS-SEFI iso-ir-8-1 csNATSSEFI }
11661    { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
11662    { NATS-DANO iso-ir-9-1 csNATSDANO }
11663    { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
11664    { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
11665    { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
11666    { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
11667    { ISO-2022-KR csISO2022KR }
11668    { EUC-KR csEUCKR }
11669    { ISO-2022-JP csISO2022JP }
11670    { ISO-2022-JP-2 csISO2022JP2 }
11671    { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
11672      csISO13JISC6220jp }
11673    { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
11674    { IT iso-ir-15 ISO646-IT csISO15Italian }
11675    { PT iso-ir-16 ISO646-PT csISO16Portuguese }
11676    { ES iso-ir-17 ISO646-ES csISO17Spanish }
11677    { greek7-old iso-ir-18 csISO18Greek7Old }
11678    { latin-greek iso-ir-19 csISO19LatinGreek }
11679    { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
11680    { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
11681    { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
11682    { ISO_5427 iso-ir-37 csISO5427Cyrillic }
11683    { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
11684    { BS_viewdata iso-ir-47 csISO47BSViewdata }
11685    { INIS iso-ir-49 csISO49INIS }
11686    { INIS-8 iso-ir-50 csISO50INIS8 }
11687    { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
11688    { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
11689    { ISO_5428:1980 iso-ir-55 csISO5428Greek }
11690    { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
11691    { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
11692    { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
11693      csISO60Norwegian1 }
11694    { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
11695    { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
11696    { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
11697    { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
11698    { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
11699    { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
11700    { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
11701    { greek7 iso-ir-88 csISO88Greek7 }
11702    { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
11703    { iso-ir-90 csISO90 }
11704    { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
11705    { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
11706      csISO92JISC62991984b }
11707    { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
11708    { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
11709    { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
11710      csISO95JIS62291984handadd }
11711    { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
11712    { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
11713    { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
11714    { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
11715      CP819 csISOLatin1 }
11716    { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
11717    { T.61-7bit iso-ir-102 csISO102T617bit }
11718    { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
11719    { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
11720    { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
11721    { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
11722    { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
11723    { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
11724    { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
11725    { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
11726      arabic csISOLatinArabic }
11727    { ISO_8859-6-E csISO88596E ISO-8859-6-E }
11728    { ISO_8859-6-I csISO88596I ISO-8859-6-I }
11729    { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
11730      greek greek8 csISOLatinGreek }
11731    { T.101-G2 iso-ir-128 csISO128T101G2 }
11732    { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
11733      csISOLatinHebrew }
11734    { ISO_8859-8-E csISO88598E ISO-8859-8-E }
11735    { ISO_8859-8-I csISO88598I ISO-8859-8-I }
11736    { CSN_369103 iso-ir-139 csISO139CSN369103 }
11737    { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
11738    { ISO_6937-2-add iso-ir-142 csISOTextComm }
11739    { IEC_P27-1 iso-ir-143 csISO143IECP271 }
11740    { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
11741      csISOLatinCyrillic }
11742    { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
11743    { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
11744    { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
11745    { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
11746    { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
11747    { ISO_6937-2-25 iso-ir-152 csISO6937Add }
11748    { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
11749    { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
11750    { ISO_10367-box iso-ir-155 csISO10367Box }
11751    { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
11752    { latin-lap lap iso-ir-158 csISO158Lap }
11753    { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
11754    { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
11755    { us-dk csUSDK }
11756    { dk-us csDKUS }
11757    { JIS_X0201 X0201 csHalfWidthKatakana }
11758    { KSC5636 ISO646-KR csKSC5636 }
11759    { ISO-10646-UCS-2 csUnicode }
11760    { ISO-10646-UCS-4 csUCS4 }
11761    { DEC-MCS dec csDECMCS }
11762    { hp-roman8 roman8 r8 csHPRoman8 }
11763    { macintosh mac csMacintosh }
11764    { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
11765      csIBM037 }
11766    { IBM038 EBCDIC-INT cp038 csIBM038 }
11767    { IBM273 CP273 csIBM273 }
11768    { IBM274 EBCDIC-BE CP274 csIBM274 }
11769    { IBM275 EBCDIC-BR cp275 csIBM275 }
11770    { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
11771    { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
11772    { IBM280 CP280 ebcdic-cp-it csIBM280 }
11773    { IBM281 EBCDIC-JP-E cp281 csIBM281 }
11774    { IBM284 CP284 ebcdic-cp-es csIBM284 }
11775    { IBM285 CP285 ebcdic-cp-gb csIBM285 }
11776    { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
11777    { IBM297 cp297 ebcdic-cp-fr csIBM297 }
11778    { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
11779    { IBM423 cp423 ebcdic-cp-gr csIBM423 }
11780    { IBM424 cp424 ebcdic-cp-he csIBM424 }
11781    { IBM437 cp437 437 csPC8CodePage437 }
11782    { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
11783    { IBM775 cp775 csPC775Baltic }
11784    { IBM850 cp850 850 csPC850Multilingual }
11785    { IBM851 cp851 851 csIBM851 }
11786    { IBM852 cp852 852 csPCp852 }
11787    { IBM855 cp855 855 csIBM855 }
11788    { IBM857 cp857 857 csIBM857 }
11789    { IBM860 cp860 860 csIBM860 }
11790    { IBM861 cp861 861 cp-is csIBM861 }
11791    { IBM862 cp862 862 csPC862LatinHebrew }
11792    { IBM863 cp863 863 csIBM863 }
11793    { IBM864 cp864 csIBM864 }
11794    { IBM865 cp865 865 csIBM865 }
11795    { IBM866 cp866 866 csIBM866 }
11796    { IBM868 CP868 cp-ar csIBM868 }
11797    { IBM869 cp869 869 cp-gr csIBM869 }
11798    { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
11799    { IBM871 CP871 ebcdic-cp-is csIBM871 }
11800    { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
11801    { IBM891 cp891 csIBM891 }
11802    { IBM903 cp903 csIBM903 }
11803    { IBM904 cp904 904 csIBBM904 }
11804    { IBM905 CP905 ebcdic-cp-tr csIBM905 }
11805    { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
11806    { IBM1026 CP1026 csIBM1026 }
11807    { EBCDIC-AT-DE csIBMEBCDICATDE }
11808    { EBCDIC-AT-DE-A csEBCDICATDEA }
11809    { EBCDIC-CA-FR csEBCDICCAFR }
11810    { EBCDIC-DK-NO csEBCDICDKNO }
11811    { EBCDIC-DK-NO-A csEBCDICDKNOA }
11812    { EBCDIC-FI-SE csEBCDICFISE }
11813    { EBCDIC-FI-SE-A csEBCDICFISEA }
11814    { EBCDIC-FR csEBCDICFR }
11815    { EBCDIC-IT csEBCDICIT }
11816    { EBCDIC-PT csEBCDICPT }
11817    { EBCDIC-ES csEBCDICES }
11818    { EBCDIC-ES-A csEBCDICESA }
11819    { EBCDIC-ES-S csEBCDICESS }
11820    { EBCDIC-UK csEBCDICUK }
11821    { EBCDIC-US csEBCDICUS }
11822    { UNKNOWN-8BIT csUnknown8BiT }
11823    { MNEMONIC csMnemonic }
11824    { MNEM csMnem }
11825    { VISCII csVISCII }
11826    { VIQR csVIQR }
11827    { KOI8-R csKOI8R }
11828    { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
11829    { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
11830    { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
11831    { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
11832    { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
11833    { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
11834    { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
11835    { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
11836    { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
11837    { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
11838    { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
11839    { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
11840    { IBM1047 IBM-1047 }
11841    { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
11842    { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
11843    { UNICODE-1-1 csUnicode11 }
11844    { CESU-8 csCESU-8 }
11845    { BOCU-1 csBOCU-1 }
11846    { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
11847    { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
11848      l8 }
11849    { ISO-8859-15 ISO_8859-15 Latin-9 }
11850    { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
11851    { GBK CP936 MS936 windows-936 }
11852    { JIS_Encoding csJISEncoding }
11853    { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
11854    { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
11855      EUC-JP }
11856    { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
11857    { ISO-10646-UCS-Basic csUnicodeASCII }
11858    { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
11859    { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
11860    { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
11861    { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
11862    { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
11863    { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
11864    { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
11865    { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
11866    { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
11867    { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
11868    { Adobe-Standard-Encoding csAdobeStandardEncoding }
11869    { Ventura-US csVenturaUS }
11870    { Ventura-International csVenturaInternational }
11871    { PC8-Danish-Norwegian csPC8DanishNorwegian }
11872    { PC8-Turkish csPC8Turkish }
11873    { IBM-Symbols csIBMSymbols }
11874    { IBM-Thai csIBMThai }
11875    { HP-Legal csHPLegal }
11876    { HP-Pi-font csHPPiFont }
11877    { HP-Math8 csHPMath8 }
11878    { Adobe-Symbol-Encoding csHPPSMath }
11879    { HP-DeskTop csHPDesktop }
11880    { Ventura-Math csVenturaMath }
11881    { Microsoft-Publishing csMicrosoftPublishing }
11882    { Windows-31J csWindows31J }
11883    { GB2312 csGB2312 }
11884    { Big5 csBig5 }
11885}
11886
11887proc tcl_encoding {enc} {
11888    global encoding_aliases tcl_encoding_cache
11889    if {[info exists tcl_encoding_cache($enc)]} {
11890        return $tcl_encoding_cache($enc)
11891    }
11892    set names [encoding names]
11893    set lcnames [string tolower $names]
11894    set enc [string tolower $enc]
11895    set i [lsearch -exact $lcnames $enc]
11896    if {$i < 0} {
11897        # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
11898        if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
11899            set i [lsearch -exact $lcnames $encx]
11900        }
11901    }
11902    if {$i < 0} {
11903        foreach l $encoding_aliases {
11904            set ll [string tolower $l]
11905            if {[lsearch -exact $ll $enc] < 0} continue
11906            # look through the aliases for one that tcl knows about
11907            foreach e $ll {
11908                set i [lsearch -exact $lcnames $e]
11909                if {$i < 0} {
11910                    if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
11911                        set i [lsearch -exact $lcnames $ex]
11912                    }
11913                }
11914                if {$i >= 0} break
11915            }
11916            break
11917        }
11918    }
11919    set tclenc {}
11920    if {$i >= 0} {
11921        set tclenc [lindex $names $i]
11922    }
11923    set tcl_encoding_cache($enc) $tclenc
11924    return $tclenc
11925}
11926
11927proc gitattr {path attr default} {
11928    global path_attr_cache
11929    if {[info exists path_attr_cache($attr,$path)]} {
11930        set r $path_attr_cache($attr,$path)
11931    } else {
11932        set r "unspecified"
11933        if {![catch {set line [exec git check-attr $attr -- $path]}]} {
11934            regexp "(.*): $attr: (.*)" $line m f r
11935        }
11936        set path_attr_cache($attr,$path) $r
11937    }
11938    if {$r eq "unspecified"} {
11939        return $default
11940    }
11941    return $r
11942}
11943
11944proc cache_gitattr {attr pathlist} {
11945    global path_attr_cache
11946    set newlist {}
11947    foreach path $pathlist {
11948        if {![info exists path_attr_cache($attr,$path)]} {
11949            lappend newlist $path
11950        }
11951    }
11952    set lim 1000
11953    if {[tk windowingsystem] == "win32"} {
11954        # windows has a 32k limit on the arguments to a command...
11955        set lim 30
11956    }
11957    while {$newlist ne {}} {
11958        set head [lrange $newlist 0 [expr {$lim - 1}]]
11959        set newlist [lrange $newlist $lim end]
11960        if {![catch {set rlist [eval exec git check-attr $attr -- $head]}]} {
11961            foreach row [split $rlist "\n"] {
11962                if {[regexp "(.*): $attr: (.*)" $row m path value]} {
11963                    if {[string index $path 0] eq "\""} {
11964                        set path [encoding convertfrom [lindex $path 0]]
11965                    }
11966                    set path_attr_cache($attr,$path) $value
11967                }
11968            }
11969        }
11970    }
11971}
11972
11973proc get_path_encoding {path} {
11974    global gui_encoding perfile_attrs
11975    set tcl_enc $gui_encoding
11976    if {$path ne {} && $perfile_attrs} {
11977        set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
11978        if {$enc2 ne {}} {
11979            set tcl_enc $enc2
11980        }
11981    }
11982    return $tcl_enc
11983}
11984
11985# First check that Tcl/Tk is recent enough
11986if {[catch {package require Tk 8.4} err]} {
11987    show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
11988                     Gitk requires at least Tcl/Tk 8.4." list
11989    exit 1
11990}
11991
11992# on OSX bring the current Wish process window to front
11993if {[tk windowingsystem] eq "aqua"} {
11994    exec osascript -e [format {
11995        tell application "System Events"
11996            set frontmost of processes whose unix id is %d to true
11997        end tell
11998    } [pid] ]
11999}
12000
12001# Unset GIT_TRACE var if set
12002if { [info exists ::env(GIT_TRACE)] } {
12003    unset ::env(GIT_TRACE)
12004}
12005
12006# defaults...
12007set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12008
12009set gitencoding {}
12010catch {
12011    set gitencoding [exec git config --get i18n.commitencoding]
12012}
12013catch {
12014    set gitencoding [exec git config --get i18n.logoutputencoding]
12015}
12016if {$gitencoding == ""} {
12017    set gitencoding "utf-8"
12018}
12019set tclencoding [tcl_encoding $gitencoding]
12020if {$tclencoding == {}} {
12021    puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12022}
12023
12024set gui_encoding [encoding system]
12025catch {
12026    set enc [exec git config --get gui.encoding]
12027    if {$enc ne {}} {
12028        set tclenc [tcl_encoding $enc]
12029        if {$tclenc ne {}} {
12030            set gui_encoding $tclenc
12031        } else {
12032            puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12033        }
12034    }
12035}
12036
12037set log_showroot true
12038catch {
12039    set log_showroot [exec git config --bool --get log.showroot]
12040}
12041
12042if {[tk windowingsystem] eq "aqua"} {
12043    set mainfont {{Lucida Grande} 9}
12044    set textfont {Monaco 9}
12045    set uifont {{Lucida Grande} 9 bold}
12046} elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12047    # fontconfig!
12048    set mainfont {sans 9}
12049    set textfont {monospace 9}
12050    set uifont {sans 9 bold}
12051} else {
12052    set mainfont {Helvetica 9}
12053    set textfont {Courier 9}
12054    set uifont {Helvetica 9 bold}
12055}
12056set tabstop 8
12057set findmergefiles 0
12058set maxgraphpct 50
12059set maxwidth 16
12060set revlistorder 0
12061set fastdate 0
12062set uparrowlen 5
12063set downarrowlen 5
12064set mingaplen 100
12065set cmitmode "patch"
12066set wrapcomment "none"
12067set showneartags 1
12068set hideremotes 0
12069set maxrefs 20
12070set visiblerefs {"master"}
12071set maxlinelen 200
12072set showlocalchanges 1
12073set limitdiffs 1
12074set datetimeformat "%Y-%m-%d %H:%M:%S"
12075set autoselect 1
12076set autosellen 40
12077set perfile_attrs 0
12078set want_ttk 1
12079
12080if {[tk windowingsystem] eq "aqua"} {
12081    set extdifftool "opendiff"
12082} else {
12083    set extdifftool "meld"
12084}
12085
12086set colors {green red blue magenta darkgrey brown orange}
12087if {[tk windowingsystem] eq "win32"} {
12088    set uicolor SystemButtonFace
12089    set uifgcolor SystemButtonText
12090    set uifgdisabledcolor SystemDisabledText
12091    set bgcolor SystemWindow
12092    set fgcolor SystemWindowText
12093    set selectbgcolor SystemHighlight
12094} else {
12095    set uicolor grey85
12096    set uifgcolor black
12097    set uifgdisabledcolor "#999"
12098    set bgcolor white
12099    set fgcolor black
12100    set selectbgcolor gray85
12101}
12102set diffcolors {red "#00a000" blue}
12103set diffcontext 3
12104set mergecolors {red blue green purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12105set ignorespace 0
12106set worddiff ""
12107set markbgcolor "#e0e0ff"
12108
12109set headbgcolor green
12110set headfgcolor black
12111set headoutlinecolor black
12112set remotebgcolor #ffddaa
12113set tagbgcolor yellow
12114set tagfgcolor black
12115set tagoutlinecolor black
12116set reflinecolor black
12117set filesepbgcolor #aaaaaa
12118set filesepfgcolor black
12119set linehoverbgcolor #ffff80
12120set linehoverfgcolor black
12121set linehoveroutlinecolor black
12122set mainheadcirclecolor yellow
12123set workingfilescirclecolor red
12124set indexcirclecolor green
12125set circlecolors {white blue gray blue blue}
12126set linkfgcolor blue
12127set circleoutlinecolor $fgcolor
12128set foundbgcolor yellow
12129set currentsearchhitbgcolor orange
12130
12131# button for popping up context menus
12132if {[tk windowingsystem] eq "aqua"} {
12133    set ctxbut <Button-2>
12134} else {
12135    set ctxbut <Button-3>
12136}
12137
12138## For msgcat loading, first locate the installation location.
12139if { [info exists ::env(GITK_MSGSDIR)] } {
12140    ## Msgsdir was manually set in the environment.
12141    set gitk_msgsdir $::env(GITK_MSGSDIR)
12142} else {
12143    ## Let's guess the prefix from argv0.
12144    set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12145    set gitk_libdir [file join $gitk_prefix share gitk lib]
12146    set gitk_msgsdir [file join $gitk_libdir msgs]
12147    unset gitk_prefix
12148}
12149
12150## Internationalization (i18n) through msgcat and gettext. See
12151## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12152package require msgcat
12153namespace import ::msgcat::mc
12154## And eventually load the actual message catalog
12155::msgcat::mcload $gitk_msgsdir
12156
12157catch {
12158    # follow the XDG base directory specification by default. See
12159    # http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
12160    if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12161        # XDG_CONFIG_HOME environment variable is set
12162        set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12163        set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12164    } else {
12165        # default XDG_CONFIG_HOME
12166        set config_file "~/.config/git/gitk"
12167        set config_file_tmp "~/.config/git/gitk-tmp"
12168    }
12169    if {![file exists $config_file]} {
12170        # for backward compatibility use the old config file if it exists
12171        if {[file exists "~/.gitk"]} {
12172            set config_file "~/.gitk"
12173            set config_file_tmp "~/.gitk-tmp"
12174        } elseif {![file exists [file dirname $config_file]]} {
12175            file mkdir [file dirname $config_file]
12176        }
12177    }
12178    source $config_file
12179}
12180
12181set config_variables {
12182    mainfont textfont uifont tabstop findmergefiles maxgraphpct maxwidth
12183    cmitmode wrapcomment autoselect autosellen showneartags maxrefs visiblerefs
12184    hideremotes showlocalchanges datetimeformat limitdiffs uicolor want_ttk
12185    bgcolor fgcolor uifgcolor uifgdisabledcolor colors diffcolors mergecolors
12186    markbgcolor diffcontext selectbgcolor foundbgcolor currentsearchhitbgcolor
12187    extdifftool perfile_attrs headbgcolor headfgcolor headoutlinecolor
12188    remotebgcolor tagbgcolor tagfgcolor tagoutlinecolor reflinecolor
12189    filesepbgcolor filesepfgcolor linehoverbgcolor linehoverfgcolor
12190    linehoveroutlinecolor mainheadcirclecolor workingfilescirclecolor
12191    indexcirclecolor circlecolors linkfgcolor circleoutlinecolor
12192}
12193foreach var $config_variables {
12194    config_init_trace $var
12195    trace add variable $var write config_variable_change_cb
12196}
12197
12198parsefont mainfont $mainfont
12199eval font create mainfont [fontflags mainfont]
12200eval font create mainfontbold [fontflags mainfont 1]
12201
12202parsefont textfont $textfont
12203eval font create textfont [fontflags textfont]
12204eval font create textfontbold [fontflags textfont 1]
12205
12206parsefont uifont $uifont
12207eval font create uifont [fontflags uifont]
12208
12209setui $uicolor
12210
12211setoptions
12212
12213# check that we can find a .git directory somewhere...
12214if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12215    show_error {} . [mc "Cannot find a git repository here."]
12216    exit 1
12217}
12218
12219set selecthead {}
12220set selectheadid {}
12221
12222set revtreeargs {}
12223set cmdline_files {}
12224set i 0
12225set revtreeargscmd {}
12226foreach arg $argv {
12227    switch -glob -- $arg {
12228        "" { }
12229        "--" {
12230            set cmdline_files [lrange $argv [expr {$i + 1}] end]
12231            break
12232        }
12233        "--select-commit=*" {
12234            set selecthead [string range $arg 16 end]
12235        }
12236        "--argscmd=*" {
12237            set revtreeargscmd [string range $arg 10 end]
12238        }
12239        default {
12240            lappend revtreeargs $arg
12241        }
12242    }
12243    incr i
12244}
12245
12246if {$selecthead eq "HEAD"} {
12247    set selecthead {}
12248}
12249
12250if {$i >= [llength $argv] && $revtreeargs ne {}} {
12251    # no -- on command line, but some arguments (other than --argscmd)
12252    if {[catch {
12253        set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
12254        set cmdline_files [split $f "\n"]
12255        set n [llength $cmdline_files]
12256        set revtreeargs [lrange $revtreeargs 0 end-$n]
12257        # Unfortunately git rev-parse doesn't produce an error when
12258        # something is both a revision and a filename.  To be consistent
12259        # with git log and git rev-list, check revtreeargs for filenames.
12260        foreach arg $revtreeargs {
12261            if {[file exists $arg]} {
12262                show_error {} . [mc "Ambiguous argument '%s': both revision\
12263                                 and filename" $arg]
12264                exit 1
12265            }
12266        }
12267    } err]} {
12268        # unfortunately we get both stdout and stderr in $err,
12269        # so look for "fatal:".
12270        set i [string first "fatal:" $err]
12271        if {$i > 0} {
12272            set err [string range $err [expr {$i + 6}] end]
12273        }
12274        show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12275        exit 1
12276    }
12277}
12278
12279set nullid "0000000000000000000000000000000000000000"
12280set nullid2 "0000000000000000000000000000000000000001"
12281set nullfile "/dev/null"
12282
12283set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
12284if {![info exists have_ttk]} {
12285    set have_ttk [llength [info commands ::ttk::style]]
12286}
12287set use_ttk [expr {$have_ttk && $want_ttk}]
12288set NS [expr {$use_ttk ? "ttk" : ""}]
12289
12290regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
12291
12292set show_notes {}
12293if {[package vcompare $git_version "1.6.6.2"] >= 0} {
12294    set show_notes "--show-notes"
12295}
12296
12297set appname "gitk"
12298
12299set runq {}
12300set history {}
12301set historyindex 0
12302set fh_serial 0
12303set nhl_names {}
12304set highlight_paths {}
12305set findpattern {}
12306set searchdirn -forwards
12307set boldids {}
12308set boldnameids {}
12309set diffelide {0 0}
12310set markingmatches 0
12311set linkentercount 0
12312set need_redisplay 0
12313set nrows_drawn 0
12314set firsttabstop 0
12315
12316set nextviewnum 1
12317set curview 0
12318set selectedview 0
12319set selectedhlview [mc "None"]
12320set highlight_related [mc "None"]
12321set highlight_files {}
12322set viewfiles(0) {}
12323set viewperm(0) 0
12324set viewchanged(0) 0
12325set viewargs(0) {}
12326set viewargscmd(0) {}
12327
12328set selectedline {}
12329set numcommits 0
12330set loginstance 0
12331set cmdlineok 0
12332set stopped 0
12333set stuffsaved 0
12334set patchnum 0
12335set lserial 0
12336set hasworktree [hasworktree]
12337set cdup {}
12338if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12339    set cdup [exec git rev-parse --show-cdup]
12340}
12341set worktree [exec git rev-parse --show-toplevel]
12342setcoords
12343makewindow
12344catch {
12345    image create photo gitlogo      -width 16 -height 16
12346
12347    image create photo gitlogominus -width  4 -height  2
12348    gitlogominus put #C00000 -to 0 0 4 2
12349    gitlogo copy gitlogominus -to  1 5
12350    gitlogo copy gitlogominus -to  6 5
12351    gitlogo copy gitlogominus -to 11 5
12352    image delete gitlogominus
12353
12354    image create photo gitlogoplus  -width  4 -height  4
12355    gitlogoplus  put #008000 -to 1 0 3 4
12356    gitlogoplus  put #008000 -to 0 1 4 3
12357    gitlogo copy gitlogoplus  -to  1 9
12358    gitlogo copy gitlogoplus  -to  6 9
12359    gitlogo copy gitlogoplus  -to 11 9
12360    image delete gitlogoplus
12361
12362    image create photo gitlogo32    -width 32 -height 32
12363    gitlogo32 copy gitlogo -zoom 2 2
12364
12365    wm iconphoto . -default gitlogo gitlogo32
12366}
12367# wait for the window to become visible
12368tkwait visibility .
12369wm title . "$appname: [reponame]"
12370update
12371readrefs
12372
12373if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12374    # create a view for the files/dirs specified on the command line
12375    set curview 1
12376    set selectedview 1
12377    set nextviewnum 2
12378    set viewname(1) [mc "Command line"]
12379    set viewfiles(1) $cmdline_files
12380    set viewargs(1) $revtreeargs
12381    set viewargscmd(1) $revtreeargscmd
12382    set viewperm(1) 0
12383    set viewchanged(1) 0
12384    set vdatemode(1) 0
12385    addviewmenu 1
12386    .bar.view entryconf [mca "Edit view..."] -state normal
12387    .bar.view entryconf [mca "Delete view"] -state normal
12388}
12389
12390if {[info exists permviews]} {
12391    foreach v $permviews {
12392        set n $nextviewnum
12393        incr nextviewnum
12394        set viewname($n) [lindex $v 0]
12395        set viewfiles($n) [lindex $v 1]
12396        set viewargs($n) [lindex $v 2]
12397        set viewargscmd($n) [lindex $v 3]
12398        set viewperm($n) 1
12399        set viewchanged($n) 0
12400        addviewmenu $n
12401    }
12402}
12403
12404if {[tk windowingsystem] eq "win32"} {
12405    focus -force .
12406}
12407
12408getcommits {}
12409
12410# Local variables:
12411# mode: tcl
12412# indent-tabs-mode: t
12413# tab-width: 8
12414# End: