gitk-git/gitk

   1 #!/bin/sh
   2 # Tcl ignores the next line -*- tcl -*- \
   3 exec wish "$0" -- "$@"
   4
   5 # Copyright © 2005-2016 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
  10 package require Tk
  11
  12 proc hasworktree {} {
  13     return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
  14                   [exec git rev-parse --is-inside-git-dir] == "false"}]
  15 }
  16
  17 proc reponame {} {
  18     global gitdir
  19     set n [file normalize $gitdir]
  20     if {[string match "*/.git" $n]} {
  21         set n [string range $n 0 end-5]
  22     }
  23     return [file tail $n]
  24 }
  25
  26 proc gitworktree {} {
  27     variable _gitworktree
  28     if {[info exists _gitworktree]} {
  29         return $_gitworktree
  30     }
  31     # v1.7.0 introduced --show-toplevel to return the canonical work-tree
  32     if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
  33         # try to set work tree from environment, core.worktree or use
  34         # cdup to obtain a relative path to the top of the worktree. If
  35         # run from the top, the ./ prefix ensures normalize expands pwd.
  36         if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
  37             catch {set _gitworktree [exec git config --get core.worktree]}
  38             if {$_gitworktree eq ""} {
  39                 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
  40             }
  41         }
  42     }
  43     return $_gitworktree
  44 }
  45
  46 # A simple scheduler for compute-intensive stuff.
  47 # The aim is to make sure that event handlers for GUI actions can
  48 # run at least every 50-100 ms.  Unfortunately fileevent handlers are
  49 # run before X event handlers, so reading from a fast source can
  50 # make the GUI completely unresponsive.
  51 proc run args {
  52     global isonrunq runq currunq
  53
  54     set script $args
  55     if {[info exists isonrunq($script)]} return
  56     if {$runq eq {} && ![info exists currunq]} {
  57         after idle dorunq
  58     }
  59     lappend runq [list {} $script]
  60     set isonrunq($script) 1
  61 }
  62
  63 proc filerun {fd script} {
  64     fileevent $fd readable [list filereadable $fd $script]
  65 }
  66
  67 proc filereadable {fd script} {
  68     global runq currunq
  69
  70     fileevent $fd readable {}
  71     if {$runq eq {} && ![info exists currunq]} {
  72         after idle dorunq
  73     }
  74     lappend runq [list $fd $script]
  75 }
  76
  77 proc nukefile {fd} {
  78     global runq
  79
  80     for {set i 0} {$i < [llength $runq]} {} {
  81         if {[lindex $runq $i 0] eq $fd} {
  82             set runq [lreplace $runq $i $i]
  83         } else {
  84             incr i
  85         }
  86     }
  87 }
  88
  89 proc dorunq {} {
  90     global isonrunq runq currunq
  91
  92     set tstart [clock clicks -milliseconds]
  93     set t0 $tstart
  94     while {[llength $runq] > 0} {
  95         set fd [lindex $runq 0 0]
  96         set script [lindex $runq 0 1]
  97         set currunq [lindex $runq 0]
  98         set runq [lrange $runq 1 end]
  99         set repeat [eval $script]
 100         unset currunq
 101         set t1 [clock clicks -milliseconds]
 102         set t [expr {$t1 - $t0}]
 103         if {$repeat ne {} && $repeat} {
 104             if {$fd eq {} || $repeat == 2} {
 105                 # script returns 1 if it wants to be readded
 106                 # file readers return 2 if they could do more straight away
 107                 lappend runq [list $fd $script]
 108             } else {
 109                 fileevent $fd readable [list filereadable $fd $script]
 110             }
 111         } elseif {$fd eq {}} {
 112             unset isonrunq($script)
 113         }
 114         set t0 $t1
 115         if {$t1 - $tstart >= 80} break
 116     }
 117     if {$runq ne {}} {
 118         after idle dorunq
 119     }
 120 }
 121
 122 proc reg_instance {fd} {
 123     global commfd leftover loginstance
 124
 125     set i [incr loginstance]
 126     set commfd($i) $fd
 127     set leftover($i) {}
 128     return $i
 129 }
 130
 131 proc unmerged_files {files} {
 132     global nr_unmerged
 133
 134     # find the list of unmerged files
 135     set mlist {}
 136     set nr_unmerged 0
 137     if {[catch {
 138         set fd [open "| git ls-files -u" r]
 139     } err]} {
 140         show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
 141         exit 1
 142     }
 143     while {[gets $fd line] >= 0} {
 144         set i [string first "\t" $line]
 145         if {$i < 0} continue
 146         set fname [string range $line [expr {$i+1}] end]
 147         if {[lsearch -exact $mlist $fname] >= 0} continue
 148         incr nr_unmerged
 149         if {$files eq {} || [path_filter $files $fname]} {
 150             lappend mlist $fname
 151         }
 152     }
 153     catch {close $fd}
 154     return $mlist
 155 }
 156
 157 proc parseviewargs {n arglist} {
 158     global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
 159     global vinlinediff
 160     global worddiff git_version
 161
 162     set vdatemode($n) 0
 163     set vmergeonly($n) 0
 164     set vinlinediff($n) 0
 165     set glflags {}
 166     set diffargs {}
 167     set nextisval 0
 168     set revargs {}
 169     set origargs $arglist
 170     set allknown 1
 171     set filtered 0
 172     set i -1
 173     foreach arg $arglist {
 174         incr i
 175         if {$nextisval} {
 176             lappend glflags $arg
 177             set nextisval 0
 178             continue
 179         }
 180         switch -glob -- $arg {
 181             "-d" -
 182             "--date-order" {
 183                 set vdatemode($n) 1
 184                 # remove from origargs in case we hit an unknown option
 185                 set origargs [lreplace $origargs $i $i]
 186                 incr i -1
 187             }
 188             "-[puabwcrRBMC]" -
 189             "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
 190             "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
 191             "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
 192             "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
 193             "--ignore-space-change" - "-U*" - "--unified=*" {
 194                 # These request or affect diff output, which we don't want.
 195                 # Some could be used to set our defaults for diff display.
 196                 lappend diffargs $arg
 197             }
 198             "--raw" - "--patch-with-raw" - "--patch-with-stat" -
 199             "--name-only" - "--name-status" - "--color" -
 200             "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
 201             "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
 202             "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
 203             "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
 204             "--objects" - "--objects-edge" - "--reverse" {
 205                 # These cause our parsing of git log's output to fail, or else
 206                 # they're options we want to set ourselves, so ignore them.
 207             }
 208             "--color-words*" - "--word-diff=color" {
 209                 # These trigger a word diff in the console interface,
 210                 # so help the user by enabling our own support
 211                 if {[package vcompare $git_version "1.7.2"] >= 0} {
 212                     set worddiff [mc "Color words"]
 213                 }
 214             }
 215             "--word-diff*" {
 216                 if {[package vcompare $git_version "1.7.2"] >= 0} {
 217                     set worddiff [mc "Markup words"]
 218                 }
 219             }
 220             "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
 221             "--check" - "--exit-code" - "--quiet" - "--topo-order" -
 222             "--full-history" - "--dense" - "--sparse" -
 223             "--follow" - "--left-right" - "--encoding=*" {
 224                 # These are harmless, and some are even useful
 225                 lappend glflags $arg
 226             }
 227             "--diff-filter=*" - "--no-merges" - "--unpacked" -
 228             "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
 229             "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
 230             "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
 231             "--remove-empty" - "--first-parent" - "--cherry-pick" -
 232             "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
 233             "--simplify-by-decoration" {
 234                 # These mean that we get a subset of the commits
 235                 set filtered 1
 236                 lappend glflags $arg
 237             }
 238             "-L*" {
 239                 # Line-log with 'stuck' argument (unstuck form is
 240                 # not supported)
 241                 set filtered 1
 242                 set vinlinediff($n) 1
 243                 set allknown 0
 244                 lappend glflags $arg
 245             }
 246             "-n" {
 247                 # This appears to be the only one that has a value as a
 248                 # separate word following it
 249                 set filtered 1
 250                 set nextisval 1
 251                 lappend glflags $arg
 252             }
 253             "--not" - "--all" {
 254                 lappend revargs $arg
 255             }
 256             "--merge" {
 257                 set vmergeonly($n) 1
 258                 # git rev-parse doesn't understand --merge
 259                 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
 260             }
 261             "--no-replace-objects" {
 262                 set env(GIT_NO_REPLACE_OBJECTS) "1"
 263             }
 264             "-*" {
 265                 # Other flag arguments including -<n>
 266                 if {[string is digit -strict [string range $arg 1 end]]} {
 267                     set filtered 1
 268                 } else {
 269                     # a flag argument that we don't recognize;
 270                     # that means we can't optimize
 271                     set allknown 0
 272                 }
 273                 lappend glflags $arg
 274             }
 275             default {
 276                 # Non-flag arguments specify commits or ranges of commits
 277                 if {[string match "*...*" $arg]} {
 278                     lappend revargs --gitk-symmetric-diff-marker
 279                 }
 280                 lappend revargs $arg
 281             }
 282         }
 283     }
 284     set vdflags($n) $diffargs
 285     set vflags($n) $glflags
 286     set vrevs($n) $revargs
 287     set vfiltered($n) $filtered
 288     set vorigargs($n) $origargs
 289     return $allknown
 290 }
 291
 292 proc parseviewrevs {view revs} {
 293     global vposids vnegids
 294
 295     if {$revs eq {}} {
 296         set revs HEAD
 297     } elseif {[lsearch -exact $revs --all] >= 0} {
 298         lappend revs HEAD
 299     }
 300     if {[catch {set ids [eval exec git rev-parse $revs]} err]} {
 301         # we get stdout followed by stderr in $err
 302         # for an unknown rev, git rev-parse echoes it and then errors out
 303         set errlines [split $err "\n"]
 304         set badrev {}
 305         for {set l 0} {$l < [llength $errlines]} {incr l} {
 306             set line [lindex $errlines $l]
 307             if {!([string length $line] == 40 && [string is xdigit $line])} {
 308                 if {[string match "fatal:*" $line]} {
 309                     if {[string match "fatal: ambiguous argument*" $line]
 310                         && $badrev ne {}} {
 311                         if {[llength $badrev] == 1} {
 312                             set err "unknown revision $badrev"
 313                         } else {
 314                             set err "unknown revisions: [join $badrev ", "]"
 315                         }
 316                     } else {
 317                         set err [join [lrange $errlines $l end] "\n"]
 318                     }
 319                     break
 320                 }
 321                 lappend badrev $line
 322             }
 323         }
 324         error_popup "[mc "Error parsing revisions:"] $err"
 325         return {}
 326     }
 327     set ret {}
 328     set pos {}
 329     set neg {}
 330     set sdm 0
 331     foreach id [split $ids "\n"] {
 332         if {$id eq "--gitk-symmetric-diff-marker"} {
 333             set sdm 4
 334         } elseif {[string match "^*" $id]} {
 335             if {$sdm != 1} {
 336                 lappend ret $id
 337                 if {$sdm == 3} {
 338                     set sdm 0
 339                 }
 340             }
 341             lappend neg [string range $id 1 end]
 342         } else {
 343             if {$sdm != 2} {
 344                 lappend ret $id
 345             } else {
 346                 lset ret end $id...[lindex $ret end]
 347             }
 348             lappend pos $id
 349         }
 350         incr sdm -1
 351     }
 352     set vposids($view) $pos
 353     set vnegids($view) $neg
 354     return $ret
 355 }
 356
 357 # Start off a git log process and arrange to read its output
 358 proc start_rev_list {view} {
 359     global startmsecs commitidx viewcomplete curview
 360     global tclencoding
 361     global viewargs viewargscmd viewfiles vfilelimit
 362     global showlocalchanges
 363     global viewactive viewinstances vmergeonly
 364     global mainheadid viewmainheadid viewmainheadid_orig
 365     global vcanopt vflags vrevs vorigargs
 366     global show_notes
 367
 368     set startmsecs [clock clicks -milliseconds]
 369     set commitidx($view) 0
 370     # these are set this way for the error exits
 371     set viewcomplete($view) 1
 372     set viewactive($view) 0
 373     varcinit $view
 374
 375     set args $viewargs($view)
 376     if {$viewargscmd($view) ne {}} {
 377         if {[catch {
 378             set str [exec sh -c $viewargscmd($view)]
 379         } err]} {
 380             error_popup "[mc "Error executing --argscmd command:"] $err"
 381             return 0
 382         }
 383         set args [concat $args [split $str "\n"]]
 384     }
 385     set vcanopt($view) [parseviewargs $view $args]
 386
 387     set files $viewfiles($view)
 388     if {$vmergeonly($view)} {
 389         set files [unmerged_files $files]
 390         if {$files eq {}} {
 391             global nr_unmerged
 392             if {$nr_unmerged == 0} {
 393                 error_popup [mc "No files selected: --merge specified but\
 394                              no files are unmerged."]
 395             } else {
 396                 error_popup [mc "No files selected: --merge specified but\
 397                              no unmerged files are within file limit."]
 398             }
 399             return 0
 400         }
 401     }
 402     set vfilelimit($view) $files
 403
 404     if {$vcanopt($view)} {
 405         set revs [parseviewrevs $view $vrevs($view)]
 406         if {$revs eq {}} {
 407             return 0
 408         }
 409         set args [concat $vflags($view) $revs]
 410     } else {
 411         set args $vorigargs($view)
 412     }
 413
 414     if {[catch {
 415         set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
 416                         --parents --boundary $args "--" $files] r]
 417     } err]} {
 418         error_popup "[mc "Error executing git log:"] $err"
 419         return 0
 420     }
 421     set i [reg_instance $fd]
 422     set viewinstances($view) [list $i]
 423     set viewmainheadid($view) $mainheadid
 424     set viewmainheadid_orig($view) $mainheadid
 425     if {$files ne {} && $mainheadid ne {}} {
 426         get_viewmainhead $view
 427     }
 428     if {$showlocalchanges && $viewmainheadid($view) ne {}} {
 429         interestedin $viewmainheadid($view) dodiffindex
 430     }
 431     fconfigure $fd -blocking 0 -translation lf -eofchar {}
 432     if {$tclencoding != {}} {
 433         fconfigure $fd -encoding $tclencoding
 434     }
 435     filerun $fd [list getcommitlines $fd $i $view 0]
 436     nowbusy $view [mc "Reading"]
 437     set viewcomplete($view) 0
 438     set viewactive($view) 1
 439     return 1
 440 }
 441
 442 proc stop_instance {inst} {
 443     global commfd leftover
 444
 445     set fd $commfd($inst)
 446     catch {
 447         set pid [pid $fd]
 448
 449         if {$::tcl_platform(platform) eq {windows}} {
 450             exec taskkill /pid $pid
 451         } else {
 452             exec kill $pid
 453         }
 454     }
 455     catch {close $fd}
 456     nukefile $fd
 457     unset commfd($inst)
 458     unset leftover($inst)
 459 }
 460
 461 proc stop_backends {} {
 462     global commfd
 463
 464     foreach inst [array names commfd] {
 465         stop_instance $inst
 466     }
 467 }
 468
 469 proc stop_rev_list {view} {
 470     global viewinstances
 471
 472     foreach inst $viewinstances($view) {
 473         stop_instance $inst
 474     }
 475     set viewinstances($view) {}
 476 }
 477
 478 proc reset_pending_select {selid} {
 479     global pending_select mainheadid selectheadid
 480
 481     if {$selid ne {}} {
 482         set pending_select $selid
 483     } elseif {$selectheadid ne {}} {
 484         set pending_select $selectheadid
 485     } else {
 486         set pending_select $mainheadid
 487     }
 488 }
 489
 490 proc getcommits {selid} {
 491     global canv curview need_redisplay viewactive
 492
 493     initlayout
 494     if {[start_rev_list $curview]} {
 495         reset_pending_select $selid
 496         show_status [mc "Reading commits..."]
 497         set need_redisplay 1
 498     } else {
 499         show_status [mc "No commits selected"]
 500     }
 501 }
 502
 503 proc updatecommits {} {
 504     global curview vcanopt vorigargs vfilelimit viewinstances
 505     global viewactive viewcomplete tclencoding
 506     global startmsecs showneartags showlocalchanges
 507     global mainheadid viewmainheadid viewmainheadid_orig pending_select
 508     global hasworktree
 509     global varcid vposids vnegids vflags vrevs
 510     global show_notes
 511
 512     set hasworktree [hasworktree]
 513     rereadrefs
 514     set view $curview
 515     if {$mainheadid ne $viewmainheadid_orig($view)} {
 516         if {$showlocalchanges} {
 517             dohidelocalchanges
 518         }
 519         set viewmainheadid($view) $mainheadid
 520         set viewmainheadid_orig($view) $mainheadid
 521         if {$vfilelimit($view) ne {}} {
 522             get_viewmainhead $view
 523         }
 524     }
 525     if {$showlocalchanges} {
 526         doshowlocalchanges
 527     }
 528     if {$vcanopt($view)} {
 529         set oldpos $vposids($view)
 530         set oldneg $vnegids($view)
 531         set revs [parseviewrevs $view $vrevs($view)]
 532         if {$revs eq {}} {
 533             return
 534         }
 535         # note: getting the delta when negative refs change is hard,
 536         # and could require multiple git log invocations, so in that
 537         # case we ask git log for all the commits (not just the delta)
 538         if {$oldneg eq $vnegids($view)} {
 539             set newrevs {}
 540             set npos 0
 541             # take out positive refs that we asked for before or
 542             # that we have already seen
 543             foreach rev $revs {
 544                 if {[string length $rev] == 40} {
 545                     if {[lsearch -exact $oldpos $rev] < 0
 546                         && ![info exists varcid($view,$rev)]} {
 547                         lappend newrevs $rev
 548                         incr npos
 549                     }
 550                 } else {
 551                     lappend $newrevs $rev
 552                 }
 553             }
 554             if {$npos == 0} return
 555             set revs $newrevs
 556             set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
 557         }
 558         set args [concat $vflags($view) $revs --not $oldpos]
 559     } else {
 560         set args $vorigargs($view)
 561     }
 562     if {[catch {
 563         set fd [open [concat | git log --no-color -z --pretty=raw $show_notes \
 564                         --parents --boundary $args "--" $vfilelimit($view)] r]
 565     } err]} {
 566         error_popup "[mc "Error executing git log:"] $err"
 567         return
 568     }
 569     if {$viewactive($view) == 0} {
 570         set startmsecs [clock clicks -milliseconds]
 571     }
 572     set i [reg_instance $fd]
 573     lappend viewinstances($view) $i
 574     fconfigure $fd -blocking 0 -translation lf -eofchar {}
 575     if {$tclencoding != {}} {
 576         fconfigure $fd -encoding $tclencoding
 577     }
 578     filerun $fd [list getcommitlines $fd $i $view 1]
 579     incr viewactive($view)
 580     set viewcomplete($view) 0
 581     reset_pending_select {}
 582     nowbusy $view [mc "Reading"]
 583     if {$showneartags} {
 584         getallcommits
 585     }
 586 }
 587
 588 proc reloadcommits {} {
 589     global curview viewcomplete selectedline currentid thickerline
 590     global showneartags treediffs commitinterest cached_commitrow
 591     global targetid commitinfo
 592
 593     set selid {}
 594     if {$selectedline ne {}} {
 595         set selid $currentid
 596     }
 597
 598     if {!$viewcomplete($curview)} {
 599         stop_rev_list $curview
 600     }
 601     resetvarcs $curview
 602     set selectedline {}
 603     unset -nocomplain currentid
 604     unset -nocomplain thickerline
 605     unset -nocomplain treediffs
 606     readrefs
 607     changedrefs
 608     if {$showneartags} {
 609         getallcommits
 610     }
 611     clear_display
 612     unset -nocomplain commitinfo
 613     unset -nocomplain commitinterest
 614     unset -nocomplain cached_commitrow
 615     unset -nocomplain targetid
 616     setcanvscroll
 617     getcommits $selid
 618     return 0
 619 }
 620
 621 # This makes a string representation of a positive integer which
 622 # sorts as a string in numerical order
 623 proc strrep {n} {
 624     if {$n < 16} {
 625         return [format "%x" $n]
 626     } elseif {$n < 256} {
 627         return [format "x%.2x" $n]
 628     } elseif {$n < 65536} {
 629         return [format "y%.4x" $n]
 630     }
 631     return [format "z%.8x" $n]
 632 }
 633
 634 # Procedures used in reordering commits from git log (without
 635 # --topo-order) into the order for display.
 636
 637 proc varcinit {view} {
 638     global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
 639     global vtokmod varcmod vrowmod varcix vlastins
 640
 641     set varcstart($view) {{}}
 642     set vupptr($view) {0}
 643     set vdownptr($view) {0}
 644     set vleftptr($view) {0}
 645     set vbackptr($view) {0}
 646     set varctok($view) {{}}
 647     set varcrow($view) {{}}
 648     set vtokmod($view) {}
 649     set varcmod($view) 0
 650     set vrowmod($view) 0
 651     set varcix($view) {{}}
 652     set vlastins($view) {0}
 653 }
 654
 655 proc resetvarcs {view} {
 656     global varcid varccommits parents children vseedcount ordertok
 657     global vshortids
 658
 659     foreach vid [array names varcid $view,*] {
 660         unset varcid($vid)
 661         unset children($vid)
 662         unset parents($vid)
 663     }
 664     foreach vid [array names vshortids $view,*] {
 665         unset vshortids($vid)
 666     }
 667     # some commits might have children but haven't been seen yet
 668     foreach vid [array names children $view,*] {
 669         unset children($vid)
 670     }
 671     foreach va [array names varccommits $view,*] {
 672         unset varccommits($va)
 673     }
 674     foreach vd [array names vseedcount $view,*] {
 675         unset vseedcount($vd)
 676     }
 677     unset -nocomplain ordertok
 678 }
 679
 680 # returns a list of the commits with no children
 681 proc seeds {v} {
 682     global vdownptr vleftptr varcstart
 683
 684     set ret {}
 685     set a [lindex $vdownptr($v) 0]
 686     while {$a != 0} {
 687         lappend ret [lindex $varcstart($v) $a]
 688         set a [lindex $vleftptr($v) $a]
 689     }
 690     return $ret
 691 }
 692
 693 proc newvarc {view id} {
 694     global varcid varctok parents children vdatemode
 695     global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
 696     global commitdata commitinfo vseedcount varccommits vlastins
 697
 698     set a [llength $varctok($view)]
 699     set vid $view,$id
 700     if {[llength $children($vid)] == 0 || $vdatemode($view)} {
 701         if {![info exists commitinfo($id)]} {
 702             parsecommit $id $commitdata($id) 1
 703         }
 704         set cdate [lindex [lindex $commitinfo($id) 4] 0]
 705         if {![string is integer -strict $cdate]} {
 706             set cdate 0
 707         }
 708         if {![info exists vseedcount($view,$cdate)]} {
 709             set vseedcount($view,$cdate) -1
 710         }
 711         set c [incr vseedcount($view,$cdate)]
 712         set cdate [expr {$cdate ^ 0xffffffff}]
 713         set tok "s[strrep $cdate][strrep $c]"
 714     } else {
 715         set tok {}
 716     }
 717     set ka 0
 718     if {[llength $children($vid)] > 0} {
 719         set kid [lindex $children($vid) end]
 720         set k $varcid($view,$kid)
 721         if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
 722             set ki $kid
 723             set ka $k
 724             set tok [lindex $varctok($view) $k]
 725         }
 726     }
 727     if {$ka != 0} {
 728         set i [lsearch -exact $parents($view,$ki) $id]
 729         set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
 730         append tok [strrep $j]
 731     }
 732     set c [lindex $vlastins($view) $ka]
 733     if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
 734         set c $ka
 735         set b [lindex $vdownptr($view) $ka]
 736     } else {
 737         set b [lindex $vleftptr($view) $c]
 738     }
 739     while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
 740         set c $b
 741         set b [lindex $vleftptr($view) $c]
 742     }
 743     if {$c == $ka} {
 744         lset vdownptr($view) $ka $a
 745         lappend vbackptr($view) 0
 746     } else {
 747         lset vleftptr($view) $c $a
 748         lappend vbackptr($view) $c
 749     }
 750     lset vlastins($view) $ka $a
 751     lappend vupptr($view) $ka
 752     lappend vleftptr($view) $b
 753     if {$b != 0} {
 754         lset vbackptr($view) $b $a
 755     }
 756     lappend varctok($view) $tok
 757     lappend varcstart($view) $id
 758     lappend vdownptr($view) 0
 759     lappend varcrow($view) {}
 760     lappend varcix($view) {}
 761     set varccommits($view,$a) {}
 762     lappend vlastins($view) 0
 763     return $a
 764 }
 765
 766 proc splitvarc {p v} {
 767     global varcid varcstart varccommits varctok vtokmod
 768     global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
 769
 770     set oa $varcid($v,$p)
 771     set otok [lindex $varctok($v) $oa]
 772     set ac $varccommits($v,$oa)
 773     set i [lsearch -exact $varccommits($v,$oa) $p]
 774     if {$i <= 0} return
 775     set na [llength $varctok($v)]
 776     # "%" sorts before "0"...
 777     set tok "$otok%[strrep $i]"
 778     lappend varctok($v) $tok
 779     lappend varcrow($v) {}
 780     lappend varcix($v) {}
 781     set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
 782     set varccommits($v,$na) [lrange $ac $i end]
 783     lappend varcstart($v) $p
 784     foreach id $varccommits($v,$na) {
 785         set varcid($v,$id) $na
 786     }
 787     lappend vdownptr($v) [lindex $vdownptr($v) $oa]
 788     lappend vlastins($v) [lindex $vlastins($v) $oa]
 789     lset vdownptr($v) $oa $na
 790     lset vlastins($v) $oa 0
 791     lappend vupptr($v) $oa
 792     lappend vleftptr($v) 0
 793     lappend vbackptr($v) 0
 794     for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
 795         lset vupptr($v) $b $na
 796     }
 797     if {[string compare $otok $vtokmod($v)] <= 0} {
 798         modify_arc $v $oa
 799     }
 800 }
 801
 802 proc renumbervarc {a v} {
 803     global parents children varctok varcstart varccommits
 804     global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
 805
 806     set t1 [clock clicks -milliseconds]
 807     set todo {}
 808     set isrelated($a) 1
 809     set kidchanged($a) 1
 810     set ntot 0
 811     while {$a != 0} {
 812         if {[info exists isrelated($a)]} {
 813             lappend todo $a
 814             set id [lindex $varccommits($v,$a) end]
 815             foreach p $parents($v,$id) {
 816                 if {[info exists varcid($v,$p)]} {
 817                     set isrelated($varcid($v,$p)) 1
 818                 }
 819             }
 820         }
 821         incr ntot
 822         set b [lindex $vdownptr($v) $a]
 823         if {$b == 0} {
 824             while {$a != 0} {
 825                 set b [lindex $vleftptr($v) $a]
 826                 if {$b != 0} break
 827                 set a [lindex $vupptr($v) $a]
 828             }
 829         }
 830         set a $b
 831     }
 832     foreach a $todo {
 833         if {![info exists kidchanged($a)]} continue
 834         set id [lindex $varcstart($v) $a]
 835         if {[llength $children($v,$id)] > 1} {
 836             set children($v,$id) [lsort -command [list vtokcmp $v] \
 837                                       $children($v,$id)]
 838         }
 839         set oldtok [lindex $varctok($v) $a]
 840         if {!$vdatemode($v)} {
 841             set tok {}
 842         } else {
 843             set tok $oldtok
 844         }
 845         set ka 0
 846         set kid [last_real_child $v,$id]
 847         if {$kid ne {}} {
 848             set k $varcid($v,$kid)
 849             if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
 850                 set ki $kid
 851                 set ka $k
 852                 set tok [lindex $varctok($v) $k]
 853             }
 854         }
 855         if {$ka != 0} {
 856             set i [lsearch -exact $parents($v,$ki) $id]
 857             set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
 858             append tok [strrep $j]
 859         }
 860         if {$tok eq $oldtok} {
 861             continue
 862         }
 863         set id [lindex $varccommits($v,$a) end]
 864         foreach p $parents($v,$id) {
 865             if {[info exists varcid($v,$p)]} {
 866                 set kidchanged($varcid($v,$p)) 1
 867             } else {
 868                 set sortkids($p) 1
 869             }
 870         }
 871         lset varctok($v) $a $tok
 872         set b [lindex $vupptr($v) $a]
 873         if {$b != $ka} {
 874             if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
 875                 modify_arc $v $ka
 876             }
 877             if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
 878                 modify_arc $v $b
 879             }
 880             set c [lindex $vbackptr($v) $a]
 881             set d [lindex $vleftptr($v) $a]
 882             if {$c == 0} {
 883                 lset vdownptr($v) $b $d
 884             } else {
 885                 lset vleftptr($v) $c $d
 886             }
 887             if {$d != 0} {
 888                 lset vbackptr($v) $d $c
 889             }
 890             if {[lindex $vlastins($v) $b] == $a} {
 891                 lset vlastins($v) $b $c
 892             }
 893             lset vupptr($v) $a $ka
 894             set c [lindex $vlastins($v) $ka]
 895             if {$c == 0 || \
 896                     [string compare $tok [lindex $varctok($v) $c]] < 0} {
 897                 set c $ka
 898                 set b [lindex $vdownptr($v) $ka]
 899             } else {
 900                 set b [lindex $vleftptr($v) $c]
 901             }
 902             while {$b != 0 && \
 903                       [string compare $tok [lindex $varctok($v) $b]] >= 0} {
 904                 set c $b
 905                 set b [lindex $vleftptr($v) $c]
 906             }
 907             if {$c == $ka} {
 908                 lset vdownptr($v) $ka $a
 909                 lset vbackptr($v) $a 0
 910             } else {
 911                 lset vleftptr($v) $c $a
 912                 lset vbackptr($v) $a $c
 913             }
 914             lset vleftptr($v) $a $b
 915             if {$b != 0} {
 916                 lset vbackptr($v) $b $a
 917             }
 918             lset vlastins($v) $ka $a
 919         }
 920     }
 921     foreach id [array names sortkids] {
 922         if {[llength $children($v,$id)] > 1} {
 923             set children($v,$id) [lsort -command [list vtokcmp $v] \
 924                                       $children($v,$id)]
 925         }
 926     }
 927     set t2 [clock clicks -milliseconds]
 928     #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
 929 }
 930
 931 # Fix up the graph after we have found out that in view $v,
 932 # $p (a commit that we have already seen) is actually the parent
 933 # of the last commit in arc $a.
 934 proc fix_reversal {p a v} {
 935     global varcid varcstart varctok vupptr
 936
 937     set pa $varcid($v,$p)
 938     if {$p ne [lindex $varcstart($v) $pa]} {
 939         splitvarc $p $v
 940         set pa $varcid($v,$p)
 941     }
 942     # seeds always need to be renumbered
 943     if {[lindex $vupptr($v) $pa] == 0 ||
 944         [string compare [lindex $varctok($v) $a] \
 945              [lindex $varctok($v) $pa]] > 0} {
 946         renumbervarc $pa $v
 947     }
 948 }
 949
 950 proc insertrow {id p v} {
 951     global cmitlisted children parents varcid varctok vtokmod
 952     global varccommits ordertok commitidx numcommits curview
 953     global targetid targetrow vshortids
 954
 955     readcommit $id
 956     set vid $v,$id
 957     set cmitlisted($vid) 1
 958     set children($vid) {}
 959     set parents($vid) [list $p]
 960     set a [newvarc $v $id]
 961     set varcid($vid) $a
 962     lappend vshortids($v,[string range $id 0 3]) $id
 963     if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
 964         modify_arc $v $a
 965     }
 966     lappend varccommits($v,$a) $id
 967     set vp $v,$p
 968     if {[llength [lappend children($vp) $id]] > 1} {
 969         set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
 970         unset -nocomplain ordertok
 971     }
 972     fix_reversal $p $a $v
 973     incr commitidx($v)
 974     if {$v == $curview} {
 975         set numcommits $commitidx($v)
 976         setcanvscroll
 977         if {[info exists targetid]} {
 978             if {![comes_before $targetid $p]} {
 979                 incr targetrow
 980             }
 981         }
 982     }
 983 }
 984
 985 proc insertfakerow {id p} {
 986     global varcid varccommits parents children cmitlisted
 987     global commitidx varctok vtokmod targetid targetrow curview numcommits
 988
 989     set v $curview
 990     set a $varcid($v,$p)
 991     set i [lsearch -exact $varccommits($v,$a) $p]
 992     if {$i < 0} {
 993         puts "oops: insertfakerow can't find [shortids $p] on arc $a"
 994         return
 995     }
 996     set children($v,$id) {}
 997     set parents($v,$id) [list $p]
 998     set varcid($v,$id) $a
 999     lappend children($v,$p) $id
1000     set cmitlisted($v,$id) 1
1001     set numcommits [incr commitidx($v)]
1002     # note we deliberately don't update varcstart($v) even if $i == 0
1003     set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1004     modify_arc $v $a $i
1005     if {[info exists targetid]} {
1006         if {![comes_before $targetid $p]} {
1007             incr targetrow
1008         }
1009     }
1010     setcanvscroll
1011     drawvisible
1012 }
1013
1014 proc removefakerow {id} {
1015     global varcid varccommits parents children commitidx
1016     global varctok vtokmod cmitlisted currentid selectedline
1017     global targetid curview numcommits
1018
1019     set v $curview
1020     if {[llength $parents($v,$id)] != 1} {
1021         puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1022         return
1023     }
1024     set p [lindex $parents($v,$id) 0]
1025     set a $varcid($v,$id)
1026     set i [lsearch -exact $varccommits($v,$a) $id]
1027     if {$i < 0} {
1028         puts "oops: removefakerow can't find [shortids $id] on arc $a"
1029         return
1030     }
1031     unset varcid($v,$id)
1032     set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1033     unset parents($v,$id)
1034     unset children($v,$id)
1035     unset cmitlisted($v,$id)
1036     set numcommits [incr commitidx($v) -1]
1037     set j [lsearch -exact $children($v,$p) $id]
1038     if {$j >= 0} {
1039         set children($v,$p) [lreplace $children($v,$p) $j $j]
1040     }
1041     modify_arc $v $a $i
1042     if {[info exist currentid] && $id eq $currentid} {
1043         unset currentid
1044         set selectedline {}
1045     }
1046     if {[info exists targetid] && $targetid eq $id} {
1047         set targetid $p
1048     }
1049     setcanvscroll
1050     drawvisible
1051 }
1052
1053 proc real_children {vp} {
1054     global children nullid nullid2
1055
1056     set kids {}
1057     foreach id $children($vp) {
1058         if {$id ne $nullid && $id ne $nullid2} {
1059             lappend kids $id
1060         }
1061     }
1062     return $kids
1063 }
1064
1065 proc first_real_child {vp} {
1066     global children nullid nullid2
1067
1068     foreach id $children($vp) {
1069         if {$id ne $nullid && $id ne $nullid2} {
1070             return $id
1071         }
1072     }
1073     return {}
1074 }
1075
1076 proc last_real_child {vp} {
1077     global children nullid nullid2
1078
1079     set kids $children($vp)
1080     for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1081         set id [lindex $kids $i]
1082         if {$id ne $nullid && $id ne $nullid2} {
1083             return $id
1084         }
1085     }
1086     return {}
1087 }
1088
1089 proc vtokcmp {v a b} {
1090     global varctok varcid
1091
1092     return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1093                 [lindex $varctok($v) $varcid($v,$b)]]
1094 }
1095
1096 # This assumes that if lim is not given, the caller has checked that
1097 # arc a's token is less than $vtokmod($v)
1098 proc modify_arc {v a {lim {}}} {
1099     global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1100
1101     if {$lim ne {}} {
1102         set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1103         if {$c > 0} return
1104         if {$c == 0} {
1105             set r [lindex $varcrow($v) $a]
1106             if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1107         }
1108     }
1109     set vtokmod($v) [lindex $varctok($v) $a]
1110     set varcmod($v) $a
1111     if {$v == $curview} {
1112         while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1113             set a [lindex $vupptr($v) $a]
1114             set lim {}
1115         }
1116         set r 0
1117         if {$a != 0} {
1118             if {$lim eq {}} {
1119                 set lim [llength $varccommits($v,$a)]
1120             }
1121             set r [expr {[lindex $varcrow($v) $a] + $lim}]
1122         }
1123         set vrowmod($v) $r
1124         undolayout $r
1125     }
1126 }
1127
1128 proc update_arcrows {v} {
1129     global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1130     global varcid vrownum varcorder varcix varccommits
1131     global vupptr vdownptr vleftptr varctok
1132     global displayorder parentlist curview cached_commitrow
1133
1134     if {$vrowmod($v) == $commitidx($v)} return
1135     if {$v == $curview} {
1136         if {[llength $displayorder] > $vrowmod($v)} {
1137             set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1138             set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1139         }
1140         unset -nocomplain cached_commitrow
1141     }
1142     set narctot [expr {[llength $varctok($v)] - 1}]
1143     set a $varcmod($v)
1144     while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1145         # go up the tree until we find something that has a row number,
1146         # or we get to a seed
1147         set a [lindex $vupptr($v) $a]
1148     }
1149     if {$a == 0} {
1150         set a [lindex $vdownptr($v) 0]
1151         if {$a == 0} return
1152         set vrownum($v) {0}
1153         set varcorder($v) [list $a]
1154         lset varcix($v) $a 0
1155         lset varcrow($v) $a 0
1156         set arcn 0
1157         set row 0
1158     } else {
1159         set arcn [lindex $varcix($v) $a]
1160         if {[llength $vrownum($v)] > $arcn + 1} {
1161             set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1162             set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1163         }
1164         set row [lindex $varcrow($v) $a]
1165     }
1166     while {1} {
1167         set p $a
1168         incr row [llength $varccommits($v,$a)]
1169         # go down if possible
1170         set b [lindex $vdownptr($v) $a]
1171         if {$b == 0} {
1172             # if not, go left, or go up until we can go left
1173             while {$a != 0} {
1174                 set b [lindex $vleftptr($v) $a]
1175                 if {$b != 0} break
1176                 set a [lindex $vupptr($v) $a]
1177             }
1178             if {$a == 0} break
1179         }
1180         set a $b
1181         incr arcn
1182         lappend vrownum($v) $row
1183         lappend varcorder($v) $a
1184         lset varcix($v) $a $arcn
1185         lset varcrow($v) $a $row
1186     }
1187     set vtokmod($v) [lindex $varctok($v) $p]
1188     set varcmod($v) $p
1189     set vrowmod($v) $row
1190     if {[info exists currentid]} {
1191         set selectedline [rowofcommit $currentid]
1192     }
1193 }
1194
1195 # Test whether view $v contains commit $id
1196 proc commitinview {id v} {
1197     global varcid
1198
1199     return [info exists varcid($v,$id)]
1200 }
1201
1202 # Return the row number for commit $id in the current view
1203 proc rowofcommit {id} {
1204     global varcid varccommits varcrow curview cached_commitrow
1205     global varctok vtokmod
1206
1207     set v $curview
1208     if {![info exists varcid($v,$id)]} {
1209         puts "oops rowofcommit no arc for [shortids $id]"
1210         return {}
1211     }
1212     set a $varcid($v,$id)
1213     if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1214         update_arcrows $v
1215     }
1216     if {[info exists cached_commitrow($id)]} {
1217         return $cached_commitrow($id)
1218     }
1219     set i [lsearch -exact $varccommits($v,$a) $id]
1220     if {$i < 0} {
1221         puts "oops didn't find commit [shortids $id] in arc $a"
1222         return {}
1223     }
1224     incr i [lindex $varcrow($v) $a]
1225     set cached_commitrow($id) $i
1226     return $i
1227 }
1228
1229 # Returns 1 if a is on an earlier row than b, otherwise 0
1230 proc comes_before {a b} {
1231     global varcid varctok curview
1232
1233     set v $curview
1234     if {$a eq $b || ![info exists varcid($v,$a)] || \
1235             ![info exists varcid($v,$b)]} {
1236         return 0
1237     }
1238     if {$varcid($v,$a) != $varcid($v,$b)} {
1239         return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1240                            [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1241     }
1242     return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1243 }
1244
1245 proc bsearch {l elt} {
1246     if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1247         return 0
1248     }
1249     set lo 0
1250     set hi [llength $l]
1251     while {$hi - $lo > 1} {
1252         set mid [expr {int(($lo + $hi) / 2)}]
1253         set t [lindex $l $mid]
1254         if {$elt < $t} {
1255             set hi $mid
1256         } elseif {$elt > $t} {
1257             set lo $mid
1258         } else {
1259             return $mid
1260         }
1261     }
1262     return $lo
1263 }
1264
1265 # Make sure rows $start..$end-1 are valid in displayorder and parentlist
1266 proc make_disporder {start end} {
1267     global vrownum curview commitidx displayorder parentlist
1268     global varccommits varcorder parents vrowmod varcrow
1269     global d_valid_start d_valid_end
1270
1271     if {$end > $vrowmod($curview)} {
1272         update_arcrows $curview
1273     }
1274     set ai [bsearch $vrownum($curview) $start]
1275     set start [lindex $vrownum($curview) $ai]
1276     set narc [llength $vrownum($curview)]
1277     for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1278         set a [lindex $varcorder($curview) $ai]
1279         set l [llength $displayorder]
1280         set al [llength $varccommits($curview,$a)]
1281         if {$l < $r + $al} {
1282             if {$l < $r} {
1283                 set pad [ntimes [expr {$r - $l}] {}]
1284                 set displayorder [concat $displayorder $pad]
1285                 set parentlist [concat $parentlist $pad]
1286             } elseif {$l > $r} {
1287                 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1288                 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1289             }
1290             foreach id $varccommits($curview,$a) {
1291                 lappend displayorder $id
1292                 lappend parentlist $parents($curview,$id)
1293             }
1294         } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1295             set i $r
1296             foreach id $varccommits($curview,$a) {
1297                 lset displayorder $i $id
1298                 lset parentlist $i $parents($curview,$id)
1299                 incr i
1300             }
1301         }
1302         incr r $al
1303     }
1304 }
1305
1306 proc commitonrow {row} {
1307     global displayorder
1308
1309     set id [lindex $displayorder $row]
1310     if {$id eq {}} {
1311         make_disporder $row [expr {$row + 1}]
1312         set id [lindex $displayorder $row]
1313     }
1314     return $id
1315 }
1316
1317 proc closevarcs {v} {
1318     global varctok varccommits varcid parents children
1319     global cmitlisted commitidx vtokmod curview numcommits
1320
1321     set missing_parents 0
1322     set scripts {}
1323     set narcs [llength $varctok($v)]
1324     for {set a 1} {$a < $narcs} {incr a} {
1325         set id [lindex $varccommits($v,$a) end]
1326         foreach p $parents($v,$id) {
1327             if {[info exists varcid($v,$p)]} continue
1328             # add p as a new commit
1329             incr missing_parents
1330             set cmitlisted($v,$p) 0
1331             set parents($v,$p) {}
1332             if {[llength $children($v,$p)] == 1 &&
1333                 [llength $parents($v,$id)] == 1} {
1334                 set b $a
1335             } else {
1336                 set b [newvarc $v $p]
1337             }
1338             set varcid($v,$p) $b
1339             if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1340                 modify_arc $v $b
1341             }
1342             lappend varccommits($v,$b) $p
1343             incr commitidx($v)
1344             if {$v == $curview} {
1345                 set numcommits $commitidx($v)
1346             }
1347             set scripts [check_interest $p $scripts]
1348         }
1349     }
1350     if {$missing_parents > 0} {
1351         foreach s $scripts {
1352             eval $s
1353         }
1354     }
1355 }
1356
1357 # Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1358 # Assumes we already have an arc for $rwid.
1359 proc rewrite_commit {v id rwid} {
1360     global children parents varcid varctok vtokmod varccommits
1361
1362     foreach ch $children($v,$id) {
1363         # make $rwid be $ch's parent in place of $id
1364         set i [lsearch -exact $parents($v,$ch) $id]
1365         if {$i < 0} {
1366             puts "oops rewrite_commit didn't find $id in parent list for $ch"
1367         }
1368         set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1369         # add $ch to $rwid's children and sort the list if necessary
1370         if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1371             set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1372                                         $children($v,$rwid)]
1373         }
1374         # fix the graph after joining $id to $rwid
1375         set a $varcid($v,$ch)
1376         fix_reversal $rwid $a $v
1377         # parentlist is wrong for the last element of arc $a
1378         # even if displayorder is right, hence the 3rd arg here
1379         modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1380     }
1381 }
1382
1383 # Mechanism for registering a command to be executed when we come
1384 # across a particular commit.  To handle the case when only the
1385 # prefix of the commit is known, the commitinterest array is now
1386 # indexed by the first 4 characters of the ID.  Each element is a
1387 # list of id, cmd pairs.
1388 proc interestedin {id cmd} {
1389     global commitinterest
1390
1391     lappend commitinterest([string range $id 0 3]) $id $cmd
1392 }
1393
1394 proc check_interest {id scripts} {
1395     global commitinterest
1396
1397     set prefix [string range $id 0 3]
1398     if {[info exists commitinterest($prefix)]} {
1399         set newlist {}
1400         foreach {i script} $commitinterest($prefix) {
1401             if {[string match "$i*" $id]} {
1402                 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1403             } else {
1404                 lappend newlist $i $script
1405             }
1406         }
1407         if {$newlist ne {}} {
1408             set commitinterest($prefix) $newlist
1409         } else {
1410             unset commitinterest($prefix)
1411         }
1412     }
1413     return $scripts
1414 }
1415
1416 proc getcommitlines {fd inst view updating}  {
1417     global cmitlisted leftover
1418     global commitidx commitdata vdatemode
1419     global parents children curview hlview
1420     global idpending ordertok
1421     global varccommits varcid varctok vtokmod vfilelimit vshortids
1422
1423     set stuff [read $fd 500000]
1424     # git log doesn't terminate the last commit with a null...
1425     if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1426         set stuff "\0"
1427     }
1428     if {$stuff == {}} {
1429         if {![eof $fd]} {
1430             return 1
1431         }
1432         global commfd viewcomplete viewactive viewname
1433         global viewinstances
1434         unset commfd($inst)
1435         set i [lsearch -exact $viewinstances($view) $inst]
1436         if {$i >= 0} {
1437             set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1438         }
1439         # set it blocking so we wait for the process to terminate
1440         fconfigure $fd -blocking 1
1441         if {[catch {close $fd} err]} {
1442             set fv {}
1443             if {$view != $curview} {
1444                 set fv " for the \"$viewname($view)\" view"
1445             }
1446             if {[string range $err 0 4] == "usage"} {
1447                 set err "Gitk: error reading commits$fv:\
1448                         bad arguments to git log."
1449                 if {$viewname($view) eq [mc "Command line"]} {
1450                     append err \
1451                         "  (Note: arguments to gitk are passed to git log\
1452                          to allow selection of commits to be displayed.)"
1453                 }
1454             } else {
1455                 set err "Error reading commits$fv: $err"
1456             }
1457             error_popup $err
1458         }
1459         if {[incr viewactive($view) -1] <= 0} {
1460             set viewcomplete($view) 1
1461             # Check if we have seen any ids listed as parents that haven't
1462             # appeared in the list
1463             closevarcs $view
1464             notbusy $view
1465         }
1466         if {$view == $curview} {
1467             run chewcommits
1468         }
1469         return 0
1470     }
1471     set start 0
1472     set gotsome 0
1473     set scripts {}
1474     while 1 {
1475         set i [string first "\0" $stuff $start]
1476         if {$i < 0} {
1477             append leftover($inst) [string range $stuff $start end]
1478             break
1479         }
1480         if {$start == 0} {
1481             set cmit $leftover($inst)
1482             append cmit [string range $stuff 0 [expr {$i - 1}]]
1483             set leftover($inst) {}
1484         } else {
1485             set cmit [string range $stuff $start [expr {$i - 1}]]
1486         }
1487         set start [expr {$i + 1}]
1488         set j [string first "\n" $cmit]
1489         set ok 0
1490         set listed 1
1491         if {$j >= 0 && [string match "commit *" $cmit]} {
1492             set ids [string range $cmit 7 [expr {$j - 1}]]
1493             if {[string match {[-^<>]*} $ids]} {
1494                 switch -- [string index $ids 0] {
1495                     "-" {set listed 0}
1496                     "^" {set listed 2}
1497                     "<" {set listed 3}
1498                     ">" {set listed 4}
1499                 }
1500                 set ids [string range $ids 1 end]
1501             }
1502             set ok 1
1503             foreach id $ids {
1504                 if {[string length $id] != 40} {
1505                     set ok 0
1506                     break
1507                 }
1508             }
1509         }
1510         if {!$ok} {
1511             set shortcmit $cmit
1512             if {[string length $shortcmit] > 80} {
1513                 set shortcmit "[string range $shortcmit 0 80]..."
1514             }
1515             error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1516             exit 1
1517         }
1518         set id [lindex $ids 0]
1519         set vid $view,$id
1520
1521         lappend vshortids($view,[string range $id 0 3]) $id
1522
1523         if {!$listed && $updating && ![info exists varcid($vid)] &&
1524             $vfilelimit($view) ne {}} {
1525             # git log doesn't rewrite parents for unlisted commits
1526             # when doing path limiting, so work around that here
1527             # by working out the rewritten parent with git rev-list
1528             # and if we already know about it, using the rewritten
1529             # parent as a substitute parent for $id's children.
1530             if {![catch {
1531                 set rwid [exec git rev-list --first-parent --max-count=1 \
1532                               $id -- $vfilelimit($view)]
1533             }]} {
1534                 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1535                     # use $rwid in place of $id
1536                     rewrite_commit $view $id $rwid
1537                     continue
1538                 }
1539             }
1540         }
1541
1542         set a 0
1543         if {[info exists varcid($vid)]} {
1544             if {$cmitlisted($vid) || !$listed} continue
1545             set a $varcid($vid)
1546         }
1547         if {$listed} {
1548             set olds [lrange $ids 1 end]
1549         } else {
1550             set olds {}
1551         }
1552         set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1553         set cmitlisted($vid) $listed
1554         set parents($vid) $olds
1555         if {![info exists children($vid)]} {
1556             set children($vid) {}
1557         } elseif {$a == 0 && [llength $children($vid)] == 1} {
1558             set k [lindex $children($vid) 0]
1559             if {[llength $parents($view,$k)] == 1 &&
1560                 (!$vdatemode($view) ||
1561                  $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1562                 set a $varcid($view,$k)
1563             }
1564         }
1565         if {$a == 0} {
1566             # new arc
1567             set a [newvarc $view $id]
1568         }
1569         if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1570             modify_arc $view $a
1571         }
1572         if {![info exists varcid($vid)]} {
1573             set varcid($vid) $a
1574             lappend varccommits($view,$a) $id
1575             incr commitidx($view)
1576         }
1577
1578         set i 0
1579         foreach p $olds {
1580             if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1581                 set vp $view,$p
1582                 if {[llength [lappend children($vp) $id]] > 1 &&
1583                     [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1584                     set children($vp) [lsort -command [list vtokcmp $view] \
1585                                            $children($vp)]
1586                     unset -nocomplain ordertok
1587                 }
1588                 if {[info exists varcid($view,$p)]} {
1589                     fix_reversal $p $a $view
1590                 }
1591             }
1592             incr i
1593         }
1594
1595         set scripts [check_interest $id $scripts]
1596         set gotsome 1
1597     }
1598     if {$gotsome} {
1599         global numcommits hlview
1600
1601         if {$view == $curview} {
1602             set numcommits $commitidx($view)
1603             run chewcommits
1604         }
1605         if {[info exists hlview] && $view == $hlview} {
1606             # we never actually get here...
1607             run vhighlightmore
1608         }
1609         foreach s $scripts {
1610             eval $s
1611         }
1612     }
1613     return 2
1614 }
1615
1616 proc chewcommits {} {
1617     global curview hlview viewcomplete
1618     global pending_select
1619
1620     layoutmore
1621     if {$viewcomplete($curview)} {
1622         global commitidx varctok
1623         global numcommits startmsecs
1624
1625         if {[info exists pending_select]} {
1626             update
1627             reset_pending_select {}
1628
1629             if {[commitinview $pending_select $curview]} {
1630                 selectline [rowofcommit $pending_select] 1
1631             } else {
1632                 set row [first_real_row]
1633                 selectline $row 1
1634             }
1635         }
1636         if {$commitidx($curview) > 0} {
1637             #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1638             #puts "overall $ms ms for $numcommits commits"
1639             #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1640         } else {
1641             show_status [mc "No commits selected"]
1642         }
1643         notbusy layout
1644     }
1645     return 0
1646 }
1647
1648 proc do_readcommit {id} {
1649     global tclencoding
1650
1651     # Invoke git-log to handle automatic encoding conversion
1652     set fd [open [concat | git log --no-color --pretty=raw -1 $id] r]
1653     # Read the results using i18n.logoutputencoding
1654     fconfigure $fd -translation lf -eofchar {}
1655     if {$tclencoding != {}} {
1656         fconfigure $fd -encoding $tclencoding
1657     }
1658     set contents [read $fd]
1659     close $fd
1660     # Remove the heading line
1661     regsub {^commit [0-9a-f]+\n} $contents {} contents
1662
1663     return $contents
1664 }
1665
1666 proc readcommit {id} {
1667     if {[catch {set contents [do_readcommit $id]}]} return
1668     parsecommit $id $contents 1
1669 }
1670
1671 proc parsecommit {id contents listed} {
1672     global commitinfo
1673
1674     set inhdr 1
1675     set comment {}
1676     set headline {}
1677     set auname {}
1678     set audate {}
1679     set comname {}
1680     set comdate {}
1681     set hdrend [string first "\n\n" $contents]
1682     if {$hdrend < 0} {
1683         # should never happen...
1684         set hdrend [string length $contents]
1685     }
1686     set header [string range $contents 0 [expr {$hdrend - 1}]]
1687     set comment [string range $contents [expr {$hdrend + 2}] end]
1688     foreach line [split $header "\n"] {
1689         set line [split $line " "]
1690         set tag [lindex $line 0]
1691         if {$tag == "author"} {
1692             set audate [lrange $line end-1 end]
1693             set auname [join [lrange $line 1 end-2] " "]
1694         } elseif {$tag == "committer"} {
1695             set comdate [lrange $line end-1 end]
1696             set comname [join [lrange $line 1 end-2] " "]
1697         }
1698     }
1699     set headline {}
1700     # take the first non-blank line of the comment as the headline
1701     set headline [string trimleft $comment]
1702     set i [string first "\n" $headline]
1703     if {$i >= 0} {
1704         set headline [string range $headline 0 $i]
1705     }
1706     set headline [string trimright $headline]
1707     set i [string first "\r" $headline]
1708     if {$i >= 0} {
1709         set headline [string trimright [string range $headline 0 $i]]
1710     }
1711     if {!$listed} {
1712         # git log indents the comment by 4 spaces;
1713         # if we got this via git cat-file, add the indentation
1714         set newcomment {}
1715         foreach line [split $comment "\n"] {
1716             append newcomment "    "
1717             append newcomment $line
1718             append newcomment "\n"
1719         }
1720         set comment $newcomment
1721     }
1722     set hasnote [string first "\nNotes:\n" $contents]
1723     set diff ""
1724     # If there is diff output shown in the git-log stream, split it
1725     # out.  But get rid of the empty line that always precedes the
1726     # diff.
1727     set i [string first "\n\ndiff" $comment]
1728     if {$i >= 0} {
1729         set diff [string range $comment $i+1 end]
1730         set comment [string range $comment 0 $i-1]
1731     }
1732     set commitinfo($id) [list $headline $auname $audate \
1733                              $comname $comdate $comment $hasnote $diff]
1734 }
1735
1736 proc getcommit {id} {
1737     global commitdata commitinfo
1738
1739     if {[info exists commitdata($id)]} {
1740         parsecommit $id $commitdata($id) 1
1741     } else {
1742         readcommit $id
1743         if {![info exists commitinfo($id)]} {
1744             set commitinfo($id) [list [mc "No commit information available"]]
1745         }
1746     }
1747     return 1
1748 }
1749
1750 # Expand an abbreviated commit ID to a list of full 40-char IDs that match
1751 # and are present in the current view.
1752 # This is fairly slow...
1753 proc longid {prefix} {
1754     global varcid curview vshortids
1755
1756     set ids {}
1757     if {[string length $prefix] >= 4} {
1758         set vshortid $curview,[string range $prefix 0 3]
1759         if {[info exists vshortids($vshortid)]} {
1760             foreach id $vshortids($vshortid) {
1761                 if {[string match "$prefix*" $id]} {
1762                     if {[lsearch -exact $ids $id] < 0} {
1763                         lappend ids $id
1764                         if {[llength $ids] >= 2} break
1765                     }
1766                 }
1767             }
1768         }
1769     } else {
1770         foreach match [array names varcid "$curview,$prefix*"] {
1771             lappend ids [lindex [split $match ","] 1]
1772             if {[llength $ids] >= 2} break
1773         }
1774     }
1775     return $ids
1776 }
1777
1778 proc readrefs {} {
1779     global tagids idtags headids idheads tagobjid
1780     global otherrefids idotherrefs mainhead mainheadid
1781     global selecthead selectheadid
1782     global hideremotes
1783
1784     foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
1785         unset -nocomplain $v
1786     }
1787     set refd [open [list | git show-ref -d] r]
1788     while {[gets $refd line] >= 0} {
1789         if {[string index $line 40] ne " "} continue
1790         set id [string range $line 0 39]
1791         set ref [string range $line 41 end]
1792         if {![string match "refs/*" $ref]} continue
1793         set name [string range $ref 5 end]
1794         if {[string match "remotes/*" $name]} {
1795             if {![string match "*/HEAD" $name] && !$hideremotes} {
1796                 set headids($name) $id
1797                 lappend idheads($id) $name
1798             }
1799         } elseif {[string match "heads/*" $name]} {
1800             set name [string range $name 6 end]
1801             set headids($name) $id
1802             lappend idheads($id) $name
1803         } elseif {[string match "tags/*" $name]} {
1804             # this lets refs/tags/foo^{} overwrite refs/tags/foo,
1805             # which is what we want since the former is the commit ID
1806             set name [string range $name 5 end]
1807             if {[string match "*^{}" $name]} {
1808                 set name [string range $name 0 end-3]
1809             } else {
1810                 set tagobjid($name) $id
1811             }
1812             set tagids($name) $id
1813             lappend idtags($id) $name
1814         } else {
1815             set otherrefids($name) $id
1816             lappend idotherrefs($id) $name
1817         }
1818     }
1819     catch {close $refd}
1820     set mainhead {}
1821     set mainheadid {}
1822     catch {
1823         set mainheadid [exec git rev-parse HEAD]
1824         set thehead [exec git symbolic-ref HEAD]
1825         if {[string match "refs/heads/*" $thehead]} {
1826             set mainhead [string range $thehead 11 end]
1827         }
1828     }
1829     set selectheadid {}
1830     if {$selecthead ne {}} {
1831         catch {
1832             set selectheadid [exec git rev-parse --verify $selecthead]
1833         }
1834     }
1835 }
1836
1837 # skip over fake commits
1838 proc first_real_row {} {
1839     global nullid nullid2 numcommits
1840
1841     for {set row 0} {$row < $numcommits} {incr row} {
1842         set id [commitonrow $row]
1843         if {$id ne $nullid && $id ne $nullid2} {
1844             break
1845         }
1846     }
1847     return $row
1848 }
1849
1850 # update things for a head moved to a child of its previous location
1851 proc movehead {id name} {
1852     global headids idheads
1853
1854     removehead $headids($name) $name
1855     set headids($name) $id
1856     lappend idheads($id) $name
1857 }
1858
1859 # update things when a head has been removed
1860 proc removehead {id name} {
1861     global headids idheads
1862
1863     if {$idheads($id) eq $name} {
1864         unset idheads($id)
1865     } else {
1866         set i [lsearch -exact $idheads($id) $name]
1867         if {$i >= 0} {
1868             set idheads($id) [lreplace $idheads($id) $i $i]
1869         }
1870     }
1871     unset headids($name)
1872 }
1873
1874 proc ttk_toplevel {w args} {
1875     global use_ttk
1876     eval [linsert $args 0 ::toplevel $w]
1877     if {$use_ttk} {
1878         place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
1879     }
1880     return $w
1881 }
1882
1883 proc make_transient {window origin} {
1884     global have_tk85
1885
1886     # In MacOS Tk 8.4 transient appears to work by setting
1887     # overrideredirect, which is utterly useless, since the
1888     # windows get no border, and are not even kept above
1889     # the parent.
1890     if {!$have_tk85 && [tk windowingsystem] eq {aqua}} return
1891
1892     wm transient $window $origin
1893
1894     # Windows fails to place transient windows normally, so
1895     # schedule a callback to center them on the parent.
1896     if {[tk windowingsystem] eq {win32}} {
1897         after idle [list tk::PlaceWindow $window widget $origin]
1898     }
1899 }
1900
1901 proc show_error {w top msg} {
1902     global NS
1903     if {![info exists NS]} {set NS ""}
1904     if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
1905     message $w.m -text $msg -justify center -aspect 400
1906     pack $w.m -side top -fill x -padx 20 -pady 20
1907     ${NS}::button $w.ok -default active -text [mc OK] -command "destroy $top"
1908     pack $w.ok -side bottom -fill x
1909     bind $top <Visibility> "grab $top; focus $top"
1910     bind $top <Key-Return> "destroy $top"
1911     bind $top <Key-space>  "destroy $top"
1912     bind $top <Key-Escape> "destroy $top"
1913     tkwait window $top
1914 }
1915
1916 proc error_popup {msg {owner .}} {
1917     if {[tk windowingsystem] eq "win32"} {
1918         tk_messageBox -icon error -type ok -title [wm title .] \
1919             -parent $owner -message $msg
1920     } else {
1921         set w .error
1922         ttk_toplevel $w
1923         make_transient $w $owner
1924         show_error $w $w $msg
1925     }
1926 }
1927
1928 proc confirm_popup {msg {owner .}} {
1929     global confirm_ok NS
1930     set confirm_ok 0
1931     set w .confirm
1932     ttk_toplevel $w
1933     make_transient $w $owner
1934     message $w.m -text $msg -justify center -aspect 400
1935     pack $w.m -side top -fill x -padx 20 -pady 20
1936     ${NS}::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
1937     pack $w.ok -side left -fill x
1938     ${NS}::button $w.cancel -text [mc Cancel] -command "destroy $w"
1939     pack $w.cancel -side right -fill x
1940     bind $w <Visibility> "grab $w; focus $w"
1941     bind $w <Key-Return> "set confirm_ok 1; destroy $w"
1942     bind $w <Key-space>  "set confirm_ok 1; destroy $w"
1943     bind $w <Key-Escape> "destroy $w"
1944     tk::PlaceWindow $w widget $owner
1945     tkwait window $w
1946     return $confirm_ok
1947 }
1948
1949 proc setoptions {} {
1950     global use_ttk
1951
1952     if {[tk windowingsystem] ne "win32"} {
1953         option add *Panedwindow.showHandle 1 startupFile
1954         option add *Panedwindow.sashRelief raised startupFile
1955         if {[tk windowingsystem] ne "aqua"} {
1956             option add *Menu.font uifont startupFile
1957         }
1958     } else {
1959         option add *Menu.TearOff 0 startupFile
1960     }
1961     option add *Button.font uifont startupFile
1962     option add *Checkbutton.font uifont startupFile
1963     option add *Radiobutton.font uifont startupFile
1964     option add *Menubutton.font uifont startupFile
1965     option add *Label.font uifont startupFile
1966     option add *Message.font uifont startupFile
1967     option add *Entry.font textfont startupFile
1968     option add *Text.font textfont startupFile
1969     option add *Labelframe.font uifont startupFile
1970     option add *Spinbox.font textfont startupFile
1971     option add *Listbox.font mainfont startupFile
1972 }
1973
1974 proc setttkstyle {} {
1975     eval font configure TkDefaultFont [fontflags mainfont]
1976     eval font configure TkTextFont [fontflags textfont]
1977     eval font configure TkHeadingFont [fontflags mainfont]
1978     eval font configure TkCaptionFont [fontflags mainfont] -weight bold
1979     eval font configure TkTooltipFont [fontflags uifont]
1980     eval font configure TkFixedFont   [fontflags textfont]
1981     eval font configure TkIconFont    [fontflags uifont]
1982     eval font configure TkMenuFont    [fontflags uifont]
1983     eval font configure TkSmallCaptionFont [fontflags uifont]
1984 }
1985
1986 # Make a menu and submenus.
1987 # m is the window name for the menu, items is the list of menu items to add.
1988 # Each item is a list {mc label type description options...}
1989 # mc is ignored; it's so we can put mc there to alert xgettext
1990 # label is the string that appears in the menu
1991 # type is cascade, command or radiobutton (should add checkbutton)
1992 # description depends on type; it's the sublist for cascade, the
1993 # command to invoke for command, or {variable value} for radiobutton
1994 proc makemenu {m items} {
1995     menu $m
1996     if {[tk windowingsystem] eq {aqua}} {
1997         set Meta1 Cmd
1998     } else {
1999         set Meta1 Ctrl
2000     }
2001     foreach i $items {
2002         set name [mc [lindex $i 1]]
2003         set type [lindex $i 2]
2004         set thing [lindex $i 3]
2005         set params [list $type]
2006         if {$name ne {}} {
2007             set u [string first "&" [string map {&& x} $name]]
2008             lappend params -label [string map {&& & & {}} $name]
2009             if {$u >= 0} {
2010                 lappend params -underline $u
2011             }
2012         }
2013         switch -- $type {
2014             "cascade" {
2015                 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
2016                 lappend params -menu $m.$submenu
2017             }
2018             "command" {
2019                 lappend params -command $thing
2020             }
2021             "radiobutton" {
2022                 lappend params -variable [lindex $thing 0] \
2023                     -value [lindex $thing 1]
2024             }
2025         }
2026         set tail [lrange $i 4 end]
2027         regsub -all {\yMeta1\y} $tail $Meta1 tail
2028         eval $m add $params $tail
2029         if {$type eq "cascade"} {
2030             makemenu $m.$submenu $thing
2031         }
2032     }
2033 }
2034
2035 # translate string and remove ampersands
2036 proc mca {str} {
2037     return [string map {&& & & {}} [mc $str]]
2038 }
2039
2040 proc cleardropsel {w} {
2041     $w selection clear
2042 }
2043 proc makedroplist {w varname args} {
2044     global use_ttk
2045     if {$use_ttk} {
2046         set width 0
2047         foreach label $args {
2048             set cx [string length $label]
2049             if {$cx > $width} {set width $cx}
2050         }
2051         set gm [ttk::combobox $w -width $width -state readonly\
2052                     -textvariable $varname -values $args \
2053                     -exportselection false]
2054         bind $gm <<ComboboxSelected>> [list $gm selection clear]
2055     } else {
2056         set gm [eval [linsert $args 0 tk_optionMenu $w $varname]]
2057     }
2058     return $gm
2059 }
2060
2061 proc makewindow {} {
2062     global canv canv2 canv3 linespc charspc ctext cflist cscroll
2063     global tabstop
2064     global findtype findtypemenu findloc findstring fstring geometry
2065     global entries sha1entry sha1string sha1but
2066     global diffcontextstring diffcontext
2067     global ignorespace
2068     global maincursor textcursor curtextcursor
2069     global rowctxmenu fakerowmenu mergemax wrapcomment
2070     global highlight_files gdttype
2071     global searchstring sstring
2072     global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
2073     global uifgcolor uifgdisabledcolor
2074     global filesepbgcolor filesepfgcolor
2075     global mergecolors foundbgcolor currentsearchhitbgcolor
2076     global headctxmenu progresscanv progressitem progresscoords statusw
2077     global fprogitem fprogcoord lastprogupdate progupdatepending
2078     global rprogitem rprogcoord rownumsel numcommits
2079     global have_tk85 use_ttk NS
2080     global git_version
2081     global worddiff
2082
2083     # The "mc" arguments here are purely so that xgettext
2084     # sees the following string as needing to be translated
2085     set file {
2086         mc "&File" cascade {
2087             {mc "&Update" command updatecommits -accelerator F5}
2088             {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2089             {mc "Reread re&ferences" command rereadrefs}
2090             {mc "&List references" command showrefs -accelerator F2}
2091             {xx "" separator}
2092             {mc "Start git &gui" command {exec git gui &}}
2093             {xx "" separator}
2094             {mc "&Quit" command doquit -accelerator Meta1-Q}
2095         }}
2096     set edit {
2097         mc "&Edit" cascade {
2098             {mc "&Preferences" command doprefs}
2099         }}
2100     set view {
2101         mc "&View" cascade {
2102             {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2103             {mc "&Edit view..." command editview -state disabled -accelerator F4}
2104             {mc "&Delete view" command delview -state disabled}
2105             {xx "" separator}
2106             {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2107         }}
2108     if {[tk windowingsystem] ne "aqua"} {
2109         set help {
2110         mc "&Help" cascade {
2111             {mc "&About gitk" command about}
2112             {mc "&Key bindings" command keys}
2113         }}
2114         set bar [list $file $edit $view $help]
2115     } else {
2116         proc ::tk::mac::ShowPreferences {} {doprefs}
2117         proc ::tk::mac::Quit {} {doquit}
2118         lset file end [lreplace [lindex $file end] end-1 end]
2119         set apple {
2120         xx "&Apple" cascade {
2121             {mc "&About gitk" command about}
2122             {xx "" separator}
2123         }}
2124         set help {
2125         mc "&Help" cascade {
2126             {mc "&Key bindings" command keys}
2127         }}
2128         set bar [list $apple $file $view $help]
2129     }
2130     makemenu .bar $bar
2131     . configure -menu .bar
2132
2133     if {$use_ttk} {
2134         # cover the non-themed toplevel with a themed frame.
2135         place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2136     }
2137
2138     # the gui has upper and lower half, parts of a paned window.
2139     ${NS}::panedwindow .ctop -orient vertical
2140
2141     # possibly use assumed geometry
2142     if {![info exists geometry(pwsash0)]} {
2143         set geometry(topheight) [expr {15 * $linespc}]
2144         set geometry(topwidth) [expr {80 * $charspc}]
2145         set geometry(botheight) [expr {15 * $linespc}]
2146         set geometry(botwidth) [expr {50 * $charspc}]
2147         set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2148         set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2149     }
2150
2151     # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2152     ${NS}::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2153     ${NS}::frame .tf.histframe
2154     ${NS}::panedwindow .tf.histframe.pwclist -orient horizontal
2155     if {!$use_ttk} {
2156         .tf.histframe.pwclist configure -sashpad 0 -handlesize 4
2157     }
2158
2159     # create three canvases
2160     set cscroll .tf.histframe.csb
2161     set canv .tf.histframe.pwclist.canv
2162     canvas $canv \
2163         -selectbackground $selectbgcolor \
2164         -background $bgcolor -bd 0 \
2165         -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2166     .tf.histframe.pwclist add $canv
2167     set canv2 .tf.histframe.pwclist.canv2
2168     canvas $canv2 \
2169         -selectbackground $selectbgcolor \
2170         -background $bgcolor -bd 0 -yscrollincr $linespc
2171     .tf.histframe.pwclist add $canv2
2172     set canv3 .tf.histframe.pwclist.canv3
2173     canvas $canv3 \
2174         -selectbackground $selectbgcolor \
2175         -background $bgcolor -bd 0 -yscrollincr $linespc
2176     .tf.histframe.pwclist add $canv3
2177     if {$use_ttk} {
2178         bind .tf.histframe.pwclist <Map> {
2179             bind %W <Map> {}
2180             .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2181             .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2182         }
2183     } else {
2184         eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
2185         eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
2186     }
2187
2188     # a scroll bar to rule them
2189     ${NS}::scrollbar $cscroll -command {allcanvs yview}
2190     if {!$use_ttk} {$cscroll configure -highlightthickness 0}
2191     pack $cscroll -side right -fill y
2192     bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2193     lappend bglist $canv $canv2 $canv3
2194     pack .tf.histframe.pwclist -fill both -expand 1 -side left
2195
2196     # we have two button bars at bottom of top frame. Bar 1
2197     ${NS}::frame .tf.bar
2198     ${NS}::frame .tf.lbar -height 15
2199
2200     set sha1entry .tf.bar.sha1
2201     set entries $sha1entry
2202     set sha1but .tf.bar.sha1label
2203     button $sha1but -text "[mc "SHA1 ID:"] " -state disabled -relief flat \
2204         -command gotocommit -width 8
2205     $sha1but conf -disabledforeground [$sha1but cget -foreground]
2206     pack .tf.bar.sha1label -side left
2207     ${NS}::entry $sha1entry -width 40 -font textfont -textvariable sha1string
2208     trace add variable sha1string write sha1change
2209     pack $sha1entry -side left -pady 2
2210
2211     set bm_left_data {
2212         #define left_width 16
2213         #define left_height 16
2214         static unsigned char left_bits[] = {
2215         0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
2216         0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
2217         0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
2218     }
2219     set bm_right_data {
2220         #define right_width 16
2221         #define right_height 16
2222         static unsigned char right_bits[] = {
2223         0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
2224         0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
2225         0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
2226     }
2227     image create bitmap bm-left -data $bm_left_data -foreground $uifgcolor
2228     image create bitmap bm-left-gray -data $bm_left_data -foreground $uifgdisabledcolor
2229     image create bitmap bm-right -data $bm_right_data -foreground $uifgcolor
2230     image create bitmap bm-right-gray -data $bm_right_data -foreground $uifgdisabledcolor
2231
2232     ${NS}::button .tf.bar.leftbut -command goback -state disabled -width 26
2233     if {$use_ttk} {
2234         .tf.bar.leftbut configure -image [list bm-left disabled bm-left-gray]
2235     } else {
2236         .tf.bar.leftbut configure -image bm-left
2237     }
2238     pack .tf.bar.leftbut -side left -fill y
2239     ${NS}::button .tf.bar.rightbut -command goforw -state disabled -width 26
2240     if {$use_ttk} {
2241         .tf.bar.rightbut configure -image [list bm-right disabled bm-right-gray]
2242     } else {
2243         .tf.bar.rightbut configure -image bm-right
2244     }
2245     pack .tf.bar.rightbut -side left -fill y
2246
2247     ${NS}::label .tf.bar.rowlabel -text [mc "Row"]
2248     set rownumsel {}
2249     ${NS}::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2250         -relief sunken -anchor e
2251     ${NS}::label .tf.bar.rowlabel2 -text "/"
2252     ${NS}::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2253         -relief sunken -anchor e
2254     pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2255         -side left
2256     if {!$use_ttk} {
2257         foreach w {rownum numcommits} {.tf.bar.$w configure -font textfont}
2258     }
2259     global selectedline
2260     trace add variable selectedline write selectedline_change
2261
2262     # Status label and progress bar
2263     set statusw .tf.bar.status
2264     ${NS}::label $statusw -width 15 -relief sunken
2265     pack $statusw -side left -padx 5
2266     if {$use_ttk} {
2267         set progresscanv [ttk::progressbar .tf.bar.progress]
2268     } else {
2269         set h [expr {[font metrics uifont -linespace] + 2}]
2270         set progresscanv .tf.bar.progress
2271         canvas $progresscanv -relief sunken -height $h -borderwidth 2
2272         set progressitem [$progresscanv create rect -1 0 0 $h -fill "#00ff00"]
2273         set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
2274         set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
2275     }
2276     pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2277     set progresscoords {0 0}
2278     set fprogcoord 0
2279     set rprogcoord 0
2280     bind $progresscanv <Configure> adjustprogress
2281     set lastprogupdate [clock clicks -milliseconds]
2282     set progupdatepending 0
2283
2284     # build up the bottom bar of upper window
2285     ${NS}::label .tf.lbar.flabel -text "[mc "Find"] "
2286
2287     set bm_down_data {
2288         #define down_width 16
2289         #define down_height 16
2290         static unsigned char down_bits[] = {
2291         0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2292         0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2293         0x87, 0xe1, 0x8e, 0x71, 0x9c, 0x39, 0xb8, 0x1d,
2294         0xf0, 0x0f, 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01};
2295     }
2296     image create bitmap bm-down -data $bm_down_data -foreground $uifgcolor
2297     ${NS}::button .tf.lbar.fnext -width 26 -command {dofind 1 1}
2298     .tf.lbar.fnext configure -image bm-down
2299
2300     set bm_up_data {
2301         #define up_width 16
2302         #define up_height 16
2303         static unsigned char up_bits[] = {
2304         0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f,
2305         0xb8, 0x1d, 0x9c, 0x39, 0x8e, 0x71, 0x87, 0xe1,
2306         0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
2307         0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01};
2308     }
2309     image create bitmap bm-up -data $bm_up_data -foreground $uifgcolor
2310     ${NS}::button .tf.lbar.fprev -width 26 -command {dofind -1 1}
2311     .tf.lbar.fprev configure -image bm-up
2312
2313     ${NS}::label .tf.lbar.flab2 -text " [mc "commit"] "
2314
2315     pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2316         -side left -fill y
2317     set gdttype [mc "containing:"]
2318     set gm [makedroplist .tf.lbar.gdttype gdttype \
2319                 [mc "containing:"] \
2320                 [mc "touching paths:"] \
2321                 [mc "adding/removing string:"] \
2322                 [mc "changing lines matching:"]]
2323     trace add variable gdttype write gdttype_change
2324     pack .tf.lbar.gdttype -side left -fill y
2325
2326     set findstring {}
2327     set fstring .tf.lbar.findstring
2328     lappend entries $fstring
2329     ${NS}::entry $fstring -width 30 -textvariable findstring
2330     trace add variable findstring write find_change
2331     set findtype [mc "Exact"]
2332     set findtypemenu [makedroplist .tf.lbar.findtype \
2333                           findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2334     trace add variable findtype write findcom_change
2335     set findloc [mc "All fields"]
2336     makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2337         [mc "Comments"] [mc "Author"] [mc "Committer"]
2338     trace add variable findloc write find_change
2339     pack .tf.lbar.findloc -side right
2340     pack .tf.lbar.findtype -side right
2341     pack $fstring -side left -expand 1 -fill x
2342
2343     # Finish putting the upper half of the viewer together
2344     pack .tf.lbar -in .tf -side bottom -fill x
2345     pack .tf.bar -in .tf -side bottom -fill x
2346     pack .tf.histframe -fill both -side top -expand 1
2347     .ctop add .tf
2348     if {!$use_ttk} {
2349         .ctop paneconfigure .tf -height $geometry(topheight)
2350         .ctop paneconfigure .tf -width $geometry(topwidth)
2351     }
2352
2353     # now build up the bottom
2354     ${NS}::panedwindow .pwbottom -orient horizontal
2355
2356     # lower left, a text box over search bar, scroll bar to the right
2357     # if we know window height, then that will set the lower text height, otherwise
2358     # we set lower text height which will drive window height
2359     if {[info exists geometry(main)]} {
2360         ${NS}::frame .bleft -width $geometry(botwidth)
2361     } else {
2362         ${NS}::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2363     }
2364     ${NS}::frame .bleft.top
2365     ${NS}::frame .bleft.mid
2366     ${NS}::frame .bleft.bottom
2367
2368     # gap between sub-widgets
2369     set wgap [font measure uifont "i"]
2370
2371     ${NS}::button .bleft.top.search -text [mc "Search"] -command dosearch
2372     pack .bleft.top.search -side left -padx 5
2373     set sstring .bleft.top.sstring
2374     set searchstring ""
2375     ${NS}::entry $sstring -width 20 -textvariable searchstring
2376     lappend entries $sstring
2377     trace add variable searchstring write incrsearch
2378     pack $sstring -side left -expand 1 -fill x
2379     ${NS}::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2380         -command changediffdisp -variable diffelide -value {0 0}
2381     ${NS}::radiobutton .bleft.mid.old -text [mc "Old version"] \
2382         -command changediffdisp -variable diffelide -value {0 1}
2383     ${NS}::radiobutton .bleft.mid.new -text [mc "New version"] \
2384         -command changediffdisp -variable diffelide -value {1 0}
2385
2386     ${NS}::label .bleft.mid.labeldiffcontext -text "      [mc "Lines of context"]: "
2387     pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left -ipadx $wgap
2388     spinbox .bleft.mid.diffcontext -width 5 \
2389         -from 0 -increment 1 -to 10000000 \
2390         -validate all -validatecommand "diffcontextvalidate %P" \
2391         -textvariable diffcontextstring
2392     .bleft.mid.diffcontext set $diffcontext
2393     trace add variable diffcontextstring write diffcontextchange
2394     lappend entries .bleft.mid.diffcontext
2395     pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left -ipadx $wgap
2396     ${NS}::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2397         -command changeignorespace -variable ignorespace
2398     pack .bleft.mid.ignspace -side left -padx 5
2399
2400     set worddiff [mc "Line diff"]
2401     if {[package vcompare $git_version "1.7.2"] >= 0} {
2402         makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2403             [mc "Markup words"] [mc "Color words"]
2404         trace add variable worddiff write changeworddiff
2405         pack .bleft.mid.worddiff -side left -padx 5
2406     }
2407
2408     set ctext .bleft.bottom.ctext
2409     text $ctext -background $bgcolor -foreground $fgcolor \
2410         -state disabled -undo 0 -font textfont \
2411         -yscrollcommand scrolltext -wrap none \
2412         -xscrollcommand ".bleft.bottom.sbhorizontal set"
2413     if {$have_tk85} {
2414         $ctext conf -tabstyle wordprocessor
2415     }
2416     ${NS}::scrollbar .bleft.bottom.sb -command "$ctext yview"
2417     ${NS}::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2418     pack .bleft.top -side top -fill x
2419     pack .bleft.mid -side top -fill x
2420     grid $ctext .bleft.bottom.sb -sticky nsew
2421     grid .bleft.bottom.sbhorizontal -sticky ew
2422     grid columnconfigure .bleft.bottom 0 -weight 1
2423     grid rowconfigure .bleft.bottom 0 -weight 1
2424     grid rowconfigure .bleft.bottom 1 -weight 0
2425     pack .bleft.bottom -side top -fill both -expand 1
2426     lappend bglist $ctext
2427     lappend fglist $ctext
2428
2429     $ctext tag conf comment -wrap $wrapcomment
2430     $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2431     $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2432     $ctext tag conf d0 -fore [lindex $diffcolors 0]
2433     $ctext tag conf dresult -fore [lindex $diffcolors 1]
2434     $ctext tag conf m0 -fore [lindex $mergecolors 0]
2435     $ctext tag conf m1 -fore [lindex $mergecolors 1]
2436     $ctext tag conf m2 -fore [lindex $mergecolors 2]
2437     $ctext tag conf m3 -fore [lindex $mergecolors 3]
2438     $ctext tag conf m4 -fore [lindex $mergecolors 4]
2439     $ctext tag conf m5 -fore [lindex $mergecolors 5]
2440     $ctext tag conf m6 -fore [lindex $mergecolors 6]
2441     $ctext tag conf m7 -fore [lindex $mergecolors 7]
2442     $ctext tag conf m8 -fore [lindex $mergecolors 8]
2443     $ctext tag conf m9 -fore [lindex $mergecolors 9]
2444     $ctext tag conf m10 -fore [lindex $mergecolors 10]
2445     $ctext tag conf m11 -fore [lindex $mergecolors 11]
2446     $ctext tag conf m12 -fore [lindex $mergecolors 12]
2447     $ctext tag conf m13 -fore [lindex $mergecolors 13]
2448     $ctext tag conf m14 -fore [lindex $mergecolors 14]
2449     $ctext tag conf m15 -fore [lindex $mergecolors 15]
2450     $ctext tag conf mmax -fore darkgrey
2451     set mergemax 16
2452     $ctext tag conf mresult -font textfontbold
2453     $ctext tag conf msep -font textfontbold
2454     $ctext tag conf found -back $foundbgcolor
2455     $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2456     $ctext tag conf wwrap -wrap word -lmargin2 1c
2457     $ctext tag conf bold -font textfontbold
2458
2459     .pwbottom add .bleft
2460     if {!$use_ttk} {
2461         .pwbottom paneconfigure .bleft -width $geometry(botwidth)
2462     }
2463
2464     # lower right
2465     ${NS}::frame .bright
2466     ${NS}::frame .bright.mode
2467     ${NS}::radiobutton .bright.mode.patch -text [mc "Patch"] \
2468         -command reselectline -variable cmitmode -value "patch"
2469     ${NS}::radiobutton .bright.mode.tree -text [mc "Tree"] \
2470         -command reselectline -variable cmitmode -value "tree"
2471     grid .bright.mode.patch .bright.mode.tree -sticky ew
2472     pack .bright.mode -side top -fill x
2473     set cflist .bright.cfiles
2474     set indent [font measure mainfont "nn"]
2475     text $cflist \
2476         -selectbackground $selectbgcolor \
2477         -background $bgcolor -foreground $fgcolor \
2478         -font mainfont \
2479         -tabs [list $indent [expr {2 * $indent}]] \
2480         -yscrollcommand ".bright.sb set" \
2481         -cursor [. cget -cursor] \
2482         -spacing1 1 -spacing3 1
2483     lappend bglist $cflist
2484     lappend fglist $cflist
2485     ${NS}::scrollbar .bright.sb -command "$cflist yview"
2486     pack .bright.sb -side right -fill y
2487     pack $cflist -side left -fill both -expand 1
2488     $cflist tag configure highlight \
2489         -background [$cflist cget -selectbackground]
2490     $cflist tag configure bold -font mainfontbold
2491
2492     .pwbottom add .bright
2493     .ctop add .pwbottom
2494
2495     # restore window width & height if known
2496     if {[info exists geometry(main)]} {
2497         if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2498             if {$w > [winfo screenwidth .]} {
2499                 set w [winfo screenwidth .]
2500             }
2501             if {$h > [winfo screenheight .]} {
2502                 set h [winfo screenheight .]
2503             }
2504             wm geometry . "${w}x$h"
2505         }
2506     }
2507
2508     if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2509         wm state . $geometry(state)
2510     }
2511
2512     if {[tk windowingsystem] eq {aqua}} {
2513         set M1B M1
2514         set ::BM "3"
2515     } else {
2516         set M1B Control
2517         set ::BM "2"
2518     }
2519
2520     if {$use_ttk} {
2521         bind .ctop <Map> {
2522             bind %W <Map> {}
2523             %W sashpos 0 $::geometry(topheight)
2524         }
2525         bind .pwbottom <Map> {
2526             bind %W <Map> {}
2527             %W sashpos 0 $::geometry(botwidth)
2528         }
2529     }
2530
2531     bind .pwbottom <Configure> {resizecdetpanes %W %w}
2532     pack .ctop -fill both -expand 1
2533     bindall <1> {selcanvline %W %x %y}
2534     #bindall <B1-Motion> {selcanvline %W %x %y}
2535     if {[tk windowingsystem] == "win32"} {
2536         bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
2537         bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
2538     } else {
2539         bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
2540         bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
2541         bind $ctext <Button> {
2542             if {"%b" eq 6} {
2543                 $ctext xview scroll -5 units
2544             } elseif {"%b" eq 7} {
2545                 $ctext xview scroll 5 units
2546             }
2547         }
2548         if {[tk windowingsystem] eq "aqua"} {
2549             bindall <MouseWheel> {
2550                 set delta [expr {- (%D)}]
2551                 allcanvs yview scroll $delta units
2552             }
2553             bindall <Shift-MouseWheel> {
2554                 set delta [expr {- (%D)}]
2555                 $canv xview scroll $delta units
2556             }
2557         }
2558     }
2559     bindall <$::BM> "canvscan mark %W %x %y"
2560     bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2561     bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2562     bind . <$M1B-Key-w> doquit
2563     bindkey <Home> selfirstline
2564     bindkey <End> sellastline
2565     bind . <Key-Up> "selnextline -1"
2566     bind . <Key-Down> "selnextline 1"
2567     bind . <Shift-Key-Up> "dofind -1 0"
2568     bind . <Shift-Key-Down> "dofind 1 0"
2569     bindkey <Key-Right> "goforw"
2570     bindkey <Key-Left> "goback"
2571     bind . <Key-Prior> "selnextpage -1"
2572     bind . <Key-Next> "selnextpage 1"
2573     bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2574     bind . <$M1B-End> "allcanvs yview moveto 1.0"
2575     bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2576     bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2577     bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2578     bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2579     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2580     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2581     bindkey <Key-space> "$ctext yview scroll 1 pages"
2582     bindkey p "selnextline -1"
2583     bindkey n "selnextline 1"
2584     bindkey z "goback"
2585     bindkey x "goforw"
2586     bindkey k "selnextline -1"
2587     bindkey j "selnextline 1"
2588     bindkey h "goback"
2589     bindkey l "goforw"
2590     bindkey b prevfile
2591     bindkey d "$ctext yview scroll 18 units"
2592     bindkey u "$ctext yview scroll -18 units"
2593     bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2594     bindkey / {focus $fstring}
2595     bindkey <Key-KP_Divide> {focus $fstring}
2596     bindkey <Key-Return> {dofind 1 1}
2597     bindkey ? {dofind -1 1}
2598     bindkey f nextfile
2599     bind . <F5> updatecommits
2600     bindmodfunctionkey Shift 5 reloadcommits
2601     bind . <F2> showrefs
2602     bindmodfunctionkey Shift 4 {newview 0}
2603     bind . <F4> edit_or_newview
2604     bind . <$M1B-q> doquit
2605     bind . <$M1B-f> {dofind 1 1}
2606     bind . <$M1B-g> {dofind 1 0}
2607     bind . <$M1B-r> dosearchback
2608     bind . <$M1B-s> dosearch
2609     bind . <$M1B-equal> {incrfont 1}
2610     bind . <$M1B-plus> {incrfont 1}
2611     bind . <$M1B-KP_Add> {incrfont 1}
2612     bind . <$M1B-minus> {incrfont -1}
2613     bind . <$M1B-KP_Subtract> {incrfont -1}
2614     wm protocol . WM_DELETE_WINDOW doquit
2615     bind . <Destroy> {stop_backends}
2616     bind . <Button-1> "click %W"
2617     bind $fstring <Key-Return> {dofind 1 1}
2618     bind $sha1entry <Key-Return> {gotocommit; break}
2619     bind $sha1entry <<PasteSelection>> clearsha1
2620     bind $sha1entry <<Paste>> clearsha1
2621     bind $cflist <1> {sel_flist %W %x %y; break}
2622     bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2623     bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2624     global ctxbut
2625     bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2626     bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2627     bind $ctext <Button-1> {focus %W}
2628     bind $ctext <<Selection>> rehighlight_search_results
2629     for {set i 1} {$i < 10} {incr i} {
2630         bind . <$M1B-Key-$i> [list go_to_parent $i]
2631     }
2632
2633     set maincursor [. cget -cursor]
2634     set textcursor [$ctext cget -cursor]
2635     set curtextcursor $textcursor
2636
2637     set rowctxmenu .rowctxmenu
2638     makemenu $rowctxmenu {
2639         {mc "Diff this -> selected" command {diffvssel 0}}
2640         {mc "Diff selected -> this" command {diffvssel 1}}
2641         {mc "Make patch" command mkpatch}
2642         {mc "Create tag" command mktag}
2643         {mc "Copy commit summary" command copysummary}
2644         {mc "Write commit to file" command writecommit}
2645         {mc "Create new branch" command mkbranch}
2646         {mc "Cherry-pick this commit" command cherrypick}
2647         {mc "Reset HEAD branch to here" command resethead}
2648         {mc "Mark this commit" command markhere}
2649         {mc "Return to mark" command gotomark}
2650         {mc "Find descendant of this and mark" command find_common_desc}
2651         {mc "Compare with marked commit" command compare_commits}
2652         {mc "Diff this -> marked commit" command {diffvsmark 0}}
2653         {mc "Diff marked commit -> this" command {diffvsmark 1}}
2654         {mc "Revert this commit" command revert}
2655     }
2656     $rowctxmenu configure -tearoff 0
2657
2658     set fakerowmenu .fakerowmenu
2659     makemenu $fakerowmenu {
2660         {mc "Diff this -> selected" command {diffvssel 0}}
2661         {mc "Diff selected -> this" command {diffvssel 1}}
2662         {mc "Make patch" command mkpatch}
2663         {mc "Diff this -> marked commit" command {diffvsmark 0}}
2664         {mc "Diff marked commit -> this" command {diffvsmark 1}}
2665     }
2666     $fakerowmenu configure -tearoff 0
2667
2668     set headctxmenu .headctxmenu
2669     makemenu $headctxmenu {
2670         {mc "Check out this branch" command cobranch}
2671         {mc "Rename this branch" command mvbranch}
2672         {mc "Remove this branch" command rmbranch}
2673         {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2674     }
2675     $headctxmenu configure -tearoff 0
2676
2677     global flist_menu
2678     set flist_menu .flistctxmenu
2679     makemenu $flist_menu {
2680         {mc "Highlight this too" command {flist_hl 0}}
2681         {mc "Highlight this only" command {flist_hl 1}}
2682         {mc "External diff" command {external_diff}}
2683         {mc "Blame parent commit" command {external_blame 1}}
2684         {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2685     }
2686     $flist_menu configure -tearoff 0
2687
2688     global diff_menu
2689     set diff_menu .diffctxmenu
2690     makemenu $diff_menu {
2691         {mc "Show origin of this line" command show_line_source}
2692         {mc "Run git gui blame on this line" command {external_blame_diff}}
2693     }
2694     $diff_menu configure -tearoff 0
2695 }
2696
2697 # Windows sends all mouse wheel events to the current focused window, not
2698 # the one where the mouse hovers, so bind those events here and redirect
2699 # to the correct window
2700 proc windows_mousewheel_redirector {W X Y D} {
2701     global canv canv2 canv3
2702     set w [winfo containing -displayof $W $X $Y]
2703     if {$w ne ""} {
2704         set u [expr {$D < 0 ? 5 : -5}]
2705         if {$w == $canv || $w == $canv2 || $w == $canv3} {
2706             allcanvs yview scroll $u units
2707         } else {
2708             catch {
2709                 $w yview scroll $u units
2710             }
2711         }
2712     }
2713 }
2714
2715 # Update row number label when selectedline changes
2716 proc selectedline_change {n1 n2 op} {
2717     global selectedline rownumsel
2718
2719     if {$selectedline eq {}} {
2720         set rownumsel {}
2721     } else {
2722         set rownumsel [expr {$selectedline + 1}]
2723     }
2724 }
2725
2726 # mouse-2 makes all windows scan vertically, but only the one
2727 # the cursor is in scans horizontally
2728 proc canvscan {op w x y} {
2729     global canv canv2 canv3
2730     foreach c [list $canv $canv2 $canv3] {
2731         if {$c == $w} {
2732             $c scan $op $x $y
2733         } else {
2734             $c scan $op 0 $y
2735         }
2736     }
2737 }
2738
2739 proc scrollcanv {cscroll f0 f1} {
2740     $cscroll set $f0 $f1
2741     drawvisible
2742     flushhighlights
2743 }
2744
2745 # when we make a key binding for the toplevel, make sure
2746 # it doesn't get triggered when that key is pressed in the
2747 # find string entry widget.
2748 proc bindkey {ev script} {
2749     global entries
2750     bind . $ev $script
2751     set escript [bind Entry $ev]
2752     if {$escript == {}} {
2753         set escript [bind Entry <Key>]
2754     }
2755     foreach e $entries {
2756         bind $e $ev "$escript; break"
2757     }
2758 }
2759
2760 proc bindmodfunctionkey {mod n script} {
2761     bind . <$mod-F$n> $script
2762     catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2763 }
2764
2765 # set the focus back to the toplevel for any click outside
2766 # the entry widgets
2767 proc click {w} {
2768     global ctext entries
2769     foreach e [concat $entries $ctext] {
2770         if {$w == $e} return
2771     }
2772     focus .
2773 }
2774
2775 # Adjust the progress bar for a change in requested extent or canvas size
2776 proc adjustprogress {} {
2777     global progresscanv progressitem progresscoords
2778     global fprogitem fprogcoord lastprogupdate progupdatepending
2779     global rprogitem rprogcoord use_ttk
2780
2781     if {$use_ttk} {
2782         $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2783         return
2784     }
2785
2786     set w [expr {[winfo width $progresscanv] - 4}]
2787     set x0 [expr {$w * [lindex $progresscoords 0]}]
2788     set x1 [expr {$w * [lindex $progresscoords 1]}]
2789     set h [winfo height $progresscanv]
2790     $progresscanv coords $progressitem $x0 0 $x1 $h
2791     $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
2792     $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
2793     set now [clock clicks -milliseconds]
2794     if {$now >= $lastprogupdate + 100} {
2795         set progupdatepending 0
2796         update
2797     } elseif {!$progupdatepending} {
2798         set progupdatepending 1
2799         after [expr {$lastprogupdate + 100 - $now}] doprogupdate
2800     }
2801 }
2802
2803 proc doprogupdate {} {
2804     global lastprogupdate progupdatepending
2805
2806     if {$progupdatepending} {
2807         set progupdatepending 0
2808         set lastprogupdate [clock clicks -milliseconds]
2809         update
2810     }
2811 }
2812
2813 proc config_check_tmp_exists {tries_left} {
2814     global config_file_tmp
2815
2816     if {[file exists $config_file_tmp]} {
2817         incr tries_left -1
2818         if {$tries_left > 0} {
2819             after 100 [list config_check_tmp_exists $tries_left]
2820         } else {
2821             error_popup "There appears to be a stale $config_file_tmp\
2822  file, which will prevent gitk from saving its configuration on exit.\
2823  Please remove it if it is not being used by any existing gitk process."
2824         }
2825     }
2826 }
2827
2828 proc config_init_trace {name} {
2829     global config_variable_changed config_variable_original
2830
2831     upvar #0 $name var
2832     set config_variable_changed($name) 0
2833     set config_variable_original($name) $var
2834 }
2835
2836 proc config_variable_change_cb {name name2 op} {
2837     global config_variable_changed config_variable_original
2838
2839     upvar #0 $name var
2840     if {$op eq "write" &&
2841         (![info exists config_variable_original($name)] ||
2842          $config_variable_original($name) ne $var)} {
2843         set config_variable_changed($name) 1
2844     }
2845 }
2846
2847 proc savestuff {w} {
2848     global stuffsaved
2849     global config_file config_file_tmp
2850     global config_variables config_variable_changed
2851     global viewchanged
2852
2853     upvar #0 viewname current_viewname
2854     upvar #0 viewfiles current_viewfiles
2855     upvar #0 viewargs current_viewargs
2856     upvar #0 viewargscmd current_viewargscmd
2857     upvar #0 viewperm current_viewperm
2858     upvar #0 nextviewnum current_nextviewnum
2859     upvar #0 use_ttk current_use_ttk
2860
2861     if {$stuffsaved} return
2862     if {![winfo viewable .]} return
2863     set remove_tmp 0
2864     if {[catch {
2865         set try_count 0
2866         while {[catch {set f [open $config_file_tmp {WRONLY CREAT EXCL}]}]} {
2867             if {[incr try_count] > 50} {
2868                 error "Unable to write config file: $config_file_tmp exists"
2869             }
2870             after 100
2871         }
2872         set remove_tmp 1
2873         if {$::tcl_platform(platform) eq {windows}} {
2874             file attributes $config_file_tmp -hidden true
2875         }
2876         if {[file exists $config_file]} {
2877             source $config_file
2878         }
2879         foreach var_name $config_variables {
2880             upvar #0 $var_name var
2881             upvar 0 $var_name old_var
2882             if {!$config_variable_changed($var_name) && [info exists old_var]} {
2883                 puts $f [list set $var_name $old_var]
2884             } else {
2885                 puts $f [list set $var_name $var]
2886             }
2887         }
2888
2889         puts $f "set geometry(main) [wm geometry .]"
2890         puts $f "set geometry(state) [wm state .]"
2891         puts $f "set geometry(topwidth) [winfo width .tf]"
2892         puts $f "set geometry(topheight) [winfo height .tf]"
2893         if {$current_use_ttk} {
2894             puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
2895             puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
2896         } else {
2897             puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
2898             puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
2899         }
2900         puts $f "set geometry(botwidth) [winfo width .bleft]"
2901         puts $f "set geometry(botheight) [winfo height .bleft]"
2902
2903         array set view_save {}
2904         array set views {}
2905         if {![info exists permviews]} { set permviews {} }
2906         foreach view $permviews {
2907             set view_save([lindex $view 0]) 1
2908             set views([lindex $view 0]) $view
2909         }
2910         puts -nonewline $f "set permviews {"
2911         for {set v 1} {$v < $current_nextviewnum} {incr v} {
2912             if {$viewchanged($v)} {
2913                 if {$current_viewperm($v)} {
2914                     set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
2915                 } else {
2916                     set view_save($current_viewname($v)) 0
2917                 }
2918             }
2919         }
2920         # write old and updated view to their places and append remaining to the end
2921         foreach view $permviews {
2922             set view_name [lindex $view 0]
2923             if {$view_save($view_name)} {
2924                 puts $f "{$views($view_name)}"
2925             }
2926             unset views($view_name)
2927         }
2928         foreach view_name [array names views] {
2929             puts $f "{$views($view_name)}"
2930         }
2931         puts $f "}"
2932         close $f
2933         file rename -force $config_file_tmp $config_file
2934         set remove_tmp 0
2935     } err]} {
2936         puts "Error saving config: $err"
2937     }
2938     if {$remove_tmp} {
2939         file delete -force $config_file_tmp
2940     }
2941     set stuffsaved 1
2942 }
2943
2944 proc resizeclistpanes {win w} {
2945     global oldwidth use_ttk
2946     if {[info exists oldwidth($win)]} {
2947         if {$use_ttk} {
2948             set s0 [$win sashpos 0]
2949             set s1 [$win sashpos 1]
2950         } else {
2951             set s0 [$win sash coord 0]
2952             set s1 [$win sash coord 1]
2953         }
2954         if {$w < 60} {
2955             set sash0 [expr {int($w/2 - 2)}]
2956             set sash1 [expr {int($w*5/6 - 2)}]
2957         } else {
2958             set factor [expr {1.0 * $w / $oldwidth($win)}]
2959             set sash0 [expr {int($factor * [lindex $s0 0])}]
2960             set sash1 [expr {int($factor * [lindex $s1 0])}]
2961             if {$sash0 < 30} {
2962                 set sash0 30
2963             }
2964             if {$sash1 < $sash0 + 20} {
2965                 set sash1 [expr {$sash0 + 20}]
2966             }
2967             if {$sash1 > $w - 10} {
2968                 set sash1 [expr {$w - 10}]
2969                 if {$sash0 > $sash1 - 20} {
2970                     set sash0 [expr {$sash1 - 20}]
2971                 }
2972             }
2973         }
2974         if {$use_ttk} {
2975             $win sashpos 0 $sash0
2976             $win sashpos 1 $sash1
2977         } else {
2978             $win sash place 0 $sash0 [lindex $s0 1]
2979             $win sash place 1 $sash1 [lindex $s1 1]
2980         }
2981     }
2982     set oldwidth($win) $w
2983 }
2984
2985 proc resizecdetpanes {win w} {
2986     global oldwidth use_ttk
2987     if {[info exists oldwidth($win)]} {
2988         if {$use_ttk} {
2989             set s0 [$win sashpos 0]
2990         } else {
2991             set s0 [$win sash coord 0]
2992         }
2993         if {$w < 60} {
2994             set sash0 [expr {int($w*3/4 - 2)}]
2995         } else {
2996             set factor [expr {1.0 * $w / $oldwidth($win)}]
2997             set sash0 [expr {int($factor * [lindex $s0 0])}]
2998             if {$sash0 < 45} {
2999                 set sash0 45
3000             }
3001             if {$sash0 > $w - 15} {
3002                 set sash0 [expr {$w - 15}]
3003             }
3004         }
3005         if {$use_ttk} {
3006             $win sashpos 0 $sash0
3007         } else {
3008             $win sash place 0 $sash0 [lindex $s0 1]
3009         }
3010     }
3011     set oldwidth($win) $w
3012 }
3013
3014 proc allcanvs args {
3015     global canv canv2 canv3
3016     eval $canv $args
3017     eval $canv2 $args
3018     eval $canv3 $args
3019 }
3020
3021 proc bindall {event action} {
3022     global canv canv2 canv3
3023     bind $canv $event $action
3024     bind $canv2 $event $action
3025     bind $canv3 $event $action
3026 }
3027
3028 proc about {} {
3029     global bgcolor NS
3030     set w .about
3031     if {[winfo exists $w]} {
3032         raise $w
3033         return
3034     }
3035     ttk_toplevel $w
3036     wm title $w [mc "About gitk"]
3037     make_transient $w .
3038     message $w.m -text [mc "
3039 Gitk - a commit viewer for git
3040
3041 Copyright \u00a9 2005-2016 Paul Mackerras
3042
3043 Use and redistribute under the terms of the GNU General Public License"] \
3044             -justify center -aspect 400 -border 2 -bg $bgcolor -relief groove
3045     pack $w.m -side top -fill x -padx 2 -pady 2
3046     ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3047     pack $w.ok -side bottom
3048     bind $w <Visibility> "focus $w.ok"
3049     bind $w <Key-Escape> "destroy $w"
3050     bind $w <Key-Return> "destroy $w"
3051     tk::PlaceWindow $w widget .
3052 }
3053
3054 proc keys {} {
3055     global bgcolor NS
3056     set w .keys
3057     if {[winfo exists $w]} {
3058         raise $w
3059         return
3060     }
3061     if {[tk windowingsystem] eq {aqua}} {
3062         set M1T Cmd
3063     } else {
3064         set M1T Ctrl
3065     }
3066     ttk_toplevel $w
3067     wm title $w [mc "Gitk key bindings"]
3068     make_transient $w .
3069     message $w.m -text "
3070 [mc "Gitk key bindings:"]
3071
3072 [mc "<%s-Q>             Quit" $M1T]
3073 [mc "<%s-W>             Close window" $M1T]
3074 [mc "<Home>             Move to first commit"]
3075 [mc "<End>              Move to last commit"]
3076 [mc "<Up>, p, k Move up one commit"]
3077 [mc "<Down>, n, j       Move down one commit"]
3078 [mc "<Left>, z, h       Go back in history list"]
3079 [mc "<Right>, x, l      Go forward in history list"]
3080 [mc "<%s-n>     Go to n-th parent of current commit in history list" $M1T]
3081 [mc "<PageUp>   Move up one page in commit list"]
3082 [mc "<PageDown> Move down one page in commit list"]
3083 [mc "<%s-Home>  Scroll to top of commit list" $M1T]
3084 [mc "<%s-End>   Scroll to bottom of commit list" $M1T]
3085 [mc "<%s-Up>    Scroll commit list up one line" $M1T]
3086 [mc "<%s-Down>  Scroll commit list down one line" $M1T]
3087 [mc "<%s-PageUp>        Scroll commit list up one page" $M1T]
3088 [mc "<%s-PageDown>      Scroll commit list down one page" $M1T]
3089 [mc "<Shift-Up> Find backwards (upwards, later commits)"]
3090 [mc "<Shift-Down>       Find forwards (downwards, earlier commits)"]
3091 [mc "<Delete>, b        Scroll diff view up one page"]
3092 [mc "<Backspace>        Scroll diff view up one page"]
3093 [mc "<Space>            Scroll diff view down one page"]
3094 [mc "u          Scroll diff view up 18 lines"]
3095 [mc "d          Scroll diff view down 18 lines"]
3096 [mc "<%s-F>             Find" $M1T]
3097 [mc "<%s-G>             Move to next find hit" $M1T]
3098 [mc "<Return>   Move to next find hit"]
3099 [mc "g          Go to commit"]
3100 [mc "/          Focus the search box"]
3101 [mc "?          Move to previous find hit"]
3102 [mc "f          Scroll diff view to next file"]
3103 [mc "<%s-S>             Search for next hit in diff view" $M1T]
3104 [mc "<%s-R>             Search for previous hit in diff view" $M1T]
3105 [mc "<%s-KP+>   Increase font size" $M1T]
3106 [mc "<%s-plus>  Increase font size" $M1T]
3107 [mc "<%s-KP->   Decrease font size" $M1T]
3108 [mc "<%s-minus> Decrease font size" $M1T]
3109 [mc "<F5>               Update"]
3110 " \
3111             -justify left -bg $bgcolor -border 2 -relief groove
3112     pack $w.m -side top -fill both -padx 2 -pady 2
3113     ${NS}::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3114     bind $w <Key-Escape> [list destroy $w]
3115     pack $w.ok -side bottom
3116     bind $w <Visibility> "focus $w.ok"
3117     bind $w <Key-Escape> "destroy $w"
3118     bind $w <Key-Return> "destroy $w"
3119 }
3120
3121 # Procedures for manipulating the file list window at the
3122 # bottom right of the overall window.
3123
3124 proc treeview {w l openlevs} {
3125     global treecontents treediropen treeheight treeparent treeindex
3126
3127     set ix 0
3128     set treeindex() 0
3129     set lev 0
3130     set prefix {}
3131     set prefixend -1
3132     set prefendstack {}
3133     set htstack {}
3134     set ht 0
3135     set treecontents() {}
3136     $w conf -state normal
3137     foreach f $l {
3138         while {[string range $f 0 $prefixend] ne $prefix} {
3139             if {$lev <= $openlevs} {
3140                 $w mark set e:$treeindex($prefix) "end -1c"
3141                 $w mark gravity e:$treeindex($prefix) left
3142             }
3143             set treeheight($prefix) $ht
3144             incr ht [lindex $htstack end]
3145             set htstack [lreplace $htstack end end]
3146             set prefixend [lindex $prefendstack end]
3147             set prefendstack [lreplace $prefendstack end end]
3148             set prefix [string range $prefix 0 $prefixend]
3149             incr lev -1
3150         }
3151         set tail [string range $f [expr {$prefixend+1}] end]
3152         while {[set slash [string first "/" $tail]] >= 0} {
3153             lappend htstack $ht
3154             set ht 0
3155             lappend prefendstack $prefixend
3156             incr prefixend [expr {$slash + 1}]
3157             set d [string range $tail 0 $slash]
3158             lappend treecontents($prefix) $d
3159             set oldprefix $prefix
3160             append prefix $d
3161             set treecontents($prefix) {}
3162             set treeindex($prefix) [incr ix]
3163             set treeparent($prefix) $oldprefix
3164             set tail [string range $tail [expr {$slash+1}] end]
3165             if {$lev <= $openlevs} {
3166                 set ht 1
3167                 set treediropen($prefix) [expr {$lev < $openlevs}]
3168                 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3169                 $w mark set d:$ix "end -1c"
3170                 $w mark gravity d:$ix left
3171                 set str "\n"
3172                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3173                 $w insert end $str
3174                 $w image create end -align center -image $bm -padx 1 \
3175                     -name a:$ix
3176                 $w insert end $d [highlight_tag $prefix]
3177                 $w mark set s:$ix "end -1c"
3178                 $w mark gravity s:$ix left
3179             }
3180             incr lev
3181         }
3182         if {$tail ne {}} {
3183             if {$lev <= $openlevs} {
3184                 incr ht
3185                 set str "\n"
3186                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3187                 $w insert end $str
3188                 $w insert end $tail [highlight_tag $f]
3189             }
3190             lappend treecontents($prefix) $tail
3191         }
3192     }
3193     while {$htstack ne {}} {
3194         set treeheight($prefix) $ht
3195         incr ht [lindex $htstack end]
3196         set htstack [lreplace $htstack end end]
3197         set prefixend [lindex $prefendstack end]
3198         set prefendstack [lreplace $prefendstack end end]
3199         set prefix [string range $prefix 0 $prefixend]
3200     }
3201     $w conf -state disabled
3202 }
3203
3204 proc linetoelt {l} {
3205     global treeheight treecontents
3206
3207     set y 2
3208     set prefix {}
3209     while {1} {
3210         foreach e $treecontents($prefix) {
3211             if {$y == $l} {
3212                 return "$prefix$e"
3213             }
3214             set n 1
3215             if {[string index $e end] eq "/"} {
3216                 set n $treeheight($prefix$e)
3217                 if {$y + $n > $l} {
3218                     append prefix $e
3219                     incr y
3220                     break
3221                 }
3222             }
3223             incr y $n
3224         }
3225     }
3226 }
3227
3228 proc highlight_tree {y prefix} {
3229     global treeheight treecontents cflist
3230
3231     foreach e $treecontents($prefix) {
3232         set path $prefix$e
3233         if {[highlight_tag $path] ne {}} {
3234             $cflist tag add bold $y.0 "$y.0 lineend"
3235         }
3236         incr y
3237         if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3238             set y [highlight_tree $y $path]
3239         }
3240     }
3241     return $y
3242 }
3243
3244 proc treeclosedir {w dir} {
3245     global treediropen treeheight treeparent treeindex
3246
3247     set ix $treeindex($dir)
3248     $w conf -state normal
3249     $w delete s:$ix e:$ix
3250     set treediropen($dir) 0
3251     $w image configure a:$ix -image tri-rt
3252     $w conf -state disabled
3253     set n [expr {1 - $treeheight($dir)}]
3254     while {$dir ne {}} {
3255         incr treeheight($dir) $n
3256         set dir $treeparent($dir)
3257     }
3258 }
3259
3260 proc treeopendir {w dir} {
3261     global treediropen treeheight treeparent treecontents treeindex
3262
3263     set ix $treeindex($dir)
3264     $w conf -state normal
3265     $w image configure a:$ix -image tri-dn
3266     $w mark set e:$ix s:$ix
3267     $w mark gravity e:$ix right
3268     set lev 0
3269     set str "\n"
3270     set n [llength $treecontents($dir)]
3271     for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3272         incr lev
3273         append str "\t"
3274         incr treeheight($x) $n
3275     }
3276     foreach e $treecontents($dir) {
3277         set de $dir$e
3278         if {[string index $e end] eq "/"} {
3279             set iy $treeindex($de)
3280             $w mark set d:$iy e:$ix
3281             $w mark gravity d:$iy left
3282             $w insert e:$ix $str
3283             set treediropen($de) 0
3284             $w image create e:$ix -align center -image tri-rt -padx 1 \
3285                 -name a:$iy
3286             $w insert e:$ix $e [highlight_tag $de]
3287             $w mark set s:$iy e:$ix
3288             $w mark gravity s:$iy left
3289             set treeheight($de) 1
3290         } else {
3291             $w insert e:$ix $str
3292             $w insert e:$ix $e [highlight_tag $de]
3293         }
3294     }
3295     $w mark gravity e:$ix right
3296     $w conf -state disabled
3297     set treediropen($dir) 1
3298     set top [lindex [split [$w index @0,0] .] 0]
3299     set ht [$w cget -height]
3300     set l [lindex [split [$w index s:$ix] .] 0]
3301     if {$l < $top} {
3302         $w yview $l.0
3303     } elseif {$l + $n + 1 > $top + $ht} {
3304         set top [expr {$l + $n + 2 - $ht}]
3305         if {$l < $top} {
3306             set top $l
3307         }
3308         $w yview $top.0
3309     }
3310 }
3311
3312 proc treeclick {w x y} {
3313     global treediropen cmitmode ctext cflist cflist_top
3314
3315     if {$cmitmode ne "tree"} return
3316     if {![info exists cflist_top]} return
3317     set l [lindex [split [$w index "@$x,$y"] "."] 0]
3318     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3319     $cflist tag add highlight $l.0 "$l.0 lineend"
3320     set cflist_top $l
3321     if {$l == 1} {
3322         $ctext yview 1.0
3323         return
3324     }
3325     set e [linetoelt $l]
3326     if {[string index $e end] ne "/"} {
3327         showfile $e
3328     } elseif {$treediropen($e)} {
3329         treeclosedir $w $e
3330     } else {
3331         treeopendir $w $e
3332     }
3333 }
3334
3335 proc setfilelist {id} {
3336     global treefilelist cflist jump_to_here
3337
3338     treeview $cflist $treefilelist($id) 0
3339     if {$jump_to_here ne {}} {
3340         set f [lindex $jump_to_here 0]
3341         if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3342             showfile $f
3343         }
3344     }
3345 }
3346
3347 image create bitmap tri-rt -background black -foreground blue -data {
3348     #define tri-rt_width 13
3349     #define tri-rt_height 13
3350     static unsigned char tri-rt_bits[] = {
3351        0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3352        0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3353        0x00, 0x00};
3354 } -maskdata {
3355     #define tri-rt-mask_width 13
3356     #define tri-rt-mask_height 13
3357     static unsigned char tri-rt-mask_bits[] = {
3358        0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3359        0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3360        0x08, 0x00};
3361 }
3362 image create bitmap tri-dn -background black -foreground blue -data {
3363     #define tri-dn_width 13
3364     #define tri-dn_height 13
3365     static unsigned char tri-dn_bits[] = {
3366        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3367        0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3368        0x00, 0x00};
3369 } -maskdata {
3370     #define tri-dn-mask_width 13
3371     #define tri-dn-mask_height 13
3372     static unsigned char tri-dn-mask_bits[] = {
3373        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3374        0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3375        0x00, 0x00};
3376 }
3377
3378 image create bitmap reficon-T -background black -foreground yellow -data {
3379     #define tagicon_width 13
3380     #define tagicon_height 9
3381     static unsigned char tagicon_bits[] = {
3382        0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3383        0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3384 } -maskdata {
3385     #define tagicon-mask_width 13
3386     #define tagicon-mask_height 9
3387     static unsigned char tagicon-mask_bits[] = {
3388        0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3389        0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3390 }
3391 set rectdata {
3392     #define headicon_width 13
3393     #define headicon_height 9
3394     static unsigned char headicon_bits[] = {
3395        0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3396        0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3397 }
3398 set rectmask {
3399     #define headicon-mask_width 13
3400     #define headicon-mask_height 9
3401     static unsigned char headicon-mask_bits[] = {
3402        0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3403        0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3404 }
3405 image create bitmap reficon-H -background black -foreground "#00ff00" \
3406     -data $rectdata -maskdata $rectmask
3407 image create bitmap reficon-R -background black -foreground "#ffddaa" \
3408     -data $rectdata -maskdata $rectmask
3409 image create bitmap reficon-o -background black -foreground "#ddddff" \
3410     -data $rectdata -maskdata $rectmask
3411
3412 proc init_flist {first} {
3413     global cflist cflist_top difffilestart
3414
3415     $cflist conf -state normal
3416     $cflist delete 0.0 end
3417     if {$first ne {}} {
3418         $cflist insert end $first
3419         set cflist_top 1
3420         $cflist tag add highlight 1.0 "1.0 lineend"
3421     } else {
3422         unset -nocomplain cflist_top
3423     }
3424     $cflist conf -state disabled
3425     set difffilestart {}
3426 }
3427
3428 proc highlight_tag {f} {
3429     global highlight_paths
3430
3431     foreach p $highlight_paths {
3432         if {[string match $p $f]} {
3433             return "bold"
3434         }
3435     }
3436     return {}
3437 }
3438
3439 proc highlight_filelist {} {
3440     global cmitmode cflist
3441
3442     $cflist conf -state normal
3443     if {$cmitmode ne "tree"} {
3444         set end [lindex [split [$cflist index end] .] 0]
3445         for {set l 2} {$l < $end} {incr l} {
3446             set line [$cflist get $l.0 "$l.0 lineend"]
3447             if {[highlight_tag $line] ne {}} {
3448                 $cflist tag add bold $l.0 "$l.0 lineend"
3449             }
3450         }
3451     } else {
3452         highlight_tree 2 {}
3453     }
3454     $cflist conf -state disabled
3455 }
3456
3457 proc unhighlight_filelist {} {
3458     global cflist
3459
3460     $cflist conf -state normal
3461     $cflist tag remove bold 1.0 end
3462     $cflist conf -state disabled
3463 }
3464
3465 proc add_flist {fl} {
3466     global cflist
3467
3468     $cflist conf -state normal
3469     foreach f $fl {
3470         $cflist insert end "\n"
3471         $cflist insert end $f [highlight_tag $f]
3472     }
3473     $cflist conf -state disabled
3474 }
3475
3476 proc sel_flist {w x y} {
3477     global ctext difffilestart cflist cflist_top cmitmode
3478
3479     if {$cmitmode eq "tree"} return
3480     if {![info exists cflist_top]} return
3481     set l [lindex [split [$w index "@$x,$y"] "."] 0]
3482     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3483     $cflist tag add highlight $l.0 "$l.0 lineend"
3484     set cflist_top $l
3485     if {$l == 1} {
3486         $ctext yview 1.0
3487     } else {
3488         catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3489     }
3490     suppress_highlighting_file_for_current_scrollpos
3491 }
3492
3493 proc pop_flist_menu {w X Y x y} {
3494     global ctext cflist cmitmode flist_menu flist_menu_file
3495     global treediffs diffids
3496
3497     stopfinding
3498     set l [lindex [split [$w index "@$x,$y"] "."] 0]
3499     if {$l <= 1} return
3500     if {$cmitmode eq "tree"} {
3501         set e [linetoelt $l]
3502         if {[string index $e end] eq "/"} return
3503     } else {
3504         set e [lindex $treediffs($diffids) [expr {$l-2}]]
3505     }
3506     set flist_menu_file $e
3507     set xdiffstate "normal"
3508     if {$cmitmode eq "tree"} {
3509         set xdiffstate "disabled"
3510     }
3511     # Disable "External diff" item in tree mode
3512     $flist_menu entryconf 2 -state $xdiffstate
3513     tk_popup $flist_menu $X $Y
3514 }
3515
3516 proc find_ctext_fileinfo {line} {
3517     global ctext_file_names ctext_file_lines
3518
3519     set ok [bsearch $ctext_file_lines $line]
3520     set tline [lindex $ctext_file_lines $ok]
3521
3522     if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3523         return {}
3524     } else {
3525         return [list [lindex $ctext_file_names $ok] $tline]
3526     }
3527 }
3528
3529 proc pop_diff_menu {w X Y x y} {
3530     global ctext diff_menu flist_menu_file
3531     global diff_menu_txtpos diff_menu_line
3532     global diff_menu_filebase
3533
3534     set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3535     set diff_menu_line [lindex $diff_menu_txtpos 0]
3536     # don't pop up the menu on hunk-separator or file-separator lines
3537     if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3538         return
3539     }
3540     stopfinding
3541     set f [find_ctext_fileinfo $diff_menu_line]
3542     if {$f eq {}} return
3543     set flist_menu_file [lindex $f 0]
3544     set diff_menu_filebase [lindex $f 1]
3545     tk_popup $diff_menu $X $Y
3546 }
3547
3548 proc flist_hl {only} {
3549     global flist_menu_file findstring gdttype
3550
3551     set x [shellquote $flist_menu_file]
3552     if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3553         set findstring $x
3554     } else {
3555         append findstring " " $x
3556     }
3557     set gdttype [mc "touching paths:"]
3558 }
3559
3560 proc gitknewtmpdir {} {
3561     global diffnum gitktmpdir gitdir env
3562
3563     if {![info exists gitktmpdir]} {
3564         if {[info exists env(GITK_TMPDIR)]} {
3565             set tmpdir $env(GITK_TMPDIR)
3566         } elseif {[info exists env(TMPDIR)]} {
3567             set tmpdir $env(TMPDIR)
3568         } else {
3569             set tmpdir $gitdir
3570         }
3571         set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3572         if {[catch {set gitktmpdir [exec mktemp -d $gitktmpformat]}]} {
3573             set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3574         }
3575         if {[catch {file mkdir $gitktmpdir} err]} {
3576             error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3577             unset gitktmpdir
3578             return {}
3579         }
3580         set diffnum 0
3581     }
3582     incr diffnum
3583     set diffdir [file join $gitktmpdir $diffnum]
3584     if {[catch {file mkdir $diffdir} err]} {
3585         error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3586         return {}
3587     }
3588     return $diffdir
3589 }
3590
3591 proc save_file_from_commit {filename output what} {
3592     global nullfile
3593
3594     if {[catch {exec git show $filename -- > $output} err]} {
3595         if {[string match "fatal: bad revision *" $err]} {
3596             return $nullfile
3597         }
3598         error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3599         return {}
3600     }
3601     return $output
3602 }
3603
3604 proc external_diff_get_one_file {diffid filename diffdir} {
3605     global nullid nullid2 nullfile
3606     global worktree
3607
3608     if {$diffid == $nullid} {
3609         set difffile [file join $worktree $filename]
3610         if {[file exists $difffile]} {
3611             return $difffile
3612         }
3613         return $nullfile
3614     }
3615     if {$diffid == $nullid2} {
3616         set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3617         return [save_file_from_commit :$filename $difffile index]
3618     }
3619     set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3620     return [save_file_from_commit $diffid:$filename $difffile \
3621                "revision $diffid"]
3622 }
3623
3624 proc external_diff {} {
3625     global nullid nullid2
3626     global flist_menu_file
3627     global diffids
3628     global extdifftool
3629
3630     if {[llength $diffids] == 1} {
3631         # no reference commit given
3632         set diffidto [lindex $diffids 0]
3633         if {$diffidto eq $nullid} {
3634             # diffing working copy with index
3635             set diffidfrom $nullid2
3636         } elseif {$diffidto eq $nullid2} {
3637             # diffing index with HEAD
3638             set diffidfrom "HEAD"
3639         } else {
3640             # use first parent commit
3641             global parentlist selectedline
3642             set diffidfrom [lindex $parentlist $selectedline 0]
3643         }
3644     } else {
3645         set diffidfrom [lindex $diffids 0]
3646         set diffidto [lindex $diffids 1]
3647     }
3648
3649     # make sure that several diffs wont collide
3650     set diffdir [gitknewtmpdir]
3651     if {$diffdir eq {}} return
3652
3653     # gather files to diff
3654     set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3655     set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3656
3657     if {$difffromfile ne {} && $difftofile ne {}} {
3658         set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3659         if {[catch {set fl [open |$cmd r]} err]} {
3660             file delete -force $diffdir
3661             error_popup "$extdifftool: [mc "command failed:"] $err"
3662         } else {
3663             fconfigure $fl -blocking 0
3664             filerun $fl [list delete_at_eof $fl $diffdir]
3665         }
3666     }
3667 }
3668
3669 proc find_hunk_blamespec {base line} {
3670     global ctext
3671
3672     # Find and parse the hunk header
3673     set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3674     if {$s_lix eq {}} return
3675
3676     set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3677     if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3678             s_line old_specs osz osz1 new_line nsz]} {
3679         return
3680     }
3681
3682     # base lines for the parents
3683     set base_lines [list $new_line]
3684     foreach old_spec [lrange [split $old_specs " "] 1 end] {
3685         if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3686                 old_spec old_line osz]} {
3687             return
3688         }
3689         lappend base_lines $old_line
3690     }
3691
3692     # Now scan the lines to determine offset within the hunk
3693     set max_parent [expr {[llength $base_lines]-2}]
3694     set dline 0
3695     set s_lno [lindex [split $s_lix "."] 0]
3696
3697     # Determine if the line is removed
3698     set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3699     if {[string match {[-+ ]*} $chunk]} {
3700         set removed_idx [string first "-" $chunk]
3701         # Choose a parent index
3702         if {$removed_idx >= 0} {
3703             set parent $removed_idx
3704         } else {
3705             set unchanged_idx [string first " " $chunk]
3706             if {$unchanged_idx >= 0} {
3707                 set parent $unchanged_idx
3708             } else {
3709                 # blame the current commit
3710                 set parent -1
3711             }
3712         }
3713         # then count other lines that belong to it
3714         for {set i $line} {[incr i -1] > $s_lno} {} {
3715             set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3716             # Determine if the line is removed
3717             set removed_idx [string first "-" $chunk]
3718             if {$parent >= 0} {
3719                 set code [string index $chunk $parent]
3720                 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3721                     incr dline
3722                 }
3723             } else {
3724                 if {$removed_idx < 0} {
3725                     incr dline
3726                 }
3727             }
3728         }
3729         incr parent
3730     } else {
3731         set parent 0
3732     }
3733
3734     incr dline [lindex $base_lines $parent]
3735     return [list $parent $dline]
3736 }
3737
3738 proc external_blame_diff {} {
3739     global currentid cmitmode
3740     global diff_menu_txtpos diff_menu_line
3741     global diff_menu_filebase flist_menu_file
3742
3743     if {$cmitmode eq "tree"} {
3744         set parent_idx 0
3745         set line [expr {$diff_menu_line - $diff_menu_filebase}]
3746     } else {
3747         set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3748         if {$hinfo ne {}} {
3749             set parent_idx [lindex $hinfo 0]
3750             set line [lindex $hinfo 1]
3751         } else {
3752             set parent_idx 0
3753             set line 0
3754         }
3755     }
3756
3757     external_blame $parent_idx $line
3758 }
3759
3760 # Find the SHA1 ID of the blob for file $fname in the index
3761 # at stage 0 or 2
3762 proc index_sha1 {fname} {
3763     set f [open [list | git ls-files -s $fname] r]
3764     while {[gets $f line] >= 0} {
3765         set info [lindex [split $line "\t"] 0]
3766         set stage [lindex $info 2]
3767         if {$stage eq "0" || $stage eq "2"} {
3768             close $f
3769             return [lindex $info 1]
3770         }
3771     }
3772     close $f
3773     return {}
3774 }
3775
3776 # Turn an absolute path into one relative to the current directory
3777 proc make_relative {f} {
3778     if {[file pathtype $f] eq "relative"} {
3779         return $f
3780     }
3781     set elts [file split $f]
3782     set here [file split [pwd]]
3783     set ei 0
3784     set hi 0
3785     set res {}
3786     foreach d $here {
3787         if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3788             lappend res ".."
3789         } else {
3790             incr ei
3791         }
3792         incr hi
3793     }
3794     set elts [concat $res [lrange $elts $ei end]]
3795     return [eval file join $elts]
3796 }
3797
3798 proc external_blame {parent_idx {line {}}} {
3799     global flist_menu_file cdup
3800     global nullid nullid2
3801     global parentlist selectedline currentid
3802
3803     if {$parent_idx > 0} {
3804         set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3805     } else {
3806         set base_commit $currentid
3807     }
3808
3809     if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3810         error_popup [mc "No such commit"]
3811         return
3812     }
3813
3814     set cmdline [list git gui blame]
3815     if {$line ne {} && $line > 1} {
3816         lappend cmdline "--line=$line"
3817     }
3818     set f [file join $cdup $flist_menu_file]
3819     # Unfortunately it seems git gui blame doesn't like
3820     # being given an absolute path...
3821     set f [make_relative $f]
3822     lappend cmdline $base_commit $f
3823     if {[catch {eval exec $cmdline &} err]} {
3824         error_popup "[mc "git gui blame: command failed:"] $err"
3825     }
3826 }
3827
3828 proc show_line_source {} {
3829     global cmitmode currentid parents curview blamestuff blameinst
3830     global diff_menu_line diff_menu_filebase flist_menu_file
3831     global nullid nullid2 gitdir cdup
3832
3833     set from_index {}
3834     if {$cmitmode eq "tree"} {
3835         set id $currentid
3836         set line [expr {$diff_menu_line - $diff_menu_filebase}]
3837     } else {
3838         set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3839         if {$h eq {}} return
3840         set pi [lindex $h 0]
3841         if {$pi == 0} {
3842             mark_ctext_line $diff_menu_line
3843             return
3844         }
3845         incr pi -1
3846         if {$currentid eq $nullid} {
3847             if {$pi > 0} {
3848                 # must be a merge in progress...
3849                 if {[catch {
3850                     # get the last line from .git/MERGE_HEAD
3851                     set f [open [file join $gitdir MERGE_HEAD] r]
3852                     set id [lindex [split [read $f] "\n"] end-1]
3853                     close $f
3854                 } err]} {
3855                     error_popup [mc "Couldn't read merge head: %s" $err]
3856                     return
3857                 }
3858             } elseif {$parents($curview,$currentid) eq $nullid2} {
3859                 # need to do the blame from the index
3860                 if {[catch {
3861                     set from_index [index_sha1 $flist_menu_file]
3862                 } err]} {
3863                     error_popup [mc "Error reading index: %s" $err]
3864                     return
3865                 }
3866             } else {
3867                 set id $parents($curview,$currentid)
3868             }
3869         } else {
3870             set id [lindex $parents($curview,$currentid) $pi]
3871         }
3872         set line [lindex $h 1]
3873     }
3874     set blameargs {}
3875     if {$from_index ne {}} {
3876         lappend blameargs | git cat-file blob $from_index
3877     }
3878     lappend blameargs | git blame -p -L$line,+1
3879     if {$from_index ne {}} {
3880         lappend blameargs --contents -
3881     } else {
3882         lappend blameargs $id
3883     }
3884     lappend blameargs -- [file join $cdup $flist_menu_file]
3885     if {[catch {
3886         set f [open $blameargs r]
3887     } err]} {
3888         error_popup [mc "Couldn't start git blame: %s" $err]
3889         return
3890     }
3891     nowbusy blaming [mc "Searching"]
3892     fconfigure $f -blocking 0
3893     set i [reg_instance $f]
3894     set blamestuff($i) {}
3895     set blameinst $i
3896     filerun $f [list read_line_source $f $i]
3897 }
3898
3899 proc stopblaming {} {
3900     global blameinst
3901
3902     if {[info exists blameinst]} {
3903         stop_instance $blameinst
3904         unset blameinst
3905         notbusy blaming
3906     }
3907 }
3908
3909 proc read_line_source {fd inst} {
3910     global blamestuff curview commfd blameinst nullid nullid2
3911
3912     while {[gets $fd line] >= 0} {
3913         lappend blamestuff($inst) $line
3914     }
3915     if {![eof $fd]} {
3916         return 1
3917     }
3918     unset commfd($inst)
3919     unset blameinst
3920     notbusy blaming
3921     fconfigure $fd -blocking 1
3922     if {[catch {close $fd} err]} {
3923         error_popup [mc "Error running git blame: %s" $err]
3924         return 0
3925     }
3926
3927     set fname {}
3928     set line [split [lindex $blamestuff($inst) 0] " "]
3929     set id [lindex $line 0]
3930     set lnum [lindex $line 1]
3931     if {[string length $id] == 40 && [string is xdigit $id] &&
3932         [string is digit -strict $lnum]} {
3933         # look for "filename" line
3934         foreach l $blamestuff($inst) {
3935             if {[string match "filename *" $l]} {
3936                 set fname [string range $l 9 end]
3937                 break
3938             }
3939         }
3940     }
3941     if {$fname ne {}} {
3942         # all looks good, select it
3943         if {$id eq $nullid} {
3944             # blame uses all-zeroes to mean not committed,
3945             # which would mean a change in the index
3946             set id $nullid2
3947         }
3948         if {[commitinview $id $curview]} {
3949             selectline [rowofcommit $id] 1 [list $fname $lnum] 1