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