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