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