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