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