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