3f7f77777def2f936ddacd1e0fc122c5121c16f2
   1#!/bin/sh
   2# Tcl ignores the next line -*- tcl -*- \
   3exec wish "$0" -- "$@"
   4
   5# Copyright (C) 2005-2006 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
  10proc gitdir {} {
  11    global env
  12    if {[info exists env(GIT_DIR)]} {
  13        return $env(GIT_DIR)
  14    } else {
  15        return [exec git rev-parse --git-dir]
  16    }
  17}
  18
  19# A simple scheduler for compute-intensive stuff.
  20# The aim is to make sure that event handlers for GUI actions can
  21# run at least every 50-100 ms.  Unfortunately fileevent handlers are
  22# run before X event handlers, so reading from a fast source can
  23# make the GUI completely unresponsive.
  24proc run args {
  25    global isonrunq runq
  26
  27    set script $args
  28    if {[info exists isonrunq($script)]} return
  29    if {$runq eq {}} {
  30        after idle dorunq
  31    }
  32    lappend runq [list {} $script]
  33    set isonrunq($script) 1
  34}
  35
  36proc filerun {fd script} {
  37    fileevent $fd readable [list filereadable $fd $script]
  38}
  39
  40proc filereadable {fd script} {
  41    global runq
  42
  43    fileevent $fd readable {}
  44    if {$runq eq {}} {
  45        after idle dorunq
  46    }
  47    lappend runq [list $fd $script]
  48}
  49
  50proc dorunq {} {
  51    global isonrunq runq
  52
  53    set tstart [clock clicks -milliseconds]
  54    set t0 $tstart
  55    while {$runq ne {}} {
  56        set fd [lindex $runq 0 0]
  57        set script [lindex $runq 0 1]
  58        set repeat [eval $script]
  59        set t1 [clock clicks -milliseconds]
  60        set t [expr {$t1 - $t0}]
  61        set runq [lrange $runq 1 end]
  62        if {$repeat ne {} && $repeat} {
  63            if {$fd eq {} || $repeat == 2} {
  64                # script returns 1 if it wants to be readded
  65                # file readers return 2 if they could do more straight away
  66                lappend runq [list $fd $script]
  67            } else {
  68                fileevent $fd readable [list filereadable $fd $script]
  69            }
  70        } elseif {$fd eq {}} {
  71            unset isonrunq($script)
  72        }
  73        set t0 $t1
  74        if {$t1 - $tstart >= 80} break
  75    }
  76    if {$runq ne {}} {
  77        after idle dorunq
  78    }
  79}
  80
  81# Start off a git rev-list process and arrange to read its output
  82proc start_rev_list {view} {
  83    global startmsecs
  84    global commfd leftover tclencoding datemode
  85    global viewargs viewfiles commitidx viewcomplete vnextroot
  86    global showlocalchanges commitinterest mainheadid
  87    global progressdirn progresscoords proglastnc curview
  88
  89    set startmsecs [clock clicks -milliseconds]
  90    set commitidx($view) 0
  91    set viewcomplete($view) 0
  92    set vnextroot($view) 0
  93    set order "--topo-order"
  94    if {$datemode} {
  95        set order "--date-order"
  96    }
  97    if {[catch {
  98        set fd [open [concat | git log -z --pretty=raw $order --parents \
  99                         --boundary $viewargs($view) "--" $viewfiles($view)] r]
 100    } err]} {
 101        error_popup "Error executing git rev-list: $err"
 102        exit 1
 103    }
 104    set commfd($view) $fd
 105    set leftover($view) {}
 106    if {$showlocalchanges} {
 107        lappend commitinterest($mainheadid) {dodiffindex}
 108    }
 109    fconfigure $fd -blocking 0 -translation lf -eofchar {}
 110    if {$tclencoding != {}} {
 111        fconfigure $fd -encoding $tclencoding
 112    }
 113    filerun $fd [list getcommitlines $fd $view]
 114    nowbusy $view
 115    if {$view == $curview} {
 116        set progressdirn 1
 117        set progresscoords {0 0}
 118        set proglastnc 0
 119    }
 120}
 121
 122proc stop_rev_list {} {
 123    global commfd curview
 124
 125    if {![info exists commfd($curview)]} return
 126    set fd $commfd($curview)
 127    catch {
 128        set pid [pid $fd]
 129        exec kill $pid
 130    }
 131    catch {close $fd}
 132    unset commfd($curview)
 133}
 134
 135proc getcommits {} {
 136    global phase canv curview
 137
 138    set phase getcommits
 139    initlayout
 140    start_rev_list $curview
 141    show_status "Reading commits..."
 142}
 143
 144# This makes a string representation of a positive integer which
 145# sorts as a string in numerical order
 146proc strrep {n} {
 147    if {$n < 16} {
 148        return [format "%x" $n]
 149    } elseif {$n < 256} {
 150        return [format "x%.2x" $n]
 151    } elseif {$n < 65536} {
 152        return [format "y%.4x" $n]
 153    }
 154    return [format "z%.8x" $n]
 155}
 156
 157proc getcommitlines {fd view}  {
 158    global commitlisted commitinterest
 159    global leftover commfd
 160    global displayorder commitidx viewcomplete commitrow commitdata
 161    global parentlist children curview hlview
 162    global vparentlist vdisporder vcmitlisted
 163    global ordertok vnextroot idpending
 164
 165    set stuff [read $fd 500000]
 166    # git log doesn't terminate the last commit with a null...
 167    if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
 168        set stuff "\0"
 169    }
 170    if {$stuff == {}} {
 171        if {![eof $fd]} {
 172            return 1
 173        }
 174        # Check if we have seen any ids listed as parents that haven't
 175        # appeared in the list
 176        foreach vid [array names idpending "$view,*"] {
 177            # should only get here if git log is buggy
 178            set id [lindex [split $vid ","] 1]
 179            set commitrow($vid) $commitidx($view)
 180            incr commitidx($view)
 181            if {$view == $curview} {
 182                lappend parentlist {}
 183                lappend displayorder $id
 184                lappend commitlisted 0
 185            } else {
 186                lappend vparentlist($view) {}
 187                lappend vdisporder($view) $id
 188                lappend vcmitlisted($view) 0
 189            }
 190        }
 191        set viewcomplete($view) 1
 192        global viewname progresscoords
 193        unset commfd($view)
 194        notbusy $view
 195        set progresscoords {0 0}
 196        adjustprogress
 197        # set it blocking so we wait for the process to terminate
 198        fconfigure $fd -blocking 1
 199        if {[catch {close $fd} err]} {
 200            set fv {}
 201            if {$view != $curview} {
 202                set fv " for the \"$viewname($view)\" view"
 203            }
 204            if {[string range $err 0 4] == "usage"} {
 205                set err "Gitk: error reading commits$fv:\
 206                        bad arguments to git rev-list."
 207                if {$viewname($view) eq "Command line"} {
 208                    append err \
 209                        "  (Note: arguments to gitk are passed to git rev-list\
 210                         to allow selection of commits to be displayed.)"
 211                }
 212            } else {
 213                set err "Error reading commits$fv: $err"
 214            }
 215            error_popup $err
 216        }
 217        if {$view == $curview} {
 218            run chewcommits $view
 219        }
 220        return 0
 221    }
 222    set start 0
 223    set gotsome 0
 224    while 1 {
 225        set i [string first "\0" $stuff $start]
 226        if {$i < 0} {
 227            append leftover($view) [string range $stuff $start end]
 228            break
 229        }
 230        if {$start == 0} {
 231            set cmit $leftover($view)
 232            append cmit [string range $stuff 0 [expr {$i - 1}]]
 233            set leftover($view) {}
 234        } else {
 235            set cmit [string range $stuff $start [expr {$i - 1}]]
 236        }
 237        set start [expr {$i + 1}]
 238        set j [string first "\n" $cmit]
 239        set ok 0
 240        set listed 1
 241        if {$j >= 0 && [string match "commit *" $cmit]} {
 242            set ids [string range $cmit 7 [expr {$j - 1}]]
 243            if {[string match {[-<>]*} $ids]} {
 244                switch -- [string index $ids 0] {
 245                    "-" {set listed 0}
 246                    "<" {set listed 2}
 247                    ">" {set listed 3}
 248                }
 249                set ids [string range $ids 1 end]
 250            }
 251            set ok 1
 252            foreach id $ids {
 253                if {[string length $id] != 40} {
 254                    set ok 0
 255                    break
 256                }
 257            }
 258        }
 259        if {!$ok} {
 260            set shortcmit $cmit
 261            if {[string length $shortcmit] > 80} {
 262                set shortcmit "[string range $shortcmit 0 80]..."
 263            }
 264            error_popup "Can't parse git log output: {$shortcmit}"
 265            exit 1
 266        }
 267        set id [lindex $ids 0]
 268        if {![info exists ordertok($view,$id)]} {
 269            set otok "o[strrep $vnextroot($view)]"
 270            incr vnextroot($view)
 271            set ordertok($view,$id) $otok
 272        } else {
 273            set otok $ordertok($view,$id)
 274            unset idpending($view,$id)
 275        }
 276        if {$listed} {
 277            set olds [lrange $ids 1 end]
 278            if {[llength $olds] == 1} {
 279                set p [lindex $olds 0]
 280                lappend children($view,$p) $id
 281                if {![info exists ordertok($view,$p)]} {
 282                    set ordertok($view,$p) $ordertok($view,$id)
 283                    set idpending($view,$p) 1
 284                }
 285            } else {
 286                set i 0
 287                foreach p $olds {
 288                    if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
 289                        lappend children($view,$p) $id
 290                    }
 291                    if {![info exists ordertok($view,$p)]} {
 292                        set ordertok($view,$p) "$otok[strrep $i]]"
 293                        set idpending($view,$p) 1
 294                    }
 295                    incr i
 296                }
 297            }
 298        } else {
 299            set olds {}
 300        }
 301        if {![info exists children($view,$id)]} {
 302            set children($view,$id) {}
 303        }
 304        set commitdata($id) [string range $cmit [expr {$j + 1}] end]
 305        set commitrow($view,$id) $commitidx($view)
 306        incr commitidx($view)
 307        if {$view == $curview} {
 308            lappend parentlist $olds
 309            lappend displayorder $id
 310            lappend commitlisted $listed
 311        } else {
 312            lappend vparentlist($view) $olds
 313            lappend vdisporder($view) $id
 314            lappend vcmitlisted($view) $listed
 315        }
 316        if {[info exists commitinterest($id)]} {
 317            foreach script $commitinterest($id) {
 318                eval [string map [list "%I" $id] $script]
 319            }
 320            unset commitinterest($id)
 321        }
 322        set gotsome 1
 323    }
 324    if {$gotsome} {
 325        run chewcommits $view
 326        if {$view == $curview} {
 327            # update progress bar
 328            global progressdirn progresscoords proglastnc
 329            set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
 330            set proglastnc $commitidx($view)
 331            set l [lindex $progresscoords 0]
 332            set r [lindex $progresscoords 1]
 333            if {$progressdirn} {
 334                set r [expr {$r + $inc}]
 335                if {$r >= 1.0} {
 336                    set r 1.0
 337                    set progressdirn 0
 338                }
 339                if {$r > 0.2} {
 340                    set l [expr {$r - 0.2}]
 341                }
 342            } else {
 343                set l [expr {$l - $inc}]
 344                if {$l <= 0.0} {
 345                    set l 0.0
 346                    set progressdirn 1
 347                }
 348                set r [expr {$l + 0.2}]
 349            }
 350            set progresscoords [list $l $r]
 351            adjustprogress
 352        }
 353    }
 354    return 2
 355}
 356
 357proc chewcommits {view} {
 358    global curview hlview viewcomplete
 359    global selectedline pending_select
 360
 361    if {$view == $curview} {
 362        layoutmore
 363        if {$viewcomplete($view)} {
 364            global displayorder commitidx phase
 365            global numcommits startmsecs
 366
 367            if {[info exists pending_select]} {
 368                set row [first_real_row]
 369                selectline $row 1
 370            }
 371            if {$commitidx($curview) > 0} {
 372                #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
 373                #puts "overall $ms ms for $numcommits commits"
 374            } else {
 375                show_status "No commits selected"
 376            }
 377            notbusy layout
 378            set phase {}
 379        }
 380    }
 381    if {[info exists hlview] && $view == $hlview} {
 382        vhighlightmore
 383    }
 384    return 0
 385}
 386
 387proc readcommit {id} {
 388    if {[catch {set contents [exec git cat-file commit $id]}]} return
 389    parsecommit $id $contents 0
 390}
 391
 392proc updatecommits {} {
 393    global viewdata curview phase displayorder ordertok idpending
 394    global children commitrow selectedline thickerline showneartags
 395
 396    if {$phase ne {}} {
 397        stop_rev_list
 398        set phase {}
 399    }
 400    set n $curview
 401    foreach id $displayorder {
 402        catch {unset children($n,$id)}
 403        catch {unset commitrow($n,$id)}
 404        catch {unset ordertok($n,$id)}
 405    }
 406    foreach vid [array names idpending "$n,*"] {
 407        unset idpending($vid)
 408    }
 409    set curview -1
 410    catch {unset selectedline}
 411    catch {unset thickerline}
 412    catch {unset viewdata($n)}
 413    readrefs
 414    changedrefs
 415    if {$showneartags} {
 416        getallcommits
 417    }
 418    showview $n
 419}
 420
 421proc parsecommit {id contents listed} {
 422    global commitinfo cdate
 423
 424    set inhdr 1
 425    set comment {}
 426    set headline {}
 427    set auname {}
 428    set audate {}
 429    set comname {}
 430    set comdate {}
 431    set hdrend [string first "\n\n" $contents]
 432    if {$hdrend < 0} {
 433        # should never happen...
 434        set hdrend [string length $contents]
 435    }
 436    set header [string range $contents 0 [expr {$hdrend - 1}]]
 437    set comment [string range $contents [expr {$hdrend + 2}] end]
 438    foreach line [split $header "\n"] {
 439        set tag [lindex $line 0]
 440        if {$tag == "author"} {
 441            set audate [lindex $line end-1]
 442            set auname [lrange $line 1 end-2]
 443        } elseif {$tag == "committer"} {
 444            set comdate [lindex $line end-1]
 445            set comname [lrange $line 1 end-2]
 446        }
 447    }
 448    set headline {}
 449    # take the first non-blank line of the comment as the headline
 450    set headline [string trimleft $comment]
 451    set i [string first "\n" $headline]
 452    if {$i >= 0} {
 453        set headline [string range $headline 0 $i]
 454    }
 455    set headline [string trimright $headline]
 456    set i [string first "\r" $headline]
 457    if {$i >= 0} {
 458        set headline [string trimright [string range $headline 0 $i]]
 459    }
 460    if {!$listed} {
 461        # git rev-list indents the comment by 4 spaces;
 462        # if we got this via git cat-file, add the indentation
 463        set newcomment {}
 464        foreach line [split $comment "\n"] {
 465            append newcomment "    "
 466            append newcomment $line
 467            append newcomment "\n"
 468        }
 469        set comment $newcomment
 470    }
 471    if {$comdate != {}} {
 472        set cdate($id) $comdate
 473    }
 474    set commitinfo($id) [list $headline $auname $audate \
 475                             $comname $comdate $comment]
 476}
 477
 478proc getcommit {id} {
 479    global commitdata commitinfo
 480
 481    if {[info exists commitdata($id)]} {
 482        parsecommit $id $commitdata($id) 1
 483    } else {
 484        readcommit $id
 485        if {![info exists commitinfo($id)]} {
 486            set commitinfo($id) {"No commit information available"}
 487        }
 488    }
 489    return 1
 490}
 491
 492proc readrefs {} {
 493    global tagids idtags headids idheads tagobjid
 494    global otherrefids idotherrefs mainhead mainheadid
 495
 496    foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
 497        catch {unset $v}
 498    }
 499    set refd [open [list | git show-ref -d] r]
 500    while {[gets $refd line] >= 0} {
 501        if {[string index $line 40] ne " "} continue
 502        set id [string range $line 0 39]
 503        set ref [string range $line 41 end]
 504        if {![string match "refs/*" $ref]} continue
 505        set name [string range $ref 5 end]
 506        if {[string match "remotes/*" $name]} {
 507            if {![string match "*/HEAD" $name]} {
 508                set headids($name) $id
 509                lappend idheads($id) $name
 510            }
 511        } elseif {[string match "heads/*" $name]} {
 512            set name [string range $name 6 end]
 513            set headids($name) $id
 514            lappend idheads($id) $name
 515        } elseif {[string match "tags/*" $name]} {
 516            # this lets refs/tags/foo^{} overwrite refs/tags/foo,
 517            # which is what we want since the former is the commit ID
 518            set name [string range $name 5 end]
 519            if {[string match "*^{}" $name]} {
 520                set name [string range $name 0 end-3]
 521            } else {
 522                set tagobjid($name) $id
 523            }
 524            set tagids($name) $id
 525            lappend idtags($id) $name
 526        } else {
 527            set otherrefids($name) $id
 528            lappend idotherrefs($id) $name
 529        }
 530    }
 531    catch {close $refd}
 532    set mainhead {}
 533    set mainheadid {}
 534    catch {
 535        set thehead [exec git symbolic-ref HEAD]
 536        if {[string match "refs/heads/*" $thehead]} {
 537            set mainhead [string range $thehead 11 end]
 538            if {[info exists headids($mainhead)]} {
 539                set mainheadid $headids($mainhead)
 540            }
 541        }
 542    }
 543}
 544
 545# skip over fake commits
 546proc first_real_row {} {
 547    global nullid nullid2 displayorder numcommits
 548
 549    for {set row 0} {$row < $numcommits} {incr row} {
 550        set id [lindex $displayorder $row]
 551        if {$id ne $nullid && $id ne $nullid2} {
 552            break
 553        }
 554    }
 555    return $row
 556}
 557
 558# update things for a head moved to a child of its previous location
 559proc movehead {id name} {
 560    global headids idheads
 561
 562    removehead $headids($name) $name
 563    set headids($name) $id
 564    lappend idheads($id) $name
 565}
 566
 567# update things when a head has been removed
 568proc removehead {id name} {
 569    global headids idheads
 570
 571    if {$idheads($id) eq $name} {
 572        unset idheads($id)
 573    } else {
 574        set i [lsearch -exact $idheads($id) $name]
 575        if {$i >= 0} {
 576            set idheads($id) [lreplace $idheads($id) $i $i]
 577        }
 578    }
 579    unset headids($name)
 580}
 581
 582proc show_error {w top msg} {
 583    message $w.m -text $msg -justify center -aspect 400
 584    pack $w.m -side top -fill x -padx 20 -pady 20
 585    button $w.ok -text OK -command "destroy $top"
 586    pack $w.ok -side bottom -fill x
 587    bind $top <Visibility> "grab $top; focus $top"
 588    bind $top <Key-Return> "destroy $top"
 589    tkwait window $top
 590}
 591
 592proc error_popup msg {
 593    set w .error
 594    toplevel $w
 595    wm transient $w .
 596    show_error $w $w $msg
 597}
 598
 599proc confirm_popup msg {
 600    global confirm_ok
 601    set confirm_ok 0
 602    set w .confirm
 603    toplevel $w
 604    wm transient $w .
 605    message $w.m -text $msg -justify center -aspect 400
 606    pack $w.m -side top -fill x -padx 20 -pady 20
 607    button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
 608    pack $w.ok -side left -fill x
 609    button $w.cancel -text Cancel -command "destroy $w"
 610    pack $w.cancel -side right -fill x
 611    bind $w <Visibility> "grab $w; focus $w"
 612    tkwait window $w
 613    return $confirm_ok
 614}
 615
 616proc makewindow {} {
 617    global canv canv2 canv3 linespc charspc ctext cflist
 618    global tabstop
 619    global findtype findtypemenu findloc findstring fstring geometry
 620    global entries sha1entry sha1string sha1but
 621    global diffcontextstring diffcontext
 622    global maincursor textcursor curtextcursor
 623    global rowctxmenu fakerowmenu mergemax wrapcomment
 624    global highlight_files gdttype
 625    global searchstring sstring
 626    global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
 627    global headctxmenu progresscanv progressitem progresscoords statusw
 628    global fprogitem fprogcoord lastprogupdate progupdatepending
 629    global have_tk85
 630
 631    menu .bar
 632    .bar add cascade -label "File" -menu .bar.file
 633    .bar configure -font uifont
 634    menu .bar.file
 635    .bar.file add command -label "Update" -command updatecommits
 636    .bar.file add command -label "Reread references" -command rereadrefs
 637    .bar.file add command -label "List references" -command showrefs
 638    .bar.file add command -label "Quit" -command doquit
 639    .bar.file configure -font uifont
 640    menu .bar.edit
 641    .bar add cascade -label "Edit" -menu .bar.edit
 642    .bar.edit add command -label "Preferences" -command doprefs
 643    .bar.edit configure -font uifont
 644
 645    menu .bar.view -font uifont
 646    .bar add cascade -label "View" -menu .bar.view
 647    .bar.view add command -label "New view..." -command {newview 0}
 648    .bar.view add command -label "Edit view..." -command editview \
 649        -state disabled
 650    .bar.view add command -label "Delete view" -command delview -state disabled
 651    .bar.view add separator
 652    .bar.view add radiobutton -label "All files" -command {showview 0} \
 653        -variable selectedview -value 0
 654
 655    menu .bar.help
 656    .bar add cascade -label "Help" -menu .bar.help
 657    .bar.help add command -label "About gitk" -command about
 658    .bar.help add command -label "Key bindings" -command keys
 659    .bar.help configure -font uifont
 660    . configure -menu .bar
 661
 662    # the gui has upper and lower half, parts of a paned window.
 663    panedwindow .ctop -orient vertical
 664
 665    # possibly use assumed geometry
 666    if {![info exists geometry(pwsash0)]} {
 667        set geometry(topheight) [expr {15 * $linespc}]
 668        set geometry(topwidth) [expr {80 * $charspc}]
 669        set geometry(botheight) [expr {15 * $linespc}]
 670        set geometry(botwidth) [expr {50 * $charspc}]
 671        set geometry(pwsash0) "[expr {40 * $charspc}] 2"
 672        set geometry(pwsash1) "[expr {60 * $charspc}] 2"
 673    }
 674
 675    # the upper half will have a paned window, a scroll bar to the right, and some stuff below
 676    frame .tf -height $geometry(topheight) -width $geometry(topwidth)
 677    frame .tf.histframe
 678    panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
 679
 680    # create three canvases
 681    set cscroll .tf.histframe.csb
 682    set canv .tf.histframe.pwclist.canv
 683    canvas $canv \
 684        -selectbackground $selectbgcolor \
 685        -background $bgcolor -bd 0 \
 686        -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
 687    .tf.histframe.pwclist add $canv
 688    set canv2 .tf.histframe.pwclist.canv2
 689    canvas $canv2 \
 690        -selectbackground $selectbgcolor \
 691        -background $bgcolor -bd 0 -yscrollincr $linespc
 692    .tf.histframe.pwclist add $canv2
 693    set canv3 .tf.histframe.pwclist.canv3
 694    canvas $canv3 \
 695        -selectbackground $selectbgcolor \
 696        -background $bgcolor -bd 0 -yscrollincr $linespc
 697    .tf.histframe.pwclist add $canv3
 698    eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
 699    eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
 700
 701    # a scroll bar to rule them
 702    scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
 703    pack $cscroll -side right -fill y
 704    bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
 705    lappend bglist $canv $canv2 $canv3
 706    pack .tf.histframe.pwclist -fill both -expand 1 -side left
 707
 708    # we have two button bars at bottom of top frame. Bar 1
 709    frame .tf.bar
 710    frame .tf.lbar -height 15
 711
 712    set sha1entry .tf.bar.sha1
 713    set entries $sha1entry
 714    set sha1but .tf.bar.sha1label
 715    button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
 716        -command gotocommit -width 8 -font uifont
 717    $sha1but conf -disabledforeground [$sha1but cget -foreground]
 718    pack .tf.bar.sha1label -side left
 719    entry $sha1entry -width 40 -font textfont -textvariable sha1string
 720    trace add variable sha1string write sha1change
 721    pack $sha1entry -side left -pady 2
 722
 723    image create bitmap bm-left -data {
 724        #define left_width 16
 725        #define left_height 16
 726        static unsigned char left_bits[] = {
 727        0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
 728        0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
 729        0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
 730    }
 731    image create bitmap bm-right -data {
 732        #define right_width 16
 733        #define right_height 16
 734        static unsigned char right_bits[] = {
 735        0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
 736        0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
 737        0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
 738    }
 739    button .tf.bar.leftbut -image bm-left -command goback \
 740        -state disabled -width 26
 741    pack .tf.bar.leftbut -side left -fill y
 742    button .tf.bar.rightbut -image bm-right -command goforw \
 743        -state disabled -width 26
 744    pack .tf.bar.rightbut -side left -fill y
 745
 746    # Status label and progress bar
 747    set statusw .tf.bar.status
 748    label $statusw -width 15 -relief sunken -font uifont
 749    pack $statusw -side left -padx 5
 750    set h [expr {[font metrics uifont -linespace] + 2}]
 751    set progresscanv .tf.bar.progress
 752    canvas $progresscanv -relief sunken -height $h -borderwidth 2
 753    set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
 754    set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
 755    pack $progresscanv -side right -expand 1 -fill x
 756    set progresscoords {0 0}
 757    set fprogcoord 0
 758    bind $progresscanv <Configure> adjustprogress
 759    set lastprogupdate [clock clicks -milliseconds]
 760    set progupdatepending 0
 761
 762    # build up the bottom bar of upper window
 763    label .tf.lbar.flabel -text "Find " -font uifont
 764    button .tf.lbar.fnext -text "next" -command dofind -font uifont
 765    button .tf.lbar.fprev -text "prev" -command {dofind 1} -font uifont
 766    label .tf.lbar.flab2 -text " commit " -font uifont
 767    pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
 768        -side left -fill y
 769    set gdttype "containing:"
 770    set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
 771                "containing:" \
 772                "touching paths:" \
 773                "adding/removing string:"]
 774    trace add variable gdttype write gdttype_change
 775    $gm conf -font uifont
 776    .tf.lbar.gdttype conf -font uifont
 777    pack .tf.lbar.gdttype -side left -fill y
 778
 779    set findstring {}
 780    set fstring .tf.lbar.findstring
 781    lappend entries $fstring
 782    entry $fstring -width 30 -font textfont -textvariable findstring
 783    trace add variable findstring write find_change
 784    set findtype Exact
 785    set findtypemenu [tk_optionMenu .tf.lbar.findtype \
 786                      findtype Exact IgnCase Regexp]
 787    trace add variable findtype write findcom_change
 788    .tf.lbar.findtype configure -font uifont
 789    .tf.lbar.findtype.menu configure -font uifont
 790    set findloc "All fields"
 791    tk_optionMenu .tf.lbar.findloc findloc "All fields" Headline \
 792        Comments Author Committer
 793    trace add variable findloc write find_change
 794    .tf.lbar.findloc configure -font uifont
 795    .tf.lbar.findloc.menu configure -font uifont
 796    pack .tf.lbar.findloc -side right
 797    pack .tf.lbar.findtype -side right
 798    pack $fstring -side left -expand 1 -fill x
 799
 800    # Finish putting the upper half of the viewer together
 801    pack .tf.lbar -in .tf -side bottom -fill x
 802    pack .tf.bar -in .tf -side bottom -fill x
 803    pack .tf.histframe -fill both -side top -expand 1
 804    .ctop add .tf
 805    .ctop paneconfigure .tf -height $geometry(topheight)
 806    .ctop paneconfigure .tf -width $geometry(topwidth)
 807
 808    # now build up the bottom
 809    panedwindow .pwbottom -orient horizontal
 810
 811    # lower left, a text box over search bar, scroll bar to the right
 812    # if we know window height, then that will set the lower text height, otherwise
 813    # we set lower text height which will drive window height
 814    if {[info exists geometry(main)]} {
 815        frame .bleft -width $geometry(botwidth)
 816    } else {
 817        frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
 818    }
 819    frame .bleft.top
 820    frame .bleft.mid
 821
 822    button .bleft.top.search -text "Search" -command dosearch \
 823        -font uifont
 824    pack .bleft.top.search -side left -padx 5
 825    set sstring .bleft.top.sstring
 826    entry $sstring -width 20 -font textfont -textvariable searchstring
 827    lappend entries $sstring
 828    trace add variable searchstring write incrsearch
 829    pack $sstring -side left -expand 1 -fill x
 830    radiobutton .bleft.mid.diff -text "Diff" \
 831        -command changediffdisp -variable diffelide -value {0 0}
 832    radiobutton .bleft.mid.old -text "Old version" \
 833        -command changediffdisp -variable diffelide -value {0 1}
 834    radiobutton .bleft.mid.new -text "New version" \
 835        -command changediffdisp -variable diffelide -value {1 0}
 836    label .bleft.mid.labeldiffcontext -text "      Lines of context: " \
 837        -font uifont
 838    pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
 839    spinbox .bleft.mid.diffcontext -width 5 -font textfont \
 840        -from 1 -increment 1 -to 10000000 \
 841        -validate all -validatecommand "diffcontextvalidate %P" \
 842        -textvariable diffcontextstring
 843    .bleft.mid.diffcontext set $diffcontext
 844    trace add variable diffcontextstring write diffcontextchange
 845    lappend entries .bleft.mid.diffcontext
 846    pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
 847    set ctext .bleft.ctext
 848    text $ctext -background $bgcolor -foreground $fgcolor \
 849        -state disabled -font textfont \
 850        -yscrollcommand scrolltext -wrap none
 851    if {$have_tk85} {
 852        $ctext conf -tabstyle wordprocessor
 853    }
 854    scrollbar .bleft.sb -command "$ctext yview"
 855    pack .bleft.top -side top -fill x
 856    pack .bleft.mid -side top -fill x
 857    pack .bleft.sb -side right -fill y
 858    pack $ctext -side left -fill both -expand 1
 859    lappend bglist $ctext
 860    lappend fglist $ctext
 861
 862    $ctext tag conf comment -wrap $wrapcomment
 863    $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
 864    $ctext tag conf hunksep -fore [lindex $diffcolors 2]
 865    $ctext tag conf d0 -fore [lindex $diffcolors 0]
 866    $ctext tag conf d1 -fore [lindex $diffcolors 1]
 867    $ctext tag conf m0 -fore red
 868    $ctext tag conf m1 -fore blue
 869    $ctext tag conf m2 -fore green
 870    $ctext tag conf m3 -fore purple
 871    $ctext tag conf m4 -fore brown
 872    $ctext tag conf m5 -fore "#009090"
 873    $ctext tag conf m6 -fore magenta
 874    $ctext tag conf m7 -fore "#808000"
 875    $ctext tag conf m8 -fore "#009000"
 876    $ctext tag conf m9 -fore "#ff0080"
 877    $ctext tag conf m10 -fore cyan
 878    $ctext tag conf m11 -fore "#b07070"
 879    $ctext tag conf m12 -fore "#70b0f0"
 880    $ctext tag conf m13 -fore "#70f0b0"
 881    $ctext tag conf m14 -fore "#f0b070"
 882    $ctext tag conf m15 -fore "#ff70b0"
 883    $ctext tag conf mmax -fore darkgrey
 884    set mergemax 16
 885    $ctext tag conf mresult -font textfontbold
 886    $ctext tag conf msep -font textfontbold
 887    $ctext tag conf found -back yellow
 888
 889    .pwbottom add .bleft
 890    .pwbottom paneconfigure .bleft -width $geometry(botwidth)
 891
 892    # lower right
 893    frame .bright
 894    frame .bright.mode
 895    radiobutton .bright.mode.patch -text "Patch" \
 896        -command reselectline -variable cmitmode -value "patch"
 897    .bright.mode.patch configure -font uifont
 898    radiobutton .bright.mode.tree -text "Tree" \
 899        -command reselectline -variable cmitmode -value "tree"
 900    .bright.mode.tree configure -font uifont
 901    grid .bright.mode.patch .bright.mode.tree -sticky ew
 902    pack .bright.mode -side top -fill x
 903    set cflist .bright.cfiles
 904    set indent [font measure mainfont "nn"]
 905    text $cflist \
 906        -selectbackground $selectbgcolor \
 907        -background $bgcolor -foreground $fgcolor \
 908        -font mainfont \
 909        -tabs [list $indent [expr {2 * $indent}]] \
 910        -yscrollcommand ".bright.sb set" \
 911        -cursor [. cget -cursor] \
 912        -spacing1 1 -spacing3 1
 913    lappend bglist $cflist
 914    lappend fglist $cflist
 915    scrollbar .bright.sb -command "$cflist yview"
 916    pack .bright.sb -side right -fill y
 917    pack $cflist -side left -fill both -expand 1
 918    $cflist tag configure highlight \
 919        -background [$cflist cget -selectbackground]
 920    $cflist tag configure bold -font mainfontbold
 921
 922    .pwbottom add .bright
 923    .ctop add .pwbottom
 924
 925    # restore window position if known
 926    if {[info exists geometry(main)]} {
 927        wm geometry . "$geometry(main)"
 928    }
 929
 930    if {[tk windowingsystem] eq {aqua}} {
 931        set M1B M1
 932    } else {
 933        set M1B Control
 934    }
 935
 936    bind .pwbottom <Configure> {resizecdetpanes %W %w}
 937    pack .ctop -fill both -expand 1
 938    bindall <1> {selcanvline %W %x %y}
 939    #bindall <B1-Motion> {selcanvline %W %x %y}
 940    if {[tk windowingsystem] == "win32"} {
 941        bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
 942        bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
 943    } else {
 944        bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
 945        bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
 946    }
 947    bindall <2> "canvscan mark %W %x %y"
 948    bindall <B2-Motion> "canvscan dragto %W %x %y"
 949    bindkey <Home> selfirstline
 950    bindkey <End> sellastline
 951    bind . <Key-Up> "selnextline -1"
 952    bind . <Key-Down> "selnextline 1"
 953    bindkey <Key-Right> "goforw"
 954    bindkey <Key-Left> "goback"
 955    bind . <Key-Prior> "selnextpage -1"
 956    bind . <Key-Next> "selnextpage 1"
 957    bind . <$M1B-Home> "allcanvs yview moveto 0.0"
 958    bind . <$M1B-End> "allcanvs yview moveto 1.0"
 959    bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
 960    bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
 961    bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
 962    bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
 963    bindkey <Key-Delete> "$ctext yview scroll -1 pages"
 964    bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
 965    bindkey <Key-space> "$ctext yview scroll 1 pages"
 966    bindkey p "selnextline -1"
 967    bindkey n "selnextline 1"
 968    bindkey z "goback"
 969    bindkey x "goforw"
 970    bindkey i "selnextline -1"
 971    bindkey k "selnextline 1"
 972    bindkey j "goback"
 973    bindkey l "goforw"
 974    bindkey b "$ctext yview scroll -1 pages"
 975    bindkey d "$ctext yview scroll 18 units"
 976    bindkey u "$ctext yview scroll -18 units"
 977    bindkey / {findnext 1}
 978    bindkey <Key-Return> {findnext 0}
 979    bindkey ? findprev
 980    bindkey f nextfile
 981    bindkey <F5> updatecommits
 982    bind . <$M1B-q> doquit
 983    bind . <$M1B-f> dofind
 984    bind . <$M1B-g> {findnext 0}
 985    bind . <$M1B-r> dosearchback
 986    bind . <$M1B-s> dosearch
 987    bind . <$M1B-equal> {incrfont 1}
 988    bind . <$M1B-KP_Add> {incrfont 1}
 989    bind . <$M1B-minus> {incrfont -1}
 990    bind . <$M1B-KP_Subtract> {incrfont -1}
 991    wm protocol . WM_DELETE_WINDOW doquit
 992    bind . <Button-1> "click %W"
 993    bind $fstring <Key-Return> dofind
 994    bind $sha1entry <Key-Return> gotocommit
 995    bind $sha1entry <<PasteSelection>> clearsha1
 996    bind $cflist <1> {sel_flist %W %x %y; break}
 997    bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
 998    bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
 999    bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1000
1001    set maincursor [. cget -cursor]
1002    set textcursor [$ctext cget -cursor]
1003    set curtextcursor $textcursor
1004
1005    set rowctxmenu .rowctxmenu
1006    menu $rowctxmenu -tearoff 0
1007    $rowctxmenu add command -label "Diff this -> selected" \
1008        -command {diffvssel 0}
1009    $rowctxmenu add command -label "Diff selected -> this" \
1010        -command {diffvssel 1}
1011    $rowctxmenu add command -label "Make patch" -command mkpatch
1012    $rowctxmenu add command -label "Create tag" -command mktag
1013    $rowctxmenu add command -label "Write commit to file" -command writecommit
1014    $rowctxmenu add command -label "Create new branch" -command mkbranch
1015    $rowctxmenu add command -label "Cherry-pick this commit" \
1016        -command cherrypick
1017    $rowctxmenu add command -label "Reset HEAD branch to here" \
1018        -command resethead
1019
1020    set fakerowmenu .fakerowmenu
1021    menu $fakerowmenu -tearoff 0
1022    $fakerowmenu add command -label "Diff this -> selected" \
1023        -command {diffvssel 0}
1024    $fakerowmenu add command -label "Diff selected -> this" \
1025        -command {diffvssel 1}
1026    $fakerowmenu add command -label "Make patch" -command mkpatch
1027#    $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1028#    $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1029#    $fakerowmenu add command -label "Revert local changes" -command revertlocal
1030
1031    set headctxmenu .headctxmenu
1032    menu $headctxmenu -tearoff 0
1033    $headctxmenu add command -label "Check out this branch" \
1034        -command cobranch
1035    $headctxmenu add command -label "Remove this branch" \
1036        -command rmbranch
1037
1038    global flist_menu
1039    set flist_menu .flistctxmenu
1040    menu $flist_menu -tearoff 0
1041    $flist_menu add command -label "Highlight this too" \
1042        -command {flist_hl 0}
1043    $flist_menu add command -label "Highlight this only" \
1044        -command {flist_hl 1}
1045}
1046
1047# Windows sends all mouse wheel events to the current focused window, not
1048# the one where the mouse hovers, so bind those events here and redirect
1049# to the correct window
1050proc windows_mousewheel_redirector {W X Y D} {
1051    global canv canv2 canv3
1052    set w [winfo containing -displayof $W $X $Y]
1053    if {$w ne ""} {
1054        set u [expr {$D < 0 ? 5 : -5}]
1055        if {$w == $canv || $w == $canv2 || $w == $canv3} {
1056            allcanvs yview scroll $u units
1057        } else {
1058            catch {
1059                $w yview scroll $u units
1060            }
1061        }
1062    }
1063}
1064
1065# mouse-2 makes all windows scan vertically, but only the one
1066# the cursor is in scans horizontally
1067proc canvscan {op w x y} {
1068    global canv canv2 canv3
1069    foreach c [list $canv $canv2 $canv3] {
1070        if {$c == $w} {
1071            $c scan $op $x $y
1072        } else {
1073            $c scan $op 0 $y
1074        }
1075    }
1076}
1077
1078proc scrollcanv {cscroll f0 f1} {
1079    $cscroll set $f0 $f1
1080    drawfrac $f0 $f1
1081    flushhighlights
1082}
1083
1084# when we make a key binding for the toplevel, make sure
1085# it doesn't get triggered when that key is pressed in the
1086# find string entry widget.
1087proc bindkey {ev script} {
1088    global entries
1089    bind . $ev $script
1090    set escript [bind Entry $ev]
1091    if {$escript == {}} {
1092        set escript [bind Entry <Key>]
1093    }
1094    foreach e $entries {
1095        bind $e $ev "$escript; break"
1096    }
1097}
1098
1099# set the focus back to the toplevel for any click outside
1100# the entry widgets
1101proc click {w} {
1102    global ctext entries
1103    foreach e [concat $entries $ctext] {
1104        if {$w == $e} return
1105    }
1106    focus .
1107}
1108
1109# Adjust the progress bar for a change in requested extent or canvas size
1110proc adjustprogress {} {
1111    global progresscanv progressitem progresscoords
1112    global fprogitem fprogcoord lastprogupdate progupdatepending
1113
1114    set w [expr {[winfo width $progresscanv] - 4}]
1115    set x0 [expr {$w * [lindex $progresscoords 0]}]
1116    set x1 [expr {$w * [lindex $progresscoords 1]}]
1117    set h [winfo height $progresscanv]
1118    $progresscanv coords $progressitem $x0 0 $x1 $h
1119    $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1120    set now [clock clicks -milliseconds]
1121    if {$now >= $lastprogupdate + 100} {
1122        set progupdatepending 0
1123        update
1124    } elseif {!$progupdatepending} {
1125        set progupdatepending 1
1126        after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1127    }
1128}
1129
1130proc doprogupdate {} {
1131    global lastprogupdate progupdatepending
1132
1133    if {$progupdatepending} {
1134        set progupdatepending 0
1135        set lastprogupdate [clock clicks -milliseconds]
1136        update
1137    }
1138}
1139
1140proc savestuff {w} {
1141    global canv canv2 canv3 mainfont textfont uifont tabstop
1142    global stuffsaved findmergefiles maxgraphpct
1143    global maxwidth showneartags showlocalchanges
1144    global viewname viewfiles viewargs viewperm nextviewnum
1145    global cmitmode wrapcomment datetimeformat
1146    global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1147
1148    if {$stuffsaved} return
1149    if {![winfo viewable .]} return
1150    catch {
1151        set f [open "~/.gitk-new" w]
1152        puts $f [list set mainfont $mainfont]
1153        puts $f [list set textfont $textfont]
1154        puts $f [list set uifont $uifont]
1155        puts $f [list set tabstop $tabstop]
1156        puts $f [list set findmergefiles $findmergefiles]
1157        puts $f [list set maxgraphpct $maxgraphpct]
1158        puts $f [list set maxwidth $maxwidth]
1159        puts $f [list set cmitmode $cmitmode]
1160        puts $f [list set wrapcomment $wrapcomment]
1161        puts $f [list set showneartags $showneartags]
1162        puts $f [list set showlocalchanges $showlocalchanges]
1163        puts $f [list set datetimeformat $datetimeformat]
1164        puts $f [list set bgcolor $bgcolor]
1165        puts $f [list set fgcolor $fgcolor]
1166        puts $f [list set colors $colors]
1167        puts $f [list set diffcolors $diffcolors]
1168        puts $f [list set diffcontext $diffcontext]
1169        puts $f [list set selectbgcolor $selectbgcolor]
1170
1171        puts $f "set geometry(main) [wm geometry .]"
1172        puts $f "set geometry(topwidth) [winfo width .tf]"
1173        puts $f "set geometry(topheight) [winfo height .tf]"
1174        puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1175        puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1176        puts $f "set geometry(botwidth) [winfo width .bleft]"
1177        puts $f "set geometry(botheight) [winfo height .bleft]"
1178
1179        puts -nonewline $f "set permviews {"
1180        for {set v 0} {$v < $nextviewnum} {incr v} {
1181            if {$viewperm($v)} {
1182                puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1183            }
1184        }
1185        puts $f "}"
1186        close $f
1187        file rename -force "~/.gitk-new" "~/.gitk"
1188    }
1189    set stuffsaved 1
1190}
1191
1192proc resizeclistpanes {win w} {
1193    global oldwidth
1194    if {[info exists oldwidth($win)]} {
1195        set s0 [$win sash coord 0]
1196        set s1 [$win sash coord 1]
1197        if {$w < 60} {
1198            set sash0 [expr {int($w/2 - 2)}]
1199            set sash1 [expr {int($w*5/6 - 2)}]
1200        } else {
1201            set factor [expr {1.0 * $w / $oldwidth($win)}]
1202            set sash0 [expr {int($factor * [lindex $s0 0])}]
1203            set sash1 [expr {int($factor * [lindex $s1 0])}]
1204            if {$sash0 < 30} {
1205                set sash0 30
1206            }
1207            if {$sash1 < $sash0 + 20} {
1208                set sash1 [expr {$sash0 + 20}]
1209            }
1210            if {$sash1 > $w - 10} {
1211                set sash1 [expr {$w - 10}]
1212                if {$sash0 > $sash1 - 20} {
1213                    set sash0 [expr {$sash1 - 20}]
1214                }
1215            }
1216        }
1217        $win sash place 0 $sash0 [lindex $s0 1]
1218        $win sash place 1 $sash1 [lindex $s1 1]
1219    }
1220    set oldwidth($win) $w
1221}
1222
1223proc resizecdetpanes {win w} {
1224    global oldwidth
1225    if {[info exists oldwidth($win)]} {
1226        set s0 [$win sash coord 0]
1227        if {$w < 60} {
1228            set sash0 [expr {int($w*3/4 - 2)}]
1229        } else {
1230            set factor [expr {1.0 * $w / $oldwidth($win)}]
1231            set sash0 [expr {int($factor * [lindex $s0 0])}]
1232            if {$sash0 < 45} {
1233                set sash0 45
1234            }
1235            if {$sash0 > $w - 15} {
1236                set sash0 [expr {$w - 15}]
1237            }
1238        }
1239        $win sash place 0 $sash0 [lindex $s0 1]
1240    }
1241    set oldwidth($win) $w
1242}
1243
1244proc allcanvs args {
1245    global canv canv2 canv3
1246    eval $canv $args
1247    eval $canv2 $args
1248    eval $canv3 $args
1249}
1250
1251proc bindall {event action} {
1252    global canv canv2 canv3
1253    bind $canv $event $action
1254    bind $canv2 $event $action
1255    bind $canv3 $event $action
1256}
1257
1258proc about {} {
1259    global uifont
1260    set w .about
1261    if {[winfo exists $w]} {
1262        raise $w
1263        return
1264    }
1265    toplevel $w
1266    wm title $w "About gitk"
1267    message $w.m -text {
1268Gitk - a commit viewer for git
1269
1270Copyright © 2005-2006 Paul Mackerras
1271
1272Use and redistribute under the terms of the GNU General Public License} \
1273            -justify center -aspect 400 -border 2 -bg white -relief groove
1274    pack $w.m -side top -fill x -padx 2 -pady 2
1275    $w.m configure -font uifont
1276    button $w.ok -text Close -command "destroy $w" -default active
1277    pack $w.ok -side bottom
1278    $w.ok configure -font uifont
1279    bind $w <Visibility> "focus $w.ok"
1280    bind $w <Key-Escape> "destroy $w"
1281    bind $w <Key-Return> "destroy $w"
1282}
1283
1284proc keys {} {
1285    global uifont
1286    set w .keys
1287    if {[winfo exists $w]} {
1288        raise $w
1289        return
1290    }
1291    if {[tk windowingsystem] eq {aqua}} {
1292        set M1T Cmd
1293    } else {
1294        set M1T Ctrl
1295    }
1296    toplevel $w
1297    wm title $w "Gitk key bindings"
1298    message $w.m -text "
1299Gitk key bindings:
1300
1301<$M1T-Q>                Quit
1302<Home>          Move to first commit
1303<End>           Move to last commit
1304<Up>, p, i      Move up one commit
1305<Down>, n, k    Move down one commit
1306<Left>, z, j    Go back in history list
1307<Right>, x, l   Go forward in history list
1308<PageUp>        Move up one page in commit list
1309<PageDown>      Move down one page in commit list
1310<$M1T-Home>     Scroll to top of commit list
1311<$M1T-End>      Scroll to bottom of commit list
1312<$M1T-Up>       Scroll commit list up one line
1313<$M1T-Down>     Scroll commit list down one line
1314<$M1T-PageUp>   Scroll commit list up one page
1315<$M1T-PageDown> Scroll commit list down one page
1316<Shift-Up>      Move to previous highlighted line
1317<Shift-Down>    Move to next highlighted line
1318<Delete>, b     Scroll diff view up one page
1319<Backspace>     Scroll diff view up one page
1320<Space>         Scroll diff view down one page
1321u               Scroll diff view up 18 lines
1322d               Scroll diff view down 18 lines
1323<$M1T-F>                Find
1324<$M1T-G>                Move to next find hit
1325<Return>        Move to next find hit
1326/               Move to next find hit, or redo find
1327?               Move to previous find hit
1328f               Scroll diff view to next file
1329<$M1T-S>                Search for next hit in diff view
1330<$M1T-R>                Search for previous hit in diff view
1331<$M1T-KP+>      Increase font size
1332<$M1T-plus>     Increase font size
1333<$M1T-KP->      Decrease font size
1334<$M1T-minus>    Decrease font size
1335<F5>            Update
1336" \
1337            -justify left -bg white -border 2 -relief groove
1338    pack $w.m -side top -fill both -padx 2 -pady 2
1339    $w.m configure -font uifont
1340    button $w.ok -text Close -command "destroy $w" -default active
1341    pack $w.ok -side bottom
1342    $w.ok configure -font uifont
1343    bind $w <Visibility> "focus $w.ok"
1344    bind $w <Key-Escape> "destroy $w"
1345    bind $w <Key-Return> "destroy $w"
1346}
1347
1348# Procedures for manipulating the file list window at the
1349# bottom right of the overall window.
1350
1351proc treeview {w l openlevs} {
1352    global treecontents treediropen treeheight treeparent treeindex
1353
1354    set ix 0
1355    set treeindex() 0
1356    set lev 0
1357    set prefix {}
1358    set prefixend -1
1359    set prefendstack {}
1360    set htstack {}
1361    set ht 0
1362    set treecontents() {}
1363    $w conf -state normal
1364    foreach f $l {
1365        while {[string range $f 0 $prefixend] ne $prefix} {
1366            if {$lev <= $openlevs} {
1367                $w mark set e:$treeindex($prefix) "end -1c"
1368                $w mark gravity e:$treeindex($prefix) left
1369            }
1370            set treeheight($prefix) $ht
1371            incr ht [lindex $htstack end]
1372            set htstack [lreplace $htstack end end]
1373            set prefixend [lindex $prefendstack end]
1374            set prefendstack [lreplace $prefendstack end end]
1375            set prefix [string range $prefix 0 $prefixend]
1376            incr lev -1
1377        }
1378        set tail [string range $f [expr {$prefixend+1}] end]
1379        while {[set slash [string first "/" $tail]] >= 0} {
1380            lappend htstack $ht
1381            set ht 0
1382            lappend prefendstack $prefixend
1383            incr prefixend [expr {$slash + 1}]
1384            set d [string range $tail 0 $slash]
1385            lappend treecontents($prefix) $d
1386            set oldprefix $prefix
1387            append prefix $d
1388            set treecontents($prefix) {}
1389            set treeindex($prefix) [incr ix]
1390            set treeparent($prefix) $oldprefix
1391            set tail [string range $tail [expr {$slash+1}] end]
1392            if {$lev <= $openlevs} {
1393                set ht 1
1394                set treediropen($prefix) [expr {$lev < $openlevs}]
1395                set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1396                $w mark set d:$ix "end -1c"
1397                $w mark gravity d:$ix left
1398                set str "\n"
1399                for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1400                $w insert end $str
1401                $w image create end -align center -image $bm -padx 1 \
1402                    -name a:$ix
1403                $w insert end $d [highlight_tag $prefix]
1404                $w mark set s:$ix "end -1c"
1405                $w mark gravity s:$ix left
1406            }
1407            incr lev
1408        }
1409        if {$tail ne {}} {
1410            if {$lev <= $openlevs} {
1411                incr ht
1412                set str "\n"
1413                for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1414                $w insert end $str
1415                $w insert end $tail [highlight_tag $f]
1416            }
1417            lappend treecontents($prefix) $tail
1418        }
1419    }
1420    while {$htstack ne {}} {
1421        set treeheight($prefix) $ht
1422        incr ht [lindex $htstack end]
1423        set htstack [lreplace $htstack end end]
1424        set prefixend [lindex $prefendstack end]
1425        set prefendstack [lreplace $prefendstack end end]
1426        set prefix [string range $prefix 0 $prefixend]
1427    }
1428    $w conf -state disabled
1429}
1430
1431proc linetoelt {l} {
1432    global treeheight treecontents
1433
1434    set y 2
1435    set prefix {}
1436    while {1} {
1437        foreach e $treecontents($prefix) {
1438            if {$y == $l} {
1439                return "$prefix$e"
1440            }
1441            set n 1
1442            if {[string index $e end] eq "/"} {
1443                set n $treeheight($prefix$e)
1444                if {$y + $n > $l} {
1445                    append prefix $e
1446                    incr y
1447                    break
1448                }
1449            }
1450            incr y $n
1451        }
1452    }
1453}
1454
1455proc highlight_tree {y prefix} {
1456    global treeheight treecontents cflist
1457
1458    foreach e $treecontents($prefix) {
1459        set path $prefix$e
1460        if {[highlight_tag $path] ne {}} {
1461            $cflist tag add bold $y.0 "$y.0 lineend"
1462        }
1463        incr y
1464        if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1465            set y [highlight_tree $y $path]
1466        }
1467    }
1468    return $y
1469}
1470
1471proc treeclosedir {w dir} {
1472    global treediropen treeheight treeparent treeindex
1473
1474    set ix $treeindex($dir)
1475    $w conf -state normal
1476    $w delete s:$ix e:$ix
1477    set treediropen($dir) 0
1478    $w image configure a:$ix -image tri-rt
1479    $w conf -state disabled
1480    set n [expr {1 - $treeheight($dir)}]
1481    while {$dir ne {}} {
1482        incr treeheight($dir) $n
1483        set dir $treeparent($dir)
1484    }
1485}
1486
1487proc treeopendir {w dir} {
1488    global treediropen treeheight treeparent treecontents treeindex
1489
1490    set ix $treeindex($dir)
1491    $w conf -state normal
1492    $w image configure a:$ix -image tri-dn
1493    $w mark set e:$ix s:$ix
1494    $w mark gravity e:$ix right
1495    set lev 0
1496    set str "\n"
1497    set n [llength $treecontents($dir)]
1498    for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1499        incr lev
1500        append str "\t"
1501        incr treeheight($x) $n
1502    }
1503    foreach e $treecontents($dir) {
1504        set de $dir$e
1505        if {[string index $e end] eq "/"} {
1506            set iy $treeindex($de)
1507            $w mark set d:$iy e:$ix
1508            $w mark gravity d:$iy left
1509            $w insert e:$ix $str
1510            set treediropen($de) 0
1511            $w image create e:$ix -align center -image tri-rt -padx 1 \
1512                -name a:$iy
1513            $w insert e:$ix $e [highlight_tag $de]
1514            $w mark set s:$iy e:$ix
1515            $w mark gravity s:$iy left
1516            set treeheight($de) 1
1517        } else {
1518            $w insert e:$ix $str
1519            $w insert e:$ix $e [highlight_tag $de]
1520        }
1521    }
1522    $w mark gravity e:$ix left
1523    $w conf -state disabled
1524    set treediropen($dir) 1
1525    set top [lindex [split [$w index @0,0] .] 0]
1526    set ht [$w cget -height]
1527    set l [lindex [split [$w index s:$ix] .] 0]
1528    if {$l < $top} {
1529        $w yview $l.0
1530    } elseif {$l + $n + 1 > $top + $ht} {
1531        set top [expr {$l + $n + 2 - $ht}]
1532        if {$l < $top} {
1533            set top $l
1534        }
1535        $w yview $top.0
1536    }
1537}
1538
1539proc treeclick {w x y} {
1540    global treediropen cmitmode ctext cflist cflist_top
1541
1542    if {$cmitmode ne "tree"} return
1543    if {![info exists cflist_top]} return
1544    set l [lindex [split [$w index "@$x,$y"] "."] 0]
1545    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1546    $cflist tag add highlight $l.0 "$l.0 lineend"
1547    set cflist_top $l
1548    if {$l == 1} {
1549        $ctext yview 1.0
1550        return
1551    }
1552    set e [linetoelt $l]
1553    if {[string index $e end] ne "/"} {
1554        showfile $e
1555    } elseif {$treediropen($e)} {
1556        treeclosedir $w $e
1557    } else {
1558        treeopendir $w $e
1559    }
1560}
1561
1562proc setfilelist {id} {
1563    global treefilelist cflist
1564
1565    treeview $cflist $treefilelist($id) 0
1566}
1567
1568image create bitmap tri-rt -background black -foreground blue -data {
1569    #define tri-rt_width 13
1570    #define tri-rt_height 13
1571    static unsigned char tri-rt_bits[] = {
1572       0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1573       0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1574       0x00, 0x00};
1575} -maskdata {
1576    #define tri-rt-mask_width 13
1577    #define tri-rt-mask_height 13
1578    static unsigned char tri-rt-mask_bits[] = {
1579       0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1580       0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1581       0x08, 0x00};
1582}
1583image create bitmap tri-dn -background black -foreground blue -data {
1584    #define tri-dn_width 13
1585    #define tri-dn_height 13
1586    static unsigned char tri-dn_bits[] = {
1587       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1588       0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1589       0x00, 0x00};
1590} -maskdata {
1591    #define tri-dn-mask_width 13
1592    #define tri-dn-mask_height 13
1593    static unsigned char tri-dn-mask_bits[] = {
1594       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1595       0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1596       0x00, 0x00};
1597}
1598
1599image create bitmap reficon-T -background black -foreground yellow -data {
1600    #define tagicon_width 13
1601    #define tagicon_height 9
1602    static unsigned char tagicon_bits[] = {
1603       0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1604       0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1605} -maskdata {
1606    #define tagicon-mask_width 13
1607    #define tagicon-mask_height 9
1608    static unsigned char tagicon-mask_bits[] = {
1609       0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1610       0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1611}
1612set rectdata {
1613    #define headicon_width 13
1614    #define headicon_height 9
1615    static unsigned char headicon_bits[] = {
1616       0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1617       0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1618}
1619set rectmask {
1620    #define headicon-mask_width 13
1621    #define headicon-mask_height 9
1622    static unsigned char headicon-mask_bits[] = {
1623       0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1624       0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1625}
1626image create bitmap reficon-H -background black -foreground green \
1627    -data $rectdata -maskdata $rectmask
1628image create bitmap reficon-o -background black -foreground "#ddddff" \
1629    -data $rectdata -maskdata $rectmask
1630
1631proc init_flist {first} {
1632    global cflist cflist_top selectedline difffilestart
1633
1634    $cflist conf -state normal
1635    $cflist delete 0.0 end
1636    if {$first ne {}} {
1637        $cflist insert end $first
1638        set cflist_top 1
1639        $cflist tag add highlight 1.0 "1.0 lineend"
1640    } else {
1641        catch {unset cflist_top}
1642    }
1643    $cflist conf -state disabled
1644    set difffilestart {}
1645}
1646
1647proc highlight_tag {f} {
1648    global highlight_paths
1649
1650    foreach p $highlight_paths {
1651        if {[string match $p $f]} {
1652            return "bold"
1653        }
1654    }
1655    return {}
1656}
1657
1658proc highlight_filelist {} {
1659    global cmitmode cflist
1660
1661    $cflist conf -state normal
1662    if {$cmitmode ne "tree"} {
1663        set end [lindex [split [$cflist index end] .] 0]
1664        for {set l 2} {$l < $end} {incr l} {
1665            set line [$cflist get $l.0 "$l.0 lineend"]
1666            if {[highlight_tag $line] ne {}} {
1667                $cflist tag add bold $l.0 "$l.0 lineend"
1668            }
1669        }
1670    } else {
1671        highlight_tree 2 {}
1672    }
1673    $cflist conf -state disabled
1674}
1675
1676proc unhighlight_filelist {} {
1677    global cflist
1678
1679    $cflist conf -state normal
1680    $cflist tag remove bold 1.0 end
1681    $cflist conf -state disabled
1682}
1683
1684proc add_flist {fl} {
1685    global cflist
1686
1687    $cflist conf -state normal
1688    foreach f $fl {
1689        $cflist insert end "\n"
1690        $cflist insert end $f [highlight_tag $f]
1691    }
1692    $cflist conf -state disabled
1693}
1694
1695proc sel_flist {w x y} {
1696    global ctext difffilestart cflist cflist_top cmitmode
1697
1698    if {$cmitmode eq "tree"} return
1699    if {![info exists cflist_top]} return
1700    set l [lindex [split [$w index "@$x,$y"] "."] 0]
1701    $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1702    $cflist tag add highlight $l.0 "$l.0 lineend"
1703    set cflist_top $l
1704    if {$l == 1} {
1705        $ctext yview 1.0
1706    } else {
1707        catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1708    }
1709}
1710
1711proc pop_flist_menu {w X Y x y} {
1712    global ctext cflist cmitmode flist_menu flist_menu_file
1713    global treediffs diffids
1714
1715    stopfinding
1716    set l [lindex [split [$w index "@$x,$y"] "."] 0]
1717    if {$l <= 1} return
1718    if {$cmitmode eq "tree"} {
1719        set e [linetoelt $l]
1720        if {[string index $e end] eq "/"} return
1721    } else {
1722        set e [lindex $treediffs($diffids) [expr {$l-2}]]
1723    }
1724    set flist_menu_file $e
1725    tk_popup $flist_menu $X $Y
1726}
1727
1728proc flist_hl {only} {
1729    global flist_menu_file findstring gdttype
1730
1731    set x [shellquote $flist_menu_file]
1732    if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
1733        set findstring $x
1734    } else {
1735        append findstring " " $x
1736    }
1737    set gdttype "touching paths:"
1738}
1739
1740# Functions for adding and removing shell-type quoting
1741
1742proc shellquote {str} {
1743    if {![string match "*\['\"\\ \t]*" $str]} {
1744        return $str
1745    }
1746    if {![string match "*\['\"\\]*" $str]} {
1747        return "\"$str\""
1748    }
1749    if {![string match "*'*" $str]} {
1750        return "'$str'"
1751    }
1752    return "\"[string map {\" \\\" \\ \\\\} $str]\""
1753}
1754
1755proc shellarglist {l} {
1756    set str {}
1757    foreach a $l {
1758        if {$str ne {}} {
1759            append str " "
1760        }
1761        append str [shellquote $a]
1762    }
1763    return $str
1764}
1765
1766proc shelldequote {str} {
1767    set ret {}
1768    set used -1
1769    while {1} {
1770        incr used
1771        if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1772            append ret [string range $str $used end]
1773            set used [string length $str]
1774            break
1775        }
1776        set first [lindex $first 0]
1777        set ch [string index $str $first]
1778        if {$first > $used} {
1779            append ret [string range $str $used [expr {$first - 1}]]
1780            set used $first
1781        }
1782        if {$ch eq " " || $ch eq "\t"} break
1783        incr used
1784        if {$ch eq "'"} {
1785            set first [string first "'" $str $used]
1786            if {$first < 0} {
1787                error "unmatched single-quote"
1788            }
1789            append ret [string range $str $used [expr {$first - 1}]]
1790            set used $first
1791            continue
1792        }
1793        if {$ch eq "\\"} {
1794            if {$used >= [string length $str]} {
1795                error "trailing backslash"
1796            }
1797            append ret [string index $str $used]
1798            continue
1799        }
1800        # here ch == "\""
1801        while {1} {
1802            if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1803                error "unmatched double-quote"
1804            }
1805            set first [lindex $first 0]
1806            set ch [string index $str $first]
1807            if {$first > $used} {
1808                append ret [string range $str $used [expr {$first - 1}]]
1809                set used $first
1810            }
1811            if {$ch eq "\""} break
1812            incr used
1813            append ret [string index $str $used]
1814            incr used
1815        }
1816    }
1817    return [list $used $ret]
1818}
1819
1820proc shellsplit {str} {
1821    set l {}
1822    while {1} {
1823        set str [string trimleft $str]
1824        if {$str eq {}} break
1825        set dq [shelldequote $str]
1826        set n [lindex $dq 0]
1827        set word [lindex $dq 1]
1828        set str [string range $str $n end]
1829        lappend l $word
1830    }
1831    return $l
1832}
1833
1834# Code to implement multiple views
1835
1836proc newview {ishighlight} {
1837    global nextviewnum newviewname newviewperm uifont newishighlight
1838    global newviewargs revtreeargs
1839
1840    set newishighlight $ishighlight
1841    set top .gitkview
1842    if {[winfo exists $top]} {
1843        raise $top
1844        return
1845    }
1846    set newviewname($nextviewnum) "View $nextviewnum"
1847    set newviewperm($nextviewnum) 0
1848    set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1849    vieweditor $top $nextviewnum "Gitk view definition"
1850}
1851
1852proc editview {} {
1853    global curview
1854    global viewname viewperm newviewname newviewperm
1855    global viewargs newviewargs
1856
1857    set top .gitkvedit-$curview
1858    if {[winfo exists $top]} {
1859        raise $top
1860        return
1861    }
1862    set newviewname($curview) $viewname($curview)
1863    set newviewperm($curview) $viewperm($curview)
1864    set newviewargs($curview) [shellarglist $viewargs($curview)]
1865    vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1866}
1867
1868proc vieweditor {top n title} {
1869    global newviewname newviewperm viewfiles
1870    global uifont
1871
1872    toplevel $top
1873    wm title $top $title
1874    label $top.nl -text "Name" -font uifont
1875    entry $top.name -width 20 -textvariable newviewname($n) -font uifont
1876    grid $top.nl $top.name -sticky w -pady 5
1877    checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1878        -font uifont
1879    grid $top.perm - -pady 5 -sticky w
1880    message $top.al -aspect 1000 -font uifont \
1881        -text "Commits to include (arguments to git rev-list):"
1882    grid $top.al - -sticky w -pady 5
1883    entry $top.args -width 50 -textvariable newviewargs($n) \
1884        -background white -font uifont
1885    grid $top.args - -sticky ew -padx 5
1886    message $top.l -aspect 1000 -font uifont \
1887        -text "Enter files and directories to include, one per line:"
1888    grid $top.l - -sticky w
1889    text $top.t -width 40 -height 10 -background white -font uifont
1890    if {[info exists viewfiles($n)]} {
1891        foreach f $viewfiles($n) {
1892            $top.t insert end $f
1893            $top.t insert end "\n"
1894        }
1895        $top.t delete {end - 1c} end
1896        $top.t mark set insert 0.0
1897    }
1898    grid $top.t - -sticky ew -padx 5
1899    frame $top.buts
1900    button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1901        -font uifont
1902    button $top.buts.can -text "Cancel" -command [list destroy $top] \
1903        -font uifont
1904    grid $top.buts.ok $top.buts.can
1905    grid columnconfigure $top.buts 0 -weight 1 -uniform a
1906    grid columnconfigure $top.buts 1 -weight 1 -uniform a
1907    grid $top.buts - -pady 10 -sticky ew
1908    focus $top.t
1909}
1910
1911proc doviewmenu {m first cmd op argv} {
1912    set nmenu [$m index end]
1913    for {set i $first} {$i <= $nmenu} {incr i} {
1914        if {[$m entrycget $i -command] eq $cmd} {
1915            eval $m $op $i $argv
1916            break
1917        }
1918    }
1919}
1920
1921proc allviewmenus {n op args} {
1922    # global viewhlmenu
1923
1924    doviewmenu .bar.view 5 [list showview $n] $op $args
1925    # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1926}
1927
1928proc newviewok {top n} {
1929    global nextviewnum newviewperm newviewname newishighlight
1930    global viewname viewfiles viewperm selectedview curview
1931    global viewargs newviewargs viewhlmenu
1932
1933    if {[catch {
1934        set newargs [shellsplit $newviewargs($n)]
1935    } err]} {
1936        error_popup "Error in commit selection arguments: $err"
1937        wm raise $top
1938        focus $top
1939        return
1940    }
1941    set files {}
1942    foreach f [split [$top.t get 0.0 end] "\n"] {
1943        set ft [string trim $f]
1944        if {$ft ne {}} {
1945            lappend files $ft
1946        }
1947    }
1948    if {![info exists viewfiles($n)]} {
1949        # creating a new view
1950        incr nextviewnum
1951        set viewname($n) $newviewname($n)
1952        set viewperm($n) $newviewperm($n)
1953        set viewfiles($n) $files
1954        set viewargs($n) $newargs
1955        addviewmenu $n
1956        if {!$newishighlight} {
1957            run showview $n
1958        } else {
1959            run addvhighlight $n
1960        }
1961    } else {
1962        # editing an existing view
1963        set viewperm($n) $newviewperm($n)
1964        if {$newviewname($n) ne $viewname($n)} {
1965            set viewname($n) $newviewname($n)
1966            doviewmenu .bar.view 5 [list showview $n] \
1967                entryconf [list -label $viewname($n)]
1968            # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1969                # entryconf [list -label $viewname($n) -value $viewname($n)]
1970        }
1971        if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1972            set viewfiles($n) $files
1973            set viewargs($n) $newargs
1974            if {$curview == $n} {
1975                run updatecommits
1976            }
1977        }
1978    }
1979    catch {destroy $top}
1980}
1981
1982proc delview {} {
1983    global curview viewdata viewperm hlview selectedhlview
1984
1985    if {$curview == 0} return
1986    if {[info exists hlview] && $hlview == $curview} {
1987        set selectedhlview None
1988        unset hlview
1989    }
1990    allviewmenus $curview delete
1991    set viewdata($curview) {}
1992    set viewperm($curview) 0
1993    showview 0
1994}
1995
1996proc addviewmenu {n} {
1997    global viewname viewhlmenu
1998
1999    .bar.view add radiobutton -label $viewname($n) \
2000        -command [list showview $n] -variable selectedview -value $n
2001    #$viewhlmenu add radiobutton -label $viewname($n) \
2002    #   -command [list addvhighlight $n] -variable selectedhlview
2003}
2004
2005proc flatten {var} {
2006    global $var
2007
2008    set ret {}
2009    foreach i [array names $var] {
2010        lappend ret $i [set $var\($i\)]
2011    }
2012    return $ret
2013}
2014
2015proc unflatten {var l} {
2016    global $var
2017
2018    catch {unset $var}
2019    foreach {i v} $l {
2020        set $var\($i\) $v
2021    }
2022}
2023
2024proc showview {n} {
2025    global curview viewdata viewfiles
2026    global displayorder parentlist rowidlist rowisopt rowfinal
2027    global colormap rowtextx commitrow nextcolor canvxmax
2028    global numcommits commitlisted
2029    global selectedline currentid canv canvy0
2030    global treediffs
2031    global pending_select phase
2032    global commitidx
2033    global commfd
2034    global selectedview selectfirst
2035    global vparentlist vdisporder vcmitlisted
2036    global hlview selectedhlview commitinterest
2037
2038    if {$n == $curview} return
2039    set selid {}
2040    if {[info exists selectedline]} {
2041        set selid $currentid
2042        set y [yc $selectedline]
2043        set ymax [lindex [$canv cget -scrollregion] 3]
2044        set span [$canv yview]
2045        set ytop [expr {[lindex $span 0] * $ymax}]
2046        set ybot [expr {[lindex $span 1] * $ymax}]
2047        if {$ytop < $y && $y < $ybot} {
2048            set yscreen [expr {$y - $ytop}]
2049        } else {
2050            set yscreen [expr {($ybot - $ytop) / 2}]
2051        }
2052    } elseif {[info exists pending_select]} {
2053        set selid $pending_select
2054        unset pending_select
2055    }
2056    unselectline
2057    normalline
2058    if {$curview >= 0} {
2059        set vparentlist($curview) $parentlist
2060        set vdisporder($curview) $displayorder
2061        set vcmitlisted($curview) $commitlisted
2062        if {$phase ne {} ||
2063            ![info exists viewdata($curview)] ||
2064            [lindex $viewdata($curview) 0] ne {}} {
2065            set viewdata($curview) \
2066                [list $phase $rowidlist $rowisopt $rowfinal]
2067        }
2068    }
2069    catch {unset treediffs}
2070    clear_display
2071    if {[info exists hlview] && $hlview == $n} {
2072        unset hlview
2073        set selectedhlview None
2074    }
2075    catch {unset commitinterest}
2076
2077    set curview $n
2078    set selectedview $n
2079    .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2080    .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2081
2082    run refill_reflist
2083    if {![info exists viewdata($n)]} {
2084        if {$selid ne {}} {
2085            set pending_select $selid
2086        }
2087        getcommits
2088        return
2089    }
2090
2091    set v $viewdata($n)
2092    set phase [lindex $v 0]
2093    set displayorder $vdisporder($n)
2094    set parentlist $vparentlist($n)
2095    set commitlisted $vcmitlisted($n)
2096    set rowidlist [lindex $v 1]
2097    set rowisopt [lindex $v 2]
2098    set rowfinal [lindex $v 3]
2099    set numcommits $commitidx($n)
2100
2101    catch {unset colormap}
2102    catch {unset rowtextx}
2103    set nextcolor 0
2104    set canvxmax [$canv cget -width]
2105    set curview $n
2106    set row 0
2107    setcanvscroll
2108    set yf 0
2109    set row {}
2110    set selectfirst 0
2111    if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2112        set row $commitrow($n,$selid)
2113        # try to get the selected row in the same position on the screen
2114        set ymax [lindex [$canv cget -scrollregion] 3]
2115        set ytop [expr {[yc $row] - $yscreen}]
2116        if {$ytop < 0} {
2117            set ytop 0
2118        }
2119        set yf [expr {$ytop * 1.0 / $ymax}]
2120    }
2121    allcanvs yview moveto $yf
2122    drawvisible
2123    if {$row ne {}} {
2124        selectline $row 0
2125    } elseif {$selid ne {}} {
2126        set pending_select $selid
2127    } else {
2128        set row [first_real_row]
2129        if {$row < $numcommits} {
2130            selectline $row 0
2131        } else {
2132            set selectfirst 1
2133        }
2134    }
2135    if {$phase ne {}} {
2136        if {$phase eq "getcommits"} {
2137            show_status "Reading commits..."
2138        }
2139        run chewcommits $n
2140    } elseif {$numcommits == 0} {
2141        show_status "No commits selected"
2142    }
2143}
2144
2145# Stuff relating to the highlighting facility
2146
2147proc ishighlighted {row} {
2148    global vhighlights fhighlights nhighlights rhighlights
2149
2150    if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2151        return $nhighlights($row)
2152    }
2153    if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2154        return $vhighlights($row)
2155    }
2156    if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2157        return $fhighlights($row)
2158    }
2159    if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2160        return $rhighlights($row)
2161    }
2162    return 0
2163}
2164
2165proc bolden {row font} {
2166    global canv linehtag selectedline boldrows
2167
2168    lappend boldrows $row
2169    $canv itemconf $linehtag($row) -font $font
2170    if {[info exists selectedline] && $row == $selectedline} {
2171        $canv delete secsel
2172        set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2173                   -outline {{}} -tags secsel \
2174                   -fill [$canv cget -selectbackground]]
2175        $canv lower $t
2176    }
2177}
2178
2179proc bolden_name {row font} {
2180    global canv2 linentag selectedline boldnamerows
2181
2182    lappend boldnamerows $row
2183    $canv2 itemconf $linentag($row) -font $font
2184    if {[info exists selectedline] && $row == $selectedline} {
2185        $canv2 delete secsel
2186        set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2187                   -outline {{}} -tags secsel \
2188                   -fill [$canv2 cget -selectbackground]]
2189        $canv2 lower $t
2190    }
2191}
2192
2193proc unbolden {} {
2194    global boldrows
2195
2196    set stillbold {}
2197    foreach row $boldrows {
2198        if {![ishighlighted $row]} {
2199            bolden $row mainfont
2200        } else {
2201            lappend stillbold $row
2202        }
2203    }
2204    set boldrows $stillbold
2205}
2206
2207proc addvhighlight {n} {
2208    global hlview curview viewdata vhl_done vhighlights commitidx
2209
2210    if {[info exists hlview]} {
2211        delvhighlight
2212    }
2213    set hlview $n
2214    if {$n != $curview && ![info exists viewdata($n)]} {
2215        set viewdata($n) [list getcommits {{}} 0 0 0]
2216        set vparentlist($n) {}
2217        set vdisporder($n) {}
2218        set vcmitlisted($n) {}
2219        start_rev_list $n
2220    }
2221    set vhl_done $commitidx($hlview)
2222    if {$vhl_done > 0} {
2223        drawvisible
2224    }
2225}
2226
2227proc delvhighlight {} {
2228    global hlview vhighlights
2229
2230    if {![info exists hlview]} return
2231    unset hlview
2232    catch {unset vhighlights}
2233    unbolden
2234}
2235
2236proc vhighlightmore {} {
2237    global hlview vhl_done commitidx vhighlights
2238    global displayorder vdisporder curview
2239
2240    set max $commitidx($hlview)
2241    if {$hlview == $curview} {
2242        set disp $displayorder
2243    } else {
2244        set disp $vdisporder($hlview)
2245    }
2246    set vr [visiblerows]
2247    set r0 [lindex $vr 0]
2248    set r1 [lindex $vr 1]
2249    for {set i $vhl_done} {$i < $max} {incr i} {
2250        set id [lindex $disp $i]
2251        if {[info exists commitrow($curview,$id)]} {
2252            set row $commitrow($curview,$id)
2253            if {$r0 <= $row && $row <= $r1} {
2254                if {![highlighted $row]} {
2255                    bolden $row mainfontbold
2256                }
2257                set vhighlights($row) 1
2258            }
2259        }
2260    }
2261    set vhl_done $max
2262}
2263
2264proc askvhighlight {row id} {
2265    global hlview vhighlights commitrow iddrawn
2266
2267    if {[info exists commitrow($hlview,$id)]} {
2268        if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2269            bolden $row mainfontbold
2270        }
2271        set vhighlights($row) 1
2272    } else {
2273        set vhighlights($row) 0
2274    }
2275}
2276
2277proc hfiles_change {} {
2278    global highlight_files filehighlight fhighlights fh_serial
2279    global highlight_paths gdttype
2280
2281    if {[info exists filehighlight]} {
2282        # delete previous highlights
2283        catch {close $filehighlight}
2284        unset filehighlight
2285        catch {unset fhighlights}
2286        unbolden
2287        unhighlight_filelist
2288    }
2289    set highlight_paths {}
2290    after cancel do_file_hl $fh_serial
2291    incr fh_serial
2292    if {$highlight_files ne {}} {
2293        after 300 do_file_hl $fh_serial
2294    }
2295}
2296
2297proc gdttype_change {name ix op} {
2298    global gdttype highlight_files findstring findpattern
2299
2300    stopfinding
2301    if {$findstring ne {}} {
2302        if {$gdttype eq "containing:"} {
2303            if {$highlight_files ne {}} {
2304                set highlight_files {}
2305                hfiles_change
2306            }
2307            findcom_change
2308        } else {
2309            if {$findpattern ne {}} {
2310                set findpattern {}
2311                findcom_change
2312            }
2313            set highlight_files $findstring
2314            hfiles_change
2315        }
2316        drawvisible
2317    }
2318    # enable/disable findtype/findloc menus too
2319}
2320
2321proc find_change {name ix op} {
2322    global gdttype findstring highlight_files
2323
2324    stopfinding
2325    if {$gdttype eq "containing:"} {
2326        findcom_change
2327    } else {
2328        if {$highlight_files ne $findstring} {
2329            set highlight_files $findstring
2330            hfiles_change
2331        }
2332    }
2333    drawvisible
2334}
2335
2336proc findcom_change args {
2337    global nhighlights boldnamerows
2338    global findpattern findtype findstring gdttype
2339
2340    stopfinding
2341    # delete previous highlights, if any
2342    foreach row $boldnamerows {
2343        bolden_name $row mainfont
2344    }
2345    set boldnamerows {}
2346    catch {unset nhighlights}
2347    unbolden
2348    unmarkmatches
2349    if {$gdttype ne "containing:" || $findstring eq {}} {
2350        set findpattern {}
2351    } elseif {$findtype eq "Regexp"} {
2352        set findpattern $findstring
2353    } else {
2354        set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2355                   $findstring]
2356        set findpattern "*$e*"
2357    }
2358}
2359
2360proc makepatterns {l} {
2361    set ret {}
2362    foreach e $l {
2363        set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2364        if {[string index $ee end] eq "/"} {
2365            lappend ret "$ee*"
2366        } else {
2367            lappend ret $ee
2368            lappend ret "$ee/*"
2369        }
2370    }
2371    return $ret
2372}
2373
2374proc do_file_hl {serial} {
2375    global highlight_files filehighlight highlight_paths gdttype fhl_list
2376
2377    if {$gdttype eq "touching paths:"} {
2378        if {[catch {set paths [shellsplit $highlight_files]}]} return
2379        set highlight_paths [makepatterns $paths]
2380        highlight_filelist
2381        set gdtargs [concat -- $paths]
2382    } elseif {$gdttype eq "adding/removing string:"} {
2383        set gdtargs [list "-S$highlight_files"]
2384    } else {
2385        # must be "containing:", i.e. we're searching commit info
2386        return
2387    }
2388    set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2389    set filehighlight [open $cmd r+]
2390    fconfigure $filehighlight -blocking 0
2391    filerun $filehighlight readfhighlight
2392    set fhl_list {}
2393    drawvisible
2394    flushhighlights
2395}
2396
2397proc flushhighlights {} {
2398    global filehighlight fhl_list
2399
2400    if {[info exists filehighlight]} {
2401        lappend fhl_list {}
2402        puts $filehighlight ""
2403        flush $filehighlight
2404    }
2405}
2406
2407proc askfilehighlight {row id} {
2408    global filehighlight fhighlights fhl_list
2409
2410    lappend fhl_list $id
2411    set fhighlights($row) -1
2412    puts $filehighlight $id
2413}
2414
2415proc readfhighlight {} {
2416    global filehighlight fhighlights commitrow curview iddrawn
2417    global fhl_list find_dirn
2418
2419    if {![info exists filehighlight]} {
2420        return 0
2421    }
2422    set nr 0
2423    while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2424        set line [string trim $line]
2425        set i [lsearch -exact $fhl_list $line]
2426        if {$i < 0} continue
2427        for {set j 0} {$j < $i} {incr j} {
2428            set id [lindex $fhl_list $j]
2429            if {[info exists commitrow($curview,$id)]} {
2430                set fhighlights($commitrow($curview,$id)) 0
2431            }
2432        }
2433        set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2434        if {$line eq {}} continue
2435        if {![info exists commitrow($curview,$line)]} continue
2436        set row $commitrow($curview,$line)
2437        if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2438            bolden $row mainfontbold
2439        }
2440        set fhighlights($row) 1
2441    }
2442    if {[eof $filehighlight]} {
2443        # strange...
2444        puts "oops, git diff-tree died"
2445        catch {close $filehighlight}
2446        unset filehighlight
2447        return 0
2448    }
2449    if {[info exists find_dirn]} {
2450        if {$find_dirn > 0} {
2451            run findmore
2452        } else {
2453            run findmorerev
2454        }
2455    }
2456    return 1
2457}
2458
2459proc doesmatch {f} {
2460    global findtype findpattern
2461
2462    if {$findtype eq "Regexp"} {
2463        return [regexp $findpattern $f]
2464    } elseif {$findtype eq "IgnCase"} {
2465        return [string match -nocase $findpattern $f]
2466    } else {
2467        return [string match $findpattern $f]
2468    }
2469}
2470
2471proc askfindhighlight {row id} {
2472    global nhighlights commitinfo iddrawn
2473    global findloc
2474    global markingmatches
2475
2476    if {![info exists commitinfo($id)]} {
2477        getcommit $id
2478    }
2479    set info $commitinfo($id)
2480    set isbold 0
2481    set fldtypes {Headline Author Date Committer CDate Comments}
2482    foreach f $info ty $fldtypes {
2483        if {($findloc eq "All fields" || $findloc eq $ty) &&
2484            [doesmatch $f]} {
2485            if {$ty eq "Author"} {
2486                set isbold 2
2487                break
2488            }
2489            set isbold 1
2490        }
2491    }
2492    if {$isbold && [info exists iddrawn($id)]} {
2493        if {![ishighlighted $row]} {
2494            bolden $row mainfontbold
2495            if {$isbold > 1} {
2496                bolden_name $row mainfontbold
2497            }
2498        }
2499        if {$markingmatches} {
2500            markrowmatches $row $id
2501        }
2502    }
2503    set nhighlights($row) $isbold
2504}
2505
2506proc markrowmatches {row id} {
2507    global canv canv2 linehtag linentag commitinfo findloc
2508
2509    set headline [lindex $commitinfo($id) 0]
2510    set author [lindex $commitinfo($id) 1]
2511    $canv delete match$row
2512    $canv2 delete match$row
2513    if {$findloc eq "All fields" || $findloc eq "Headline"} {
2514        set m [findmatches $headline]
2515        if {$m ne {}} {
2516            markmatches $canv $row $headline $linehtag($row) $m \
2517                [$canv itemcget $linehtag($row) -font] $row
2518        }
2519    }
2520    if {$findloc eq "All fields" || $findloc eq "Author"} {
2521        set m [findmatches $author]
2522        if {$m ne {}} {
2523            markmatches $canv2 $row $author $linentag($row) $m \
2524                [$canv2 itemcget $linentag($row) -font] $row
2525        }
2526    }
2527}
2528
2529proc vrel_change {name ix op} {
2530    global highlight_related
2531
2532    rhighlight_none
2533    if {$highlight_related ne "None"} {
2534        run drawvisible
2535    }
2536}
2537
2538# prepare for testing whether commits are descendents or ancestors of a
2539proc rhighlight_sel {a} {
2540    global descendent desc_todo ancestor anc_todo
2541    global highlight_related rhighlights
2542
2543    catch {unset descendent}
2544    set desc_todo [list $a]
2545    catch {unset ancestor}
2546    set anc_todo [list $a]
2547    if {$highlight_related ne "None"} {
2548        rhighlight_none
2549        run drawvisible
2550    }
2551}
2552
2553proc rhighlight_none {} {
2554    global rhighlights
2555
2556    catch {unset rhighlights}
2557    unbolden
2558}
2559
2560proc is_descendent {a} {
2561    global curview children commitrow descendent desc_todo
2562
2563    set v $curview
2564    set la $commitrow($v,$a)
2565    set todo $desc_todo
2566    set leftover {}
2567    set done 0
2568    for {set i 0} {$i < [llength $todo]} {incr i} {
2569        set do [lindex $todo $i]
2570        if {$commitrow($v,$do) < $la} {
2571            lappend leftover $do
2572            continue
2573        }
2574        foreach nk $children($v,$do) {
2575            if {![info exists descendent($nk)]} {
2576                set descendent($nk) 1
2577                lappend todo $nk
2578                if {$nk eq $a} {
2579                    set done 1
2580                }
2581            }
2582        }
2583        if {$done} {
2584            set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2585            return
2586        }
2587    }
2588    set descendent($a) 0
2589    set desc_todo $leftover
2590}
2591
2592proc is_ancestor {a} {
2593    global curview parentlist commitrow ancestor anc_todo
2594
2595    set v $curview
2596    set la $commitrow($v,$a)
2597    set todo $anc_todo
2598    set leftover {}
2599    set done 0
2600    for {set i 0} {$i < [llength $todo]} {incr i} {
2601        set do [lindex $todo $i]
2602        if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2603            lappend leftover $do
2604            continue
2605        }
2606        foreach np [lindex $parentlist $commitrow($v,$do)] {
2607            if {![info exists ancestor($np)]} {
2608                set ancestor($np) 1
2609                lappend todo $np
2610                if {$np eq $a} {
2611                    set done 1
2612                }
2613            }
2614        }
2615        if {$done} {
2616            set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2617            return
2618        }
2619    }
2620    set ancestor($a) 0
2621    set anc_todo $leftover
2622}
2623
2624proc askrelhighlight {row id} {
2625    global descendent highlight_related iddrawn rhighlights
2626    global selectedline ancestor
2627
2628    if {![info exists selectedline]} return
2629    set isbold 0
2630    if {$highlight_related eq "Descendent" ||
2631        $highlight_related eq "Not descendent"} {
2632        if {![info exists descendent($id)]} {
2633            is_descendent $id
2634        }
2635        if {$descendent($id) == ($highlight_related eq "Descendent")} {
2636            set isbold 1
2637        }
2638    } elseif {$highlight_related eq "Ancestor" ||
2639              $highlight_related eq "Not ancestor"} {
2640        if {![info exists ancestor($id)]} {
2641            is_ancestor $id
2642        }
2643        if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2644            set isbold 1
2645        }
2646    }
2647    if {[info exists iddrawn($id)]} {
2648        if {$isbold && ![ishighlighted $row]} {
2649            bolden $row mainfontbold
2650        }
2651    }
2652    set rhighlights($row) $isbold
2653}
2654
2655# Graph layout functions
2656
2657proc shortids {ids} {
2658    set res {}
2659    foreach id $ids {
2660        if {[llength $id] > 1} {
2661            lappend res [shortids $id]
2662        } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2663            lappend res [string range $id 0 7]
2664        } else {
2665            lappend res $id
2666        }
2667    }
2668    return $res
2669}
2670
2671proc ntimes {n o} {
2672    set ret {}
2673    set o [list $o]
2674    for {set mask 1} {$mask <= $n} {incr mask $mask} {
2675        if {($n & $mask) != 0} {
2676            set ret [concat $ret $o]
2677        }
2678        set o [concat $o $o]
2679    }
2680    return $ret
2681}
2682
2683# Work out where id should go in idlist so that order-token
2684# values increase from left to right
2685proc idcol {idlist id {i 0}} {
2686    global ordertok curview
2687
2688    set t $ordertok($curview,$id)
2689    if {$i >= [llength $idlist] ||
2690        $t < $ordertok($curview,[lindex $idlist $i])} {
2691        if {$i > [llength $idlist]} {
2692            set i [llength $idlist]
2693        }
2694        while {[incr i -1] >= 0 &&
2695               $t < $ordertok($curview,[lindex $idlist $i])} {}
2696        incr i
2697    } else {
2698        if {$t > $ordertok($curview,[lindex $idlist $i])} {
2699            while {[incr i] < [llength $idlist] &&
2700                   $t >= $ordertok($curview,[lindex $idlist $i])} {}
2701        }
2702    }
2703    return $i
2704}
2705
2706proc initlayout {} {
2707    global rowidlist rowisopt rowfinal displayorder commitlisted
2708    global numcommits canvxmax canv
2709    global nextcolor
2710    global parentlist
2711    global colormap rowtextx
2712    global selectfirst
2713
2714    set numcommits 0
2715    set displayorder {}
2716    set commitlisted {}
2717    set parentlist {}
2718    set nextcolor 0
2719    set rowidlist {}
2720    set rowisopt {}
2721    set rowfinal {}
2722    set canvxmax [$canv cget -width]
2723    catch {unset colormap}
2724    catch {unset rowtextx}
2725    set selectfirst 1
2726}
2727
2728proc setcanvscroll {} {
2729    global canv canv2 canv3 numcommits linespc canvxmax canvy0
2730
2731    set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2732    $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2733    $canv2 conf -scrollregion [list 0 0 0 $ymax]
2734    $canv3 conf -scrollregion [list 0 0 0 $ymax]
2735}
2736
2737proc visiblerows {} {
2738    global canv numcommits linespc
2739
2740    set ymax [lindex [$canv cget -scrollregion] 3]
2741    if {$ymax eq {} || $ymax == 0} return
2742    set f [$canv yview]
2743    set y0 [expr {int([lindex $f 0] * $ymax)}]
2744    set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2745    if {$r0 < 0} {
2746        set r0 0
2747    }
2748    set y1 [expr {int([lindex $f 1] * $ymax)}]
2749    set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2750    if {$r1 >= $numcommits} {
2751        set r1 [expr {$numcommits - 1}]
2752    }
2753    return [list $r0 $r1]
2754}
2755
2756proc layoutmore {} {
2757    global commitidx viewcomplete numcommits
2758    global uparrowlen downarrowlen mingaplen curview
2759
2760    set show $commitidx($curview)
2761    if {$show > $numcommits || $viewcomplete($curview)} {
2762        showstuff $show $viewcomplete($curview)
2763    }
2764}
2765
2766proc showstuff {canshow last} {
2767    global numcommits commitrow pending_select selectedline curview
2768    global mainheadid displayorder selectfirst
2769    global lastscrollset commitinterest
2770
2771    if {$numcommits == 0} {
2772        global phase
2773        set phase "incrdraw"
2774        allcanvs delete all
2775    }
2776    set r0 $numcommits
2777    set prev $numcommits
2778    set numcommits $canshow
2779    set t [clock clicks -milliseconds]
2780    if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2781        set lastscrollset $t
2782        setcanvscroll
2783    }
2784    set rows [visiblerows]
2785    set r1 [lindex $rows 1]
2786    if {$r1 >= $canshow} {
2787        set r1 [expr {$canshow - 1}]
2788    }
2789    if {$r0 <= $r1} {
2790        drawcommits $r0 $r1
2791    }
2792    if {[info exists pending_select] &&
2793        [info exists commitrow($curview,$pending_select)] &&
2794        $commitrow($curview,$pending_select) < $numcommits} {
2795        selectline $commitrow($curview,$pending_select) 1
2796    }
2797    if {$selectfirst} {
2798        if {[info exists selectedline] || [info exists pending_select]} {
2799            set selectfirst 0
2800        } else {
2801            set l [first_real_row]
2802            selectline $l 1
2803            set selectfirst 0
2804        }
2805    }
2806}
2807
2808proc doshowlocalchanges {} {
2809    global curview mainheadid phase commitrow
2810
2811    if {[info exists commitrow($curview,$mainheadid)] &&
2812        ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2813        dodiffindex
2814    } elseif {$phase ne {}} {
2815        lappend commitinterest($mainheadid) {}
2816    }
2817}
2818
2819proc dohidelocalchanges {} {
2820    global localfrow localirow lserial
2821
2822    if {$localfrow >= 0} {
2823        removerow $localfrow
2824        set localfrow -1
2825        if {$localirow > 0} {
2826            incr localirow -1
2827        }
2828    }
2829    if {$localirow >= 0} {
2830        removerow $localirow
2831        set localirow -1
2832    }
2833    incr lserial
2834}
2835
2836# spawn off a process to do git diff-index --cached HEAD
2837proc dodiffindex {} {
2838    global localirow localfrow lserial showlocalchanges
2839
2840    if {!$showlocalchanges} return
2841    incr lserial
2842    set localfrow -1
2843    set localirow -1
2844    set fd [open "|git diff-index --cached HEAD" r]
2845    fconfigure $fd -blocking 0
2846    filerun $fd [list readdiffindex $fd $lserial]
2847}
2848
2849proc readdiffindex {fd serial} {
2850    global localirow commitrow mainheadid nullid2 curview
2851    global commitinfo commitdata lserial
2852
2853    set isdiff 1
2854    if {[gets $fd line] < 0} {
2855        if {![eof $fd]} {
2856            return 1
2857        }
2858        set isdiff 0
2859    }
2860    # we only need to see one line and we don't really care what it says...
2861    close $fd
2862
2863    # now see if there are any local changes not checked in to the index
2864    if {$serial == $lserial} {
2865        set fd [open "|git diff-files" r]
2866        fconfigure $fd -blocking 0
2867        filerun $fd [list readdifffiles $fd $serial]
2868    }
2869
2870    if {$isdiff && $serial == $lserial && $localirow == -1} {
2871        # add the line for the changes in the index to the graph
2872        set localirow $commitrow($curview,$mainheadid)
2873        set hl "Local changes checked in to index but not committed"
2874        set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
2875        set commitdata($nullid2) "\n    $hl\n"
2876        insertrow $localirow $nullid2
2877    }
2878    return 0
2879}
2880
2881proc readdifffiles {fd serial} {
2882    global localirow localfrow commitrow mainheadid nullid curview
2883    global commitinfo commitdata lserial
2884
2885    set isdiff 1
2886    if {[gets $fd line] < 0} {
2887        if {![eof $fd]} {
2888            return 1
2889        }
2890        set isdiff 0
2891    }
2892    # we only need to see one line and we don't really care what it says...
2893    close $fd
2894
2895    if {$isdiff && $serial == $lserial && $localfrow == -1} {
2896        # add the line for the local diff to the graph
2897        if {$localirow >= 0} {
2898            set localfrow $localirow
2899            incr localirow
2900        } else {
2901            set localfrow $commitrow($curview,$mainheadid)
2902        }
2903        set hl "Local uncommitted changes, not checked in to index"
2904        set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
2905        set commitdata($nullid) "\n    $hl\n"
2906        insertrow $localfrow $nullid
2907    }
2908    return 0
2909}
2910
2911proc nextuse {id row} {
2912    global commitrow curview children
2913
2914    if {[info exists children($curview,$id)]} {
2915        foreach kid $children($curview,$id) {
2916            if {![info exists commitrow($curview,$kid)]} {
2917                return -1
2918            }
2919            if {$commitrow($curview,$kid) > $row} {
2920                return $commitrow($curview,$kid)
2921            }
2922        }
2923    }
2924    if {[info exists commitrow($curview,$id)]} {
2925        return $commitrow($curview,$id)
2926    }
2927    return -1
2928}
2929
2930proc prevuse {id row} {
2931    global commitrow curview children
2932
2933    set ret -1
2934    if {[info exists children($curview,$id)]} {
2935        foreach kid $children($curview,$id) {
2936            if {![info exists commitrow($curview,$kid)]} break
2937            if {$commitrow($curview,$kid) < $row} {
2938                set ret $commitrow($curview,$kid)
2939            }
2940        }
2941    }
2942    return $ret
2943}
2944
2945proc make_idlist {row} {
2946    global displayorder parentlist uparrowlen downarrowlen mingaplen
2947    global commitidx curview ordertok children commitrow
2948
2949    set r [expr {$row - $mingaplen - $downarrowlen - 1}]
2950    if {$r < 0} {
2951        set r 0
2952    }
2953    set ra [expr {$row - $downarrowlen}]
2954    if {$ra < 0} {
2955        set ra 0
2956    }
2957    set rb [expr {$row + $uparrowlen}]
2958    if {$rb > $commitidx($curview)} {
2959        set rb $commitidx($curview)
2960    }
2961    set ids {}
2962    for {} {$r < $ra} {incr r} {
2963        set nextid [lindex $displayorder [expr {$r + 1}]]
2964        foreach p [lindex $parentlist $r] {
2965            if {$p eq $nextid} continue
2966            set rn [nextuse $p $r]
2967            if {$rn >= $row &&
2968                $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
2969                lappend ids [list $ordertok($curview,$p) $p]
2970            }
2971        }
2972    }
2973    for {} {$r < $row} {incr r} {
2974        set nextid [lindex $displayorder [expr {$r + 1}]]
2975        foreach p [lindex $parentlist $r] {
2976            if {$p eq $nextid} continue
2977            set rn [nextuse $p $r]
2978            if {$rn < 0 || $rn >= $row} {
2979                lappend ids [list $ordertok($curview,$p) $p]
2980            }
2981        }
2982    }
2983    set id [lindex $displayorder $row]
2984    lappend ids [list $ordertok($curview,$id) $id]
2985    while {$r < $rb} {
2986        foreach p [lindex $parentlist $r] {
2987            set firstkid [lindex $children($curview,$p) 0]
2988            if {$commitrow($curview,$firstkid) < $row} {
2989                lappend ids [list $ordertok($curview,$p) $p]
2990            }
2991        }
2992        incr r
2993        set id [lindex $displayorder $r]
2994        if {$id ne {}} {
2995            set firstkid [lindex $children($curview,$id) 0]
2996            if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
2997                lappend ids [list $ordertok($curview,$id) $id]
2998            }
2999        }
3000    }
3001    set idlist {}
3002    foreach idx [lsort -unique $ids] {
3003        lappend idlist [lindex $idx 1]
3004    }
3005    return $idlist
3006}
3007
3008proc rowsequal {a b} {
3009    while {[set i [lsearch -exact $a {}]] >= 0} {
3010        set a [lreplace $a $i $i]
3011    }
3012    while {[set i [lsearch -exact $b {}]] >= 0} {
3013        set b [lreplace $b $i $i]
3014    }
3015    return [expr {$a eq $b}]
3016}
3017
3018proc makeupline {id row rend col} {
3019    global rowidlist uparrowlen downarrowlen mingaplen
3020
3021    for {set r $rend} {1} {set r $rstart} {
3022        set rstart [prevuse $id $r]
3023        if {$rstart < 0} return
3024        if {$rstart < $row} break
3025    }
3026    if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3027        set rstart [expr {$rend - $uparrowlen - 1}]
3028    }
3029    for {set r $rstart} {[incr r] <= $row} {} {
3030        set idlist [lindex $rowidlist $r]
3031        if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3032            set col [idcol $idlist $id $col]
3033            lset rowidlist $r [linsert $idlist $col $id]
3034            changedrow $r
3035        }
3036    }
3037}
3038
3039proc layoutrows {row endrow} {
3040    global rowidlist rowisopt rowfinal displayorder
3041    global uparrowlen downarrowlen maxwidth mingaplen
3042    global children parentlist
3043    global commitidx viewcomplete curview commitrow
3044
3045    set idlist {}
3046    if {$row > 0} {
3047        set rm1 [expr {$row - 1}]
3048        foreach id [lindex $rowidlist $rm1] {
3049            if {$id ne {}} {
3050                lappend idlist $id
3051            }
3052        }
3053        set final [lindex $rowfinal $rm1]
3054    }
3055    for {} {$row < $endrow} {incr row} {
3056        set rm1 [expr {$row - 1}]
3057        if {$rm1 < 0 || $idlist eq {}} {
3058            set idlist [make_idlist $row]
3059            set final 1
3060        } else {
3061            set id [lindex $displayorder $rm1]
3062            set col [lsearch -exact $idlist $id]
3063            set idlist [lreplace $idlist $col $col]
3064            foreach p [lindex $parentlist $rm1] {
3065                if {[lsearch -exact $idlist $p] < 0} {
3066                    set col [idcol $idlist $p $col]
3067                    set idlist [linsert $idlist $col $p]
3068                    # if not the first child, we have to insert a line going up
3069                    if {$id ne [lindex $children($curview,$p) 0]} {
3070                        makeupline $p $rm1 $row $col
3071                    }
3072                }
3073            }
3074            set id [lindex $displayorder $row]
3075            if {$row > $downarrowlen} {
3076                set termrow [expr {$row - $downarrowlen - 1}]
3077                foreach p [lindex $parentlist $termrow] {
3078                    set i [lsearch -exact $idlist $p]
3079                    if {$i < 0} continue
3080                    set nr [nextuse $p $termrow]
3081                    if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3082                        set idlist [lreplace $idlist $i $i]
3083                    }
3084                }
3085            }
3086            set col [lsearch -exact $idlist $id]
3087            if {$col < 0} {
3088                set col [idcol $idlist $id]
3089                set idlist [linsert $idlist $col $id]
3090                if {$children($curview,$id) ne {}} {
3091                    makeupline $id $rm1 $row $col
3092                }
3093            }
3094            set r [expr {$row + $uparrowlen - 1}]
3095            if {$r < $commitidx($curview)} {
3096                set x $col
3097                foreach p [lindex $parentlist $r] {
3098                    if {[lsearch -exact $idlist $p] >= 0} continue
3099                    set fk [lindex $children($curview,$p) 0]
3100                    if {$commitrow($curview,$fk) < $row} {
3101                        set x [idcol $idlist $p $x]
3102                        set idlist [linsert $idlist $x $p]
3103                    }
3104                }
3105                if {[incr r] < $commitidx($curview)} {
3106                    set p [lindex $displayorder $r]
3107                    if {[lsearch -exact $idlist $p] < 0} {
3108                        set fk [lindex $children($curview,$p) 0]
3109                        if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3110                            set x [idcol $idlist $p $x]
3111                            set idlist [linsert $idlist $x $p]
3112                        }
3113                    }
3114                }
3115            }
3116        }
3117        if {$final && !$viewcomplete($curview) &&
3118            $row + $uparrowlen + $mingaplen + $downarrowlen
3119                >= $commitidx($curview)} {
3120            set final 0
3121        }
3122        set l [llength $rowidlist]
3123        if {$row == $l} {
3124            lappend rowidlist $idlist
3125            lappend rowisopt 0
3126            lappend rowfinal $final
3127        } elseif {$row < $l} {
3128            if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3129                lset rowidlist $row $idlist
3130                changedrow $row
3131            }
3132            lset rowfinal $row $final
3133        } else {
3134            set pad [ntimes [expr {$row - $l}] {}]
3135            set rowidlist [concat $rowidlist $pad]
3136            lappend rowidlist $idlist
3137            set rowfinal [concat $rowfinal $pad]
3138            lappend rowfinal $final
3139            set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3140        }
3141    }
3142    return $row
3143}
3144
3145proc changedrow {row} {
3146    global displayorder iddrawn rowisopt need_redisplay
3147
3148    set l [llength $rowisopt]
3149    if {$row < $l} {
3150        lset rowisopt $row 0
3151        if {$row + 1 < $l} {
3152            lset rowisopt [expr {$row + 1}] 0
3153            if {$row + 2 < $l} {
3154                lset rowisopt [expr {$row + 2}] 0
3155            }
3156        }
3157    }
3158    set id [lindex $displayorder $row]
3159    if {[info exists iddrawn($id)]} {
3160        set need_redisplay 1
3161    }
3162}
3163
3164proc insert_pad {row col npad} {
3165    global rowidlist
3166
3167    set pad [ntimes $npad {}]
3168    set idlist [lindex $rowidlist $row]
3169    set bef [lrange $idlist 0 [expr {$col - 1}]]
3170    set aft [lrange $idlist $col end]
3171    set i [lsearch -exact $aft {}]
3172    if {$i > 0} {
3173        set aft [lreplace $aft $i $i]
3174    }
3175    lset rowidlist $row [concat $bef $pad $aft]
3176    changedrow $row
3177}
3178
3179proc optimize_rows {row col endrow} {
3180    global rowidlist rowisopt displayorder curview children
3181
3182    if {$row < 1} {
3183        set row 1
3184    }
3185    for {} {$row < $endrow} {incr row; set col 0} {
3186        if {[lindex $rowisopt $row]} continue
3187        set haspad 0
3188        set y0 [expr {$row - 1}]
3189        set ym [expr {$row - 2}]
3190        set idlist [lindex $rowidlist $row]
3191        set previdlist [lindex $rowidlist $y0]
3192        if {$idlist eq {} || $previdlist eq {}} continue
3193        if {$ym >= 0} {
3194            set pprevidlist [lindex $rowidlist $ym]
3195            if {$pprevidlist eq {}} continue
3196        } else {
3197            set pprevidlist {}
3198        }
3199        set x0 -1
3200        set xm -1
3201        for {} {$col < [llength $idlist]} {incr col} {
3202            set id [lindex $idlist $col]
3203            if {[lindex $previdlist $col] eq $id} continue
3204            if {$id eq {}} {
3205                set haspad 1
3206                continue
3207            }
3208            set x0 [lsearch -exact $previdlist $id]
3209            if {$x0 < 0} continue
3210            set z [expr {$x0 - $col}]
3211            set isarrow 0
3212            set z0 {}
3213            if {$ym >= 0} {
3214                set xm [lsearch -exact $pprevidlist $id]
3215                if {$xm >= 0} {
3216                    set z0 [expr {$xm - $x0}]
3217                }
3218            }
3219            if {$z0 eq {}} {
3220                # if row y0 is the first child of $id then it's not an arrow
3221                if {[lindex $children($curview,$id) 0] ne
3222                    [lindex $displayorder $y0]} {
3223                    set isarrow 1
3224                }
3225            }
3226            if {!$isarrow && $id ne [lindex $displayorder $row] &&
3227                [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3228                set isarrow 1
3229            }
3230            # Looking at lines from this row to the previous row,
3231            # make them go straight up if they end in an arrow on
3232            # the previous row; otherwise make them go straight up
3233            # or at 45 degrees.
3234            if {$z < -1 || ($z < 0 && $isarrow)} {
3235                # Line currently goes left too much;
3236                # insert pads in the previous row, then optimize it
3237                set npad [expr {-1 - $z + $isarrow}]
3238                insert_pad $y0 $x0 $npad
3239                if {$y0 > 0} {
3240                    optimize_rows $y0 $x0 $row
3241                }
3242                set previdlist [lindex $rowidlist $y0]
3243                set x0 [lsearch -exact $previdlist $id]
3244                set z [expr {$x0 - $col}]
3245                if {$z0 ne {}} {
3246                    set pprevidlist [lindex $rowidlist $ym]
3247                    set xm [lsearch -exact $pprevidlist $id]
3248                    set z0 [expr {$xm - $x0}]
3249                }
3250            } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3251                # Line currently goes right too much;
3252                # insert pads in this line
3253                set npad [expr {$z - 1 + $isarrow}]
3254                insert_pad $row $col $npad
3255                set idlist [lindex $rowidlist $row]
3256                incr col $npad
3257                set z [expr {$x0 - $col}]
3258                set haspad 1
3259            }
3260            if {$z0 eq {} && !$isarrow && $ym >= 0} {
3261                # this line links to its first child on row $row-2
3262                set id [lindex $displayorder $ym]
3263                set xc [lsearch -exact $pprevidlist $id]
3264                if {$xc >= 0} {
3265                    set z0 [expr {$xc - $x0}]
3266                }
3267            }
3268            # avoid lines jigging left then immediately right
3269            if {$z0 ne {} && $z < 0 && $z0 > 0} {
3270                insert_pad $y0 $x0 1
3271                incr x0
3272                optimize_rows $y0 $x0 $row
3273                set previdlist [lindex $rowidlist $y0]
3274            }
3275        }
3276        if {!$haspad} {
3277            # Find the first column that doesn't have a line going right
3278            for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3279                set id [lindex $idlist $col]
3280                if {$id eq {}} break
3281                set x0 [lsearch -exact $previdlist $id]
3282                if {$x0 < 0} {
3283                    # check if this is the link to the first child
3284                    set kid [lindex $displayorder $y0]
3285                    if {[lindex $children($curview,$id) 0] eq $kid} {
3286                        # it is, work out offset to child
3287                        set x0 [lsearch -exact $previdlist $kid]
3288                    }
3289                }
3290                if {$x0 <= $col} break
3291            }
3292            # Insert a pad at that column as long as it has a line and
3293            # isn't the last column
3294            if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3295                set idlist [linsert $idlist $col {}]
3296                lset rowidlist $row $idlist
3297                changedrow $row
3298            }
3299        }
3300    }
3301}
3302
3303proc xc {row col} {
3304    global canvx0 linespc
3305    return [expr {$canvx0 + $col * $linespc}]
3306}
3307
3308proc yc {row} {
3309    global canvy0 linespc
3310    return [expr {$canvy0 + $row * $linespc}]
3311}
3312
3313proc linewidth {id} {
3314    global thickerline lthickness
3315
3316    set wid $lthickness
3317    if {[info exists thickerline] && $id eq $thickerline} {
3318        set wid [expr {2 * $lthickness}]
3319    }
3320    return $wid
3321}
3322
3323proc rowranges {id} {
3324    global commitrow curview children uparrowlen downarrowlen
3325    global rowidlist
3326
3327    set kids $children($curview,$id)
3328    if {$kids eq {}} {
3329        return {}
3330    }
3331    set ret {}
3332    lappend kids $id
3333    foreach child $kids {
3334        if {![info exists commitrow($curview,$child)]} break
3335        set row $commitrow($curview,$child)
3336        if {![info exists prev]} {
3337            lappend ret [expr {$row + 1}]
3338        } else {
3339            if {$row <= $prevrow} {
3340                puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3341            }
3342            # see if the line extends the whole way from prevrow to row
3343            if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3344                [lsearch -exact [lindex $rowidlist \
3345                            [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3346                # it doesn't, see where it ends
3347                set r [expr {$prevrow + $downarrowlen}]
3348                if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3349                    while {[incr r -1] > $prevrow &&
3350                           [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3351                } else {
3352                    while {[incr r] <= $row &&
3353                           [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3354                    incr r -1
3355                }
3356                lappend ret $r
3357                # see where it starts up again
3358                set r [expr {$row - $uparrowlen}]
3359                if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3360                    while {[incr r] < $row &&
3361                           [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3362                } else {
3363                    while {[incr r -1] >= $prevrow &&
3364                           [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3365                    incr r
3366                }
3367                lappend ret $r
3368            }
3369        }
3370        if {$child eq $id} {
3371            lappend ret $row
3372        }
3373        set prev $id
3374        set prevrow $row
3375    }
3376    return $ret
3377}
3378
3379proc drawlineseg {id row endrow arrowlow} {
3380    global rowidlist displayorder iddrawn linesegs
3381    global canv colormap linespc curview maxlinelen parentlist
3382
3383    set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3384    set le [expr {$row + 1}]
3385    set arrowhigh 1
3386    while {1} {
3387        set c [lsearch -exact [lindex $rowidlist $le] $id]
3388        if {$c < 0} {
3389            incr le -1
3390            break
3391        }
3392        lappend cols $c
3393        set x [lindex $displayorder $le]
3394        if {$x eq $id} {
3395            set arrowhigh 0
3396            break
3397        }
3398        if {[info exists iddrawn($x)] || $le == $endrow} {
3399            set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3400            if {$c >= 0} {
3401                lappend cols $c
3402                set arrowhigh 0
3403            }
3404            break
3405        }
3406        incr le
3407    }
3408    if {$le <= $row} {
3409        return $row
3410    }
3411
3412    set lines {}
3413    set i 0
3414    set joinhigh 0
3415    if {[info exists linesegs($id)]} {
3416        set lines $linesegs($id)
3417        foreach li $lines {
3418            set r0 [lindex $li 0]
3419            if {$r0 > $row} {
3420                if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3421                    set joinhigh 1
3422                }
3423                break
3424            }
3425            incr i
3426        }
3427    }
3428    set joinlow 0
3429    if {$i > 0} {
3430        set li [lindex $lines [expr {$i-1}]]
3431        set r1 [lindex $li 1]
3432        if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3433            set joinlow 1
3434        }
3435    }
3436
3437    set x [lindex $cols [expr {$le - $row}]]
3438    set xp [lindex $cols [expr {$le - 1 - $row}]]
3439    set dir [expr {$xp - $x}]
3440    if {$joinhigh} {
3441        set ith [lindex $lines $i 2]
3442        set coords [$canv coords $ith]
3443        set ah [$canv itemcget $ith -arrow]
3444        set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3445        set x2 [lindex $cols [expr {$le + 1 - $row}]]
3446        if {$x2 ne {} && $x - $x2 == $dir} {
3447            set coords [lrange $coords 0 end-2]
3448        }
3449    } else {
3450        set coords [list [xc $le $x] [yc $le]]
3451    }
3452    if {$joinlow} {
3453        set itl [lindex $lines [expr {$i-1}] 2]
3454        set al [$canv itemcget $itl -arrow]
3455        set arrowlow [expr {$al eq "last" || $al eq "both"}]
3456    } elseif {$arrowlow} {
3457        if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3458            [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3459            set arrowlow 0
3460        }
3461    }
3462    set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3463    for {set y $le} {[incr y -1] > $row} {} {
3464        set x $xp
3465        set xp [lindex $cols [expr {$y - 1 - $row}]]
3466        set ndir [expr {$xp - $x}]
3467        if {$dir != $ndir || $xp < 0} {
3468            lappend coords [xc $y $x] [yc $y]
3469        }
3470        set dir $ndir
3471    }
3472    if {!$joinlow} {
3473        if {$xp < 0} {
3474            # join parent line to first child
3475            set ch [lindex $displayorder $row]
3476            set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3477            if {$xc < 0} {
3478                puts "oops: drawlineseg: child $ch not on row $row"
3479            } elseif {$xc != $x} {
3480                if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3481                    set d [expr {int(0.5 * $linespc)}]
3482                    set x1 [xc $row $x]
3483                    if {$xc < $x} {
3484                        set x2 [expr {$x1 - $d}]
3485                    } else {
3486                        set x2 [expr {$x1 + $d}]
3487                    }
3488                    set y2 [yc $row]
3489                    set y1 [expr {$y2 + $d}]
3490                    lappend coords $x1 $y1 $x2 $y2
3491                } elseif {$xc < $x - 1} {
3492                    lappend coords [xc $row [expr {$x-1}]] [yc $row]
3493                } elseif {$xc > $x + 1} {
3494                    lappend coords [xc $row [expr {$x+1}]] [yc $row]
3495                }
3496                set x $xc
3497            }
3498            lappend coords [xc $row $x] [yc $row]
3499        } else {
3500            set xn [xc $row $xp]
3501            set yn [yc $row]
3502            lappend coords $xn $yn
3503        }
3504        if {!$joinhigh} {
3505            assigncolor $id
3506            set t [$canv create line $coords -width [linewidth $id] \
3507                       -fill $colormap($id) -tags lines.$id -arrow $arrow]
3508            $canv lower $t
3509            bindline $t $id
3510            set lines [linsert $lines $i [list $row $le $t]]
3511        } else {
3512            $canv coords $ith $coords
3513            if {$arrow ne $ah} {
3514                $canv itemconf $ith -arrow $arrow
3515            }
3516            lset lines $i 0 $row
3517        }
3518    } else {
3519        set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3520        set ndir [expr {$xo - $xp}]
3521        set clow [$canv coords $itl]
3522        if {$dir == $ndir} {
3523            set clow [lrange $clow 2 end]
3524        }
3525        set coords [concat $coords $clow]
3526        if {!$joinhigh} {
3527            lset lines [expr {$i-1}] 1 $le
3528        } else {
3529            # coalesce two pieces
3530            $canv delete $ith
3531            set b [lindex $lines [expr {$i-1}] 0]
3532            set e [lindex $lines $i 1]
3533            set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3534        }
3535        $canv coords $itl $coords
3536        if {$arrow ne $al} {
3537            $canv itemconf $itl -arrow $arrow
3538        }
3539    }
3540
3541    set linesegs($id) $lines
3542    return $le
3543}
3544
3545proc drawparentlinks {id row} {
3546    global rowidlist canv colormap curview parentlist
3547    global idpos linespc
3548
3549    set rowids [lindex $rowidlist $row]
3550    set col [lsearch -exact $rowids $id]
3551    if {$col < 0} return
3552    set olds [lindex $parentlist $row]
3553    set row2 [expr {$row + 1}]
3554    set x [xc $row $col]
3555    set y [yc $row]
3556    set y2 [yc $row2]
3557    set d [expr {int(0.5 * $linespc)}]
3558    set ymid [expr {$y + $d}]
3559    set ids [lindex $rowidlist $row2]
3560    # rmx = right-most X coord used
3561    set rmx 0
3562    foreach p $olds {
3563        set i [lsearch -exact $ids $p]
3564        if {$i < 0} {
3565            puts "oops, parent $p of $id not in list"
3566            continue
3567        }
3568        set x2 [xc $row2 $i]
3569        if {$x2 > $rmx} {
3570            set rmx $x2
3571        }
3572        set j [lsearch -exact $rowids $p]
3573        if {$j < 0} {
3574            # drawlineseg will do this one for us
3575            continue
3576        }
3577        assigncolor $p
3578        # should handle duplicated parents here...
3579        set coords [list $x $y]
3580        if {$i != $col} {
3581            # if attaching to a vertical segment, draw a smaller
3582            # slant for visual distinctness
3583            if {$i == $j} {
3584                if {$i < $col} {
3585                    lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3586                } else {
3587                    lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3588                }
3589            } elseif {$i < $col && $i < $j} {
3590                # segment slants towards us already
3591                lappend coords [xc $row $j] $y
3592            } else {
3593                if {$i < $col - 1} {
3594                    lappend coords [expr {$x2 + $linespc}] $y
3595                } elseif {$i > $col + 1} {
3596                    lappend coords [expr {$x2 - $linespc}] $y
3597                }
3598                lappend coords $x2 $y2
3599            }
3600        } else {
3601            lappend coords $x2 $y2
3602        }
3603        set t [$canv create line $coords -width [linewidth $p] \
3604                   -fill $colormap($p) -tags lines.$p]
3605        $canv lower $t
3606        bindline $t $p
3607    }
3608    if {$rmx > [lindex $idpos($id) 1]} {
3609        lset idpos($id) 1 $rmx
3610        redrawtags $id
3611    }
3612}
3613
3614proc drawlines {id} {
3615    global canv
3616
3617    $canv itemconf lines.$id -width [linewidth $id]
3618}
3619
3620proc drawcmittext {id row col} {
3621    global linespc canv canv2 canv3 canvy0 fgcolor curview
3622    global commitlisted commitinfo rowidlist parentlist
3623    global rowtextx idpos idtags idheads idotherrefs
3624    global linehtag linentag linedtag selectedline
3625    global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3626
3627    # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3628    set listed [lindex $commitlisted $row]
3629    if {$id eq $nullid} {
3630        set ofill red
3631    } elseif {$id eq $nullid2} {
3632        set ofill green
3633    } else {
3634        set ofill [expr {$listed != 0? "blue": "white"}]
3635    }
3636    set x [xc $row $col]
3637    set y [yc $row]
3638    set orad [expr {$linespc / 3}]
3639    if {$listed <= 1} {
3640        set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3641                   [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3642                   -fill $ofill -outline $fgcolor -width 1 -tags circle]
3643    } elseif {$listed == 2} {
3644        # triangle pointing left for left-side commits
3645        set t [$canv create polygon \
3646                   [expr {$x - $orad}] $y \
3647                   [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3648                   [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3649                   -fill $ofill -outline $fgcolor -width 1 -tags circle]
3650    } else {
3651        # triangle pointing right for right-side commits
3652        set t [$canv create polygon \
3653                   [expr {$x + $orad - 1}] $y \
3654                   [expr {$x - $orad}] [expr {$y - $orad}] \
3655                   [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3656                   -fill $ofill -outline $fgcolor -width 1 -tags circle]
3657    }
3658    $canv raise $t
3659    $canv bind $t <1> {selcanvline {} %x %y}
3660    set rmx [llength [lindex $rowidlist $row]]
3661    set olds [lindex $parentlist $row]
3662    if {$olds ne {}} {
3663        set nextids [lindex $rowidlist [expr {$row + 1}]]
3664        foreach p $olds {
3665            set i [lsearch -exact $nextids $p]
3666            if {$i > $rmx} {
3667                set rmx $i
3668            }
3669        }
3670    }
3671    set xt [xc $row $rmx]
3672    set rowtextx($row) $xt
3673    set idpos($id) [list $x $xt $y]
3674    if {[info exists idtags($id)] || [info exists idheads($id)]
3675        || [info exists idotherrefs($id)]} {
3676        set xt [drawtags $id $x $xt $y]
3677    }
3678    set headline [lindex $commitinfo($id) 0]
3679    set name [lindex $commitinfo($id) 1]
3680    set date [lindex $commitinfo($id) 2]
3681    set date [formatdate $date]
3682    set font mainfont
3683    set nfont mainfont
3684    set isbold [ishighlighted $row]
3685    if {$isbold > 0} {
3686        lappend boldrows $row
3687        set font mainfontbold
3688        if {$isbold > 1} {
3689            lappend boldnamerows $row
3690            set nfont mainfontbold
3691        }
3692    }
3693    set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3694                            -text $headline -font $font -tags text]
3695    $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3696    set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3697                            -text $name -font $nfont -tags text]
3698    set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3699                            -text $date -font mainfont -tags text]
3700    if {[info exists selectedline] && $selectedline == $row} {
3701        make_secsel $row
3702    }
3703    set xr [expr {$xt + [font measure $font $headline]}]
3704    if {$xr > $canvxmax} {
3705        set canvxmax $xr
3706        setcanvscroll
3707    }
3708}
3709
3710proc drawcmitrow {row} {
3711    global displayorder rowidlist nrows_drawn
3712    global iddrawn markingmatches
3713    global commitinfo parentlist numcommits
3714    global filehighlight fhighlights findpattern nhighlights
3715    global hlview vhighlights
3716    global highlight_related rhighlights
3717
3718    if {$row >= $numcommits} return
3719
3720    set id [lindex $displayorder $row]
3721    if {[info exists hlview] && ![info exists vhighlights($row)]} {
3722        askvhighlight $row $id
3723    }
3724    if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3725        askfilehighlight $row $id
3726    }
3727    if {$findpattern ne {} && ![info exists nhighlights($row)]} {
3728        askfindhighlight $row $id
3729    }
3730    if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3731        askrelhighlight $row $id
3732    }
3733    if {![info exists iddrawn($id)]} {
3734        set col [lsearch -exact [lindex $rowidlist $row] $id]
3735        if {$col < 0} {
3736            puts "oops, row $row id $id not in list"
3737            return
3738        }
3739        if {![info exists commitinfo($id)]} {
3740            getcommit $id
3741        }
3742        assigncolor $id
3743        drawcmittext $id $row $col
3744        set iddrawn($id) 1
3745        incr nrows_drawn
3746    }
3747    if {$markingmatches} {
3748        markrowmatches $row $id
3749    }
3750}
3751
3752proc drawcommits {row {endrow {}}} {
3753    global numcommits iddrawn displayorder curview need_redisplay
3754    global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3755
3756    if {$row < 0} {
3757        set row 0
3758    }
3759    if {$endrow eq {}} {
3760        set endrow $row
3761    }
3762    if {$endrow >= $numcommits} {
3763        set endrow [expr {$numcommits - 1}]
3764    }
3765
3766    set rl1 [expr {$row - $downarrowlen - 3}]
3767    if {$rl1 < 0} {
3768        set rl1 0
3769    }
3770    set ro1 [expr {$row - 3}]
3771    if {$ro1 < 0} {
3772        set ro1 0
3773    }
3774    set r2 [expr {$endrow + $uparrowlen + 3}]
3775    if {$r2 > $numcommits} {
3776        set r2 $numcommits
3777    }
3778    for {set r $rl1} {$r < $r2} {incr r} {
3779        if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3780            if {$rl1 < $r} {
3781                layoutrows $rl1 $r
3782            }
3783            set rl1 [expr {$r + 1}]
3784        }
3785    }
3786    if {$rl1 < $r} {
3787        layoutrows $rl1 $r
3788    }
3789    optimize_rows $ro1 0 $r2
3790    if {$need_redisplay || $nrows_drawn > 2000} {
3791        clear_display
3792        drawvisible
3793    }
3794
3795    # make the lines join to already-drawn rows either side
3796    set r [expr {$row - 1}]
3797    if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3798        set r $row
3799    }
3800    set er [expr {$endrow + 1}]
3801    if {$er >= $numcommits ||
3802        ![info exists iddrawn([lindex $displayorder $er])]} {
3803        set er $endrow
3804    }
3805    for {} {$r <= $er} {incr r} {
3806        set id [lindex $displayorder $r]
3807        set wasdrawn [info exists iddrawn($id)]
3808        drawcmitrow $r
3809        if {$r == $er} break
3810        set nextid [lindex $displayorder [expr {$r + 1}]]
3811        if {$wasdrawn && [info exists iddrawn($nextid)]} {
3812            catch {unset prevlines}
3813            continue
3814        }
3815        drawparentlinks $id $r
3816
3817        if {[info exists lineends($r)]} {
3818            foreach lid $lineends($r) {
3819                unset prevlines($lid)
3820            }
3821        }
3822        set rowids [lindex $rowidlist $r]
3823        foreach lid $rowids {
3824            if {$lid eq {}} continue
3825            if {$lid eq $id} {
3826                # see if this is the first child of any of its parents
3827                foreach p [lindex $parentlist $r] {
3828                    if {[lsearch -exact $rowids $p] < 0} {
3829                        # make this line extend up to the child
3830                        set le [drawlineseg $p $r $er 0]
3831                        lappend lineends($le) $p
3832                        set prevlines($p) 1
3833                    }
3834                }
3835            } elseif {![info exists prevlines($lid)]} {
3836                set le [drawlineseg $lid $r $er 1]
3837                lappend lineends($le) $lid
3838                set prevlines($lid) 1
3839            }
3840        }
3841    }
3842}
3843
3844proc drawfrac {f0 f1} {
3845    global canv linespc
3846
3847    set ymax [lindex [$canv cget -scrollregion] 3]
3848    if {$ymax eq {} || $ymax == 0} return
3849    set y0 [expr {int($f0 * $ymax)}]
3850    set row [expr {int(($y0 - 3) / $linespc) - 1}]
3851    set y1 [expr {int($f1 * $ymax)}]
3852    set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3853    drawcommits $row $endrow
3854}
3855
3856proc drawvisible {} {
3857    global canv
3858    eval drawfrac [$canv yview]
3859}
3860
3861proc clear_display {} {
3862    global iddrawn linesegs need_redisplay nrows_drawn
3863    global vhighlights fhighlights nhighlights rhighlights
3864
3865    allcanvs delete all
3866    catch {unset iddrawn}
3867    catch {unset linesegs}
3868    catch {unset vhighlights}
3869    catch {unset fhighlights}
3870    catch {unset nhighlights}
3871    catch {unset rhighlights}
3872    set need_redisplay 0
3873    set nrows_drawn 0
3874}
3875
3876proc findcrossings {id} {
3877    global rowidlist parentlist numcommits displayorder
3878
3879    set cross {}
3880    set ccross {}
3881    foreach {s e} [rowranges $id] {
3882        if {$e >= $numcommits} {
3883            set e [expr {$numcommits - 1}]
3884        }
3885        if {$e <= $s} continue
3886        for {set row $e} {[incr row -1] >= $s} {} {
3887            set x [lsearch -exact [lindex $rowidlist $row] $id]
3888            if {$x < 0} break
3889            set olds [lindex $parentlist $row]
3890            set kid [lindex $displayorder $row]
3891            set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3892            if {$kidx < 0} continue
3893            set nextrow [lindex $rowidlist [expr {$row + 1}]]
3894            foreach p $olds {
3895                set px [lsearch -exact $nextrow $p]
3896                if {$px < 0} continue
3897                if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3898                    if {[lsearch -exact $ccross $p] >= 0} continue
3899                    if {$x == $px + ($kidx < $px? -1: 1)} {
3900                        lappend ccross $p
3901                    } elseif {[lsearch -exact $cross $p] < 0} {
3902                        lappend cross $p
3903                    }
3904                }
3905            }
3906        }
3907    }
3908    return [concat $ccross {{}} $cross]
3909}
3910
3911proc assigncolor {id} {
3912    global colormap colors nextcolor
3913    global commitrow parentlist children children curview
3914
3915    if {[info exists colormap($id)]} return
3916    set ncolors [llength $colors]
3917    if {[info exists children($curview,$id)]} {
3918        set kids $children($curview,$id)
3919    } else {
3920        set kids {}
3921    }
3922    if {[llength $kids] == 1} {
3923        set child [lindex $kids 0]
3924        if {[info exists colormap($child)]
3925            && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3926            set colormap($id) $colormap($child)
3927            return
3928        }
3929    }
3930    set badcolors {}
3931    set origbad {}
3932    foreach x [findcrossings $id] {
3933        if {$x eq {}} {
3934            # delimiter between corner crossings and other crossings
3935            if {[llength $badcolors] >= $ncolors - 1} break
3936            set origbad $badcolors
3937        }
3938        if {[info exists colormap($x)]
3939            && [lsearch -exact $badcolors $colormap($x)] < 0} {
3940            lappend badcolors $colormap($x)
3941        }
3942    }
3943    if {[llength $badcolors] >= $ncolors} {
3944        set badcolors $origbad
3945    }
3946    set origbad $badcolors
3947    if {[llength $badcolors] < $ncolors - 1} {
3948        foreach child $kids {
3949            if {[info exists colormap($child)]
3950                && [lsearch -exact $badcolors $colormap($child)] < 0} {
3951                lappend badcolors $colormap($child)
3952            }
3953            foreach p [lindex $parentlist $commitrow($curview,$child)] {
3954                if {[info exists colormap($p)]
3955                    && [lsearch -exact $badcolors $colormap($p)] < 0} {
3956                    lappend badcolors $colormap($p)
3957                }
3958            }
3959        }
3960        if {[llength $badcolors] >= $ncolors} {
3961            set badcolors $origbad
3962        }
3963    }
3964    for {set i 0} {$i <= $ncolors} {incr i} {
3965        set c [lindex $colors $nextcolor]
3966        if {[incr nextcolor] >= $ncolors} {
3967            set nextcolor 0
3968        }
3969        if {[lsearch -exact $badcolors $c]} break
3970    }
3971    set colormap($id) $c
3972}
3973
3974proc bindline {t id} {
3975    global canv
3976
3977    $canv bind $t <Enter> "lineenter %x %y $id"
3978    $canv bind $t <Motion> "linemotion %x %y $id"
3979    $canv bind $t <Leave> "lineleave $id"
3980    $canv bind $t <Button-1> "lineclick %x %y $id 1"
3981}
3982
3983proc drawtags {id x xt y1} {
3984    global idtags idheads idotherrefs mainhead
3985    global linespc lthickness
3986    global canv commitrow rowtextx curview fgcolor bgcolor
3987
3988    set marks {}
3989    set ntags 0
3990    set nheads 0
3991    if {[info exists idtags($id)]} {
3992        set marks $idtags($id)
3993        set ntags [llength $marks]
3994    }
3995    if {[info exists idheads($id)]} {
3996        set marks [concat $marks $idheads($id)]
3997        set nheads [llength $idheads($id)]
3998    }
3999    if {[info exists idotherrefs($id)]} {
4000        set marks [concat $marks $idotherrefs($id)]
4001    }
4002    if {$marks eq {}} {
4003        return $xt
4004    }
4005
4006    set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4007    set yt [expr {$y1 - 0.5 * $linespc}]
4008    set yb [expr {$yt + $linespc - 1}]
4009    set xvals {}
4010    set wvals {}
4011    set i -1
4012    foreach tag $marks {
4013        incr i
4014        if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4015            set wid [font measure mainfontbold $tag]
4016        } else {
4017            set wid [font measure mainfont $tag]
4018        }
4019        lappend xvals $xt
4020        lappend wvals $wid
4021        set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4022    }
4023    set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4024               -width $lthickness -fill black -tags tag.$id]
4025    $canv lower $t
4026    foreach tag $marks x $xvals wid $wvals {
4027        set xl [expr {$x + $delta}]
4028        set xr [expr {$x + $delta + $wid + $lthickness}]
4029        set font mainfont
4030        if {[incr ntags -1] >= 0} {
4031            # draw a tag
4032            set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4033                       $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4034                       -width 1 -outline black -fill yellow -tags tag.$id]
4035            $canv bind $t <1> [list showtag $tag 1]
4036            set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4037        } else {
4038            # draw a head or other ref
4039            if {[incr nheads -1] >= 0} {
4040                set col green
4041                if {$tag eq $mainhead} {
4042                    set font mainfontbold
4043                }
4044            } else {
4045                set col "#ddddff"
4046            }
4047            set xl [expr {$xl - $delta/2}]
4048            $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4049                -width 1 -outline black -fill $col -tags tag.$id
4050            if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4051                set rwid [font measure mainfont $remoteprefix]
4052                set xi [expr {$x + 1}]
4053                set yti [expr {$yt + 1}]
4054                set xri [expr {$x + $rwid}]
4055                $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4056                        -width 0 -fill "#ffddaa" -tags tag.$id
4057            }
4058        }
4059        set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4060                   -font $font -tags [list tag.$id text]]
4061        if {$ntags >= 0} {
4062            $canv bind $t <1> [list showtag $tag 1]
4063        } elseif {$nheads >= 0} {
4064            $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4065        }
4066    }
4067    return $xt
4068}
4069
4070proc xcoord {i level ln} {
4071    global canvx0 xspc1 xspc2
4072
4073    set x [expr {$canvx0 + $i * $xspc1($ln)}]
4074    if {$i > 0 && $i == $level} {
4075        set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4076    } elseif {$i > $level} {
4077        set x [expr {$x + $xspc2 - $xspc1($ln)}]
4078    }
4079    return $x
4080}
4081
4082proc show_status {msg} {
4083    global canv fgcolor
4084
4085    clear_display
4086    $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4087        -tags text -fill $fgcolor
4088}
4089
4090# Insert a new commit as the child of the commit on row $row.
4091# The new commit will be displayed on row $row and the commits
4092# on that row and below will move down one row.
4093proc insertrow {row newcmit} {
4094    global displayorder parentlist commitlisted children
4095    global commitrow curview rowidlist rowisopt rowfinal numcommits
4096    global numcommits
4097    global selectedline commitidx ordertok
4098
4099    if {$row >= $numcommits} {
4100        puts "oops, inserting new row $row but only have $numcommits rows"
4101        return
4102    }
4103    set p [lindex $displayorder $row]
4104    set displayorder [linsert $displayorder $row $newcmit]
4105    set parentlist [linsert $parentlist $row $p]
4106    set kids $children($curview,$p)
4107    lappend kids $newcmit
4108    set children($curview,$p) $kids
4109    set children($curview,$newcmit) {}
4110    set commitlisted [linsert $commitlisted $row 1]
4111    set l [llength $displayorder]
4112    for {set r $row} {$r < $l} {incr r} {
4113        set id [lindex $displayorder $r]
4114        set commitrow($curview,$id) $r
4115    }
4116    incr commitidx($curview)
4117    set ordertok($curview,$newcmit) $ordertok($curview,$p)
4118
4119    if {$row < [llength $rowidlist]} {
4120        set idlist [lindex $rowidlist $row]
4121        if {$idlist ne {}} {
4122            if {[llength $kids] == 1} {
4123                set col [lsearch -exact $idlist $p]
4124                lset idlist $col $newcmit
4125            } else {
4126                set col [llength $idlist]
4127                lappend idlist $newcmit
4128            }
4129        }
4130        set rowidlist [linsert $rowidlist $row $idlist]
4131        set rowisopt [linsert $rowisopt $row 0]
4132        set rowfinal [linsert $rowfinal $row [lindex $rowfinal $row]]
4133    }
4134
4135    incr numcommits
4136
4137    if {[info exists selectedline] && $selectedline >= $row} {
4138        incr selectedline
4139    }
4140    redisplay
4141}
4142
4143# Remove a commit that was inserted with insertrow on row $row.
4144proc removerow {row} {
4145    global displayorder parentlist commitlisted children
4146    global commitrow curview rowidlist rowisopt rowfinal numcommits
4147    global numcommits
4148    global linesegends selectedline commitidx
4149
4150    if {$row >= $numcommits} {
4151        puts "oops, removing row $row but only have $numcommits rows"
4152        return
4153    }
4154    set rp1 [expr {$row + 1}]
4155    set id [lindex $displayorder $row]
4156    set p [lindex $parentlist $row]
4157    set displayorder [lreplace $displayorder $row $row]
4158    set parentlist [lreplace $parentlist $row $row]
4159    set commitlisted [lreplace $commitlisted $row $row]
4160    set kids $children($curview,$p)
4161    set i [lsearch -exact $kids $id]
4162    if {$i >= 0} {
4163        set kids [lreplace $kids $i $i]
4164        set children($curview,$p) $kids
4165    }
4166    set l [llength $displayorder]
4167    for {set r $row} {$r < $l} {incr r} {
4168        set id [lindex $displayorder $r]
4169        set commitrow($curview,$id) $r
4170    }
4171    incr commitidx($curview) -1
4172
4173    if {$row < [llength $rowidlist]} {
4174        set rowidlist [lreplace $rowidlist $row $row]
4175        set rowisopt [lreplace $rowisopt $row $row]
4176        set rowfinal [lreplace $rowfinal $row $row]
4177    }
4178
4179    incr numcommits -1
4180
4181    if {[info exists selectedline] && $selectedline > $row} {
4182        incr selectedline -1
4183    }
4184    redisplay
4185}
4186
4187# Don't change the text pane cursor if it is currently the hand cursor,
4188# showing that we are over a sha1 ID link.
4189proc settextcursor {c} {
4190    global ctext curtextcursor
4191
4192    if {[$ctext cget -cursor] == $curtextcursor} {
4193        $ctext config -cursor $c
4194    }
4195    set curtextcursor $c
4196}
4197
4198proc nowbusy {what} {
4199    global isbusy
4200
4201    if {[array names isbusy] eq {}} {
4202        . config -cursor watch
4203        settextcursor watch
4204    }
4205    set isbusy($what) 1
4206}
4207
4208proc notbusy {what} {
4209    global isbusy maincursor textcursor
4210
4211    catch {unset isbusy($what)}
4212    if {[array names isbusy] eq {}} {
4213        . config -cursor $maincursor
4214        settextcursor $textcursor
4215    }
4216}
4217
4218proc findmatches {f} {
4219    global findtype findstring
4220    if {$findtype == "Regexp"} {
4221        set matches [regexp -indices -all -inline $findstring $f]
4222    } else {
4223        set fs $findstring
4224        if {$findtype == "IgnCase"} {
4225            set f [string tolower $f]
4226            set fs [string tolower $fs]
4227        }
4228        set matches {}
4229        set i 0
4230        set l [string length $fs]
4231        while {[set j [string first $fs $f $i]] >= 0} {
4232            lappend matches [list $j [expr {$j+$l-1}]]
4233            set i [expr {$j + $l}]
4234        }
4235    }
4236    return $matches
4237}
4238
4239proc dofind {{rev 0}} {
4240    global findstring findstartline findcurline selectedline numcommits
4241    global gdttype filehighlight fh_serial find_dirn
4242
4243    unmarkmatches
4244    focus .
4245    if {$findstring eq {} || $numcommits == 0} return
4246    if {![info exists selectedline]} {
4247        set findstartline [lindex [visiblerows] $rev]
4248    } else {
4249        set findstartline $selectedline
4250    }
4251    set findcurline $findstartline
4252    nowbusy finding
4253    if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4254        after cancel do_file_hl $fh_serial
4255        do_file_hl $fh_serial
4256    }
4257    if {!$rev} {
4258        set find_dirn 1
4259        run findmore
4260    } else {
4261        set find_dirn -1
4262        run findmorerev
4263    }
4264}
4265
4266proc stopfinding {} {
4267    global find_dirn findcurline fprogcoord
4268
4269    if {[info exists find_dirn]} {
4270        unset find_dirn
4271        unset findcurline
4272        notbusy finding
4273        set fprogcoord 0
4274        adjustprogress
4275    }
4276}
4277
4278proc findnext {restart} {
4279    global findcurline find_dirn
4280
4281    if {[info exists find_dirn]} return
4282    set find_dirn 1
4283    if {![info exists findcurline]} {
4284        if {$restart} {
4285            dofind
4286        } else {
4287            bell
4288        }
4289    } else {
4290        run findmore
4291        nowbusy finding
4292    }
4293}
4294
4295proc findprev {} {
4296    global findcurline find_dirn
4297
4298    if {[info exists find_dirn]} return
4299    set find_dirn -1
4300    if {![info exists findcurline]} {
4301        dofind 1
4302    } else {
4303        run findmorerev
4304        nowbusy finding
4305    }
4306}
4307
4308proc findmore {} {
4309    global commitdata commitinfo numcommits findpattern findloc
4310    global findstartline findcurline displayorder
4311    global find_dirn gdttype fhighlights fprogcoord
4312
4313    if {![info exists find_dirn]} {
4314        return 0
4315    }
4316    set fldtypes {Headline Author Date Committer CDate Comments}
4317    set l [expr {$findcurline + 1}]
4318    if {$l >= $numcommits} {
4319        set l 0
4320    }
4321    if {$l <= $findstartline} {
4322        set lim [expr {$findstartline + 1}]
4323    } else {
4324        set lim $numcommits
4325    }
4326    if {$lim - $l > 500} {
4327        set lim [expr {$l + 500}]
4328    }
4329    set found 0
4330    set domore 1
4331    if {$gdttype eq "containing:"} {
4332        for {} {$l < $lim} {incr l} {
4333            set id [lindex $displayorder $l]
4334            # shouldn't happen unless git log doesn't give all the commits...
4335            if {![info exists commitdata($id)]} continue
4336            if {![doesmatch $commitdata($id)]} continue
4337            if {![info exists commitinfo($id)]} {
4338                getcommit $id
4339            }
4340            set info $commitinfo($id)
4341            foreach f $info ty $fldtypes {
4342                if {($findloc eq "All fields" || $findloc eq $ty) &&
4343                    [doesmatch $f]} {
4344                    set found 1
4345                    break
4346                }
4347            }
4348            if {$found} break
4349        }
4350    } else {
4351        for {} {$l < $lim} {incr l} {
4352            set id [lindex $displayorder $l]
4353            if {![info exists fhighlights($l)]} {
4354                askfilehighlight $l $id
4355                if {$domore} {
4356                    set domore 0
4357                    set findcurline [expr {$l - 1}]
4358                }
4359            } elseif {$fhighlights($l)} {
4360                set found $domore
4361                break
4362            }
4363        }
4364    }
4365    if {$found || ($domore && $l == $findstartline + 1)} {
4366        unset findcurline
4367        unset find_dirn
4368        notbusy finding
4369        set fprogcoord 0
4370        adjustprogress
4371        if {$found} {
4372            findselectline $l
4373        } else {
4374            bell
4375        }
4376        return 0
4377    }
4378    if {!$domore} {
4379        flushhighlights
4380    } else {
4381        set findcurline [expr {$l - 1}]
4382    }
4383    set n [expr {$findcurline - ($findstartline + 1)}]
4384    if {$n < 0} {
4385        incr n $numcommits
4386    }
4387    set fprogcoord [expr {$n * 1.0 / $numcommits}]
4388    adjustprogress
4389    return $domore
4390}
4391
4392proc findmorerev {} {
4393    global commitdata commitinfo numcommits findpattern findloc
4394    global findstartline findcurline displayorder
4395    global find_dirn gdttype fhighlights fprogcoord
4396
4397    if {![info exists find_dirn]} {
4398        return 0
4399    }
4400    set fldtypes {Headline Author Date Committer CDate Comments}
4401    set l $findcurline
4402    if {$l == 0} {
4403        set l $numcommits
4404    }
4405    incr l -1
4406    if {$l >= $findstartline} {
4407        set lim [expr {$findstartline - 1}]
4408    } else {
4409        set lim -1
4410    }
4411    if {$l - $lim > 500} {
4412        set lim [expr {$l - 500}]
4413    }
4414    set found 0
4415    set domore 1
4416    if {$gdttype eq "containing:"} {
4417        for {} {$l > $lim} {incr l -1} {
4418            set id [lindex $displayorder $l]
4419            if {![info exists commitdata($id)]} continue
4420            if {![doesmatch $commitdata($id)]} continue
4421            if {![info exists commitinfo($id)]} {
4422                getcommit $id
4423            }
4424            set info $commitinfo($id)
4425            foreach f $info ty $fldtypes {
4426                if {($findloc eq "All fields" || $findloc eq $ty) &&
4427                    [doesmatch $f]} {
4428                    set found 1
4429                    break
4430                }
4431            }
4432            if {$found} break
4433        }
4434    } else {
4435        for {} {$l > $lim} {incr l -1} {
4436            set id [lindex $displayorder $l]
4437            if {![info exists fhighlights($l)]} {
4438                askfilehighlight $l $id
4439                if {$domore} {
4440                    set domore 0
4441                    set findcurline [expr {$l + 1}]
4442                }
4443            } elseif {$fhighlights($l)} {
4444                set found $domore
4445                break
4446            }
4447        }
4448    }
4449    if {$found || ($domore && $l == $findstartline - 1)} {
4450        unset findcurline
4451        unset find_dirn
4452        notbusy finding
4453        set fprogcoord 0
4454        adjustprogress
4455        if {$found} {
4456            findselectline $l
4457        } else {
4458            bell
4459        }
4460        return 0
4461    }
4462    if {!$domore} {
4463        flushhighlights
4464    } else {
4465        set findcurline [expr {$l + 1}]
4466    }
4467    set n [expr {($findstartline - 1) - $findcurline}]
4468    if {$n < 0} {
4469        incr n $numcommits
4470    }
4471    set fprogcoord [expr {$n * 1.0 / $numcommits}]
4472    adjustprogress
4473    return $domore
4474}
4475
4476proc findselectline {l} {
4477    global findloc commentend ctext findcurline markingmatches gdttype
4478
4479    set markingmatches 1
4480    set findcurline $l
4481    selectline $l 1
4482    if {$findloc == "All fields" || $findloc == "Comments"} {
4483        # highlight the matches in the comments
4484        set f [$ctext get 1.0 $commentend]
4485        set matches [findmatches $f]
4486        foreach match $matches {
4487            set start [lindex $match 0]
4488            set end [expr {[lindex $match 1] + 1}]
4489            $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4490        }
4491    }
4492    drawvisible
4493}
4494
4495# mark the bits of a headline or author that match a find string
4496proc markmatches {canv l str tag matches font row} {
4497    global selectedline
4498
4499    set bbox [$canv bbox $tag]
4500    set x0 [lindex $bbox 0]
4501    set y0 [lindex $bbox 1]
4502    set y1 [lindex $bbox 3]
4503    foreach match $matches {
4504        set start [lindex $match 0]
4505        set end [lindex $match 1]
4506        if {$start > $end} continue
4507        set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4508        set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4509        set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4510                   [expr {$x0+$xlen+2}] $y1 \
4511                   -outline {} -tags [list match$l matches] -fill yellow]
4512        $canv lower $t
4513        if {[info exists selectedline] && $row == $selectedline} {
4514            $canv raise $t secsel
4515        }
4516    }
4517}
4518
4519proc unmarkmatches {} {
4520    global markingmatches
4521
4522    allcanvs delete matches
4523    set markingmatches 0
4524    stopfinding
4525}
4526
4527proc selcanvline {w x y} {
4528    global canv canvy0 ctext linespc
4529    global rowtextx
4530    set ymax [lindex [$canv cget -scrollregion] 3]
4531    if {$ymax == {}} return
4532    set yfrac [lindex [$canv yview] 0]
4533    set y [expr {$y + $yfrac * $ymax}]
4534    set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4535    if {$l < 0} {
4536        set l 0
4537    }
4538    if {$w eq $canv} {
4539        if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4540    }
4541    unmarkmatches
4542    selectline $l 1
4543}
4544
4545proc commit_descriptor {p} {
4546    global commitinfo
4547    if {![info exists commitinfo($p)]} {
4548        getcommit $p
4549    }
4550    set l "..."
4551    if {[llength $commitinfo($p)] > 1} {
4552        set l [lindex $commitinfo($p) 0]
4553    }
4554    return "$p ($l)\n"
4555}
4556
4557# append some text to the ctext widget, and make any SHA1 ID
4558# that we know about be a clickable link.
4559proc appendwithlinks {text tags} {
4560    global ctext commitrow linknum curview pendinglinks
4561
4562    set start [$ctext index "end - 1c"]
4563    $ctext insert end $text $tags
4564    set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4565    foreach l $links {
4566        set s [lindex $l 0]
4567        set e [lindex $l 1]
4568        set linkid [string range $text $s $e]
4569        incr e
4570        $ctext tag delete link$linknum
4571        $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4572        setlink $linkid link$linknum
4573        incr linknum
4574    }
4575}
4576
4577proc setlink {id lk} {
4578    global curview commitrow ctext pendinglinks commitinterest
4579
4580    if {[info exists commitrow($curview,$id)]} {
4581        $ctext tag conf $lk -foreground blue -underline 1
4582        $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4583        $ctext tag bind $lk <Enter> {linkcursor %W 1}
4584        $ctext tag bind $lk <Leave> {linkcursor %W -1}
4585    } else {
4586        lappend pendinglinks($id) $lk
4587        lappend commitinterest($id) {makelink %I}
4588    }
4589}
4590
4591proc makelink {id} {
4592    global pendinglinks
4593
4594    if {![info exists pendinglinks($id)]} return
4595    foreach lk $pendinglinks($id) {
4596        setlink $id $lk
4597    }
4598    unset pendinglinks($id)
4599}
4600
4601proc linkcursor {w inc} {
4602    global linkentercount curtextcursor
4603
4604    if {[incr linkentercount $inc] > 0} {
4605        $w configure -cursor hand2
4606    } else {
4607        $w configure -cursor $curtextcursor
4608        if {$linkentercount < 0} {
4609            set linkentercount 0
4610        }
4611    }
4612}
4613
4614proc viewnextline {dir} {
4615    global canv linespc
4616
4617    $canv delete hover
4618    set ymax [lindex [$canv cget -scrollregion] 3]
4619    set wnow [$canv yview]
4620    set wtop [expr {[lindex $wnow 0] * $ymax}]
4621    set newtop [expr {$wtop + $dir * $linespc}]
4622    if {$newtop < 0} {
4623        set newtop 0
4624    } elseif {$newtop > $ymax} {
4625        set newtop $ymax
4626    }
4627    allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4628}
4629
4630# add a list of tag or branch names at position pos
4631# returns the number of names inserted
4632proc appendrefs {pos ids var} {
4633    global ctext commitrow linknum curview $var maxrefs
4634
4635    if {[catch {$ctext index $pos}]} {
4636        return 0
4637    }
4638    $ctext conf -state normal
4639    $ctext delete $pos "$pos lineend"
4640    set tags {}
4641    foreach id $ids {
4642        foreach tag [set $var\($id\)] {
4643            lappend tags [list $tag $id]
4644        }
4645    }
4646    if {[llength $tags] > $maxrefs} {
4647        $ctext insert $pos "many ([llength $tags])"
4648    } else {
4649        set tags [lsort -index 0 -decreasing $tags]
4650        set sep {}
4651        foreach ti $tags {
4652            set id [lindex $ti 1]
4653            set lk link$linknum
4654            incr linknum
4655            $ctext tag delete $lk
4656            $ctext insert $pos $sep
4657            $ctext insert $pos [lindex $ti 0] $lk
4658            setlink $id $lk
4659            set sep ", "
4660        }
4661    }
4662    $ctext conf -state disabled
4663    return [llength $tags]
4664}
4665
4666# called when we have finished computing the nearby tags
4667proc dispneartags {delay} {
4668    global selectedline currentid showneartags tagphase
4669
4670    if {![info exists selectedline] || !$showneartags} return
4671    after cancel dispnexttag
4672    if {$delay} {
4673        after 200 dispnexttag
4674        set tagphase -1
4675    } else {
4676        after idle dispnexttag
4677        set tagphase 0
4678    }
4679}
4680
4681proc dispnexttag {} {
4682    global selectedline currentid showneartags tagphase ctext
4683
4684    if {![info exists selectedline] || !$showneartags} return
4685    switch -- $tagphase {
4686        0 {
4687            set dtags [desctags $currentid]
4688            if {$dtags ne {}} {
4689                appendrefs precedes $dtags idtags
4690            }
4691        }
4692        1 {
4693            set atags [anctags $currentid]
4694            if {$atags ne {}} {
4695                appendrefs follows $atags idtags
4696            }
4697        }
4698        2 {
4699            set dheads [descheads $currentid]
4700            if {$dheads ne {}} {
4701                if {[appendrefs branch $dheads idheads] > 1
4702                    && [$ctext get "branch -3c"] eq "h"} {
4703                    # turn "Branch" into "Branches"
4704                    $ctext conf -state normal
4705                    $ctext insert "branch -2c" "es"
4706                    $ctext conf -state disabled
4707                }
4708            }
4709        }
4710    }
4711    if {[incr tagphase] <= 2} {
4712        after idle dispnexttag
4713    }
4714}
4715
4716proc make_secsel {l} {
4717    global linehtag linentag linedtag canv canv2 canv3
4718
4719    if {![info exists linehtag($l)]} return
4720    $canv delete secsel
4721    set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4722               -tags secsel -fill [$canv cget -selectbackground]]
4723    $canv lower $t
4724    $canv2 delete secsel
4725    set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4726               -tags secsel -fill [$canv2 cget -selectbackground]]
4727    $canv2 lower $t
4728    $canv3 delete secsel
4729    set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4730               -tags secsel -fill [$canv3 cget -selectbackground]]
4731    $canv3 lower $t
4732}
4733
4734proc selectline {l isnew} {
4735    global canv ctext commitinfo selectedline
4736    global displayorder
4737    global canvy0 linespc parentlist children curview
4738    global currentid sha1entry
4739    global commentend idtags linknum
4740    global mergemax numcommits pending_select
4741    global cmitmode showneartags allcommits
4742
4743    catch {unset pending_select}
4744    $canv delete hover
4745    normalline
4746    unsel_reflist
4747    stopfinding
4748    if {$l < 0 || $l >= $numcommits} return
4749    set y [expr {$canvy0 + $l * $linespc}]
4750    set ymax [lindex [$canv cget -scrollregion] 3]
4751    set ytop [expr {$y - $linespc - 1}]
4752    set ybot [expr {$y + $linespc + 1}]
4753    set wnow [$canv yview]
4754    set wtop [expr {[lindex $wnow 0] * $ymax}]
4755    set wbot [expr {[lindex $wnow 1] * $ymax}]
4756    set wh [expr {$wbot - $wtop}]
4757    set newtop $wtop
4758    if {$ytop < $wtop} {
4759        if {$ybot < $wtop} {
4760            set newtop [expr {$y - $wh / 2.0}]
4761        } else {
4762            set newtop $ytop
4763            if {$newtop > $wtop - $linespc} {
4764                set newtop [expr {$wtop - $linespc}]
4765            }
4766        }
4767    } elseif {$ybot > $wbot} {
4768        if {$ytop > $wbot} {
4769            set newtop [expr {$y - $wh / 2.0}]
4770        } else {
4771            set newtop [expr {$ybot - $wh}]
4772            if {$newtop < $wtop + $linespc} {
4773                set newtop [expr {$wtop + $linespc}]
4774            }
4775        }
4776    }
4777    if {$newtop != $wtop} {
4778        if {$newtop < 0} {
4779            set newtop 0
4780        }
4781        allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4782        drawvisible
4783    }
4784
4785    make_secsel $l
4786
4787    if {$isnew} {
4788        addtohistory [list selectline $l 0]
4789    }
4790
4791    set selectedline $l
4792
4793    set id [lindex $displayorder $l]
4794    set currentid $id
4795    $sha1entry delete 0 end
4796    $sha1entry insert 0 $id
4797    $sha1entry selection from 0
4798    $sha1entry selection to end
4799    rhighlight_sel $id
4800
4801    $ctext conf -state normal
4802    clear_ctext
4803    set linknum 0
4804    set info $commitinfo($id)
4805    set date [formatdate [lindex $info 2]]
4806    $ctext insert end "Author: [lindex $info 1]  $date\n"
4807    set date [formatdate [lindex $info 4]]
4808    $ctext insert end "Committer: [lindex $info 3]  $date\n"
4809    if {[info exists idtags($id)]} {
4810        $ctext insert end "Tags:"
4811        foreach tag $idtags($id) {
4812            $ctext insert end " $tag"
4813        }
4814        $ctext insert end "\n"
4815    }
4816
4817    set headers {}
4818    set olds [lindex $parentlist $l]
4819    if {[llength $olds] > 1} {
4820        set np 0
4821        foreach p $olds {
4822            if {$np >= $mergemax} {
4823                set tag mmax
4824            } else {
4825                set tag m$np
4826            }
4827            $ctext insert end "Parent: " $tag
4828            appendwithlinks [commit_descriptor $p] {}
4829            incr np
4830        }
4831    } else {
4832        foreach p $olds {
4833            append headers "Parent: [commit_descriptor $p]"
4834        }
4835    }
4836
4837    foreach c $children($curview,$id) {
4838        append headers "Child:  [commit_descriptor $c]"
4839    }
4840
4841    # make anything that looks like a SHA1 ID be a clickable link
4842    appendwithlinks $headers {}
4843    if {$showneartags} {
4844        if {![info exists allcommits]} {
4845            getallcommits
4846        }
4847        $ctext insert end "Branch: "
4848        $ctext mark set branch "end -1c"
4849        $ctext mark gravity branch left
4850        $ctext insert end "\nFollows: "
4851        $ctext mark set follows "end -1c"
4852        $ctext mark gravity follows left
4853        $ctext insert end "\nPrecedes: "
4854        $ctext mark set precedes "end -1c"
4855        $ctext mark gravity precedes left
4856        $ctext insert end "\n"
4857        dispneartags 1
4858    }
4859    $ctext insert end "\n"
4860    set comment [lindex $info 5]
4861    if {[string first "\r" $comment] >= 0} {
4862        set comment [string map {"\r" "\n    "} $comment]
4863    }
4864    appendwithlinks $comment {comment}
4865
4866    $ctext tag remove found 1.0 end
4867    $ctext conf -state disabled
4868    set commentend [$ctext index "end - 1c"]
4869
4870    init_flist "Comments"
4871    if {$cmitmode eq "tree"} {
4872        gettree $id
4873    } elseif {[llength $olds] <= 1} {
4874        startdiff $id
4875    } else {
4876        mergediff $id $l
4877    }
4878}
4879
4880proc selfirstline {} {
4881    unmarkmatches
4882    selectline 0 1
4883}
4884
4885proc sellastline {} {
4886    global numcommits
4887    unmarkmatches
4888    set l [expr {$numcommits - 1}]
4889    selectline $l 1
4890}
4891
4892proc selnextline {dir} {
4893    global selectedline
4894    focus .
4895    if {![info exists selectedline]} return
4896    set l [expr {$selectedline + $dir}]
4897    unmarkmatches
4898    selectline $l 1
4899}
4900
4901proc selnextpage {dir} {
4902    global canv linespc selectedline numcommits
4903
4904    set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4905    if {$lpp < 1} {
4906        set lpp 1
4907    }
4908    allcanvs yview scroll [expr {$dir * $lpp}] units
4909    drawvisible
4910    if {![info exists selectedline]} return
4911    set l [expr {$selectedline + $dir * $lpp}]
4912    if {$l < 0} {
4913        set l 0
4914    } elseif {$l >= $numcommits} {
4915        set l [expr $numcommits - 1]
4916    }
4917    unmarkmatches
4918    selectline $l 1
4919}
4920
4921proc unselectline {} {
4922    global selectedline currentid
4923
4924    catch {unset selectedline}
4925    catch {unset currentid}
4926    allcanvs delete secsel
4927    rhighlight_none
4928}
4929
4930proc reselectline {} {
4931    global selectedline
4932
4933    if {[info exists selectedline]} {
4934        selectline $selectedline 0
4935    }
4936}
4937
4938proc addtohistory {cmd} {
4939    global history historyindex curview
4940
4941    set elt [list $curview $cmd]
4942    if {$historyindex > 0
4943        && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4944        return
4945    }
4946
4947    if {$historyindex < [llength $history]} {
4948        set history [lreplace $history $historyindex end $elt]
4949    } else {
4950        lappend history $elt
4951    }
4952    incr historyindex
4953    if {$historyindex > 1} {
4954        .tf.bar.leftbut conf -state normal
4955    } else {
4956        .tf.bar.leftbut conf -state disabled
4957    }
4958    .tf.bar.rightbut conf -state disabled
4959}
4960
4961proc godo {elt} {
4962    global curview
4963
4964    set view [lindex $elt 0]
4965    set cmd [lindex $elt 1]
4966    if {$curview != $view} {
4967        showview $view
4968    }
4969    eval $cmd
4970}
4971
4972proc goback {} {
4973    global history historyindex
4974    focus .
4975
4976    if {$historyindex > 1} {
4977        incr historyindex -1
4978        godo [lindex $history [expr {$historyindex - 1}]]
4979        .tf.bar.rightbut conf -state normal
4980    }
4981    if {$historyindex <= 1} {
4982        .tf.bar.leftbut conf -state disabled
4983    }
4984}
4985
4986proc goforw {} {
4987    global history historyindex
4988    focus .
4989
4990    if {$historyindex < [llength $history]} {
4991        set cmd [lindex $history $historyindex]
4992        incr historyindex
4993        godo $cmd
4994        .tf.bar.leftbut conf -state normal
4995    }
4996    if {$historyindex >= [llength $history]} {
4997        .tf.bar.rightbut conf -state disabled
4998    }
4999}
5000
5001proc gettree {id} {
5002    global treefilelist treeidlist diffids diffmergeid treepending
5003    global nullid nullid2
5004
5005    set diffids $id
5006    catch {unset diffmergeid}
5007    if {![info exists treefilelist($id)]} {
5008        if {![info exists treepending]} {
5009            if {$id eq $nullid} {
5010                set cmd [list | git ls-files]
5011            } elseif {$id eq $nullid2} {
5012                set cmd [list | git ls-files --stage -t]
5013            } else {
5014                set cmd [list | git ls-tree -r $id]
5015            }
5016            if {[catch {set gtf [open $cmd r]}]} {
5017                return
5018            }
5019            set treepending $id
5020            set treefilelist($id) {}
5021            set treeidlist($id) {}
5022            fconfigure $gtf -blocking 0
5023            filerun $gtf [list gettreeline $gtf $id]
5024        }
5025    } else {
5026        setfilelist $id
5027    }
5028}
5029
5030proc gettreeline {gtf id} {
5031    global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5032
5033    set nl 0
5034    while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5035        if {$diffids eq $nullid} {
5036            set fname $line
5037        } else {
5038            if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5039            set i [string first "\t" $line]
5040            if {$i < 0} continue
5041            set sha1 [lindex $line 2]
5042            set fname [string range $line [expr {$i+1}] end]
5043            if {[string index $fname 0] eq "\""} {
5044                set fname [lindex $fname 0]
5045            }
5046            lappend treeidlist($id) $sha1
5047        }
5048        lappend treefilelist($id) $fname
5049    }
5050    if {![eof $gtf]} {
5051        return [expr {$nl >= 1000? 2: 1}]
5052    }
5053    close $gtf
5054    unset treepending
5055    if {$cmitmode ne "tree"} {
5056        if {![info exists diffmergeid]} {
5057            gettreediffs $diffids
5058        }
5059    } elseif {$id ne $diffids} {
5060        gettree $diffids
5061    } else {
5062        setfilelist $id
5063    }
5064    return 0
5065}
5066
5067proc showfile {f} {
5068    global treefilelist treeidlist diffids nullid nullid2
5069    global ctext commentend
5070
5071    set i [lsearch -exact $treefilelist($diffids) $f]
5072    if {$i < 0} {
5073        puts "oops, $f not in list for id $diffids"
5074        return
5075    }
5076    if {$diffids eq $nullid} {
5077        if {[catch {set bf [open $f r]} err]} {
5078            puts "oops, can't read $f: $err"
5079            return
5080        }
5081    } else {
5082        set blob [lindex $treeidlist($diffids) $i]
5083        if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5084            puts "oops, error reading blob $blob: $err"
5085            return
5086        }
5087    }
5088    fconfigure $bf -blocking 0
5089    filerun $bf [list getblobline $bf $diffids]
5090    $ctext config -state normal
5091    clear_ctext $commentend
5092    $ctext insert end "\n"
5093    $ctext insert end "$f\n" filesep
5094    $ctext config -state disabled
5095    $ctext yview $commentend
5096    settabs 0
5097}
5098
5099proc getblobline {bf id} {
5100    global diffids cmitmode ctext
5101
5102    if {$id ne $diffids || $cmitmode ne "tree"} {
5103        catch {close $bf}
5104        return 0
5105    }
5106    $ctext config -state normal
5107    set nl 0
5108    while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5109        $ctext insert end "$line\n"
5110    }
5111    if {[eof $bf]} {
5112        # delete last newline
5113        $ctext delete "end - 2c" "end - 1c"
5114        close $bf
5115        return 0
5116    }
5117    $ctext config -state disabled
5118    return [expr {$nl >= 1000? 2: 1}]
5119}
5120
5121proc mergediff {id l} {
5122    global diffmergeid diffopts mdifffd
5123    global diffids
5124    global parentlist
5125
5126    set diffmergeid $id
5127    set diffids $id
5128    # this doesn't seem to actually affect anything...
5129    set env(GIT_DIFF_OPTS) $diffopts
5130    set cmd [concat | git diff-tree --no-commit-id --cc $id]
5131    if {[catch {set mdf [open $cmd r]} err]} {
5132        error_popup "Error getting merge diffs: $err"
5133        return
5134    }
5135    fconfigure $mdf -blocking 0
5136    set mdifffd($id) $mdf
5137    set np [llength [lindex $parentlist $l]]
5138    settabs $np
5139    filerun $mdf [list getmergediffline $mdf $id $np]
5140}
5141
5142proc getmergediffline {mdf id np} {
5143    global diffmergeid ctext cflist mergemax
5144    global difffilestart mdifffd
5145
5146    $ctext conf -state normal
5147    set nr 0
5148    while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5149        if {![info exists diffmergeid] || $id != $diffmergeid
5150            || $mdf != $mdifffd($id)} {
5151            close $mdf
5152            return 0
5153        }
5154        if {[regexp {^diff --cc (.*)} $line match fname]} {
5155            # start of a new file
5156            $ctext insert end "\n"
5157            set here [$ctext index "end - 1c"]
5158            lappend difffilestart $here
5159            add_flist [list $fname]
5160            set l [expr {(78 - [string length $fname]) / 2}]
5161            set pad [string range "----------------------------------------" 1 $l]
5162            $ctext insert end "$pad $fname $pad\n" filesep
5163        } elseif {[regexp {^@@} $line]} {
5164            $ctext insert end "$line\n" hunksep
5165        } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5166            # do nothing
5167        } else {
5168            # parse the prefix - one ' ', '-' or '+' for each parent
5169            set spaces {}
5170            set minuses {}
5171            set pluses {}
5172            set isbad 0
5173            for {set j 0} {$j < $np} {incr j} {
5174                set c [string range $line $j $j]
5175                if {$c == " "} {
5176                    lappend spaces $j
5177                } elseif {$c == "-"} {
5178                    lappend minuses $j
5179                } elseif {$c == "+"} {
5180                    lappend pluses $j
5181                } else {
5182                    set isbad 1
5183                    break
5184                }
5185            }
5186            set tags {}
5187            set num {}
5188            if {!$isbad && $minuses ne {} && $pluses eq {}} {
5189                # line doesn't appear in result, parents in $minuses have the line
5190                set num [lindex $minuses 0]
5191            } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5192                # line appears in result, parents in $pluses don't have the line
5193                lappend tags mresult
5194                set num [lindex $spaces 0]
5195            }
5196            if {$num ne {}} {
5197                if {$num >= $mergemax} {
5198                    set num "max"
5199                }
5200                lappend tags m$num
5201            }
5202            $ctext insert end "$line\n" $tags
5203        }
5204    }
5205    $ctext conf -state disabled
5206    if {[eof $mdf]} {
5207        close $mdf
5208        return 0
5209    }
5210    return [expr {$nr >= 1000? 2: 1}]
5211}
5212
5213proc startdiff {ids} {
5214    global treediffs diffids treepending diffmergeid nullid nullid2
5215
5216    settabs 1
5217    set diffids $ids
5218    catch {unset diffmergeid}
5219    if {![info exists treediffs($ids)] ||
5220        [lsearch -exact $ids $nullid] >= 0 ||
5221        [lsearch -exact $ids $nullid2] >= 0} {
5222        if {![info exists treepending]} {
5223            gettreediffs $ids
5224        }
5225    } else {
5226        addtocflist $ids
5227    }
5228}
5229
5230proc addtocflist {ids} {
5231    global treediffs cflist
5232    add_flist $treediffs($ids)
5233    getblobdiffs $ids
5234}
5235
5236proc diffcmd {ids flags} {
5237    global nullid nullid2
5238
5239    set i [lsearch -exact $ids $nullid]
5240    set j [lsearch -exact $ids $nullid2]
5241    if {$i >= 0} {
5242        if {[llength $ids] > 1 && $j < 0} {
5243            # comparing working directory with some specific revision
5244            set cmd [concat | git diff-index $flags]
5245            if {$i == 0} {
5246                lappend cmd -R [lindex $ids 1]
5247            } else {
5248                lappend cmd [lindex $ids 0]
5249            }
5250        } else {
5251            # comparing working directory with index
5252            set cmd [concat | git diff-files $flags]
5253            if {$j == 1} {
5254                lappend cmd -R
5255            }
5256        }
5257    } elseif {$j >= 0} {
5258        set cmd [concat | git diff-index --cached $flags]
5259        if {[llength $ids] > 1} {
5260            # comparing index with specific revision
5261            if {$i == 0} {
5262                lappend cmd -R [lindex $ids 1]
5263            } else {
5264                lappend cmd [lindex $ids 0]
5265            }
5266        } else {
5267            # comparing index with HEAD
5268            lappend cmd HEAD
5269        }
5270    } else {
5271        set cmd [concat | git diff-tree -r $flags $ids]
5272    }
5273    return $cmd
5274}
5275
5276proc gettreediffs {ids} {
5277    global treediff treepending
5278
5279    set treepending $ids
5280    set treediff {}
5281    if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5282    fconfigure $gdtf -blocking 0
5283    filerun $gdtf [list gettreediffline $gdtf $ids]
5284}
5285
5286proc gettreediffline {gdtf ids} {
5287    global treediff treediffs treepending diffids diffmergeid
5288    global cmitmode
5289
5290    set nr 0
5291    while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5292        set i [string first "\t" $line]
5293        if {$i >= 0} {
5294            set file [string range $line [expr {$i+1}] end]
5295            if {[string index $file 0] eq "\""} {
5296                set file [lindex $file 0]
5297            }
5298            lappend treediff $file
5299        }
5300    }
5301    if {![eof $gdtf]} {
5302        return [expr {$nr >= 1000? 2: 1}]
5303    }
5304    close $gdtf
5305    set treediffs($ids) $treediff
5306    unset treepending
5307    if {$cmitmode eq "tree"} {
5308        gettree $diffids
5309    } elseif {$ids != $diffids} {
5310        if {![info exists diffmergeid]} {
5311            gettreediffs $diffids
5312        }
5313    } else {
5314        addtocflist $ids
5315    }
5316    return 0
5317}
5318
5319# empty string or positive integer
5320proc diffcontextvalidate {v} {
5321    return [regexp {^(|[1-9][0-9]*)$} $v]
5322}
5323
5324proc diffcontextchange {n1 n2 op} {
5325    global diffcontextstring diffcontext
5326
5327    if {[string is integer -strict $diffcontextstring]} {
5328        if {$diffcontextstring > 0} {
5329            set diffcontext $diffcontextstring
5330            reselectline
5331        }
5332    }
5333}
5334
5335proc getblobdiffs {ids} {
5336    global diffopts blobdifffd diffids env
5337    global diffinhdr treediffs
5338    global diffcontext
5339
5340    set env(GIT_DIFF_OPTS) $diffopts
5341    if {[catch {set bdf [open [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"] r]} err]} {
5342        puts "error getting diffs: $err"
5343        return
5344    }
5345    set diffinhdr 0
5346    fconfigure $bdf -blocking 0
5347    set blobdifffd($ids) $bdf
5348    filerun $bdf [list getblobdiffline $bdf $diffids]
5349}
5350
5351proc setinlist {var i val} {
5352    global $var
5353
5354    while {[llength [set $var]] < $i} {
5355        lappend $var {}
5356    }
5357    if {[llength [set $var]] == $i} {
5358        lappend $var $val
5359    } else {
5360        lset $var $i $val
5361    }
5362}
5363
5364proc makediffhdr {fname ids} {
5365    global ctext curdiffstart treediffs
5366
5367    set i [lsearch -exact $treediffs($ids) $fname]
5368    if {$i >= 0} {
5369        setinlist difffilestart $i $curdiffstart
5370    }
5371    set l [expr {(78 - [string length $fname]) / 2}]
5372    set pad [string range "----------------------------------------" 1 $l]
5373    $ctext insert $curdiffstart "$pad $fname $pad" filesep
5374}
5375
5376proc getblobdiffline {bdf ids} {
5377    global diffids blobdifffd ctext curdiffstart
5378    global diffnexthead diffnextnote difffilestart
5379    global diffinhdr treediffs
5380
5381    set nr 0
5382    $ctext conf -state normal
5383    while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5384        if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5385            close $bdf
5386            return 0
5387        }
5388        if {![string compare -length 11 "diff --git " $line]} {
5389            # trim off "diff --git "
5390            set line [string range $line 11 end]
5391            set diffinhdr 1
5392            # start of a new file
5393            $ctext insert end "\n"
5394            set curdiffstart [$ctext index "end - 1c"]
5395            $ctext insert end "\n" filesep
5396            # If the name hasn't changed the length will be odd,
5397            # the middle char will be a space, and the two bits either
5398            # side will be a/name and b/name, or "a/name" and "b/name".
5399            # If the name has changed we'll get "rename from" and
5400            # "rename to" or "copy from" and "copy to" lines following this,
5401            # and we'll use them to get the filenames.
5402            # This complexity is necessary because spaces in the filename(s)
5403            # don't get escaped.
5404            set l [string length $line]
5405            set i [expr {$l / 2}]
5406            if {!(($l & 1) && [string index $line $i] eq " " &&
5407                  [string range $line 2 [expr {$i - 1}]] eq \
5408                      [string range $line [expr {$i + 3}] end])} {
5409                continue
5410            }
5411            # unescape if quoted and chop off the a/ from the front
5412            if {[string index $line 0] eq "\""} {
5413                set fname [string range [lindex $line 0] 2 end]
5414            } else {
5415                set fname [string range $line 2 [expr {$i - 1}]]
5416            }
5417            makediffhdr $fname $ids
5418
5419        } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5420                       $line match f1l f1c f2l f2c rest]} {
5421            $ctext insert end "$line\n" hunksep
5422            set diffinhdr 0
5423
5424        } elseif {$diffinhdr} {
5425            if {![string compare -length 12 "rename from " $line] ||
5426                ![string compare -length 10 "copy from " $line]} {
5427                set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5428                if {[string index $fname 0] eq "\""} {
5429                    set fname [lindex $fname 0]
5430                }
5431                set i [lsearch -exact $treediffs($ids) $fname]
5432                if {$i >= 0} {
5433                    setinlist difffilestart $i $curdiffstart
5434                }
5435            } elseif {![string compare -length 10 $line "rename to "] ||
5436                      ![string compare -length 8 $line "copy to "]} {
5437                set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5438                if {[string index $fname 0] eq "\""} {
5439                    set fname [lindex $fname 0]
5440                }
5441                makediffhdr $fname $ids
5442            } elseif {[string compare -length 3 $line "---"] == 0} {
5443                # do nothing
5444                continue
5445            } elseif {[string compare -length 3 $line "+++"] == 0} {
5446                set diffinhdr 0
5447                continue
5448            }
5449            $ctext insert end "$line\n" filesep
5450
5451        } else {
5452            set x [string range $line 0 0]
5453            if {$x == "-" || $x == "+"} {
5454                set tag [expr {$x == "+"}]
5455                $ctext insert end "$line\n" d$tag
5456            } elseif {$x == " "} {
5457                $ctext insert end "$line\n"
5458            } else {
5459                # "\ No newline at end of file",
5460                # or something else we don't recognize
5461                $ctext insert end "$line\n" hunksep
5462            }
5463        }
5464    }
5465    $ctext conf -state disabled
5466    if {[eof $bdf]} {
5467        close $bdf
5468        return 0
5469    }
5470    return [expr {$nr >= 1000? 2: 1}]
5471}
5472
5473proc changediffdisp {} {
5474    global ctext diffelide
5475
5476    $ctext tag conf d0 -elide [lindex $diffelide 0]
5477    $ctext tag conf d1 -elide [lindex $diffelide 1]
5478}
5479
5480proc prevfile {} {
5481    global difffilestart ctext
5482    set prev [lindex $difffilestart 0]
5483    set here [$ctext index @0,0]
5484    foreach loc $difffilestart {
5485        if {[$ctext compare $loc >= $here]} {
5486            $ctext yview $prev
5487            return
5488        }
5489        set prev $loc
5490    }
5491    $ctext yview $prev
5492}
5493
5494proc nextfile {} {
5495    global difffilestart ctext
5496    set here [$ctext index @0,0]
5497    foreach loc $difffilestart {
5498        if {[$ctext compare $loc > $here]} {
5499            $ctext yview $loc
5500            return
5501        }
5502    }
5503}
5504
5505proc clear_ctext {{first 1.0}} {
5506    global ctext smarktop smarkbot
5507    global pendinglinks
5508
5509    set l [lindex [split $first .] 0]
5510    if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5511        set smarktop $l
5512    }
5513    if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5514        set smarkbot $l
5515    }
5516    $ctext delete $first end
5517    if {$first eq "1.0"} {
5518        catch {unset pendinglinks}
5519    }
5520}
5521
5522proc settabs {{firstab {}}} {
5523    global firsttabstop tabstop ctext have_tk85
5524
5525    if {$firstab ne {} && $have_tk85} {
5526        set firsttabstop $firstab
5527    }
5528    set w [font measure textfont "0"]
5529    if {$firsttabstop != 0} {
5530        $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5531                               [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5532    } elseif {$have_tk85 || $tabstop != 8} {
5533        $ctext conf -tabs [expr {$tabstop * $w}]
5534    } else {
5535        $ctext conf -tabs {}
5536    }
5537}
5538
5539proc incrsearch {name ix op} {
5540    global ctext searchstring searchdirn
5541
5542    $ctext tag remove found 1.0 end
5543    if {[catch {$ctext index anchor}]} {
5544        # no anchor set, use start of selection, or of visible area
5545        set sel [$ctext tag ranges sel]
5546        if {$sel ne {}} {
5547            $ctext mark set anchor [lindex $sel 0]
5548        } elseif {$searchdirn eq "-forwards"} {
5549            $ctext mark set anchor @0,0
5550        } else {
5551            $ctext mark set anchor @0,[winfo height $ctext]
5552        }
5553    }
5554    if {$searchstring ne {}} {
5555        set here [$ctext search $searchdirn -- $searchstring anchor]
5556        if {$here ne {}} {
5557            $ctext see $here
5558        }
5559        searchmarkvisible 1
5560    }
5561}
5562
5563proc dosearch {} {
5564    global sstring ctext searchstring searchdirn
5565
5566    focus $sstring
5567    $sstring icursor end
5568    set searchdirn -forwards
5569    if {$searchstring ne {}} {
5570        set sel [$ctext tag ranges sel]
5571        if {$sel ne {}} {
5572            set start "[lindex $sel 0] + 1c"
5573        } elseif {[catch {set start [$ctext index anchor]}]} {
5574            set start "@0,0"
5575        }
5576        set match [$ctext search -count mlen -- $searchstring $start]
5577        $ctext tag remove sel 1.0 end
5578        if {$match eq {}} {
5579            bell
5580            return
5581        }
5582        $ctext see $match
5583        set mend "$match + $mlen c"
5584        $ctext tag add sel $match $mend
5585        $ctext mark unset anchor
5586    }
5587}
5588
5589proc dosearchback {} {
5590    global sstring ctext searchstring searchdirn
5591
5592    focus $sstring
5593    $sstring icursor end
5594    set searchdirn -backwards
5595    if {$searchstring ne {}} {
5596        set sel [$ctext tag ranges sel]
5597        if {$sel ne {}} {
5598            set start [lindex $sel 0]
5599        } elseif {[catch {set start [$ctext index anchor]}]} {
5600            set start @0,[winfo height $ctext]
5601        }
5602        set match [$ctext search -backwards -count ml -- $searchstring $start]
5603        $ctext tag remove sel 1.0 end
5604        if {$match eq {}} {
5605            bell
5606            return
5607        }
5608        $ctext see $match
5609        set mend "$match + $ml c"
5610        $ctext tag add sel $match $mend
5611        $ctext mark unset anchor
5612    }
5613}
5614
5615proc searchmark {first last} {
5616    global ctext searchstring
5617
5618    set mend $first.0
5619    while {1} {
5620        set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5621        if {$match eq {}} break
5622        set mend "$match + $mlen c"
5623        $ctext tag add found $match $mend
5624    }
5625}
5626
5627proc searchmarkvisible {doall} {
5628    global ctext smarktop smarkbot
5629
5630    set topline [lindex [split [$ctext index @0,0] .] 0]
5631    set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5632    if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5633        # no overlap with previous
5634        searchmark $topline $botline
5635        set smarktop $topline
5636        set smarkbot $botline
5637    } else {
5638        if {$topline < $smarktop} {
5639            searchmark $topline [expr {$smarktop-1}]
5640            set smarktop $topline
5641        }
5642        if {$botline > $smarkbot} {
5643            searchmark [expr {$smarkbot+1}] $botline
5644            set smarkbot $botline
5645        }
5646    }
5647}
5648
5649proc scrolltext {f0 f1} {
5650    global searchstring
5651
5652    .bleft.sb set $f0 $f1
5653    if {$searchstring ne {}} {
5654        searchmarkvisible 0
5655    }
5656}
5657
5658proc setcoords {} {
5659    global linespc charspc canvx0 canvy0
5660    global xspc1 xspc2 lthickness
5661
5662    set linespc [font metrics mainfont -linespace]
5663    set charspc [font measure mainfont "m"]
5664    set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5665    set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5666    set lthickness [expr {int($linespc / 9) + 1}]
5667    set xspc1(0) $linespc
5668    set xspc2 $linespc
5669}
5670
5671proc redisplay {} {
5672    global canv
5673    global selectedline
5674
5675    set ymax [lindex [$canv cget -scrollregion] 3]
5676    if {$ymax eq {} || $ymax == 0} return
5677    set span [$canv yview]
5678    clear_display
5679    setcanvscroll
5680    allcanvs yview moveto [lindex $span 0]
5681    drawvisible
5682    if {[info exists selectedline]} {
5683        selectline $selectedline 0
5684        allcanvs yview moveto [lindex $span 0]
5685    }
5686}
5687
5688proc parsefont {f n} {
5689    global fontattr
5690
5691    set fontattr($f,family) [lindex $n 0]
5692    set s [lindex $n 1]
5693    if {$s eq {} || $s == 0} {
5694        set s 10
5695    } elseif {$s < 0} {
5696        set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5697    }
5698    set fontattr($f,size) $s
5699    set fontattr($f,weight) normal
5700    set fontattr($f,slant) roman
5701    foreach style [lrange $n 2 end] {
5702        switch -- $style {
5703            "normal" -
5704            "bold"   {set fontattr($f,weight) $style}
5705            "roman" -
5706            "italic" {set fontattr($f,slant) $style}
5707        }
5708    }
5709}
5710
5711proc fontflags {f {isbold 0}} {
5712    global fontattr
5713
5714    return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5715                -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5716                -slant $fontattr($f,slant)]
5717}
5718
5719proc fontname {f} {
5720    global fontattr
5721
5722    set n [list $fontattr($f,family) $fontattr($f,size)]
5723    if {$fontattr($f,weight) eq "bold"} {
5724        lappend n "bold"
5725    }
5726    if {$fontattr($f,slant) eq "italic"} {
5727        lappend n "italic"
5728    }
5729    return $n
5730}
5731
5732proc incrfont {inc} {
5733    global mainfont textfont ctext canv phase cflist showrefstop
5734    global stopped entries fontattr
5735
5736    unmarkmatches
5737    set s $fontattr(mainfont,size)
5738    incr s $inc
5739    if {$s < 1} {
5740        set s 1
5741    }
5742    set fontattr(mainfont,size) $s
5743    font config mainfont -size $s
5744    font config mainfontbold -size $s
5745    set mainfont [fontname mainfont]
5746    set s $fontattr(textfont,size)
5747    incr s $inc
5748    if {$s < 1} {
5749        set s 1
5750    }
5751    set fontattr(textfont,size) $s
5752    font config textfont -size $s
5753    font config textfontbold -size $s
5754    set textfont [fontname textfont]
5755    setcoords
5756    settabs
5757    redisplay
5758}
5759
5760proc clearsha1 {} {
5761    global sha1entry sha1string
5762    if {[string length $sha1string] == 40} {
5763        $sha1entry delete 0 end
5764    }
5765}
5766
5767proc sha1change {n1 n2 op} {
5768    global sha1string currentid sha1but
5769    if {$sha1string == {}
5770        || ([info exists currentid] && $sha1string == $currentid)} {
5771        set state disabled
5772    } else {
5773        set state normal
5774    }
5775    if {[$sha1but cget -state] == $state} return
5776    if {$state == "normal"} {
5777        $sha1but conf -state normal -relief raised -text "Goto: "
5778    } else {
5779        $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5780    }
5781}
5782
5783proc gotocommit {} {
5784    global sha1string currentid commitrow tagids headids
5785    global displayorder numcommits curview
5786
5787    if {$sha1string == {}
5788        || ([info exists currentid] && $sha1string == $currentid)} return
5789    if {[info exists tagids($sha1string)]} {
5790        set id $tagids($sha1string)
5791    } elseif {[info exists headids($sha1string)]} {
5792        set id $headids($sha1string)
5793    } else {
5794        set id [string tolower $sha1string]
5795        if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5796            set matches {}
5797            foreach i $displayorder {
5798                if {[string match $id* $i]} {
5799                    lappend matches $i
5800                }
5801            }
5802            if {$matches ne {}} {
5803                if {[llength $matches] > 1} {
5804                    error_popup "Short SHA1 id $id is ambiguous"
5805                    return
5806                }
5807                set id [lindex $matches 0]
5808            }
5809        }
5810    }
5811    if {[info exists commitrow($curview,$id)]} {
5812        selectline $commitrow($curview,$id) 1
5813        return
5814    }
5815    if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5816        set type "SHA1 id"
5817    } else {
5818        set type "Tag/Head"
5819    }
5820    error_popup "$type $sha1string is not known"
5821}
5822
5823proc lineenter {x y id} {
5824    global hoverx hovery hoverid hovertimer
5825    global commitinfo canv
5826
5827    if {![info exists commitinfo($id)] && ![getcommit $id]} return
5828    set hoverx $x
5829    set hovery $y
5830    set hoverid $id
5831    if {[info exists hovertimer]} {
5832        after cancel $hovertimer
5833    }
5834    set hovertimer [after 500 linehover]
5835    $canv delete hover
5836}
5837
5838proc linemotion {x y id} {
5839    global hoverx hovery hoverid hovertimer
5840
5841    if {[info exists hoverid] && $id == $hoverid} {
5842        set hoverx $x
5843        set hovery $y
5844        if {[info exists hovertimer]} {
5845            after cancel $hovertimer
5846        }
5847        set hovertimer [after 500 linehover]
5848    }
5849}
5850
5851proc lineleave {id} {
5852    global hoverid hovertimer canv
5853
5854    if {[info exists hoverid] && $id == $hoverid} {
5855        $canv delete hover
5856        if {[info exists hovertimer]} {
5857            after cancel $hovertimer
5858            unset hovertimer
5859        }
5860        unset hoverid
5861    }
5862}
5863
5864proc linehover {} {
5865    global hoverx hovery hoverid hovertimer
5866    global canv linespc lthickness
5867    global commitinfo
5868
5869    set text [lindex $commitinfo($hoverid) 0]
5870    set ymax [lindex [$canv cget -scrollregion] 3]
5871    if {$ymax == {}} return
5872    set yfrac [lindex [$canv yview] 0]
5873    set x [expr {$hoverx + 2 * $linespc}]
5874    set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5875    set x0 [expr {$x - 2 * $lthickness}]
5876    set y0 [expr {$y - 2 * $lthickness}]
5877    set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5878    set y1 [expr {$y + $linespc + 2 * $lthickness}]
5879    set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5880               -fill \#ffff80 -outline black -width 1 -tags hover]
5881    $canv raise $t
5882    set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5883               -font mainfont]
5884    $canv raise $t
5885}
5886
5887proc clickisonarrow {id y} {
5888    global lthickness
5889
5890    set ranges [rowranges $id]
5891    set thresh [expr {2 * $lthickness + 6}]
5892    set n [expr {[llength $ranges] - 1}]
5893    for {set i 1} {$i < $n} {incr i} {
5894        set row [lindex $ranges $i]
5895        if {abs([yc $row] - $y) < $thresh} {
5896            return $i
5897        }
5898    }
5899    return {}
5900}
5901
5902proc arrowjump {id n y} {
5903    global canv
5904
5905    # 1 <-> 2, 3 <-> 4, etc...
5906    set n [expr {(($n - 1) ^ 1) + 1}]
5907    set row [lindex [rowranges $id] $n]
5908    set yt [yc $row]
5909    set ymax [lindex [$canv cget -scrollregion] 3]
5910    if {$ymax eq {} || $ymax <= 0} return
5911    set view [$canv yview]
5912    set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5913    set yfrac [expr {$yt / $ymax - $yspan / 2}]
5914    if {$yfrac < 0} {
5915        set yfrac 0
5916    }
5917    allcanvs yview moveto $yfrac
5918}
5919
5920proc lineclick {x y id isnew} {
5921    global ctext commitinfo children canv thickerline curview commitrow
5922
5923    if {![info exists commitinfo($id)] && ![getcommit $id]} return
5924    unmarkmatches
5925    unselectline
5926    normalline
5927    $canv delete hover
5928    # draw this line thicker than normal
5929    set thickerline $id
5930    drawlines $id
5931    if {$isnew} {
5932        set ymax [lindex [$canv cget -scrollregion] 3]
5933        if {$ymax eq {}} return
5934        set yfrac [lindex [$canv yview] 0]
5935        set y [expr {$y + $yfrac * $ymax}]
5936    }
5937    set dirn [clickisonarrow $id $y]
5938    if {$dirn ne {}} {
5939        arrowjump $id $dirn $y
5940        return
5941    }
5942
5943    if {$isnew} {
5944        addtohistory [list lineclick $x $y $id 0]
5945    }
5946    # fill the details pane with info about this line
5947    $ctext conf -state normal
5948    clear_ctext
5949    settabs 0
5950    $ctext insert end "Parent:\t"
5951    $ctext insert end $id link0
5952    setlink $id link0
5953    set info $commitinfo($id)
5954    $ctext insert end "\n\t[lindex $info 0]\n"
5955    $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5956    set date [formatdate [lindex $info 2]]
5957    $ctext insert end "\tDate:\t$date\n"
5958    set kids $children($curview,$id)
5959    if {$kids ne {}} {
5960        $ctext insert end "\nChildren:"
5961        set i 0
5962        foreach child $kids {
5963            incr i
5964            if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5965            set info $commitinfo($child)
5966            $ctext insert end "\n\t"
5967            $ctext insert end $child link$i
5968            setlink $child link$i
5969            $ctext insert end "\n\t[lindex $info 0]"
5970            $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5971            set date [formatdate [lindex $info 2]]
5972            $ctext insert end "\n\tDate:\t$date\n"
5973        }
5974    }
5975    $ctext conf -state disabled
5976    init_flist {}
5977}
5978
5979proc normalline {} {
5980    global thickerline
5981    if {[info exists thickerline]} {
5982        set id $thickerline
5983        unset thickerline
5984        drawlines $id
5985    }
5986}
5987
5988proc selbyid {id} {
5989    global commitrow curview
5990    if {[info exists commitrow($curview,$id)]} {
5991        selectline $commitrow($curview,$id) 1
5992    }
5993}
5994
5995proc mstime {} {
5996    global startmstime
5997    if {![info exists startmstime]} {
5998        set startmstime [clock clicks -milliseconds]
5999    }
6000    return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6001}
6002
6003proc rowmenu {x y id} {
6004    global rowctxmenu commitrow selectedline rowmenuid curview
6005    global nullid nullid2 fakerowmenu mainhead
6006
6007    stopfinding
6008    set rowmenuid $id
6009    if {![info exists selectedline]
6010        || $commitrow($curview,$id) eq $selectedline} {
6011        set state disabled
6012    } else {
6013        set state normal
6014    }
6015    if {$id ne $nullid && $id ne $nullid2} {
6016        set menu $rowctxmenu
6017        $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6018    } else {
6019        set menu $fakerowmenu
6020    }
6021    $menu entryconfigure "Diff this*" -state $state
6022    $menu entryconfigure "Diff selected*" -state $state
6023    $menu entryconfigure "Make patch" -state $state
6024    tk_popup $menu $x $y
6025}
6026
6027proc diffvssel {dirn} {
6028    global rowmenuid selectedline displayorder
6029
6030    if {![info exists selectedline]} return
6031    if {$dirn} {
6032        set oldid [lindex $displayorder $selectedline]
6033        set newid $rowmenuid
6034    } else {
6035        set oldid $rowmenuid
6036        set newid [lindex $displayorder $selectedline]
6037    }
6038    addtohistory [list doseldiff $oldid $newid]
6039    doseldiff $oldid $newid
6040}
6041
6042proc doseldiff {oldid newid} {
6043    global ctext
6044    global commitinfo
6045
6046    $ctext conf -state normal
6047    clear_ctext
6048    init_flist "Top"
6049    $ctext insert end "From "
6050    $ctext insert end $oldid link0
6051    setlink $oldid link0
6052    $ctext insert end "\n     "
6053    $ctext insert end [lindex $commitinfo($oldid) 0]
6054    $ctext insert end "\n\nTo   "
6055    $ctext insert end $newid link1
6056    setlink $newid link1
6057    $ctext insert end "\n     "
6058    $ctext insert end [lindex $commitinfo($newid) 0]
6059    $ctext insert end "\n"
6060    $ctext conf -state disabled
6061    $ctext tag remove found 1.0 end
6062    startdiff [list $oldid $newid]
6063}
6064
6065proc mkpatch {} {
6066    global rowmenuid currentid commitinfo patchtop patchnum
6067
6068    if {![info exists currentid]} return
6069    set oldid $currentid
6070    set oldhead [lindex $commitinfo($oldid) 0]
6071    set newid $rowmenuid
6072    set newhead [lindex $commitinfo($newid) 0]
6073    set top .patch
6074    set patchtop $top
6075    catch {destroy $top}
6076    toplevel $top
6077    label $top.title -text "Generate patch"
6078    grid $top.title - -pady 10
6079    label $top.from -text "From:"
6080    entry $top.fromsha1 -width 40 -relief flat
6081    $top.fromsha1 insert 0 $oldid
6082    $top.fromsha1 conf -state readonly
6083    grid $top.from $top.fromsha1 -sticky w
6084    entry $top.fromhead -width 60 -relief flat
6085    $top.fromhead insert 0 $oldhead
6086    $top.fromhead conf -state readonly
6087    grid x $top.fromhead -sticky w
6088    label $top.to -text "To:"
6089    entry $top.tosha1 -width 40 -relief flat
6090    $top.tosha1 insert 0 $newid
6091    $top.tosha1 conf -state readonly
6092    grid $top.to $top.tosha1 -sticky w
6093    entry $top.tohead -width 60 -relief flat
6094    $top.tohead insert 0 $newhead
6095    $top.tohead conf -state readonly
6096    grid x $top.tohead -sticky w
6097    button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6098    grid $top.rev x -pady 10
6099    label $top.flab -text "Output file:"
6100    entry $top.fname -width 60
6101    $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6102    incr patchnum
6103    grid $top.flab $top.fname -sticky w
6104    frame $top.buts
6105    button $top.buts.gen -text "Generate" -command mkpatchgo
6106    button $top.buts.can -text "Cancel" -command mkpatchcan
6107    grid $top.buts.gen $top.buts.can
6108    grid columnconfigure $top.buts 0 -weight 1 -uniform a
6109    grid columnconfigure $top.buts 1 -weight 1 -uniform a
6110    grid $top.buts - -pady 10 -sticky ew
6111    focus $top.fname
6112}
6113
6114proc mkpatchrev {} {
6115    global patchtop
6116
6117    set oldid [$patchtop.fromsha1 get]
6118    set oldhead [$patchtop.fromhead get]
6119    set newid [$patchtop.tosha1 get]
6120    set newhead [$patchtop.tohead get]
6121    foreach e [list fromsha1 fromhead tosha1 tohead] \
6122            v [list $newid $newhead $oldid $oldhead] {
6123        $patchtop.$e conf -state normal
6124        $patchtop.$e delete 0 end
6125        $patchtop.$e insert 0 $v
6126        $patchtop.$e conf -state readonly
6127    }
6128}
6129
6130proc mkpatchgo {} {
6131    global patchtop nullid nullid2
6132
6133    set oldid [$patchtop.fromsha1 get]
6134    set newid [$patchtop.tosha1 get]
6135    set fname [$patchtop.fname get]
6136    set cmd [diffcmd [list $oldid $newid] -p]
6137    # trim off the initial "|"
6138    set cmd [lrange $cmd 1 end]
6139    lappend cmd >$fname &
6140    if {[catch {eval exec $cmd} err]} {
6141        error_popup "Error creating patch: $err"
6142    }
6143    catch {destroy $patchtop}
6144    unset patchtop
6145}
6146
6147proc mkpatchcan {} {
6148    global patchtop
6149
6150    catch {destroy $patchtop}
6151    unset patchtop
6152}
6153
6154proc mktag {} {
6155    global rowmenuid mktagtop commitinfo
6156
6157    set top .maketag
6158    set mktagtop $top
6159    catch {destroy $top}
6160    toplevel $top
6161    label $top.title -text "Create tag"
6162    grid $top.title - -pady 10
6163    label $top.id -text "ID:"
6164    entry $top.sha1 -width 40 -relief flat
6165    $top.sha1 insert 0 $rowmenuid
6166    $top.sha1 conf -state readonly
6167    grid $top.id $top.sha1 -sticky w
6168    entry $top.head -width 60 -relief flat
6169    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6170    $top.head conf -state readonly
6171    grid x $top.head -sticky w
6172    label $top.tlab -text "Tag name:"
6173    entry $top.tag -width 60
6174    grid $top.tlab $top.tag -sticky w
6175    frame $top.buts
6176    button $top.buts.gen -text "Create" -command mktaggo
6177    button $top.buts.can -text "Cancel" -command mktagcan
6178    grid $top.buts.gen $top.buts.can
6179    grid columnconfigure $top.buts 0 -weight 1 -uniform a
6180    grid columnconfigure $top.buts 1 -weight 1 -uniform a
6181    grid $top.buts - -pady 10 -sticky ew
6182    focus $top.tag
6183}
6184
6185proc domktag {} {
6186    global mktagtop env tagids idtags
6187
6188    set id [$mktagtop.sha1 get]
6189    set tag [$mktagtop.tag get]
6190    if {$tag == {}} {
6191        error_popup "No tag name specified"
6192        return
6193    }
6194    if {[info exists tagids($tag)]} {
6195        error_popup "Tag \"$tag\" already exists"
6196        return
6197    }
6198    if {[catch {
6199        set dir [gitdir]
6200        set fname [file join $dir "refs/tags" $tag]
6201        set f [open $fname w]
6202        puts $f $id
6203        close $f
6204    } err]} {
6205        error_popup "Error creating tag: $err"
6206        return
6207    }
6208
6209    set tagids($tag) $id
6210    lappend idtags($id) $tag
6211    redrawtags $id
6212    addedtag $id
6213    dispneartags 0
6214    run refill_reflist
6215}
6216
6217proc redrawtags {id} {
6218    global canv linehtag commitrow idpos selectedline curview
6219    global canvxmax iddrawn
6220
6221    if {![info exists commitrow($curview,$id)]} return
6222    if {![info exists iddrawn($id)]} return
6223    drawcommits $commitrow($curview,$id)
6224    $canv delete tag.$id
6225    set xt [eval drawtags $id $idpos($id)]
6226    $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6227    set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6228    set xr [expr {$xt + [font measure mainfont $text]}]
6229    if {$xr > $canvxmax} {
6230        set canvxmax $xr
6231        setcanvscroll
6232    }
6233    if {[info exists selectedline]
6234        && $selectedline == $commitrow($curview,$id)} {
6235        selectline $selectedline 0
6236    }
6237}
6238
6239proc mktagcan {} {
6240    global mktagtop
6241
6242    catch {destroy $mktagtop}
6243    unset mktagtop
6244}
6245
6246proc mktaggo {} {
6247    domktag
6248    mktagcan
6249}
6250
6251proc writecommit {} {
6252    global rowmenuid wrcomtop commitinfo wrcomcmd
6253
6254    set top .writecommit
6255    set wrcomtop $top
6256    catch {destroy $top}
6257    toplevel $top
6258    label $top.title -text "Write commit to file"
6259    grid $top.title - -pady 10
6260    label $top.id -text "ID:"
6261    entry $top.sha1 -width 40 -relief flat
6262    $top.sha1 insert 0 $rowmenuid
6263    $top.sha1 conf -state readonly
6264    grid $top.id $top.sha1 -sticky w
6265    entry $top.head -width 60 -relief flat
6266    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6267    $top.head conf -state readonly
6268    grid x $top.head -sticky w
6269    label $top.clab -text "Command:"
6270    entry $top.cmd -width 60 -textvariable wrcomcmd
6271    grid $top.clab $top.cmd -sticky w -pady 10
6272    label $top.flab -text "Output file:"
6273    entry $top.fname -width 60
6274    $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6275    grid $top.flab $top.fname -sticky w
6276    frame $top.buts
6277    button $top.buts.gen -text "Write" -command wrcomgo
6278    button $top.buts.can -text "Cancel" -command wrcomcan
6279    grid $top.buts.gen $top.buts.can
6280    grid columnconfigure $top.buts 0 -weight 1 -uniform a
6281    grid columnconfigure $top.buts 1 -weight 1 -uniform a
6282    grid $top.buts - -pady 10 -sticky ew
6283    focus $top.fname
6284}
6285
6286proc wrcomgo {} {
6287    global wrcomtop
6288
6289    set id [$wrcomtop.sha1 get]
6290    set cmd "echo $id | [$wrcomtop.cmd get]"
6291    set fname [$wrcomtop.fname get]
6292    if {[catch {exec sh -c $cmd >$fname &} err]} {
6293        error_popup "Error writing commit: $err"
6294    }
6295    catch {destroy $wrcomtop}
6296    unset wrcomtop
6297}
6298
6299proc wrcomcan {} {
6300    global wrcomtop
6301
6302    catch {destroy $wrcomtop}
6303    unset wrcomtop
6304}
6305
6306proc mkbranch {} {
6307    global rowmenuid mkbrtop
6308
6309    set top .makebranch
6310    catch {destroy $top}
6311    toplevel $top
6312    label $top.title -text "Create new branch"
6313    grid $top.title - -pady 10
6314    label $top.id -text "ID:"
6315    entry $top.sha1 -width 40 -relief flat
6316    $top.sha1 insert 0 $rowmenuid
6317    $top.sha1 conf -state readonly
6318    grid $top.id $top.sha1 -sticky w
6319    label $top.nlab -text "Name:"
6320    entry $top.name -width 40
6321    grid $top.nlab $top.name -sticky w
6322    frame $top.buts
6323    button $top.buts.go -text "Create" -command [list mkbrgo $top]
6324    button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6325    grid $top.buts.go $top.buts.can
6326    grid columnconfigure $top.buts 0 -weight 1 -uniform a
6327    grid columnconfigure $top.buts 1 -weight 1 -uniform a
6328    grid $top.buts - -pady 10 -sticky ew
6329    focus $top.name
6330}
6331
6332proc mkbrgo {top} {
6333    global headids idheads
6334
6335    set name [$top.name get]
6336    set id [$top.sha1 get]
6337    if {$name eq {}} {
6338        error_popup "Please specify a name for the new branch"
6339        return
6340    }
6341    catch {destroy $top}
6342    nowbusy newbranch
6343    update
6344    if {[catch {
6345        exec git branch $name $id
6346    } err]} {
6347        notbusy newbranch
6348        error_popup $err
6349    } else {
6350        set headids($name) $id
6351        lappend idheads($id) $name
6352        addedhead $id $name
6353        notbusy newbranch
6354        redrawtags $id
6355        dispneartags 0
6356        run refill_reflist
6357    }
6358}
6359
6360proc cherrypick {} {
6361    global rowmenuid curview commitrow
6362    global mainhead
6363
6364    set oldhead [exec git rev-parse HEAD]
6365    set dheads [descheads $rowmenuid]
6366    if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6367        set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6368                        included in branch $mainhead -- really re-apply it?"]
6369        if {!$ok} return
6370    }
6371    nowbusy cherrypick
6372    update
6373    # Unfortunately git-cherry-pick writes stuff to stderr even when
6374    # no error occurs, and exec takes that as an indication of error...
6375    if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6376        notbusy cherrypick
6377        error_popup $err
6378        return
6379    }
6380    set newhead [exec git rev-parse HEAD]
6381    if {$newhead eq $oldhead} {
6382        notbusy cherrypick
6383        error_popup "No changes committed"
6384        return
6385    }
6386    addnewchild $newhead $oldhead
6387    if {[info exists commitrow($curview,$oldhead)]} {
6388        insertrow $commitrow($curview,$oldhead) $newhead
6389        if {$mainhead ne {}} {
6390            movehead $newhead $mainhead
6391            movedhead $newhead $mainhead
6392        }
6393        redrawtags $oldhead
6394        redrawtags $newhead
6395    }
6396    notbusy cherrypick
6397}
6398
6399proc resethead {} {
6400    global mainheadid mainhead rowmenuid confirm_ok resettype
6401
6402    set confirm_ok 0
6403    set w ".confirmreset"
6404    toplevel $w
6405    wm transient $w .
6406    wm title $w "Confirm reset"
6407    message $w.m -text \
6408        "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6409        -justify center -aspect 1000
6410    pack $w.m -side top -fill x -padx 20 -pady 20
6411    frame $w.f -relief sunken -border 2
6412    message $w.f.rt -text "Reset type:" -aspect 1000
6413    grid $w.f.rt -sticky w
6414    set resettype mixed
6415    radiobutton $w.f.soft -value soft -variable resettype -justify left \
6416        -text "Soft: Leave working tree and index untouched"
6417    grid $w.f.soft -sticky w
6418    radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6419        -text "Mixed: Leave working tree untouched, reset index"
6420    grid $w.f.mixed -sticky w
6421    radiobutton $w.f.hard -value hard -variable resettype -justify left \
6422        -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6423    grid $w.f.hard -sticky w
6424    pack $w.f -side top -fill x
6425    button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6426    pack $w.ok -side left -fill x -padx 20 -pady 20
6427    button $w.cancel -text Cancel -command "destroy $w"
6428    pack $w.cancel -side right -fill x -padx 20 -pady 20
6429    bind $w <Visibility> "grab $w; focus $w"
6430    tkwait window $w
6431    if {!$confirm_ok} return
6432    if {[catch {set fd [open \
6433            [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6434        error_popup $err
6435    } else {
6436        dohidelocalchanges
6437        set w ".resetprogress"
6438        filerun $fd [list readresetstat $fd $w]
6439        toplevel $w
6440        wm transient $w
6441        wm title $w "Reset progress"
6442        message $w.m -text "Reset in progress, please wait..." \
6443            -justify center -aspect 1000
6444        pack $w.m -side top -fill x -padx 20 -pady 5
6445        canvas $w.c -width 150 -height 20 -bg white
6446        $w.c create rect 0 0 0 20 -fill green -tags rect
6447        pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6448        nowbusy reset
6449    }
6450}
6451
6452proc readresetstat {fd w} {
6453    global mainhead mainheadid showlocalchanges
6454
6455    if {[gets $fd line] >= 0} {
6456        if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6457            set x [expr {($m * 150) / $n}]
6458            $w.c coords rect 0 0 $x 20
6459        }
6460        return 1
6461    }
6462    destroy $w
6463    notbusy reset
6464    if {[catch {close $fd} err]} {
6465        error_popup $err
6466    }
6467    set oldhead $mainheadid
6468    set newhead [exec git rev-parse HEAD]
6469    if {$newhead ne $oldhead} {
6470        movehead $newhead $mainhead
6471        movedhead $newhead $mainhead
6472        set mainheadid $newhead
6473        redrawtags $oldhead
6474        redrawtags $newhead
6475    }
6476    if {$showlocalchanges} {
6477        doshowlocalchanges
6478    }
6479    return 0
6480}
6481
6482# context menu for a head
6483proc headmenu {x y id head} {
6484    global headmenuid headmenuhead headctxmenu mainhead
6485
6486    stopfinding
6487    set headmenuid $id
6488    set headmenuhead $head
6489    set state normal
6490    if {$head eq $mainhead} {
6491        set state disabled
6492    }
6493    $headctxmenu entryconfigure 0 -state $state
6494    $headctxmenu entryconfigure 1 -state $state
6495    tk_popup $headctxmenu $x $y
6496}
6497
6498proc cobranch {} {
6499    global headmenuid headmenuhead mainhead headids
6500    global showlocalchanges mainheadid
6501
6502    # check the tree is clean first??
6503    set oldmainhead $mainhead
6504    nowbusy checkout
6505    update
6506    dohidelocalchanges
6507    if {[catch {
6508        exec git checkout -q $headmenuhead
6509    } err]} {
6510        notbusy checkout
6511        error_popup $err
6512    } else {
6513        notbusy checkout
6514        set mainhead $headmenuhead
6515        set mainheadid $headmenuid
6516        if {[info exists headids($oldmainhead)]} {
6517            redrawtags $headids($oldmainhead)
6518        }
6519        redrawtags $headmenuid
6520    }
6521    if {$showlocalchanges} {
6522        dodiffindex
6523    }
6524}
6525
6526proc rmbranch {} {
6527    global headmenuid headmenuhead mainhead
6528    global idheads
6529
6530    set head $headmenuhead
6531    set id $headmenuid
6532    # this check shouldn't be needed any more...
6533    if {$head eq $mainhead} {
6534        error_popup "Cannot delete the currently checked-out branch"
6535        return
6536    }
6537    set dheads [descheads $id]
6538    if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6539        # the stuff on this branch isn't on any other branch
6540        if {![confirm_popup "The commits on branch $head aren't on any other\
6541                        branch.\nReally delete branch $head?"]} return
6542    }
6543    nowbusy rmbranch
6544    update
6545    if {[catch {exec git branch -D $head} err]} {
6546        notbusy rmbranch
6547        error_popup $err
6548        return
6549    }
6550    removehead $id $head
6551    removedhead $id $head
6552    redrawtags $id
6553    notbusy rmbranch
6554    dispneartags 0
6555    run refill_reflist
6556}
6557
6558# Display a list of tags and heads
6559proc showrefs {} {
6560    global showrefstop bgcolor fgcolor selectbgcolor
6561    global bglist fglist reflistfilter reflist maincursor
6562
6563    set top .showrefs
6564    set showrefstop $top
6565    if {[winfo exists $top]} {
6566        raise $top
6567        refill_reflist
6568        return
6569    }
6570    toplevel $top
6571    wm title $top "Tags and heads: [file tail [pwd]]"
6572    text $top.list -background $bgcolor -foreground $fgcolor \
6573        -selectbackground $selectbgcolor -font mainfont \
6574        -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6575        -width 30 -height 20 -cursor $maincursor \
6576        -spacing1 1 -spacing3 1 -state disabled
6577    $top.list tag configure highlight -background $selectbgcolor
6578    lappend bglist $top.list
6579    lappend fglist $top.list
6580    scrollbar $top.ysb -command "$top.list yview" -orient vertical
6581    scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6582    grid $top.list $top.ysb -sticky nsew
6583    grid $top.xsb x -sticky ew
6584    frame $top.f
6585    label $top.f.l -text "Filter: " -font uifont
6586    entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
6587    set reflistfilter "*"
6588    trace add variable reflistfilter write reflistfilter_change
6589    pack $top.f.e -side right -fill x -expand 1
6590    pack $top.f.l -side left
6591    grid $top.f - -sticky ew -pady 2
6592    button $top.close -command [list destroy $top] -text "Close" \
6593        -font uifont
6594    grid $top.close -
6595    grid columnconfigure $top 0 -weight 1
6596    grid rowconfigure $top 0 -weight 1
6597    bind $top.list <1> {break}
6598    bind $top.list <B1-Motion> {break}
6599    bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6600    set reflist {}
6601    refill_reflist
6602}
6603
6604proc sel_reflist {w x y} {
6605    global showrefstop reflist headids tagids otherrefids
6606
6607    if {![winfo exists $showrefstop]} return
6608    set l [lindex [split [$w index "@$x,$y"] "."] 0]
6609    set ref [lindex $reflist [expr {$l-1}]]
6610    set n [lindex $ref 0]
6611    switch -- [lindex $ref 1] {
6612        "H" {selbyid $headids($n)}
6613        "T" {selbyid $tagids($n)}
6614        "o" {selbyid $otherrefids($n)}
6615    }
6616    $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6617}
6618
6619proc unsel_reflist {} {
6620    global showrefstop
6621
6622    if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6623    $showrefstop.list tag remove highlight 0.0 end
6624}
6625
6626proc reflistfilter_change {n1 n2 op} {
6627    global reflistfilter
6628
6629    after cancel refill_reflist
6630    after 200 refill_reflist
6631}
6632
6633proc refill_reflist {} {
6634    global reflist reflistfilter showrefstop headids tagids otherrefids
6635    global commitrow curview commitinterest
6636
6637    if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6638    set refs {}
6639    foreach n [array names headids] {
6640        if {[string match $reflistfilter $n]} {
6641            if {[info exists commitrow($curview,$headids($n))]} {
6642                lappend refs [list $n H]
6643            } else {
6644                set commitinterest($headids($n)) {run refill_reflist}
6645            }
6646        }
6647    }
6648    foreach n [array names tagids] {
6649        if {[string match $reflistfilter $n]} {
6650            if {[info exists commitrow($curview,$tagids($n))]} {
6651                lappend refs [list $n T]
6652            } else {
6653                set commitinterest($tagids($n)) {run refill_reflist}
6654            }
6655        }
6656    }
6657    foreach n [array names otherrefids] {
6658        if {[string match $reflistfilter $n]} {
6659            if {[info exists commitrow($curview,$otherrefids($n))]} {
6660                lappend refs [list $n o]
6661            } else {
6662                set commitinterest($otherrefids($n)) {run refill_reflist}
6663            }
6664        }
6665    }
6666    set refs [lsort -index 0 $refs]
6667    if {$refs eq $reflist} return
6668
6669    # Update the contents of $showrefstop.list according to the
6670    # differences between $reflist (old) and $refs (new)
6671    $showrefstop.list conf -state normal
6672    $showrefstop.list insert end "\n"
6673    set i 0
6674    set j 0
6675    while {$i < [llength $reflist] || $j < [llength $refs]} {
6676        if {$i < [llength $reflist]} {
6677            if {$j < [llength $refs]} {
6678                set cmp [string compare [lindex $reflist $i 0] \
6679                             [lindex $refs $j 0]]
6680                if {$cmp == 0} {
6681                    set cmp [string compare [lindex $reflist $i 1] \
6682                                 [lindex $refs $j 1]]
6683                }
6684            } else {
6685                set cmp -1
6686            }
6687        } else {
6688            set cmp 1
6689        }
6690        switch -- $cmp {
6691            -1 {
6692                $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6693                incr i
6694            }
6695            0 {
6696                incr i
6697                incr j
6698            }
6699            1 {
6700                set l [expr {$j + 1}]
6701                $showrefstop.list image create $l.0 -align baseline \
6702                    -image reficon-[lindex $refs $j 1] -padx 2
6703                $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6704                incr j
6705            }
6706        }
6707    }
6708    set reflist $refs
6709    # delete last newline
6710    $showrefstop.list delete end-2c end-1c
6711    $showrefstop.list conf -state disabled
6712}
6713
6714# Stuff for finding nearby tags
6715proc getallcommits {} {
6716    global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6717    global idheads idtags idotherrefs allparents tagobjid
6718
6719    if {![info exists allcommits]} {
6720        set nextarc 0
6721        set allcommits 0
6722        set seeds {}
6723        set allcwait 0
6724        set cachedarcs 0
6725        set allccache [file join [gitdir] "gitk.cache"]
6726        if {![catch {
6727            set f [open $allccache r]
6728            set allcwait 1
6729            getcache $f
6730        }]} return
6731    }
6732
6733    if {$allcwait} {
6734        return
6735    }
6736    set cmd [list | git rev-list --parents]
6737    set allcupdate [expr {$seeds ne {}}]
6738    if {!$allcupdate} {
6739        set ids "--all"
6740    } else {
6741        set refs [concat [array names idheads] [array names idtags] \
6742                      [array names idotherrefs]]
6743        set ids {}
6744        set tagobjs {}
6745        foreach name [array names tagobjid] {
6746            lappend tagobjs $tagobjid($name)
6747        }
6748        foreach id [lsort -unique $refs] {
6749            if {![info exists allparents($id)] &&
6750                [lsearch -exact $tagobjs $id] < 0} {
6751                lappend ids $id
6752            }
6753        }
6754        if {$ids ne {}} {
6755            foreach id $seeds {
6756                lappend ids "^$id"
6757            }
6758        }
6759    }
6760    if {$ids ne {}} {
6761        set fd [open [concat $cmd $ids] r]
6762        fconfigure $fd -blocking 0
6763        incr allcommits
6764        nowbusy allcommits
6765        filerun $fd [list getallclines $fd]
6766    } else {
6767        dispneartags 0
6768    }
6769}
6770
6771# Since most commits have 1 parent and 1 child, we group strings of
6772# such commits into "arcs" joining branch/merge points (BMPs), which
6773# are commits that either don't have 1 parent or don't have 1 child.
6774#
6775# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6776# arcout(id) - outgoing arcs for BMP
6777# arcids(a) - list of IDs on arc including end but not start
6778# arcstart(a) - BMP ID at start of arc
6779# arcend(a) - BMP ID at end of arc
6780# growing(a) - arc a is still growing
6781# arctags(a) - IDs out of arcids (excluding end) that have tags
6782# archeads(a) - IDs out of arcids (excluding end) that have heads
6783# The start of an arc is at the descendent end, so "incoming" means
6784# coming from descendents, and "outgoing" means going towards ancestors.
6785
6786proc getallclines {fd} {
6787    global allparents allchildren idtags idheads nextarc
6788    global arcnos arcids arctags arcout arcend arcstart archeads growing
6789    global seeds allcommits cachedarcs allcupdate
6790    
6791    set nid 0
6792    while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6793        set id [lindex $line 0]
6794        if {[info exists allparents($id)]} {
6795            # seen it already
6796            continue
6797        }
6798        set cachedarcs 0
6799        set olds [lrange $line 1 end]
6800        set allparents($id) $olds
6801        if {![info exists allchildren($id)]} {
6802            set allchildren($id) {}
6803            set arcnos($id) {}
6804            lappend seeds $id
6805        } else {
6806            set a $arcnos($id)
6807            if {[llength $olds] == 1 && [llength $a] == 1} {
6808                lappend arcids($a) $id
6809                if {[info exists idtags($id)]} {
6810                    lappend arctags($a) $id
6811                }
6812                if {[info exists idheads($id)]} {
6813                    lappend archeads($a) $id
6814                }
6815                if {[info exists allparents($olds)]} {
6816                    # seen parent already
6817                    if {![info exists arcout($olds)]} {
6818                        splitarc $olds
6819                    }
6820                    lappend arcids($a) $olds
6821                    set arcend($a) $olds
6822                    unset growing($a)
6823                }
6824                lappend allchildren($olds) $id
6825                lappend arcnos($olds) $a
6826                continue
6827            }
6828        }
6829        foreach a $arcnos($id) {
6830            lappend arcids($a) $id
6831            set arcend($a) $id
6832            unset growing($a)
6833        }
6834
6835        set ao {}
6836        foreach p $olds {
6837            lappend allchildren($p) $id
6838            set a [incr nextarc]
6839            set arcstart($a) $id
6840            set archeads($a) {}
6841            set arctags($a) {}
6842            set archeads($a) {}
6843            set arcids($a) {}
6844            lappend ao $a
6845            set growing($a) 1
6846            if {[info exists allparents($p)]} {
6847                # seen it already, may need to make a new branch
6848                if {![info exists arcout($p)]} {
6849                    splitarc $p
6850                }
6851                lappend arcids($a) $p
6852                set arcend($a) $p
6853                unset growing($a)
6854            }
6855            lappend arcnos($p) $a
6856        }
6857        set arcout($id) $ao
6858    }
6859    if {$nid > 0} {
6860        global cached_dheads cached_dtags cached_atags
6861        catch {unset cached_dheads}
6862        catch {unset cached_dtags}
6863        catch {unset cached_atags}
6864    }
6865    if {![eof $fd]} {
6866        return [expr {$nid >= 1000? 2: 1}]
6867    }
6868    set cacheok 1
6869    if {[catch {
6870        fconfigure $fd -blocking 1
6871        close $fd
6872    } err]} {
6873        # got an error reading the list of commits
6874        # if we were updating, try rereading the whole thing again
6875        if {$allcupdate} {
6876            incr allcommits -1
6877            dropcache $err
6878            return
6879        }
6880        error_popup "Error reading commit topology information;\
6881                branch and preceding/following tag information\
6882                will be incomplete.\n($err)"
6883        set cacheok 0
6884    }
6885    if {[incr allcommits -1] == 0} {
6886        notbusy allcommits
6887        if {$cacheok} {
6888            run savecache
6889        }
6890    }
6891    dispneartags 0
6892    return 0
6893}
6894
6895proc recalcarc {a} {
6896    global arctags archeads arcids idtags idheads
6897
6898    set at {}
6899    set ah {}
6900    foreach id [lrange $arcids($a) 0 end-1] {
6901        if {[info exists idtags($id)]} {
6902            lappend at $id
6903        }
6904        if {[info exists idheads($id)]} {
6905            lappend ah $id
6906        }
6907    }
6908    set arctags($a) $at
6909    set archeads($a) $ah
6910}
6911
6912proc splitarc {p} {
6913    global arcnos arcids nextarc arctags archeads idtags idheads
6914    global arcstart arcend arcout allparents growing
6915
6916    set a $arcnos($p)
6917    if {[llength $a] != 1} {
6918        puts "oops splitarc called but [llength $a] arcs already"
6919        return
6920    }
6921    set a [lindex $a 0]
6922    set i [lsearch -exact $arcids($a) $p]
6923    if {$i < 0} {
6924        puts "oops splitarc $p not in arc $a"
6925        return
6926    }
6927    set na [incr nextarc]
6928    if {[info exists arcend($a)]} {
6929        set arcend($na) $arcend($a)
6930    } else {
6931        set l [lindex $allparents([lindex $arcids($a) end]) 0]
6932        set j [lsearch -exact $arcnos($l) $a]
6933        set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6934    }
6935    set tail [lrange $arcids($a) [expr {$i+1}] end]
6936    set arcids($a) [lrange $arcids($a) 0 $i]
6937    set arcend($a) $p
6938    set arcstart($na) $p
6939    set arcout($p) $na
6940    set arcids($na) $tail
6941    if {[info exists growing($a)]} {
6942        set growing($na) 1
6943        unset growing($a)
6944    }
6945
6946    foreach id $tail {
6947        if {[llength $arcnos($id)] == 1} {
6948            set arcnos($id) $na
6949        } else {
6950            set j [lsearch -exact $arcnos($id) $a]
6951            set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6952        }
6953    }
6954
6955    # reconstruct tags and heads lists
6956    if {$arctags($a) ne {} || $archeads($a) ne {}} {
6957        recalcarc $a
6958        recalcarc $na
6959    } else {
6960        set arctags($na) {}
6961        set archeads($na) {}
6962    }
6963}
6964
6965# Update things for a new commit added that is a child of one
6966# existing commit.  Used when cherry-picking.
6967proc addnewchild {id p} {
6968    global allparents allchildren idtags nextarc
6969    global arcnos arcids arctags arcout arcend arcstart archeads growing
6970    global seeds allcommits
6971
6972    if {![info exists allcommits]} return
6973    set allparents($id) [list $p]
6974    set allchildren($id) {}
6975    set arcnos($id) {}
6976    lappend seeds $id
6977    lappend allchildren($p) $id
6978    set a [incr nextarc]
6979    set arcstart($a) $id
6980    set archeads($a) {}
6981    set arctags($a) {}
6982    set arcids($a) [list $p]
6983    set arcend($a) $p
6984    if {![info exists arcout($p)]} {
6985        splitarc $p
6986    }
6987    lappend arcnos($p) $a
6988    set arcout($id) [list $a]
6989}
6990
6991# This implements a cache for the topology information.
6992# The cache saves, for each arc, the start and end of the arc,
6993# the ids on the arc, and the outgoing arcs from the end.
6994proc readcache {f} {
6995    global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6996    global idtags idheads allparents cachedarcs possible_seeds seeds growing
6997    global allcwait
6998
6999    set a $nextarc
7000    set lim $cachedarcs
7001    if {$lim - $a > 500} {
7002        set lim [expr {$a + 500}]
7003    }
7004    if {[catch {
7005        if {$a == $lim} {
7006            # finish reading the cache and setting up arctags, etc.
7007            set line [gets $f]
7008            if {$line ne "1"} {error "bad final version"}
7009            close $f
7010            foreach id [array names idtags] {
7011                if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7012                    [llength $allparents($id)] == 1} {
7013                    set a [lindex $arcnos($id) 0]
7014                    if {$arctags($a) eq {}} {
7015                        recalcarc $a
7016                    }
7017                }
7018            }
7019            foreach id [array names idheads] {
7020                if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7021                    [llength $allparents($id)] == 1} {
7022                    set a [lindex $arcnos($id) 0]
7023                    if {$archeads($a) eq {}} {
7024                        recalcarc $a
7025                    }
7026                }
7027            }
7028            foreach id [lsort -unique $possible_seeds] {
7029                if {$arcnos($id) eq {}} {
7030                    lappend seeds $id
7031                }
7032            }
7033            set allcwait 0
7034        } else {
7035            while {[incr a] <= $lim} {
7036                set line [gets $f]
7037                if {[llength $line] != 3} {error "bad line"}
7038                set s [lindex $line 0]
7039                set arcstart($a) $s
7040                lappend arcout($s) $a
7041                if {![info exists arcnos($s)]} {
7042                    lappend possible_seeds $s
7043                    set arcnos($s) {}
7044                }
7045                set e [lindex $line 1]
7046                if {$e eq {}} {
7047                    set growing($a) 1
7048                } else {
7049                    set arcend($a) $e
7050                    if {![info exists arcout($e)]} {
7051                        set arcout($e) {}
7052                    }
7053                }
7054                set arcids($a) [lindex $line 2]
7055                foreach id $arcids($a) {
7056                    lappend allparents($s) $id
7057                    set s $id
7058                    lappend arcnos($id) $a
7059                }
7060                if {![info exists allparents($s)]} {
7061                    set allparents($s) {}
7062                }
7063                set arctags($a) {}
7064                set archeads($a) {}
7065            }
7066            set nextarc [expr {$a - 1}]
7067        }
7068    } err]} {
7069        dropcache $err
7070        return 0
7071    }
7072    if {!$allcwait} {
7073        getallcommits
7074    }
7075    return $allcwait
7076}
7077
7078proc getcache {f} {
7079    global nextarc cachedarcs possible_seeds
7080
7081    if {[catch {
7082        set line [gets $f]
7083        if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7084        # make sure it's an integer
7085        set cachedarcs [expr {int([lindex $line 1])}]
7086        if {$cachedarcs < 0} {error "bad number of arcs"}
7087        set nextarc 0
7088        set possible_seeds {}
7089        run readcache $f
7090    } err]} {
7091        dropcache $err
7092    }
7093    return 0
7094}
7095
7096proc dropcache {err} {
7097    global allcwait nextarc cachedarcs seeds
7098
7099    #puts "dropping cache ($err)"
7100    foreach v {arcnos arcout arcids arcstart arcend growing \
7101                   arctags archeads allparents allchildren} {
7102        global $v
7103        catch {unset $v}
7104    }
7105    set allcwait 0
7106    set nextarc 0
7107    set cachedarcs 0
7108    set seeds {}
7109    getallcommits
7110}
7111
7112proc writecache {f} {
7113    global cachearc cachedarcs allccache
7114    global arcstart arcend arcnos arcids arcout
7115
7116    set a $cachearc
7117    set lim $cachedarcs
7118    if {$lim - $a > 1000} {
7119        set lim [expr {$a + 1000}]
7120    }
7121    if {[catch {
7122        while {[incr a] <= $lim} {
7123            if {[info exists arcend($a)]} {
7124                puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7125            } else {
7126                puts $f [list $arcstart($a) {} $arcids($a)]
7127            }
7128        }
7129    } err]} {
7130        catch {close $f}
7131        catch {file delete $allccache}
7132        #puts "writing cache failed ($err)"
7133        return 0
7134    }
7135    set cachearc [expr {$a - 1}]
7136    if {$a > $cachedarcs} {
7137        puts $f "1"
7138        close $f
7139        return 0
7140    }
7141    return 1
7142}
7143
7144proc savecache {} {
7145    global nextarc cachedarcs cachearc allccache
7146
7147    if {$nextarc == $cachedarcs} return
7148    set cachearc 0
7149    set cachedarcs $nextarc
7150    catch {
7151        set f [open $allccache w]
7152        puts $f [list 1 $cachedarcs]
7153        run writecache $f
7154    }
7155}
7156
7157# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7158# or 0 if neither is true.
7159proc anc_or_desc {a b} {
7160    global arcout arcstart arcend arcnos cached_isanc
7161
7162    if {$arcnos($a) eq $arcnos($b)} {
7163        # Both are on the same arc(s); either both are the same BMP,
7164        # or if one is not a BMP, the other is also not a BMP or is
7165        # the BMP at end of the arc (and it only has 1 incoming arc).
7166        # Or both can be BMPs with no incoming arcs.
7167        if {$a eq $b || $arcnos($a) eq {}} {
7168            return 0
7169        }
7170        # assert {[llength $arcnos($a)] == 1}
7171        set arc [lindex $arcnos($a) 0]
7172        set i [lsearch -exact $arcids($arc) $a]
7173        set j [lsearch -exact $arcids($arc) $b]
7174        if {$i < 0 || $i > $j} {
7175            return 1
7176        } else {
7177            return -1
7178        }
7179    }
7180
7181    if {![info exists arcout($a)]} {
7182        set arc [lindex $arcnos($a) 0]
7183        if {[info exists arcend($arc)]} {
7184            set aend $arcend($arc)
7185        } else {
7186            set aend {}
7187        }
7188        set a $arcstart($arc)
7189    } else {
7190        set aend $a
7191    }
7192    if {![info exists arcout($b)]} {
7193        set arc [lindex $arcnos($b) 0]
7194        if {[info exists arcend($arc)]} {
7195            set bend $arcend($arc)
7196        } else {
7197            set bend {}
7198        }
7199        set b $arcstart($arc)
7200    } else {
7201        set bend $b
7202    }
7203    if {$a eq $bend} {
7204        return 1
7205    }
7206    if {$b eq $aend} {
7207        return -1
7208    }
7209    if {[info exists cached_isanc($a,$bend)]} {
7210        if {$cached_isanc($a,$bend)} {
7211            return 1
7212        }
7213    }
7214    if {[info exists cached_isanc($b,$aend)]} {
7215        if {$cached_isanc($b,$aend)} {
7216            return -1
7217        }
7218        if {[info exists cached_isanc($a,$bend)]} {
7219            return 0
7220        }
7221    }
7222
7223    set todo [list $a $b]
7224    set anc($a) a
7225    set anc($b) b
7226    for {set i 0} {$i < [llength $todo]} {incr i} {
7227        set x [lindex $todo $i]
7228        if {$anc($x) eq {}} {
7229            continue
7230        }
7231        foreach arc $arcnos($x) {
7232            set xd $arcstart($arc)
7233            if {$xd eq $bend} {
7234                set cached_isanc($a,$bend) 1
7235                set cached_isanc($b,$aend) 0
7236                return 1
7237            } elseif {$xd eq $aend} {
7238                set cached_isanc($b,$aend) 1
7239                set cached_isanc($a,$bend) 0
7240                return -1
7241            }
7242            if {![info exists anc($xd)]} {
7243                set anc($xd) $anc($x)
7244                lappend todo $xd
7245            } elseif {$anc($xd) ne $anc($x)} {
7246                set anc($xd) {}
7247            }
7248        }
7249    }
7250    set cached_isanc($a,$bend) 0
7251    set cached_isanc($b,$aend) 0
7252    return 0
7253}
7254
7255# This identifies whether $desc has an ancestor that is
7256# a growing tip of the graph and which is not an ancestor of $anc
7257# and returns 0 if so and 1 if not.
7258# If we subsequently discover a tag on such a growing tip, and that
7259# turns out to be a descendent of $anc (which it could, since we
7260# don't necessarily see children before parents), then $desc
7261# isn't a good choice to display as a descendent tag of
7262# $anc (since it is the descendent of another tag which is
7263# a descendent of $anc).  Similarly, $anc isn't a good choice to
7264# display as a ancestor tag of $desc.
7265#
7266proc is_certain {desc anc} {
7267    global arcnos arcout arcstart arcend growing problems
7268
7269    set certain {}
7270    if {[llength $arcnos($anc)] == 1} {
7271        # tags on the same arc are certain
7272        if {$arcnos($desc) eq $arcnos($anc)} {
7273            return 1
7274        }
7275        if {![info exists arcout($anc)]} {
7276            # if $anc is partway along an arc, use the start of the arc instead
7277            set a [lindex $arcnos($anc) 0]
7278            set anc $arcstart($a)
7279        }
7280    }
7281    if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7282        set x $desc
7283    } else {
7284        set a [lindex $arcnos($desc) 0]
7285        set x $arcend($a)
7286    }
7287    if {$x == $anc} {
7288        return 1
7289    }
7290    set anclist [list $x]
7291    set dl($x) 1
7292    set nnh 1
7293    set ngrowanc 0
7294    for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7295        set x [lindex $anclist $i]
7296        if {$dl($x)} {
7297            incr nnh -1
7298        }
7299        set done($x) 1
7300        foreach a $arcout($x) {
7301            if {[info exists growing($a)]} {
7302                if {![info exists growanc($x)] && $dl($x)} {
7303                    set growanc($x) 1
7304                    incr ngrowanc
7305                }
7306            } else {
7307                set y $arcend($a)
7308                if {[info exists dl($y)]} {
7309                    if {$dl($y)} {
7310                        if {!$dl($x)} {
7311                            set dl($y) 0
7312                            if {![info exists done($y)]} {
7313                                incr nnh -1
7314                            }
7315                            if {[info exists growanc($x)]} {
7316                                incr ngrowanc -1
7317                            }
7318                            set xl [list $y]
7319                            for {set k 0} {$k < [llength $xl]} {incr k} {
7320                                set z [lindex $xl $k]
7321                                foreach c $arcout($z) {
7322                                    if {[info exists arcend($c)]} {
7323                                        set v $arcend($c)
7324                                        if {[info exists dl($v)] && $dl($v)} {
7325                                            set dl($v) 0
7326                                            if {![info exists done($v)]} {
7327                                                incr nnh -1
7328                                            }
7329                                            if {[info exists growanc($v)]} {
7330                                                incr ngrowanc -1
7331                                            }
7332                                            lappend xl $v
7333                                        }
7334                                    }
7335                                }
7336                            }
7337                        }
7338                    }
7339                } elseif {$y eq $anc || !$dl($x)} {
7340                    set dl($y) 0
7341                    lappend anclist $y
7342                } else {
7343                    set dl($y) 1
7344                    lappend anclist $y
7345                    incr nnh
7346                }
7347            }
7348        }
7349    }
7350    foreach x [array names growanc] {
7351        if {$dl($x)} {
7352            return 0
7353        }
7354        return 0
7355    }
7356    return 1
7357}
7358
7359proc validate_arctags {a} {
7360    global arctags idtags
7361
7362    set i -1
7363    set na $arctags($a)
7364    foreach id $arctags($a) {
7365        incr i
7366        if {![info exists idtags($id)]} {
7367            set na [lreplace $na $i $i]
7368            incr i -1
7369        }
7370    }
7371    set arctags($a) $na
7372}
7373
7374proc validate_archeads {a} {
7375    global archeads idheads
7376
7377    set i -1
7378    set na $archeads($a)
7379    foreach id $archeads($a) {
7380        incr i
7381        if {![info exists idheads($id)]} {
7382            set na [lreplace $na $i $i]
7383            incr i -1
7384        }
7385    }
7386    set archeads($a) $na
7387}
7388
7389# Return the list of IDs that have tags that are descendents of id,
7390# ignoring IDs that are descendents of IDs already reported.
7391proc desctags {id} {
7392    global arcnos arcstart arcids arctags idtags allparents
7393    global growing cached_dtags
7394
7395    if {![info exists allparents($id)]} {
7396        return {}
7397    }
7398    set t1 [clock clicks -milliseconds]
7399    set argid $id
7400    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7401        # part-way along an arc; check that arc first
7402        set a [lindex $arcnos($id) 0]
7403        if {$arctags($a) ne {}} {
7404            validate_arctags $a
7405            set i [lsearch -exact $arcids($a) $id]
7406            set tid {}
7407            foreach t $arctags($a) {
7408                set j [lsearch -exact $arcids($a) $t]
7409                if {$j >= $i} break
7410                set tid $t
7411            }
7412            if {$tid ne {}} {
7413                return $tid
7414            }
7415        }
7416        set id $arcstart($a)
7417        if {[info exists idtags($id)]} {
7418            return $id
7419        }
7420    }
7421    if {[info exists cached_dtags($id)]} {
7422        return $cached_dtags($id)
7423    }
7424
7425    set origid $id
7426    set todo [list $id]
7427    set queued($id) 1
7428    set nc 1
7429    for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7430        set id [lindex $todo $i]
7431        set done($id) 1
7432        set ta [info exists hastaggedancestor($id)]
7433        if {!$ta} {
7434            incr nc -1
7435        }
7436        # ignore tags on starting node
7437        if {!$ta && $i > 0} {
7438            if {[info exists idtags($id)]} {
7439                set tagloc($id) $id
7440                set ta 1
7441            } elseif {[info exists cached_dtags($id)]} {
7442                set tagloc($id) $cached_dtags($id)
7443                set ta 1
7444            }
7445        }
7446        foreach a $arcnos($id) {
7447            set d $arcstart($a)
7448            if {!$ta && $arctags($a) ne {}} {
7449                validate_arctags $a
7450                if {$arctags($a) ne {}} {
7451                    lappend tagloc($id) [lindex $arctags($a) end]
7452                }
7453            }
7454            if {$ta || $arctags($a) ne {}} {
7455                set tomark [list $d]
7456                for {set j 0} {$j < [llength $tomark]} {incr j} {
7457                    set dd [lindex $tomark $j]
7458                    if {![info exists hastaggedancestor($dd)]} {
7459                        if {[info exists done($dd)]} {
7460                            foreach b $arcnos($dd) {
7461                                lappend tomark $arcstart($b)
7462                            }
7463                            if {[info exists tagloc($dd)]} {
7464                                unset tagloc($dd)
7465                            }
7466                        } elseif {[info exists queued($dd)]} {
7467                            incr nc -1
7468                        }
7469                        set hastaggedancestor($dd) 1
7470                    }
7471                }
7472            }
7473            if {![info exists queued($d)]} {
7474                lappend todo $d
7475                set queued($d) 1
7476                if {![info exists hastaggedancestor($d)]} {
7477                    incr nc
7478                }
7479            }
7480        }
7481    }
7482    set tags {}
7483    foreach id [array names tagloc] {
7484        if {![info exists hastaggedancestor($id)]} {
7485            foreach t $tagloc($id) {
7486                if {[lsearch -exact $tags $t] < 0} {
7487                    lappend tags $t
7488                }
7489            }
7490        }
7491    }
7492    set t2 [clock clicks -milliseconds]
7493    set loopix $i
7494
7495    # remove tags that are descendents of other tags
7496    for {set i 0} {$i < [llength $tags]} {incr i} {
7497        set a [lindex $tags $i]
7498        for {set j 0} {$j < $i} {incr j} {
7499            set b [lindex $tags $j]
7500            set r [anc_or_desc $a $b]
7501            if {$r == 1} {
7502                set tags [lreplace $tags $j $j]
7503                incr j -1
7504                incr i -1
7505            } elseif {$r == -1} {
7506                set tags [lreplace $tags $i $i]
7507                incr i -1
7508                break
7509            }
7510        }
7511    }
7512
7513    if {[array names growing] ne {}} {
7514        # graph isn't finished, need to check if any tag could get
7515        # eclipsed by another tag coming later.  Simply ignore any
7516        # tags that could later get eclipsed.
7517        set ctags {}
7518        foreach t $tags {
7519            if {[is_certain $t $origid]} {
7520                lappend ctags $t
7521            }
7522        }
7523        if {$tags eq $ctags} {
7524            set cached_dtags($origid) $tags
7525        } else {
7526            set tags $ctags
7527        }
7528    } else {
7529        set cached_dtags($origid) $tags
7530    }
7531    set t3 [clock clicks -milliseconds]
7532    if {0 && $t3 - $t1 >= 100} {
7533        puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7534            [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7535    }
7536    return $tags
7537}
7538
7539proc anctags {id} {
7540    global arcnos arcids arcout arcend arctags idtags allparents
7541    global growing cached_atags
7542
7543    if {![info exists allparents($id)]} {
7544        return {}
7545    }
7546    set t1 [clock clicks -milliseconds]
7547    set argid $id
7548    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7549        # part-way along an arc; check that arc first
7550        set a [lindex $arcnos($id) 0]
7551        if {$arctags($a) ne {}} {
7552            validate_arctags $a
7553            set i [lsearch -exact $arcids($a) $id]
7554            foreach t $arctags($a) {
7555                set j [lsearch -exact $arcids($a) $t]
7556                if {$j > $i} {
7557                    return $t
7558                }
7559            }
7560        }
7561        if {![info exists arcend($a)]} {
7562            return {}
7563        }
7564        set id $arcend($a)
7565        if {[info exists idtags($id)]} {
7566            return $id
7567        }
7568    }
7569    if {[info exists cached_atags($id)]} {
7570        return $cached_atags($id)
7571    }
7572
7573    set origid $id
7574    set todo [list $id]
7575    set queued($id) 1
7576    set taglist {}
7577    set nc 1
7578    for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7579        set id [lindex $todo $i]
7580        set done($id) 1
7581        set td [info exists hastaggeddescendent($id)]
7582        if {!$td} {
7583            incr nc -1
7584        }
7585        # ignore tags on starting node
7586        if {!$td && $i > 0} {
7587            if {[info exists idtags($id)]} {
7588                set tagloc($id) $id
7589                set td 1
7590            } elseif {[info exists cached_atags($id)]} {
7591                set tagloc($id) $cached_atags($id)
7592                set td 1
7593            }
7594        }
7595        foreach a $arcout($id) {
7596            if {!$td && $arctags($a) ne {}} {
7597                validate_arctags $a
7598                if {$arctags($a) ne {}} {
7599                    lappend tagloc($id) [lindex $arctags($a) 0]
7600                }
7601            }
7602            if {![info exists arcend($a)]} continue
7603            set d $arcend($a)
7604            if {$td || $arctags($a) ne {}} {
7605                set tomark [list $d]
7606                for {set j 0} {$j < [llength $tomark]} {incr j} {
7607                    set dd [lindex $tomark $j]
7608                    if {![info exists hastaggeddescendent($dd)]} {
7609                        if {[info exists done($dd)]} {
7610                            foreach b $arcout($dd) {
7611                                if {[info exists arcend($b)]} {
7612                                    lappend tomark $arcend($b)
7613                                }
7614                            }
7615                            if {[info exists tagloc($dd)]} {
7616                                unset tagloc($dd)
7617                            }
7618                        } elseif {[info exists queued($dd)]} {
7619                            incr nc -1
7620                        }
7621                        set hastaggeddescendent($dd) 1
7622                    }
7623                }
7624            }
7625            if {![info exists queued($d)]} {
7626                lappend todo $d
7627                set queued($d) 1
7628                if {![info exists hastaggeddescendent($d)]} {
7629                    incr nc
7630                }
7631            }
7632        }
7633    }
7634    set t2 [clock clicks -milliseconds]
7635    set loopix $i
7636    set tags {}
7637    foreach id [array names tagloc] {
7638        if {![info exists hastaggeddescendent($id)]} {
7639            foreach t $tagloc($id) {
7640                if {[lsearch -exact $tags $t] < 0} {
7641                    lappend tags $t
7642                }
7643            }
7644        }
7645    }
7646
7647    # remove tags that are ancestors of other tags
7648    for {set i 0} {$i < [llength $tags]} {incr i} {
7649        set a [lindex $tags $i]
7650        for {set j 0} {$j < $i} {incr j} {
7651            set b [lindex $tags $j]
7652            set r [anc_or_desc $a $b]
7653            if {$r == -1} {
7654                set tags [lreplace $tags $j $j]
7655                incr j -1
7656                incr i -1
7657            } elseif {$r == 1} {
7658                set tags [lreplace $tags $i $i]
7659                incr i -1
7660                break
7661            }
7662        }
7663    }
7664
7665    if {[array names growing] ne {}} {
7666        # graph isn't finished, need to check if any tag could get
7667        # eclipsed by another tag coming later.  Simply ignore any
7668        # tags that could later get eclipsed.
7669        set ctags {}
7670        foreach t $tags {
7671            if {[is_certain $origid $t]} {
7672                lappend ctags $t
7673            }
7674        }
7675        if {$tags eq $ctags} {
7676            set cached_atags($origid) $tags
7677        } else {
7678            set tags $ctags
7679        }
7680    } else {
7681        set cached_atags($origid) $tags
7682    }
7683    set t3 [clock clicks -milliseconds]
7684    if {0 && $t3 - $t1 >= 100} {
7685        puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7686            [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7687    }
7688    return $tags
7689}
7690
7691# Return the list of IDs that have heads that are descendents of id,
7692# including id itself if it has a head.
7693proc descheads {id} {
7694    global arcnos arcstart arcids archeads idheads cached_dheads
7695    global allparents
7696
7697    if {![info exists allparents($id)]} {
7698        return {}
7699    }
7700    set aret {}
7701    if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7702        # part-way along an arc; check it first
7703        set a [lindex $arcnos($id) 0]
7704        if {$archeads($a) ne {}} {
7705            validate_archeads $a
7706            set i [lsearch -exact $arcids($a) $id]
7707            foreach t $archeads($a) {
7708                set j [lsearch -exact $arcids($a) $t]
7709                if {$j > $i} break
7710                lappend aret $t
7711            }
7712        }
7713        set id $arcstart($a)
7714    }
7715    set origid $id
7716    set todo [list $id]
7717    set seen($id) 1
7718    set ret {}
7719    for {set i 0} {$i < [llength $todo]} {incr i} {
7720        set id [lindex $todo $i]
7721        if {[info exists cached_dheads($id)]} {
7722            set ret [concat $ret $cached_dheads($id)]
7723        } else {
7724            if {[info exists idheads($id)]} {
7725                lappend ret $id
7726            }
7727            foreach a $arcnos($id) {
7728                if {$archeads($a) ne {}} {
7729                    validate_archeads $a
7730                    if {$archeads($a) ne {}} {
7731                        set ret [concat $ret $archeads($a)]
7732                    }
7733                }
7734                set d $arcstart($a)
7735                if {![info exists seen($d)]} {
7736                    lappend todo $d
7737                    set seen($d) 1
7738                }
7739            }
7740        }
7741    }
7742    set ret [lsort -unique $ret]
7743    set cached_dheads($origid) $ret
7744    return [concat $ret $aret]
7745}
7746
7747proc addedtag {id} {
7748    global arcnos arcout cached_dtags cached_atags
7749
7750    if {![info exists arcnos($id)]} return
7751    if {![info exists arcout($id)]} {
7752        recalcarc [lindex $arcnos($id) 0]
7753    }
7754    catch {unset cached_dtags}
7755    catch {unset cached_atags}
7756}
7757
7758proc addedhead {hid head} {
7759    global arcnos arcout cached_dheads
7760
7761    if {![info exists arcnos($hid)]} return
7762    if {![info exists arcout($hid)]} {
7763        recalcarc [lindex $arcnos($hid) 0]
7764    }
7765    catch {unset cached_dheads}
7766}
7767
7768proc removedhead {hid head} {
7769    global cached_dheads
7770
7771    catch {unset cached_dheads}
7772}
7773
7774proc movedhead {hid head} {
7775    global arcnos arcout cached_dheads
7776
7777    if {![info exists arcnos($hid)]} return
7778    if {![info exists arcout($hid)]} {
7779        recalcarc [lindex $arcnos($hid) 0]
7780    }
7781    catch {unset cached_dheads}
7782}
7783
7784proc changedrefs {} {
7785    global cached_dheads cached_dtags cached_atags
7786    global arctags archeads arcnos arcout idheads idtags
7787
7788    foreach id [concat [array names idheads] [array names idtags]] {
7789        if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7790            set a [lindex $arcnos($id) 0]
7791            if {![info exists donearc($a)]} {
7792                recalcarc $a
7793                set donearc($a) 1
7794            }
7795        }
7796    }
7797    catch {unset cached_dtags}
7798    catch {unset cached_atags}
7799    catch {unset cached_dheads}
7800}
7801
7802proc rereadrefs {} {
7803    global idtags idheads idotherrefs mainhead
7804
7805    set refids [concat [array names idtags] \
7806                    [array names idheads] [array names idotherrefs]]
7807    foreach id $refids {
7808        if {![info exists ref($id)]} {
7809            set ref($id) [listrefs $id]
7810        }
7811    }
7812    set oldmainhead $mainhead
7813    readrefs
7814    changedrefs
7815    set refids [lsort -unique [concat $refids [array names idtags] \
7816                        [array names idheads] [array names idotherrefs]]]
7817    foreach id $refids {
7818        set v [listrefs $id]
7819        if {![info exists ref($id)] || $ref($id) != $v ||
7820            ($id eq $oldmainhead && $id ne $mainhead) ||
7821            ($id eq $mainhead && $id ne $oldmainhead)} {
7822            redrawtags $id
7823        }
7824    }
7825    run refill_reflist
7826}
7827
7828proc listrefs {id} {
7829    global idtags idheads idotherrefs
7830
7831    set x {}
7832    if {[info exists idtags($id)]} {
7833        set x $idtags($id)
7834    }
7835    set y {}
7836    if {[info exists idheads($id)]} {
7837        set y $idheads($id)
7838    }
7839    set z {}
7840    if {[info exists idotherrefs($id)]} {
7841        set z $idotherrefs($id)
7842    }
7843    return [list $x $y $z]
7844}
7845
7846proc showtag {tag isnew} {
7847    global ctext tagcontents tagids linknum tagobjid
7848
7849    if {$isnew} {
7850        addtohistory [list showtag $tag 0]
7851    }
7852    $ctext conf -state normal
7853    clear_ctext
7854    settabs 0
7855    set linknum 0
7856    if {![info exists tagcontents($tag)]} {
7857        catch {
7858            set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7859        }
7860    }
7861    if {[info exists tagcontents($tag)]} {
7862        set text $tagcontents($tag)
7863    } else {
7864        set text "Tag: $tag\nId:  $tagids($tag)"
7865    }
7866    appendwithlinks $text {}
7867    $ctext conf -state disabled
7868    init_flist {}
7869}
7870
7871proc doquit {} {
7872    global stopped
7873    set stopped 100
7874    savestuff .
7875    destroy .
7876}
7877
7878proc mkfontdisp {font top which} {
7879    global fontattr fontpref $font
7880
7881    set fontpref($font) [set $font]
7882    button $top.${font}but -text $which -font optionfont \
7883        -command [list choosefont $font $which]
7884    label $top.$font -relief flat -font $font \
7885        -text $fontattr($font,family) -justify left
7886    grid x $top.${font}but $top.$font -sticky w
7887}
7888
7889proc choosefont {font which} {
7890    global fontparam fontlist fonttop fontattr
7891
7892    set fontparam(which) $which
7893    set fontparam(font) $font
7894    set fontparam(family) [font actual $font -family]
7895    set fontparam(size) $fontattr($font,size)
7896    set fontparam(weight) $fontattr($font,weight)
7897    set fontparam(slant) $fontattr($font,slant)
7898    set top .gitkfont
7899    set fonttop $top
7900    if {![winfo exists $top]} {
7901        font create sample
7902        eval font config sample [font actual $font]
7903        toplevel $top
7904        wm title $top "Gitk font chooser"
7905        label $top.l -textvariable fontparam(which) -font uifont
7906        pack $top.l -side top
7907        set fontlist [lsort [font families]]
7908        frame $top.f
7909        listbox $top.f.fam -listvariable fontlist \
7910            -yscrollcommand [list $top.f.sb set]
7911        bind $top.f.fam <<ListboxSelect>> selfontfam
7912        scrollbar $top.f.sb -command [list $top.f.fam yview]
7913        pack $top.f.sb -side right -fill y
7914        pack $top.f.fam -side left -fill both -expand 1
7915        pack $top.f -side top -fill both -expand 1
7916        frame $top.g
7917        spinbox $top.g.size -from 4 -to 40 -width 4 \
7918            -textvariable fontparam(size) \
7919            -validatecommand {string is integer -strict %s}
7920        checkbutton $top.g.bold -padx 5 \
7921            -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
7922            -variable fontparam(weight) -onvalue bold -offvalue normal
7923        checkbutton $top.g.ital -padx 5 \
7924            -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0  \
7925            -variable fontparam(slant) -onvalue italic -offvalue roman
7926        pack $top.g.size $top.g.bold $top.g.ital -side left
7927        pack $top.g -side top
7928        canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7929            -background white
7930        $top.c create text 100 25 -anchor center -text $which -font sample \
7931            -fill black -tags text
7932        bind $top.c <Configure> [list centertext $top.c]
7933        pack $top.c -side top -fill x
7934        frame $top.buts
7935        button $top.buts.ok -text "OK" -command fontok -default active \
7936            -font uifont
7937        button $top.buts.can -text "Cancel" -command fontcan -default normal \
7938            -font uifont
7939        grid $top.buts.ok $top.buts.can
7940        grid columnconfigure $top.buts 0 -weight 1 -uniform a
7941        grid columnconfigure $top.buts 1 -weight 1 -uniform a
7942        pack $top.buts -side bottom -fill x
7943        trace add variable fontparam write chg_fontparam
7944    } else {
7945        raise $top
7946        $top.c itemconf text -text $which
7947    }
7948    set i [lsearch -exact $fontlist $fontparam(family)]
7949    if {$i >= 0} {
7950        $top.f.fam selection set $i
7951        $top.f.fam see $i
7952    }
7953}
7954
7955proc centertext {w} {
7956    $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7957}
7958
7959proc fontok {} {
7960    global fontparam fontpref prefstop
7961
7962    set f $fontparam(font)
7963    set fontpref($f) [list $fontparam(family) $fontparam(size)]
7964    if {$fontparam(weight) eq "bold"} {
7965        lappend fontpref($f) "bold"
7966    }
7967    if {$fontparam(slant) eq "italic"} {
7968        lappend fontpref($f) "italic"
7969    }
7970    set w $prefstop.$f
7971    $w conf -text $fontparam(family) -font $fontpref($f)
7972        
7973    fontcan
7974}
7975
7976proc fontcan {} {
7977    global fonttop fontparam
7978
7979    if {[info exists fonttop]} {
7980        catch {destroy $fonttop}
7981        catch {font delete sample}
7982        unset fonttop
7983        unset fontparam
7984    }
7985}
7986
7987proc selfontfam {} {
7988    global fonttop fontparam
7989
7990    set i [$fonttop.f.fam curselection]
7991    if {$i ne {}} {
7992        set fontparam(family) [$fonttop.f.fam get $i]
7993    }
7994}
7995
7996proc chg_fontparam {v sub op} {
7997    global fontparam
7998
7999    font config sample -$sub $fontparam($sub)
8000}
8001
8002proc doprefs {} {
8003    global maxwidth maxgraphpct diffopts
8004    global oldprefs prefstop showneartags showlocalchanges
8005    global bgcolor fgcolor ctext diffcolors selectbgcolor
8006    global uifont tabstop
8007
8008    set top .gitkprefs
8009    set prefstop $top
8010    if {[winfo exists $top]} {
8011        raise $top
8012        return
8013    }
8014    foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
8015        set oldprefs($v) [set $v]
8016    }
8017    toplevel $top
8018    wm title $top "Gitk preferences"
8019    label $top.ldisp -text "Commit list display options"
8020    $top.ldisp configure -font uifont
8021    grid $top.ldisp - -sticky w -pady 10
8022    label $top.spacer -text " "
8023    label $top.maxwidthl -text "Maximum graph width (lines)" \
8024        -font optionfont
8025    spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8026    grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8027    label $top.maxpctl -text "Maximum graph width (% of pane)" \
8028        -font optionfont
8029    spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8030    grid x $top.maxpctl $top.maxpct -sticky w
8031    frame $top.showlocal
8032    label $top.showlocal.l -text "Show local changes" -font optionfont
8033    checkbutton $top.showlocal.b -variable showlocalchanges
8034    pack $top.showlocal.b $top.showlocal.l -side left
8035    grid x $top.showlocal -sticky w
8036
8037    label $top.ddisp -text "Diff display options"
8038    $top.ddisp configure -font uifont
8039    grid $top.ddisp - -sticky w -pady 10
8040    label $top.diffoptl -text "Options for diff program" \
8041        -font optionfont
8042    entry $top.diffopt -width 20 -textvariable diffopts
8043    grid x $top.diffoptl $top.diffopt -sticky w
8044    frame $top.ntag
8045    label $top.ntag.l -text "Display nearby tags" -font optionfont
8046    checkbutton $top.ntag.b -variable showneartags
8047    pack $top.ntag.b $top.ntag.l -side left
8048    grid x $top.ntag -sticky w
8049    label $top.tabstopl -text "tabstop" -font optionfont
8050    spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8051    grid x $top.tabstopl $top.tabstop -sticky w
8052
8053    label $top.cdisp -text "Colors: press to choose"
8054    $top.cdisp configure -font uifont
8055    grid $top.cdisp - -sticky w -pady 10
8056    label $top.bg -padx 40 -relief sunk -background $bgcolor
8057    button $top.bgbut -text "Background" -font optionfont \
8058        -command [list choosecolor bgcolor 0 $top.bg background setbg]
8059    grid x $top.bgbut $top.bg -sticky w
8060    label $top.fg -padx 40 -relief sunk -background $fgcolor
8061    button $top.fgbut -text "Foreground" -font optionfont \
8062        -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8063    grid x $top.fgbut $top.fg -sticky w
8064    label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8065    button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8066        -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8067                      [list $ctext tag conf d0 -foreground]]
8068    grid x $top.diffoldbut $top.diffold -sticky w
8069    label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8070    button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8071        -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8072                      [list $ctext tag conf d1 -foreground]]
8073    grid x $top.diffnewbut $top.diffnew -sticky w
8074    label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8075    button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8076        -command [list choosecolor diffcolors 2 $top.hunksep \
8077                      "diff hunk header" \
8078                      [list $ctext tag conf hunksep -foreground]]
8079    grid x $top.hunksepbut $top.hunksep -sticky w
8080    label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8081    button $top.selbgbut -text "Select bg" -font optionfont \
8082        -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8083    grid x $top.selbgbut $top.selbgsep -sticky w
8084
8085    label $top.cfont -text "Fonts: press to choose"
8086    $top.cfont configure -font uifont
8087    grid $top.cfont - -sticky w -pady 10
8088    mkfontdisp mainfont $top "Main font"
8089    mkfontdisp textfont $top "Diff display font"
8090    mkfontdisp uifont $top "User interface font"
8091
8092    frame $top.buts
8093    button $top.buts.ok -text "OK" -command prefsok -default active
8094    $top.buts.ok configure -font uifont
8095    button $top.buts.can -text "Cancel" -command prefscan -default normal
8096    $top.buts.can configure -font uifont
8097    grid $top.buts.ok $top.buts.can
8098    grid columnconfigure $top.buts 0 -weight 1 -uniform a
8099    grid columnconfigure $top.buts 1 -weight 1 -uniform a
8100    grid $top.buts - - -pady 10 -sticky ew
8101    bind $top <Visibility> "focus $top.buts.ok"
8102}
8103
8104proc choosecolor {v vi w x cmd} {
8105    global $v
8106
8107    set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8108               -title "Gitk: choose color for $x"]
8109    if {$c eq {}} return
8110    $w conf -background $c
8111    lset $v $vi $c
8112    eval $cmd $c
8113}
8114
8115proc setselbg {c} {
8116    global bglist cflist
8117    foreach w $bglist {
8118        $w configure -selectbackground $c
8119    }
8120    $cflist tag configure highlight \
8121        -background [$cflist cget -selectbackground]
8122    allcanvs itemconf secsel -fill $c
8123}
8124
8125proc setbg {c} {
8126    global bglist
8127
8128    foreach w $bglist {
8129        $w conf -background $c
8130    }
8131}
8132
8133proc setfg {c} {
8134    global fglist canv
8135
8136    foreach w $fglist {
8137        $w conf -foreground $c
8138    }
8139    allcanvs itemconf text -fill $c
8140    $canv itemconf circle -outline $c
8141}
8142
8143proc prefscan {} {
8144    global maxwidth maxgraphpct diffopts
8145    global oldprefs prefstop showneartags showlocalchanges
8146
8147    foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
8148        set $v $oldprefs($v)
8149    }
8150    catch {destroy $prefstop}
8151    unset prefstop
8152    fontcan
8153}
8154
8155proc prefsok {} {
8156    global maxwidth maxgraphpct
8157    global oldprefs prefstop showneartags showlocalchanges
8158    global fontpref mainfont textfont uifont
8159
8160    catch {destroy $prefstop}
8161    unset prefstop
8162    fontcan
8163    set fontchanged 0
8164    if {$mainfont ne $fontpref(mainfont)} {
8165        set mainfont $fontpref(mainfont)
8166        parsefont mainfont $mainfont
8167        eval font configure mainfont [fontflags mainfont]
8168        eval font configure mainfontbold [fontflags mainfont 1]
8169        setcoords
8170        set fontchanged 1
8171    }
8172    if {$textfont ne $fontpref(textfont)} {
8173        set textfont $fontpref(textfont)
8174        parsefont textfont $textfont
8175        eval font configure textfont [fontflags textfont]
8176        eval font configure textfontbold [fontflags textfont 1]
8177    }
8178    if {$uifont ne $fontpref(uifont)} {
8179        set uifont $fontpref(uifont)
8180        parsefont uifont $uifont
8181        eval font configure uifont [fontflags uifont]
8182    }
8183    settabs
8184    if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8185        if {$showlocalchanges} {
8186            doshowlocalchanges
8187        } else {
8188            dohidelocalchanges
8189        }
8190    }
8191    if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8192        || $maxgraphpct != $oldprefs(maxgraphpct)} {
8193        redisplay
8194    } elseif {$showneartags != $oldprefs(showneartags)} {
8195        reselectline
8196    }
8197}
8198
8199proc formatdate {d} {
8200    global datetimeformat
8201    if {$d ne {}} {
8202        set d [clock format $d -format $datetimeformat]
8203    }
8204    return $d
8205}
8206
8207# This list of encoding names and aliases is distilled from
8208# http://www.iana.org/assignments/character-sets.
8209# Not all of them are supported by Tcl.
8210set encoding_aliases {
8211    { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8212      ISO646-US US-ASCII us IBM367 cp367 csASCII }
8213    { ISO-10646-UTF-1 csISO10646UTF1 }
8214    { ISO_646.basic:1983 ref csISO646basic1983 }
8215    { INVARIANT csINVARIANT }
8216    { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8217    { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8218    { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8219    { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8220    { NATS-DANO iso-ir-9-1 csNATSDANO }
8221    { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8222    { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8223    { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8224    { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8225    { ISO-2022-KR csISO2022KR }
8226    { EUC-KR csEUCKR }
8227    { ISO-2022-JP csISO2022JP }
8228    { ISO-2022-JP-2 csISO2022JP2 }
8229    { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8230      csISO13JISC6220jp }
8231    { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8232    { IT iso-ir-15 ISO646-IT csISO15Italian }
8233    { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8234    { ES iso-ir-17 ISO646-ES csISO17Spanish }
8235    { greek7-old iso-ir-18 csISO18Greek7Old }
8236    { latin-greek iso-ir-19 csISO19LatinGreek }
8237    { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8238    { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8239    { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8240    { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8241    { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8242    { BS_viewdata iso-ir-47 csISO47BSViewdata }
8243    { INIS iso-ir-49 csISO49INIS }
8244    { INIS-8 iso-ir-50 csISO50INIS8 }
8245    { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8246    { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8247    { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8248    { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8249    { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8250    { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8251      csISO60Norwegian1 }
8252    { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8253    { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8254    { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8255    { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8256    { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8257    { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8258    { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8259    { greek7 iso-ir-88 csISO88Greek7 }
8260    { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8261    { iso-ir-90 csISO90 }
8262    { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8263    { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8264      csISO92JISC62991984b }
8265    { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8266    { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8267    { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8268      csISO95JIS62291984handadd }
8269    { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8270    { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8271    { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8272    { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8273      CP819 csISOLatin1 }
8274    { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8275    { T.61-7bit iso-ir-102 csISO102T617bit }
8276    { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8277    { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8278    { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8279    { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8280    { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8281    { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8282    { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8283    { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8284      arabic csISOLatinArabic }
8285    { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8286    { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8287    { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8288      greek greek8 csISOLatinGreek }
8289    { T.101-G2 iso-ir-128 csISO128T101G2 }
8290    { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8291      csISOLatinHebrew }
8292    { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8293    { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8294    { CSN_369103 iso-ir-139 csISO139CSN369103 }
8295    { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8296    { ISO_6937-2-add iso-ir-142 csISOTextComm }
8297    { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8298    { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8299      csISOLatinCyrillic }
8300    { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8301    { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8302    { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8303    { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8304    { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8305    { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8306    { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8307    { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8308    { ISO_10367-box iso-ir-155 csISO10367Box }
8309    { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8310    { latin-lap lap iso-ir-158 csISO158Lap }
8311    { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8312    { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8313    { us-dk csUSDK }
8314    { dk-us csDKUS }
8315    { JIS_X0201 X0201 csHalfWidthKatakana }
8316    { KSC5636 ISO646-KR csKSC5636 }
8317    { ISO-10646-UCS-2 csUnicode }
8318    { ISO-10646-UCS-4 csUCS4 }
8319    { DEC-MCS dec csDECMCS }
8320    { hp-roman8 roman8 r8 csHPRoman8 }
8321    { macintosh mac csMacintosh }
8322    { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8323      csIBM037 }
8324    { IBM038 EBCDIC-INT cp038 csIBM038 }
8325    { IBM273 CP273 csIBM273 }
8326    { IBM274 EBCDIC-BE CP274 csIBM274 }
8327    { IBM275 EBCDIC-BR cp275 csIBM275 }
8328    { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8329    { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8330    { IBM280 CP280 ebcdic-cp-it csIBM280 }
8331    { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8332    { IBM284 CP284 ebcdic-cp-es csIBM284 }
8333    { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8334    { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8335    { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8336    { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8337    { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8338    { IBM424 cp424 ebcdic-cp-he csIBM424 }
8339    { IBM437 cp437 437 csPC8CodePage437 }
8340    { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8341    { IBM775 cp775 csPC775Baltic }
8342    { IBM850 cp850 850 csPC850Multilingual }
8343    { IBM851 cp851 851 csIBM851 }
8344    { IBM852 cp852 852 csPCp852 }
8345    { IBM855 cp855 855 csIBM855 }
8346    { IBM857 cp857 857 csIBM857 }
8347    { IBM860 cp860 860 csIBM860 }
8348    { IBM861 cp861 861 cp-is csIBM861 }
8349    { IBM862 cp862 862 csPC862LatinHebrew }
8350    { IBM863 cp863 863 csIBM863 }
8351    { IBM864 cp864 csIBM864 }
8352    { IBM865 cp865 865 csIBM865 }
8353    { IBM866 cp866 866 csIBM866 }
8354    { IBM868 CP868 cp-ar csIBM868 }
8355    { IBM869 cp869 869 cp-gr csIBM869 }
8356    { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8357    { IBM871 CP871 ebcdic-cp-is csIBM871 }
8358    { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8359    { IBM891 cp891 csIBM891 }
8360    { IBM903 cp903 csIBM903 }
8361    { IBM904 cp904 904 csIBBM904 }
8362    { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8363    { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8364    { IBM1026 CP1026 csIBM1026 }
8365    { EBCDIC-AT-DE csIBMEBCDICATDE }
8366    { EBCDIC-AT-DE-A csEBCDICATDEA }
8367    { EBCDIC-CA-FR csEBCDICCAFR }
8368    { EBCDIC-DK-NO csEBCDICDKNO }
8369    { EBCDIC-DK-NO-A csEBCDICDKNOA }
8370    { EBCDIC-FI-SE csEBCDICFISE }
8371    { EBCDIC-FI-SE-A csEBCDICFISEA }
8372    { EBCDIC-FR csEBCDICFR }
8373    { EBCDIC-IT csEBCDICIT }
8374    { EBCDIC-PT csEBCDICPT }
8375    { EBCDIC-ES csEBCDICES }
8376    { EBCDIC-ES-A csEBCDICESA }
8377    { EBCDIC-ES-S csEBCDICESS }
8378    { EBCDIC-UK csEBCDICUK }
8379    { EBCDIC-US csEBCDICUS }
8380    { UNKNOWN-8BIT csUnknown8BiT }
8381    { MNEMONIC csMnemonic }
8382    { MNEM csMnem }
8383    { VISCII csVISCII }
8384    { VIQR csVIQR }
8385    { KOI8-R csKOI8R }
8386    { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8387    { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8388    { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8389    { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8390    { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8391    { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8392    { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8393    { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8394    { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8395    { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8396    { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8397    { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8398    { IBM1047 IBM-1047 }
8399    { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8400    { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8401    { UNICODE-1-1 csUnicode11 }
8402    { CESU-8 csCESU-8 }
8403    { BOCU-1 csBOCU-1 }
8404    { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8405    { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8406      l8 }
8407    { ISO-8859-15 ISO_8859-15 Latin-9 }
8408    { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8409    { GBK CP936 MS936 windows-936 }
8410    { JIS_Encoding csJISEncoding }
8411    { Shift_JIS MS_Kanji csShiftJIS }
8412    { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8413      EUC-JP }
8414    { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8415    { ISO-10646-UCS-Basic csUnicodeASCII }
8416    { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8417    { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8418    { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8419    { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8420    { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8421    { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8422    { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8423    { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8424    { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8425    { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8426    { Adobe-Standard-Encoding csAdobeStandardEncoding }
8427    { Ventura-US csVenturaUS }
8428    { Ventura-International csVenturaInternational }
8429    { PC8-Danish-Norwegian csPC8DanishNorwegian }
8430    { PC8-Turkish csPC8Turkish }
8431    { IBM-Symbols csIBMSymbols }
8432    { IBM-Thai csIBMThai }
8433    { HP-Legal csHPLegal }
8434    { HP-Pi-font csHPPiFont }
8435    { HP-Math8 csHPMath8 }
8436    { Adobe-Symbol-Encoding csHPPSMath }
8437    { HP-DeskTop csHPDesktop }
8438    { Ventura-Math csVenturaMath }
8439    { Microsoft-Publishing csMicrosoftPublishing }
8440    { Windows-31J csWindows31J }
8441    { GB2312 csGB2312 }
8442    { Big5 csBig5 }
8443}
8444
8445proc tcl_encoding {enc} {
8446    global encoding_aliases
8447    set names [encoding names]
8448    set lcnames [string tolower $names]
8449    set enc [string tolower $enc]
8450    set i [lsearch -exact $lcnames $enc]
8451    if {$i < 0} {
8452        # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8453        if {[regsub {^iso[-_]} $enc iso encx]} {
8454            set i [lsearch -exact $lcnames $encx]
8455        }
8456    }
8457    if {$i < 0} {
8458        foreach l $encoding_aliases {
8459            set ll [string tolower $l]
8460            if {[lsearch -exact $ll $enc] < 0} continue
8461            # look through the aliases for one that tcl knows about
8462            foreach e $ll {
8463                set i [lsearch -exact $lcnames $e]
8464                if {$i < 0} {
8465                    if {[regsub {^iso[-_]} $e iso ex]} {
8466                        set i [lsearch -exact $lcnames $ex]
8467                    }
8468                }
8469                if {$i >= 0} break
8470            }
8471            break
8472        }
8473    }
8474    if {$i >= 0} {
8475        return [lindex $names $i]
8476    }
8477    return {}
8478}
8479
8480# defaults...
8481set datemode 0
8482set diffopts "-U 5 -p"
8483set wrcomcmd "git diff-tree --stdin -p --pretty"
8484
8485set gitencoding {}
8486catch {
8487    set gitencoding [exec git config --get i18n.commitencoding]
8488}
8489if {$gitencoding == ""} {
8490    set gitencoding "utf-8"
8491}
8492set tclencoding [tcl_encoding $gitencoding]
8493if {$tclencoding == {}} {
8494    puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8495}
8496
8497set mainfont {Helvetica 9}
8498set textfont {Courier 9}
8499set uifont {Helvetica 9 bold}
8500set tabstop 8
8501set findmergefiles 0
8502set maxgraphpct 50
8503set maxwidth 16
8504set revlistorder 0
8505set fastdate 0
8506set uparrowlen 5
8507set downarrowlen 5
8508set mingaplen 100
8509set cmitmode "patch"
8510set wrapcomment "none"
8511set showneartags 1
8512set maxrefs 20
8513set maxlinelen 200
8514set showlocalchanges 1
8515set datetimeformat "%Y-%m-%d %H:%M:%S"
8516
8517set colors {green red blue magenta darkgrey brown orange}
8518set bgcolor white
8519set fgcolor black
8520set diffcolors {red "#00a000" blue}
8521set diffcontext 3
8522set selectbgcolor gray85
8523
8524catch {source ~/.gitk}
8525
8526font create optionfont -family sans-serif -size -12
8527
8528parsefont mainfont $mainfont
8529eval font create mainfont [fontflags mainfont]
8530eval font create mainfontbold [fontflags mainfont 1]
8531
8532parsefont textfont $textfont
8533eval font create textfont [fontflags textfont]
8534eval font create textfontbold [fontflags textfont 1]
8535
8536parsefont uifont $uifont
8537eval font create uifont [fontflags uifont]
8538
8539# check that we can find a .git directory somewhere...
8540if {[catch {set gitdir [gitdir]}]} {
8541    show_error {} . "Cannot find a git repository here."
8542    exit 1
8543}
8544if {![file isdirectory $gitdir]} {
8545    show_error {} . "Cannot find the git directory \"$gitdir\"."
8546    exit 1
8547}
8548
8549set revtreeargs {}
8550set cmdline_files {}
8551set i 0
8552foreach arg $argv {
8553    switch -- $arg {
8554        "" { }
8555        "-d" { set datemode 1 }
8556        "--" {
8557            set cmdline_files [lrange $argv [expr {$i + 1}] end]
8558            break
8559        }
8560        default {
8561            lappend revtreeargs $arg
8562        }
8563    }
8564    incr i
8565}
8566
8567if {$i >= [llength $argv] && $revtreeargs ne {}} {
8568    # no -- on command line, but some arguments (other than -d)
8569    if {[catch {
8570        set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8571        set cmdline_files [split $f "\n"]
8572        set n [llength $cmdline_files]
8573        set revtreeargs [lrange $revtreeargs 0 end-$n]
8574        # Unfortunately git rev-parse doesn't produce an error when
8575        # something is both a revision and a filename.  To be consistent
8576        # with git log and git rev-list, check revtreeargs for filenames.
8577        foreach arg $revtreeargs {
8578            if {[file exists $arg]} {
8579                show_error {} . "Ambiguous argument '$arg': both revision\
8580                                 and filename"
8581                exit 1
8582            }
8583        }
8584    } err]} {
8585        # unfortunately we get both stdout and stderr in $err,
8586        # so look for "fatal:".
8587        set i [string first "fatal:" $err]
8588        if {$i > 0} {
8589            set err [string range $err [expr {$i + 6}] end]
8590        }
8591        show_error {} . "Bad arguments to gitk:\n$err"
8592        exit 1
8593    }
8594}
8595
8596set nullid "0000000000000000000000000000000000000000"
8597set nullid2 "0000000000000000000000000000000000000001"
8598
8599set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8600
8601set runq {}
8602set history {}
8603set historyindex 0
8604set fh_serial 0
8605set nhl_names {}
8606set highlight_paths {}
8607set findpattern {}
8608set searchdirn -forwards
8609set boldrows {}
8610set boldnamerows {}
8611set diffelide {0 0}
8612set markingmatches 0
8613set linkentercount 0
8614set need_redisplay 0
8615set nrows_drawn 0
8616set firsttabstop 0
8617
8618set nextviewnum 1
8619set curview 0
8620set selectedview 0
8621set selectedhlview None
8622set highlight_related None
8623set highlight_files {}
8624set viewfiles(0) {}
8625set viewperm(0) 0
8626set viewargs(0) {}
8627
8628set cmdlineok 0
8629set stopped 0
8630set stuffsaved 0
8631set patchnum 0
8632set localirow -1
8633set localfrow -1
8634set lserial 0
8635setcoords
8636makewindow
8637# wait for the window to become visible
8638tkwait visibility .
8639wm title . "[file tail $argv0]: [file tail [pwd]]"
8640readrefs
8641
8642if {$cmdline_files ne {} || $revtreeargs ne {}} {
8643    # create a view for the files/dirs specified on the command line
8644    set curview 1
8645    set selectedview 1
8646    set nextviewnum 2
8647    set viewname(1) "Command line"
8648    set viewfiles(1) $cmdline_files
8649    set viewargs(1) $revtreeargs
8650    set viewperm(1) 0
8651    addviewmenu 1
8652    .bar.view entryconf Edit* -state normal
8653    .bar.view entryconf Delete* -state normal
8654}
8655
8656if {[info exists permviews]} {
8657    foreach v $permviews {
8658        set n $nextviewnum
8659        incr nextviewnum
8660        set viewname($n) [lindex $v 0]
8661        set viewfiles($n) [lindex $v 1]
8662        set viewargs($n) [lindex $v 2]
8663        set viewperm($n) 1
8664        addviewmenu $n
8665    }
8666}
8667getcommits