gitkon commit [PATCH] Add tests for git-mv in subdirectories (8bf2c69)
   1#!/bin/sh
   2# Tcl ignores the next line -*- tcl -*- \
   3exec wish "$0" -- "$@"
   4
   5# Copyright (C) 2005 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 ".git"
  16    }
  17}
  18
  19proc getcommits {rargs} {
  20    global commits commfd phase canv mainfont env
  21    global startmsecs nextupdate ncmupdate
  22    global ctext maincursor textcursor leftover gitencoding
  23
  24    # check that we can find a .git directory somewhere...
  25    set gitdir [gitdir]
  26    if {![file isdirectory $gitdir]} {
  27        error_popup "Cannot find the git directory \"$gitdir\"."
  28        exit 1
  29    }
  30    set commits {}
  31    set phase getcommits
  32    set startmsecs [clock clicks -milliseconds]
  33    set nextupdate [expr {$startmsecs + 100}]
  34    set ncmupdate 1
  35    if [catch {
  36        set parse_args [concat --default HEAD $rargs]
  37        set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
  38    }] {
  39        # if git-rev-parse failed for some reason...
  40        if {$rargs == {}} {
  41            set rargs HEAD
  42        }
  43        set parsed_args $rargs
  44    }
  45    if [catch {
  46        set commfd [open "|git-rev-list --header --topo-order --parents $parsed_args" r]
  47    } err] {
  48        puts stderr "Error executing git-rev-list: $err"
  49        exit 1
  50    }
  51    set leftover {}
  52    fconfigure $commfd -blocking 0 -translation lf -encoding $gitencoding
  53    fileevent $commfd readable [list getcommitlines $commfd]
  54    $canv delete all
  55    $canv create text 3 3 -anchor nw -text "Reading commits..." \
  56        -font $mainfont -tags textitems
  57    . config -cursor watch
  58    settextcursor watch
  59}
  60
  61proc getcommitlines {commfd}  {
  62    global commits parents cdate children
  63    global commitlisted phase nextupdate
  64    global stopped redisplaying leftover
  65
  66    set stuff [read $commfd]
  67    if {$stuff == {}} {
  68        if {![eof $commfd]} return
  69        # set it blocking so we wait for the process to terminate
  70        fconfigure $commfd -blocking 1
  71        if {![catch {close $commfd} err]} {
  72            after idle finishcommits
  73            return
  74        }
  75        if {[string range $err 0 4] == "usage"} {
  76            set err \
  77                "Gitk: error reading commits: bad arguments to git-rev-list.\
  78                (Note: arguments to gitk are passed to git-rev-list\
  79                to allow selection of commits to be displayed.)"
  80        } else {
  81            set err "Error reading commits: $err"
  82        }
  83        error_popup $err
  84        exit 1
  85    }
  86    set start 0
  87    while 1 {
  88        set i [string first "\0" $stuff $start]
  89        if {$i < 0} {
  90            append leftover [string range $stuff $start end]
  91            return
  92        }
  93        set cmit [string range $stuff $start [expr {$i - 1}]]
  94        if {$start == 0} {
  95            set cmit "$leftover$cmit"
  96            set leftover {}
  97        }
  98        set start [expr {$i + 1}]
  99        set j [string first "\n" $cmit]
 100        set ok 0
 101        if {$j >= 0} {
 102            set ids [string range $cmit 0 [expr {$j - 1}]]
 103            set ok 1
 104            foreach id $ids {
 105                if {![regexp {^[0-9a-f]{40}$} $id]} {
 106                    set ok 0
 107                    break
 108                }
 109            }
 110        }
 111        if {!$ok} {
 112            set shortcmit $cmit
 113            if {[string length $shortcmit] > 80} {
 114                set shortcmit "[string range $shortcmit 0 80]..."
 115            }
 116            error_popup "Can't parse git-rev-list output: {$shortcmit}"
 117            exit 1
 118        }
 119        set id [lindex $ids 0]
 120        set olds [lrange $ids 1 end]
 121        set cmit [string range $cmit [expr {$j + 1}] end]
 122        lappend commits $id
 123        set commitlisted($id) 1
 124        parsecommit $id $cmit 1 [lrange $ids 1 end]
 125        drawcommit $id
 126        if {[clock clicks -milliseconds] >= $nextupdate} {
 127            doupdate 1
 128        }
 129        while {$redisplaying} {
 130            set redisplaying 0
 131            if {$stopped == 1} {
 132                set stopped 0
 133                set phase "getcommits"
 134                foreach id $commits {
 135                    drawcommit $id
 136                    if {$stopped} break
 137                    if {[clock clicks -milliseconds] >= $nextupdate} {
 138                        doupdate 1
 139                    }
 140                }
 141            }
 142        }
 143    }
 144}
 145
 146proc doupdate {reading} {
 147    global commfd nextupdate numcommits ncmupdate
 148
 149    if {$reading} {
 150        fileevent $commfd readable {}
 151    }
 152    update
 153    set nextupdate [expr {[clock clicks -milliseconds] + 100}]
 154    if {$numcommits < 100} {
 155        set ncmupdate [expr {$numcommits + 1}]
 156    } elseif {$numcommits < 10000} {
 157        set ncmupdate [expr {$numcommits + 10}]
 158    } else {
 159        set ncmupdate [expr {$numcommits + 100}]
 160    }
 161    if {$reading} {
 162        fileevent $commfd readable [list getcommitlines $commfd]
 163    }
 164}
 165
 166proc readcommit {id} {
 167    if [catch {set contents [exec git-cat-file commit $id]}] return
 168    parsecommit $id $contents 0 {}
 169}
 170
 171proc parsecommit {id contents listed olds} {
 172    global commitinfo children nchildren parents nparents cdate ncleft
 173
 174    set inhdr 1
 175    set comment {}
 176    set headline {}
 177    set auname {}
 178    set audate {}
 179    set comname {}
 180    set comdate {}
 181    if {![info exists nchildren($id)]} {
 182        set children($id) {}
 183        set nchildren($id) 0
 184        set ncleft($id) 0
 185    }
 186    set parents($id) $olds
 187    set nparents($id) [llength $olds]
 188    foreach p $olds {
 189        if {![info exists nchildren($p)]} {
 190            set children($p) [list $id]
 191            set nchildren($p) 1
 192            set ncleft($p) 1
 193        } elseif {[lsearch -exact $children($p) $id] < 0} {
 194            lappend children($p) $id
 195            incr nchildren($p)
 196            incr ncleft($p)
 197        }
 198    }
 199    set hdrend [string first "\n\n" $contents]
 200    if {$hdrend < 0} {
 201        # should never happen...
 202        set hdrend [string length $contents]
 203    }
 204    set header [string range $contents 0 [expr {$hdrend - 1}]]
 205    set comment [string range $contents [expr {$hdrend + 2}] end]
 206    foreach line [split $header "\n"] {
 207        set tag [lindex $line 0]
 208        if {$tag == "author"} {
 209            set audate [lindex $line end-1]
 210            set auname [lrange $line 1 end-2]
 211        } elseif {$tag == "committer"} {
 212            set comdate [lindex $line end-1]
 213            set comname [lrange $line 1 end-2]
 214        }
 215    }
 216    set headline {}
 217    # take the first line of the comment as the headline
 218    set i [string first "\n" $comment]
 219    if {$i >= 0} {
 220        set headline [string trim [string range $comment 0 $i]]
 221    } else {
 222        set headline $comment
 223    }
 224    if {!$listed} {
 225        # git-rev-list indents the comment by 4 spaces;
 226        # if we got this via git-cat-file, add the indentation
 227        set newcomment {}
 228        foreach line [split $comment "\n"] {
 229            append newcomment "    "
 230            append newcomment $line
 231            append newcomment "\n"
 232        }
 233        set comment $newcomment
 234    }
 235    if {$comdate != {}} {
 236        set cdate($id) $comdate
 237    }
 238    set commitinfo($id) [list $headline $auname $audate \
 239                             $comname $comdate $comment]
 240}
 241
 242proc readrefs {} {
 243    global tagids idtags headids idheads tagcontents
 244    global otherrefids idotherrefs
 245
 246    set refd [open [list | git-ls-remote [gitdir]] r]
 247    while {0 <= [set n [gets $refd line]]} {
 248        if {![regexp {^([0-9a-f]{40})   refs/([^^]*)$} $line \
 249            match id path]} {
 250            continue
 251        }
 252        if {![regexp {^(tags|heads)/(.*)$} $path match type name]} {
 253            set type others
 254            set name $path
 255        }
 256        if {$type == "tags"} {
 257            set tagids($name) $id
 258            lappend idtags($id) $name
 259            set obj {}
 260            set type {}
 261            set tag {}
 262            catch {
 263                set commit [exec git-rev-parse "$id^0"]
 264                if {"$commit" != "$id"} {
 265                    set tagids($name) $commit
 266                    lappend idtags($commit) $name
 267                }
 268            }           
 269            catch {
 270                set tagcontents($name) [exec git-cat-file tag "$id"]
 271            }
 272        } elseif { $type == "heads" } {
 273            set headids($name) $id
 274            lappend idheads($id) $name
 275        } else {
 276            set otherrefids($name) $id
 277            lappend idotherrefs($id) $name
 278        }
 279    }
 280    close $refd
 281}
 282
 283proc error_popup msg {
 284    set w .error
 285    toplevel $w
 286    wm transient $w .
 287    message $w.m -text $msg -justify center -aspect 400
 288    pack $w.m -side top -fill x -padx 20 -pady 20
 289    button $w.ok -text OK -command "destroy $w"
 290    pack $w.ok -side bottom -fill x
 291    bind $w <Visibility> "grab $w; focus $w"
 292    tkwait window $w
 293}
 294
 295proc makewindow {} {
 296    global canv canv2 canv3 linespc charspc ctext cflist textfont
 297    global findtype findtypemenu findloc findstring fstring geometry
 298    global entries sha1entry sha1string sha1but
 299    global maincursor textcursor curtextcursor
 300    global rowctxmenu gaudydiff mergemax
 301
 302    menu .bar
 303    .bar add cascade -label "File" -menu .bar.file
 304    menu .bar.file
 305    .bar.file add command -label "Reread references" -command rereadrefs
 306    .bar.file add command -label "Quit" -command doquit
 307    menu .bar.help
 308    .bar add cascade -label "Help" -menu .bar.help
 309    .bar.help add command -label "About gitk" -command about
 310    . configure -menu .bar
 311
 312    if {![info exists geometry(canv1)]} {
 313        set geometry(canv1) [expr {45 * $charspc}]
 314        set geometry(canv2) [expr {30 * $charspc}]
 315        set geometry(canv3) [expr {15 * $charspc}]
 316        set geometry(canvh) [expr {25 * $linespc + 4}]
 317        set geometry(ctextw) 80
 318        set geometry(ctexth) 30
 319        set geometry(cflistw) 30
 320    }
 321    panedwindow .ctop -orient vertical
 322    if {[info exists geometry(width)]} {
 323        .ctop conf -width $geometry(width) -height $geometry(height)
 324        set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
 325        set geometry(ctexth) [expr {($texth - 8) /
 326                                    [font metrics $textfont -linespace]}]
 327    }
 328    frame .ctop.top
 329    frame .ctop.top.bar
 330    pack .ctop.top.bar -side bottom -fill x
 331    set cscroll .ctop.top.csb
 332    scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
 333    pack $cscroll -side right -fill y
 334    panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
 335    pack .ctop.top.clist -side top -fill both -expand 1
 336    .ctop add .ctop.top
 337    set canv .ctop.top.clist.canv
 338    canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
 339        -bg white -bd 0 \
 340        -yscrollincr $linespc -yscrollcommand "$cscroll set"
 341    .ctop.top.clist add $canv
 342    set canv2 .ctop.top.clist.canv2
 343    canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
 344        -bg white -bd 0 -yscrollincr $linespc
 345    .ctop.top.clist add $canv2
 346    set canv3 .ctop.top.clist.canv3
 347    canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
 348        -bg white -bd 0 -yscrollincr $linespc
 349    .ctop.top.clist add $canv3
 350    bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
 351
 352    set sha1entry .ctop.top.bar.sha1
 353    set entries $sha1entry
 354    set sha1but .ctop.top.bar.sha1label
 355    button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
 356        -command gotocommit -width 8
 357    $sha1but conf -disabledforeground [$sha1but cget -foreground]
 358    pack .ctop.top.bar.sha1label -side left
 359    entry $sha1entry -width 40 -font $textfont -textvariable sha1string
 360    trace add variable sha1string write sha1change
 361    pack $sha1entry -side left -pady 2
 362
 363    image create bitmap bm-left -data {
 364        #define left_width 16
 365        #define left_height 16
 366        static unsigned char left_bits[] = {
 367        0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
 368        0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
 369        0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
 370    }
 371    image create bitmap bm-right -data {
 372        #define right_width 16
 373        #define right_height 16
 374        static unsigned char right_bits[] = {
 375        0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
 376        0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
 377        0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
 378    }
 379    button .ctop.top.bar.leftbut -image bm-left -command goback \
 380        -state disabled -width 26
 381    pack .ctop.top.bar.leftbut -side left -fill y
 382    button .ctop.top.bar.rightbut -image bm-right -command goforw \
 383        -state disabled -width 26
 384    pack .ctop.top.bar.rightbut -side left -fill y
 385
 386    button .ctop.top.bar.findbut -text "Find" -command dofind
 387    pack .ctop.top.bar.findbut -side left
 388    set findstring {}
 389    set fstring .ctop.top.bar.findstring
 390    lappend entries $fstring
 391    entry $fstring -width 30 -font $textfont -textvariable findstring
 392    pack $fstring -side left -expand 1 -fill x
 393    set findtype Exact
 394    set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
 395                          findtype Exact IgnCase Regexp]
 396    set findloc "All fields"
 397    tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
 398        Comments Author Committer Files Pickaxe
 399    pack .ctop.top.bar.findloc -side right
 400    pack .ctop.top.bar.findtype -side right
 401    # for making sure type==Exact whenever loc==Pickaxe
 402    trace add variable findloc write findlocchange
 403
 404    panedwindow .ctop.cdet -orient horizontal
 405    .ctop add .ctop.cdet
 406    frame .ctop.cdet.left
 407    set ctext .ctop.cdet.left.ctext
 408    text $ctext -bg white -state disabled -font $textfont \
 409        -width $geometry(ctextw) -height $geometry(ctexth) \
 410        -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
 411    scrollbar .ctop.cdet.left.sb -command "$ctext yview"
 412    pack .ctop.cdet.left.sb -side right -fill y
 413    pack $ctext -side left -fill both -expand 1
 414    .ctop.cdet add .ctop.cdet.left
 415
 416    $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
 417    if {$gaudydiff} {
 418        $ctext tag conf hunksep -back blue -fore white
 419        $ctext tag conf d0 -back "#ff8080"
 420        $ctext tag conf d1 -back green
 421    } else {
 422        $ctext tag conf hunksep -fore blue
 423        $ctext tag conf d0 -fore red
 424        $ctext tag conf d1 -fore "#00a000"
 425        $ctext tag conf m0 -fore red
 426        $ctext tag conf m1 -fore blue
 427        $ctext tag conf m2 -fore green
 428        $ctext tag conf m3 -fore purple
 429        $ctext tag conf m4 -fore brown
 430        $ctext tag conf mmax -fore darkgrey
 431        set mergemax 5
 432        $ctext tag conf mresult -font [concat $textfont bold]
 433        $ctext tag conf msep -font [concat $textfont bold]
 434        $ctext tag conf found -back yellow
 435    }
 436
 437    frame .ctop.cdet.right
 438    set cflist .ctop.cdet.right.cfiles
 439    listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
 440        -yscrollcommand ".ctop.cdet.right.sb set"
 441    scrollbar .ctop.cdet.right.sb -command "$cflist yview"
 442    pack .ctop.cdet.right.sb -side right -fill y
 443    pack $cflist -side left -fill both -expand 1
 444    .ctop.cdet add .ctop.cdet.right
 445    bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
 446
 447    pack .ctop -side top -fill both -expand 1
 448
 449    bindall <1> {selcanvline %W %x %y}
 450    #bindall <B1-Motion> {selcanvline %W %x %y}
 451    bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
 452    bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
 453    bindall <2> "allcanvs scan mark 0 %y"
 454    bindall <B2-Motion> "allcanvs scan dragto 0 %y"
 455    bind . <Key-Up> "selnextline -1"
 456    bind . <Key-Down> "selnextline 1"
 457    bind . <Key-Right> "goforw"
 458    bind . <Key-Left> "goback"
 459    bind . <Key-Prior> "allcanvs yview scroll -1 pages"
 460    bind . <Key-Next> "allcanvs yview scroll 1 pages"
 461    bindkey <Key-Delete> "$ctext yview scroll -1 pages"
 462    bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
 463    bindkey <Key-space> "$ctext yview scroll 1 pages"
 464    bindkey p "selnextline -1"
 465    bindkey n "selnextline 1"
 466    bindkey z "goback"
 467    bindkey x "goforw"
 468    bindkey i "selnextline -1"
 469    bindkey k "selnextline 1"
 470    bindkey j "goback"
 471    bindkey l "goforw"
 472    bindkey b "$ctext yview scroll -1 pages"
 473    bindkey d "$ctext yview scroll 18 units"
 474    bindkey u "$ctext yview scroll -18 units"
 475    bindkey / {findnext 1}
 476    bindkey <Key-Return> {findnext 0}
 477    bindkey ? findprev
 478    bindkey f nextfile
 479    bind . <Control-q> doquit
 480    bind . <Control-f> dofind
 481    bind . <Control-g> {findnext 0}
 482    bind . <Control-r> findprev
 483    bind . <Control-equal> {incrfont 1}
 484    bind . <Control-KP_Add> {incrfont 1}
 485    bind . <Control-minus> {incrfont -1}
 486    bind . <Control-KP_Subtract> {incrfont -1}
 487    bind $cflist <<ListboxSelect>> listboxsel
 488    bind . <Destroy> {savestuff %W}
 489    bind . <Button-1> "click %W"
 490    bind $fstring <Key-Return> dofind
 491    bind $sha1entry <Key-Return> gotocommit
 492    bind $sha1entry <<PasteSelection>> clearsha1
 493
 494    set maincursor [. cget -cursor]
 495    set textcursor [$ctext cget -cursor]
 496    set curtextcursor $textcursor
 497
 498    set rowctxmenu .rowctxmenu
 499    menu $rowctxmenu -tearoff 0
 500    $rowctxmenu add command -label "Diff this -> selected" \
 501        -command {diffvssel 0}
 502    $rowctxmenu add command -label "Diff selected -> this" \
 503        -command {diffvssel 1}
 504    $rowctxmenu add command -label "Make patch" -command mkpatch
 505    $rowctxmenu add command -label "Create tag" -command mktag
 506    $rowctxmenu add command -label "Write commit to file" -command writecommit
 507}
 508
 509# when we make a key binding for the toplevel, make sure
 510# it doesn't get triggered when that key is pressed in the
 511# find string entry widget.
 512proc bindkey {ev script} {
 513    global entries
 514    bind . $ev $script
 515    set escript [bind Entry $ev]
 516    if {$escript == {}} {
 517        set escript [bind Entry <Key>]
 518    }
 519    foreach e $entries {
 520        bind $e $ev "$escript; break"
 521    }
 522}
 523
 524# set the focus back to the toplevel for any click outside
 525# the entry widgets
 526proc click {w} {
 527    global entries
 528    foreach e $entries {
 529        if {$w == $e} return
 530    }
 531    focus .
 532}
 533
 534proc savestuff {w} {
 535    global canv canv2 canv3 ctext cflist mainfont textfont
 536    global stuffsaved findmergefiles gaudydiff maxgraphpct
 537    global maxwidth
 538
 539    if {$stuffsaved} return
 540    if {![winfo viewable .]} return
 541    catch {
 542        set f [open "~/.gitk-new" w]
 543        puts $f [list set mainfont $mainfont]
 544        puts $f [list set textfont $textfont]
 545        puts $f [list set findmergefiles $findmergefiles]
 546        puts $f [list set gaudydiff $gaudydiff]
 547        puts $f [list set maxgraphpct $maxgraphpct]
 548        puts $f [list set maxwidth $maxwidth]
 549        puts $f "set geometry(width) [winfo width .ctop]"
 550        puts $f "set geometry(height) [winfo height .ctop]"
 551        puts $f "set geometry(canv1) [expr {[winfo width $canv]-2}]"
 552        puts $f "set geometry(canv2) [expr {[winfo width $canv2]-2}]"
 553        puts $f "set geometry(canv3) [expr {[winfo width $canv3]-2}]"
 554        puts $f "set geometry(canvh) [expr {[winfo height $canv]-2}]"
 555        set wid [expr {([winfo width $ctext] - 8) \
 556                           / [font measure $textfont "0"]}]
 557        puts $f "set geometry(ctextw) $wid"
 558        set wid [expr {([winfo width $cflist] - 11) \
 559                           / [font measure [$cflist cget -font] "0"]}]
 560        puts $f "set geometry(cflistw) $wid"
 561        close $f
 562        file rename -force "~/.gitk-new" "~/.gitk"
 563    }
 564    set stuffsaved 1
 565}
 566
 567proc resizeclistpanes {win w} {
 568    global oldwidth
 569    if [info exists oldwidth($win)] {
 570        set s0 [$win sash coord 0]
 571        set s1 [$win sash coord 1]
 572        if {$w < 60} {
 573            set sash0 [expr {int($w/2 - 2)}]
 574            set sash1 [expr {int($w*5/6 - 2)}]
 575        } else {
 576            set factor [expr {1.0 * $w / $oldwidth($win)}]
 577            set sash0 [expr {int($factor * [lindex $s0 0])}]
 578            set sash1 [expr {int($factor * [lindex $s1 0])}]
 579            if {$sash0 < 30} {
 580                set sash0 30
 581            }
 582            if {$sash1 < $sash0 + 20} {
 583                set sash1 [expr {$sash0 + 20}]
 584            }
 585            if {$sash1 > $w - 10} {
 586                set sash1 [expr {$w - 10}]
 587                if {$sash0 > $sash1 - 20} {
 588                    set sash0 [expr {$sash1 - 20}]
 589                }
 590            }
 591        }
 592        $win sash place 0 $sash0 [lindex $s0 1]
 593        $win sash place 1 $sash1 [lindex $s1 1]
 594    }
 595    set oldwidth($win) $w
 596}
 597
 598proc resizecdetpanes {win w} {
 599    global oldwidth
 600    if [info exists oldwidth($win)] {
 601        set s0 [$win sash coord 0]
 602        if {$w < 60} {
 603            set sash0 [expr {int($w*3/4 - 2)}]
 604        } else {
 605            set factor [expr {1.0 * $w / $oldwidth($win)}]
 606            set sash0 [expr {int($factor * [lindex $s0 0])}]
 607            if {$sash0 < 45} {
 608                set sash0 45
 609            }
 610            if {$sash0 > $w - 15} {
 611                set sash0 [expr {$w - 15}]
 612            }
 613        }
 614        $win sash place 0 $sash0 [lindex $s0 1]
 615    }
 616    set oldwidth($win) $w
 617}
 618
 619proc allcanvs args {
 620    global canv canv2 canv3
 621    eval $canv $args
 622    eval $canv2 $args
 623    eval $canv3 $args
 624}
 625
 626proc bindall {event action} {
 627    global canv canv2 canv3
 628    bind $canv $event $action
 629    bind $canv2 $event $action
 630    bind $canv3 $event $action
 631}
 632
 633proc about {} {
 634    set w .about
 635    if {[winfo exists $w]} {
 636        raise $w
 637        return
 638    }
 639    toplevel $w
 640    wm title $w "About gitk"
 641    message $w.m -text {
 642Gitk version 1.2
 643
 644Copyright © 2005 Paul Mackerras
 645
 646Use and redistribute under the terms of the GNU General Public License} \
 647            -justify center -aspect 400
 648    pack $w.m -side top -fill x -padx 20 -pady 20
 649    button $w.ok -text Close -command "destroy $w"
 650    pack $w.ok -side bottom
 651}
 652
 653proc assigncolor {id} {
 654    global colormap commcolors colors nextcolor
 655    global parents nparents children nchildren
 656    global cornercrossings crossings
 657
 658    if [info exists colormap($id)] return
 659    set ncolors [llength $colors]
 660    if {$nparents($id) <= 1 && $nchildren($id) == 1} {
 661        set child [lindex $children($id) 0]
 662        if {[info exists colormap($child)]
 663            && $nparents($child) == 1} {
 664            set colormap($id) $colormap($child)
 665            return
 666        }
 667    }
 668    set badcolors {}
 669    if {[info exists cornercrossings($id)]} {
 670        foreach x $cornercrossings($id) {
 671            if {[info exists colormap($x)]
 672                && [lsearch -exact $badcolors $colormap($x)] < 0} {
 673                lappend badcolors $colormap($x)
 674            }
 675        }
 676        if {[llength $badcolors] >= $ncolors} {
 677            set badcolors {}
 678        }
 679    }
 680    set origbad $badcolors
 681    if {[llength $badcolors] < $ncolors - 1} {
 682        if {[info exists crossings($id)]} {
 683            foreach x $crossings($id) {
 684                if {[info exists colormap($x)]
 685                    && [lsearch -exact $badcolors $colormap($x)] < 0} {
 686                    lappend badcolors $colormap($x)
 687                }
 688            }
 689            if {[llength $badcolors] >= $ncolors} {
 690                set badcolors $origbad
 691            }
 692        }
 693        set origbad $badcolors
 694    }
 695    if {[llength $badcolors] < $ncolors - 1} {
 696        foreach child $children($id) {
 697            if {[info exists colormap($child)]
 698                && [lsearch -exact $badcolors $colormap($child)] < 0} {
 699                lappend badcolors $colormap($child)
 700            }
 701            if {[info exists parents($child)]} {
 702                foreach p $parents($child) {
 703                    if {[info exists colormap($p)]
 704                        && [lsearch -exact $badcolors $colormap($p)] < 0} {
 705                        lappend badcolors $colormap($p)
 706                    }
 707                }
 708            }
 709        }
 710        if {[llength $badcolors] >= $ncolors} {
 711            set badcolors $origbad
 712        }
 713    }
 714    for {set i 0} {$i <= $ncolors} {incr i} {
 715        set c [lindex $colors $nextcolor]
 716        if {[incr nextcolor] >= $ncolors} {
 717            set nextcolor 0
 718        }
 719        if {[lsearch -exact $badcolors $c]} break
 720    }
 721    set colormap($id) $c
 722}
 723
 724proc initgraph {} {
 725    global canvy canvy0 lineno numcommits nextcolor linespc
 726    global mainline mainlinearrow sidelines
 727    global nchildren ncleft
 728    global displist nhyperspace
 729
 730    allcanvs delete all
 731    set nextcolor 0
 732    set canvy $canvy0
 733    set lineno -1
 734    set numcommits 0
 735    catch {unset mainline}
 736    catch {unset mainlinearrow}
 737    catch {unset sidelines}
 738    foreach id [array names nchildren] {
 739        set ncleft($id) $nchildren($id)
 740    }
 741    set displist {}
 742    set nhyperspace 0
 743}
 744
 745proc bindline {t id} {
 746    global canv
 747
 748    $canv bind $t <Enter> "lineenter %x %y $id"
 749    $canv bind $t <Motion> "linemotion %x %y $id"
 750    $canv bind $t <Leave> "lineleave $id"
 751    $canv bind $t <Button-1> "lineclick %x %y $id 1"
 752}
 753
 754proc drawlines {id xtra delold} {
 755    global mainline mainlinearrow sidelines lthickness colormap canv
 756
 757    if {$delold} {
 758        $canv delete lines.$id
 759    }
 760    if {[info exists mainline($id)]} {
 761        set t [$canv create line $mainline($id) \
 762                   -width [expr {($xtra + 1) * $lthickness}] \
 763                   -fill $colormap($id) -tags lines.$id \
 764                   -arrow $mainlinearrow($id)]
 765        $canv lower $t
 766        bindline $t $id
 767    }
 768    if {[info exists sidelines($id)]} {
 769        foreach ls $sidelines($id) {
 770            set coords [lindex $ls 0]
 771            set thick [lindex $ls 1]
 772            set arrow [lindex $ls 2]
 773            set t [$canv create line $coords -fill $colormap($id) \
 774                       -width [expr {($thick + $xtra) * $lthickness}] \
 775                       -arrow $arrow -tags lines.$id]
 776            $canv lower $t
 777            bindline $t $id
 778        }
 779    }
 780}
 781
 782# level here is an index in displist
 783proc drawcommitline {level} {
 784    global parents children nparents displist
 785    global canv canv2 canv3 mainfont namefont canvy linespc
 786    global lineid linehtag linentag linedtag commitinfo
 787    global colormap numcommits currentparents dupparents
 788    global idtags idline idheads idotherrefs
 789    global lineno lthickness mainline mainlinearrow sidelines
 790    global commitlisted rowtextx idpos lastuse displist
 791    global oldnlines olddlevel olddisplist
 792
 793    incr numcommits
 794    incr lineno
 795    set id [lindex $displist $level]
 796    set lastuse($id) $lineno
 797    set lineid($lineno) $id
 798    set idline($id) $lineno
 799    set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
 800    if {![info exists commitinfo($id)]} {
 801        readcommit $id
 802        if {![info exists commitinfo($id)]} {
 803            set commitinfo($id) {"No commit information available"}
 804            set nparents($id) 0
 805        }
 806    }
 807    assigncolor $id
 808    set currentparents {}
 809    set dupparents {}
 810    if {[info exists commitlisted($id)] && [info exists parents($id)]} {
 811        foreach p $parents($id) {
 812            if {[lsearch -exact $currentparents $p] < 0} {
 813                lappend currentparents $p
 814            } else {
 815                # remember that this parent was listed twice
 816                lappend dupparents $p
 817            }
 818        }
 819    }
 820    set x [xcoord $level $level $lineno]
 821    set y1 $canvy
 822    set canvy [expr {$canvy + $linespc}]
 823    allcanvs conf -scrollregion \
 824        [list 0 0 0 [expr {$y1 + 0.5 * $linespc + 2}]]
 825    if {[info exists mainline($id)]} {
 826        lappend mainline($id) $x $y1
 827        if {$mainlinearrow($id) ne "none"} {
 828            set mainline($id) [trimdiagstart $mainline($id)]
 829        }
 830    }
 831    drawlines $id 0 0
 832    set orad [expr {$linespc / 3}]
 833    set t [$canv create oval [expr {$x - $orad}] [expr {$y1 - $orad}] \
 834               [expr {$x + $orad - 1}] [expr {$y1 + $orad - 1}] \
 835               -fill $ofill -outline black -width 1]
 836    $canv raise $t
 837    $canv bind $t <1> {selcanvline {} %x %y}
 838    set xt [xcoord [llength $displist] $level $lineno]
 839    if {[llength $currentparents] > 2} {
 840        set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
 841    }
 842    set rowtextx($lineno) $xt
 843    set idpos($id) [list $x $xt $y1]
 844    if {[info exists idtags($id)] || [info exists idheads($id)]
 845        || [info exists idotherrefs($id)]} {
 846        set xt [drawtags $id $x $xt $y1]
 847    }
 848    set headline [lindex $commitinfo($id) 0]
 849    set name [lindex $commitinfo($id) 1]
 850    set date [lindex $commitinfo($id) 2]
 851    set date [formatdate $date]
 852    set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
 853                               -text $headline -font $mainfont ]
 854    $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
 855    set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
 856                               -text $name -font $namefont]
 857    set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
 858                               -text $date -font $mainfont]
 859
 860    set olddlevel $level
 861    set olddisplist $displist
 862    set oldnlines [llength $displist]
 863}
 864
 865proc drawtags {id x xt y1} {
 866    global idtags idheads idotherrefs
 867    global linespc lthickness
 868    global canv mainfont idline rowtextx
 869
 870    set marks {}
 871    set ntags 0
 872    set nheads 0
 873    if {[info exists idtags($id)]} {
 874        set marks $idtags($id)
 875        set ntags [llength $marks]
 876    }
 877    if {[info exists idheads($id)]} {
 878        set marks [concat $marks $idheads($id)]
 879        set nheads [llength $idheads($id)]
 880    }
 881    if {[info exists idotherrefs($id)]} {
 882        set marks [concat $marks $idotherrefs($id)]
 883    }
 884    if {$marks eq {}} {
 885        return $xt
 886    }
 887
 888    set delta [expr {int(0.5 * ($linespc - $lthickness))}]
 889    set yt [expr {$y1 - 0.5 * $linespc}]
 890    set yb [expr {$yt + $linespc - 1}]
 891    set xvals {}
 892    set wvals {}
 893    foreach tag $marks {
 894        set wid [font measure $mainfont $tag]
 895        lappend xvals $xt
 896        lappend wvals $wid
 897        set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
 898    }
 899    set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
 900               -width $lthickness -fill black -tags tag.$id]
 901    $canv lower $t
 902    foreach tag $marks x $xvals wid $wvals {
 903        set xl [expr {$x + $delta}]
 904        set xr [expr {$x + $delta + $wid + $lthickness}]
 905        if {[incr ntags -1] >= 0} {
 906            # draw a tag
 907            set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
 908                       $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
 909                       -width 1 -outline black -fill yellow -tags tag.$id]
 910            $canv bind $t <1> [list showtag $tag 1]
 911            set rowtextx($idline($id)) [expr {$xr + $linespc}]
 912        } else {
 913            # draw a head or other ref
 914            if {[incr nheads -1] >= 0} {
 915                set col green
 916            } else {
 917                set col "#ddddff"
 918            }
 919            set xl [expr {$xl - $delta/2}]
 920            $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
 921                -width 1 -outline black -fill $col -tags tag.$id
 922        }
 923        set t [$canv create text $xl $y1 -anchor w -text $tag \
 924                   -font $mainfont -tags tag.$id]
 925        if {$ntags >= 0} {
 926            $canv bind $t <1> [list showtag $tag 1]
 927        }
 928    }
 929    return $xt
 930}
 931
 932proc notecrossings {id lo hi corner} {
 933    global olddisplist crossings cornercrossings
 934
 935    for {set i $lo} {[incr i] < $hi} {} {
 936        set p [lindex $olddisplist $i]
 937        if {$p == {}} continue
 938        if {$i == $corner} {
 939            if {![info exists cornercrossings($id)]
 940                || [lsearch -exact $cornercrossings($id) $p] < 0} {
 941                lappend cornercrossings($id) $p
 942            }
 943            if {![info exists cornercrossings($p)]
 944                || [lsearch -exact $cornercrossings($p) $id] < 0} {
 945                lappend cornercrossings($p) $id
 946            }
 947        } else {
 948            if {![info exists crossings($id)]
 949                || [lsearch -exact $crossings($id) $p] < 0} {
 950                lappend crossings($id) $p
 951            }
 952            if {![info exists crossings($p)]
 953                || [lsearch -exact $crossings($p) $id] < 0} {
 954                lappend crossings($p) $id
 955            }
 956        }
 957    }
 958}
 959
 960proc xcoord {i level ln} {
 961    global canvx0 xspc1 xspc2
 962
 963    set x [expr {$canvx0 + $i * $xspc1($ln)}]
 964    if {$i > 0 && $i == $level} {
 965        set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
 966    } elseif {$i > $level} {
 967        set x [expr {$x + $xspc2 - $xspc1($ln)}]
 968    }
 969    return $x
 970}
 971
 972# it seems Tk can't draw arrows on the end of diagonal line segments...
 973proc trimdiagend {line} {
 974    while {[llength $line] > 4} {
 975        set x1 [lindex $line end-3]
 976        set y1 [lindex $line end-2]
 977        set x2 [lindex $line end-1]
 978        set y2 [lindex $line end]
 979        if {($x1 == $x2) != ($y1 == $y2)} break
 980        set line [lreplace $line end-1 end]
 981    }
 982    return $line
 983}
 984
 985proc trimdiagstart {line} {
 986    while {[llength $line] > 4} {
 987        set x1 [lindex $line 0]
 988        set y1 [lindex $line 1]
 989        set x2 [lindex $line 2]
 990        set y2 [lindex $line 3]
 991        if {($x1 == $x2) != ($y1 == $y2)} break
 992        set line [lreplace $line 0 1]
 993    }
 994    return $line
 995}
 996
 997proc drawslants {id needonscreen nohs} {
 998    global canv mainline mainlinearrow sidelines
 999    global canvx0 canvy xspc1 xspc2 lthickness
1000    global currentparents dupparents
1001    global lthickness linespc canvy colormap lineno geometry
1002    global maxgraphpct maxwidth
1003    global displist onscreen lastuse
1004    global parents commitlisted
1005    global oldnlines olddlevel olddisplist
1006    global nhyperspace numcommits nnewparents
1007
1008    if {$lineno < 0} {
1009        lappend displist $id
1010        set onscreen($id) 1
1011        return 0
1012    }
1013
1014    set y1 [expr {$canvy - $linespc}]
1015    set y2 $canvy
1016
1017    # work out what we need to get back on screen
1018    set reins {}
1019    if {$onscreen($id) < 0} {
1020        # next to do isn't displayed, better get it on screen...
1021        lappend reins [list $id 0]
1022    }
1023    # make sure all the previous commits's parents are on the screen
1024    foreach p $currentparents {
1025        if {$onscreen($p) < 0} {
1026            lappend reins [list $p 0]
1027        }
1028    }
1029    # bring back anything requested by caller
1030    if {$needonscreen ne {}} {
1031        lappend reins $needonscreen
1032    }
1033
1034    # try the shortcut
1035    if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
1036        set dlevel $olddlevel
1037        set x [xcoord $dlevel $dlevel $lineno]
1038        set mainline($id) [list $x $y1]
1039        set mainlinearrow($id) none
1040        set lastuse($id) $lineno
1041        set displist [lreplace $displist $dlevel $dlevel $id]
1042        set onscreen($id) 1
1043        set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
1044        return $dlevel
1045    }
1046
1047    # update displist
1048    set displist [lreplace $displist $olddlevel $olddlevel]
1049    set j $olddlevel
1050    foreach p $currentparents {
1051        set lastuse($p) $lineno
1052        if {$onscreen($p) == 0} {
1053            set displist [linsert $displist $j $p]
1054            set onscreen($p) 1
1055            incr j
1056        }
1057    }
1058    if {$onscreen($id) == 0} {
1059        lappend displist $id
1060        set onscreen($id) 1
1061    }
1062
1063    # remove the null entry if present
1064    set nullentry [lsearch -exact $displist {}]
1065    if {$nullentry >= 0} {
1066        set displist [lreplace $displist $nullentry $nullentry]
1067    }
1068
1069    # bring back the ones we need now (if we did it earlier
1070    # it would change displist and invalidate olddlevel)
1071    foreach pi $reins {
1072        # test again in case of duplicates in reins
1073        set p [lindex $pi 0]
1074        if {$onscreen($p) < 0} {
1075            set onscreen($p) 1
1076            set lastuse($p) $lineno
1077            set displist [linsert $displist [lindex $pi 1] $p]
1078            incr nhyperspace -1
1079        }
1080    }
1081
1082    set lastuse($id) $lineno
1083
1084    # see if we need to make any lines jump off into hyperspace
1085    set displ [llength $displist]
1086    if {$displ > $maxwidth} {
1087        set ages {}
1088        foreach x $displist {
1089            lappend ages [list $lastuse($x) $x]
1090        }
1091        set ages [lsort -integer -index 0 $ages]
1092        set k 0
1093        while {$displ > $maxwidth} {
1094            set use [lindex $ages $k 0]
1095            set victim [lindex $ages $k 1]
1096            if {$use >= $lineno - 5} break
1097            incr k
1098            if {[lsearch -exact $nohs $victim] >= 0} continue
1099            set i [lsearch -exact $displist $victim]
1100            set displist [lreplace $displist $i $i]
1101            set onscreen($victim) -1
1102            incr nhyperspace
1103            incr displ -1
1104            if {$i < $nullentry} {
1105                incr nullentry -1
1106            }
1107            set x [lindex $mainline($victim) end-1]
1108            lappend mainline($victim) $x $y1
1109            set line [trimdiagend $mainline($victim)]
1110            set arrow "last"
1111            if {$mainlinearrow($victim) ne "none"} {
1112                set line [trimdiagstart $line]
1113                set arrow "both"
1114            }
1115            lappend sidelines($victim) [list $line 1 $arrow]
1116            unset mainline($victim)
1117        }
1118    }
1119
1120    set dlevel [lsearch -exact $displist $id]
1121
1122    # If we are reducing, put in a null entry
1123    if {$displ < $oldnlines} {
1124        # does the next line look like a merge?
1125        # i.e. does it have > 1 new parent?
1126        if {$nnewparents($id) > 1} {
1127            set i [expr {$dlevel + 1}]
1128        } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
1129            set i $olddlevel
1130            if {$nullentry >= 0 && $nullentry < $i} {
1131                incr i -1
1132            }
1133        } elseif {$nullentry >= 0} {
1134            set i $nullentry
1135            while {$i < $displ
1136                   && [lindex $olddisplist $i] == [lindex $displist $i]} {
1137                incr i
1138            }
1139        } else {
1140            set i $olddlevel
1141            if {$dlevel >= $i} {
1142                incr i
1143            }
1144        }
1145        if {$i < $displ} {
1146            set displist [linsert $displist $i {}]
1147            incr displ
1148            if {$dlevel >= $i} {
1149                incr dlevel
1150            }
1151        }
1152    }
1153
1154    # decide on the line spacing for the next line
1155    set lj [expr {$lineno + 1}]
1156    set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1157    if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
1158        set xspc1($lj) $xspc2
1159    } else {
1160        set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
1161        if {$xspc1($lj) < $lthickness} {
1162            set xspc1($lj) $lthickness
1163        }
1164    }
1165
1166    foreach idi $reins {
1167        set id [lindex $idi 0]
1168        set j [lsearch -exact $displist $id]
1169        set xj [xcoord $j $dlevel $lj]
1170        set mainline($id) [list $xj $y2]
1171        set mainlinearrow($id) first
1172    }
1173
1174    set i -1
1175    foreach id $olddisplist {
1176        incr i
1177        if {$id == {}} continue
1178        if {$onscreen($id) <= 0} continue
1179        set xi [xcoord $i $olddlevel $lineno]
1180        if {$i == $olddlevel} {
1181            foreach p $currentparents {
1182                set j [lsearch -exact $displist $p]
1183                set coords [list $xi $y1]
1184                set xj [xcoord $j $dlevel $lj]
1185                if {$xj < $xi - $linespc} {
1186                    lappend coords [expr {$xj + $linespc}] $y1
1187                    notecrossings $p $j $i [expr {$j + 1}]
1188                } elseif {$xj > $xi + $linespc} {
1189                    lappend coords [expr {$xj - $linespc}] $y1
1190                    notecrossings $p $i $j [expr {$j - 1}]
1191                }
1192                if {[lsearch -exact $dupparents $p] >= 0} {
1193                    # draw a double-width line to indicate the doubled parent
1194                    lappend coords $xj $y2
1195                    lappend sidelines($p) [list $coords 2 none]
1196                    if {![info exists mainline($p)]} {
1197                        set mainline($p) [list $xj $y2]
1198                        set mainlinearrow($p) none
1199                    }
1200                } else {
1201                    # normal case, no parent duplicated
1202                    set yb $y2
1203                    set dx [expr {abs($xi - $xj)}]
1204                    if {0 && $dx < $linespc} {
1205                        set yb [expr {$y1 + $dx}]
1206                    }
1207                    if {![info exists mainline($p)]} {
1208                        if {$xi != $xj} {
1209                            lappend coords $xj $yb
1210                        }
1211                        set mainline($p) $coords
1212                        set mainlinearrow($p) none
1213                    } else {
1214                        lappend coords $xj $yb
1215                        if {$yb < $y2} {
1216                            lappend coords $xj $y2
1217                        }
1218                        lappend sidelines($p) [list $coords 1 none]
1219                    }
1220                }
1221            }
1222        } else {
1223            set j $i
1224            if {[lindex $displist $i] != $id} {
1225                set j [lsearch -exact $displist $id]
1226            }
1227            if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1228                || ($olddlevel < $i && $i < $dlevel)
1229                || ($dlevel < $i && $i < $olddlevel)} {
1230                set xj [xcoord $j $dlevel $lj]
1231                lappend mainline($id) $xi $y1 $xj $y2
1232            }
1233        }
1234    }
1235    return $dlevel
1236}
1237
1238# search for x in a list of lists
1239proc llsearch {llist x} {
1240    set i 0
1241    foreach l $llist {
1242        if {$l == $x || [lsearch -exact $l $x] >= 0} {
1243            return $i
1244        }
1245        incr i
1246    }
1247    return -1
1248}
1249
1250proc drawmore {reading} {
1251    global displayorder numcommits ncmupdate nextupdate
1252    global stopped nhyperspace parents commitlisted
1253    global maxwidth onscreen displist currentparents olddlevel
1254
1255    set n [llength $displayorder]
1256    while {$numcommits < $n} {
1257        set id [lindex $displayorder $numcommits]
1258        set ctxend [expr {$numcommits + 10}]
1259        if {!$reading && $ctxend > $n} {
1260            set ctxend $n
1261        }
1262        set dlist {}
1263        if {$numcommits > 0} {
1264            set dlist [lreplace $displist $olddlevel $olddlevel]
1265            set i $olddlevel
1266            foreach p $currentparents {
1267                if {$onscreen($p) == 0} {
1268                    set dlist [linsert $dlist $i $p]
1269                    incr i
1270                }
1271            }
1272        }
1273        set nohs {}
1274        set reins {}
1275        set isfat [expr {[llength $dlist] > $maxwidth}]
1276        if {$nhyperspace > 0 || $isfat} {
1277            if {$ctxend > $n} break
1278            # work out what to bring back and
1279            # what we want to don't want to send into hyperspace
1280            set room 1
1281            for {set k $numcommits} {$k < $ctxend} {incr k} {
1282                set x [lindex $displayorder $k]
1283                set i [llsearch $dlist $x]
1284                if {$i < 0} {
1285                    set i [llength $dlist]
1286                    lappend dlist $x
1287                }
1288                if {[lsearch -exact $nohs $x] < 0} {
1289                    lappend nohs $x
1290                }
1291                if {$reins eq {} && $onscreen($x) < 0 && $room} {
1292                    set reins [list $x $i]
1293                }
1294                set newp {}
1295                if {[info exists commitlisted($x)]} {
1296                    set right 0
1297                    foreach p $parents($x) {
1298                        if {[llsearch $dlist $p] < 0} {
1299                            lappend newp $p
1300                            if {[lsearch -exact $nohs $p] < 0} {
1301                                lappend nohs $p
1302                            }
1303                            if {$reins eq {} && $onscreen($p) < 0 && $room} {
1304                                set reins [list $p [expr {$i + $right}]]
1305                            }
1306                        }
1307                        set right 1
1308                    }
1309                }
1310                set l [lindex $dlist $i]
1311                if {[llength $l] == 1} {
1312                    set l $newp
1313                } else {
1314                    set j [lsearch -exact $l $x]
1315                    set l [concat [lreplace $l $j $j] $newp]
1316                }
1317                set dlist [lreplace $dlist $i $i $l]
1318                if {$room && $isfat && [llength $newp] <= 1} {
1319                    set room 0
1320                }
1321            }
1322        }
1323
1324        set dlevel [drawslants $id $reins $nohs]
1325        drawcommitline $dlevel
1326        if {[clock clicks -milliseconds] >= $nextupdate
1327            && $numcommits >= $ncmupdate} {
1328            doupdate $reading
1329            if {$stopped} break
1330        }
1331    }
1332}
1333
1334# level here is an index in todo
1335proc updatetodo {level noshortcut} {
1336    global ncleft todo nnewparents
1337    global commitlisted parents onscreen
1338
1339    set id [lindex $todo $level]
1340    set olds {}
1341    if {[info exists commitlisted($id)]} {
1342        foreach p $parents($id) {
1343            if {[lsearch -exact $olds $p] < 0} {
1344                lappend olds $p
1345            }
1346        }
1347    }
1348    if {!$noshortcut && [llength $olds] == 1} {
1349        set p [lindex $olds 0]
1350        if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
1351            set ncleft($p) 0
1352            set todo [lreplace $todo $level $level $p]
1353            set onscreen($p) 0
1354            set nnewparents($id) 1
1355            return 0
1356        }
1357    }
1358
1359    set todo [lreplace $todo $level $level]
1360    set i $level
1361    set n 0
1362    foreach p $olds {
1363        incr ncleft($p) -1
1364        set k [lsearch -exact $todo $p]
1365        if {$k < 0} {
1366            set todo [linsert $todo $i $p]
1367            set onscreen($p) 0
1368            incr i
1369            incr n
1370        }
1371    }
1372    set nnewparents($id) $n
1373
1374    return 1
1375}
1376
1377proc decidenext {{noread 0}} {
1378    global ncleft todo
1379    global datemode cdate
1380    global commitinfo
1381
1382    # choose which one to do next time around
1383    set todol [llength $todo]
1384    set level -1
1385    set latest {}
1386    for {set k $todol} {[incr k -1] >= 0} {} {
1387        set p [lindex $todo $k]
1388        if {$ncleft($p) == 0} {
1389            if {$datemode} {
1390                if {![info exists commitinfo($p)]} {
1391                    if {$noread} {
1392                        return {}
1393                    }
1394                    readcommit $p
1395                }
1396                if {$latest == {} || $cdate($p) > $latest} {
1397                    set level $k
1398                    set latest $cdate($p)
1399                }
1400            } else {
1401                set level $k
1402                break
1403            }
1404        }
1405    }
1406    if {$level < 0} {
1407        if {$todo != {}} {
1408            puts "ERROR: none of the pending commits can be done yet:"
1409            foreach p $todo {
1410                puts "  $p ($ncleft($p))"
1411            }
1412        }
1413        return -1
1414    }
1415
1416    return $level
1417}
1418
1419proc drawcommit {id} {
1420    global phase todo nchildren datemode nextupdate revlistorder
1421    global numcommits ncmupdate displayorder todo onscreen parents
1422
1423    if {$phase != "incrdraw"} {
1424        set phase incrdraw
1425        set displayorder {}
1426        set todo {}
1427        initgraph
1428    }
1429    if {$nchildren($id) == 0} {
1430        lappend todo $id
1431        set onscreen($id) 0
1432    }
1433    if {$revlistorder} {
1434        set level [lsearch -exact $todo $id]
1435        if {$level < 0} {
1436            error_popup "oops, $id isn't in todo"
1437            return
1438        }
1439        lappend displayorder $id
1440        updatetodo $level 0
1441    } else {
1442        set level [decidenext 1]
1443        if {$level == {} || $id != [lindex $todo $level]} {
1444            return
1445        }
1446        while 1 {
1447            lappend displayorder [lindex $todo $level]
1448            if {[updatetodo $level $datemode]} {
1449                set level [decidenext 1]
1450                if {$level == {}} break
1451            }
1452            set id [lindex $todo $level]
1453            if {![info exists commitlisted($id)]} {
1454                break
1455            }
1456        }
1457    }
1458    drawmore 1
1459}
1460
1461proc finishcommits {} {
1462    global phase
1463    global canv mainfont ctext maincursor textcursor
1464
1465    if {$phase != "incrdraw"} {
1466        $canv delete all
1467        $canv create text 3 3 -anchor nw -text "No commits selected" \
1468            -font $mainfont -tags textitems
1469        set phase {}
1470    } else {
1471        drawrest
1472    }
1473    . config -cursor $maincursor
1474    settextcursor $textcursor
1475}
1476
1477# Don't change the text pane cursor if it is currently the hand cursor,
1478# showing that we are over a sha1 ID link.
1479proc settextcursor {c} {
1480    global ctext curtextcursor
1481
1482    if {[$ctext cget -cursor] == $curtextcursor} {
1483        $ctext config -cursor $c
1484    }
1485    set curtextcursor $c
1486}
1487
1488proc drawgraph {} {
1489    global nextupdate startmsecs ncmupdate
1490    global displayorder onscreen
1491
1492    if {$displayorder == {}} return
1493    set startmsecs [clock clicks -milliseconds]
1494    set nextupdate [expr {$startmsecs + 100}]
1495    set ncmupdate 1
1496    initgraph
1497    foreach id $displayorder {
1498        set onscreen($id) 0
1499    }
1500    drawmore 0
1501}
1502
1503proc drawrest {} {
1504    global phase stopped redisplaying selectedline
1505    global datemode todo displayorder
1506    global numcommits ncmupdate
1507    global nextupdate startmsecs revlistorder
1508
1509    set level [decidenext]
1510    if {$level >= 0} {
1511        set phase drawgraph
1512        while 1 {
1513            lappend displayorder [lindex $todo $level]
1514            set hard [updatetodo $level $datemode]
1515            if {$hard} {
1516                set level [decidenext]
1517                if {$level < 0} break
1518            }
1519        }
1520    }
1521    drawmore 0
1522    set phase {}
1523    set drawmsecs [expr {[clock clicks -milliseconds] - $startmsecs}]
1524    #puts "overall $drawmsecs ms for $numcommits commits"
1525    if {$redisplaying} {
1526        if {$stopped == 0 && [info exists selectedline]} {
1527            selectline $selectedline 0
1528        }
1529        if {$stopped == 1} {
1530            set stopped 0
1531            after idle drawgraph
1532        } else {
1533            set redisplaying 0
1534        }
1535    }
1536}
1537
1538proc findmatches {f} {
1539    global findtype foundstring foundstrlen
1540    if {$findtype == "Regexp"} {
1541        set matches [regexp -indices -all -inline $foundstring $f]
1542    } else {
1543        if {$findtype == "IgnCase"} {
1544            set str [string tolower $f]
1545        } else {
1546            set str $f
1547        }
1548        set matches {}
1549        set i 0
1550        while {[set j [string first $foundstring $str $i]] >= 0} {
1551            lappend matches [list $j [expr {$j+$foundstrlen-1}]]
1552            set i [expr {$j + $foundstrlen}]
1553        }
1554    }
1555    return $matches
1556}
1557
1558proc dofind {} {
1559    global findtype findloc findstring markedmatches commitinfo
1560    global numcommits lineid linehtag linentag linedtag
1561    global mainfont namefont canv canv2 canv3 selectedline
1562    global matchinglines foundstring foundstrlen
1563
1564    stopfindproc
1565    unmarkmatches
1566    focus .
1567    set matchinglines {}
1568    if {$findloc == "Pickaxe"} {
1569        findpatches
1570        return
1571    }
1572    if {$findtype == "IgnCase"} {
1573        set foundstring [string tolower $findstring]
1574    } else {
1575        set foundstring $findstring
1576    }
1577    set foundstrlen [string length $findstring]
1578    if {$foundstrlen == 0} return
1579    if {$findloc == "Files"} {
1580        findfiles
1581        return
1582    }
1583    if {![info exists selectedline]} {
1584        set oldsel -1
1585    } else {
1586        set oldsel $selectedline
1587    }
1588    set didsel 0
1589    set fldtypes {Headline Author Date Committer CDate Comment}
1590    for {set l 0} {$l < $numcommits} {incr l} {
1591        set id $lineid($l)
1592        set info $commitinfo($id)
1593        set doesmatch 0
1594        foreach f $info ty $fldtypes {
1595            if {$findloc != "All fields" && $findloc != $ty} {
1596                continue
1597            }
1598            set matches [findmatches $f]
1599            if {$matches == {}} continue
1600            set doesmatch 1
1601            if {$ty == "Headline"} {
1602                markmatches $canv $l $f $linehtag($l) $matches $mainfont
1603            } elseif {$ty == "Author"} {
1604                markmatches $canv2 $l $f $linentag($l) $matches $namefont
1605            } elseif {$ty == "Date"} {
1606                markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1607            }
1608        }
1609        if {$doesmatch} {
1610            lappend matchinglines $l
1611            if {!$didsel && $l > $oldsel} {
1612                findselectline $l
1613                set didsel 1
1614            }
1615        }
1616    }
1617    if {$matchinglines == {}} {
1618        bell
1619    } elseif {!$didsel} {
1620        findselectline [lindex $matchinglines 0]
1621    }
1622}
1623
1624proc findselectline {l} {
1625    global findloc commentend ctext
1626    selectline $l 1
1627    if {$findloc == "All fields" || $findloc == "Comments"} {
1628        # highlight the matches in the comments
1629        set f [$ctext get 1.0 $commentend]
1630        set matches [findmatches $f]
1631        foreach match $matches {
1632            set start [lindex $match 0]
1633            set end [expr {[lindex $match 1] + 1}]
1634            $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1635        }
1636    }
1637}
1638
1639proc findnext {restart} {
1640    global matchinglines selectedline
1641    if {![info exists matchinglines]} {
1642        if {$restart} {
1643            dofind
1644        }
1645        return
1646    }
1647    if {![info exists selectedline]} return
1648    foreach l $matchinglines {
1649        if {$l > $selectedline} {
1650            findselectline $l
1651            return
1652        }
1653    }
1654    bell
1655}
1656
1657proc findprev {} {
1658    global matchinglines selectedline
1659    if {![info exists matchinglines]} {
1660        dofind
1661        return
1662    }
1663    if {![info exists selectedline]} return
1664    set prev {}
1665    foreach l $matchinglines {
1666        if {$l >= $selectedline} break
1667        set prev $l
1668    }
1669    if {$prev != {}} {
1670        findselectline $prev
1671    } else {
1672        bell
1673    }
1674}
1675
1676proc findlocchange {name ix op} {
1677    global findloc findtype findtypemenu
1678    if {$findloc == "Pickaxe"} {
1679        set findtype Exact
1680        set state disabled
1681    } else {
1682        set state normal
1683    }
1684    $findtypemenu entryconf 1 -state $state
1685    $findtypemenu entryconf 2 -state $state
1686}
1687
1688proc stopfindproc {{done 0}} {
1689    global findprocpid findprocfile findids
1690    global ctext findoldcursor phase maincursor textcursor
1691    global findinprogress
1692
1693    catch {unset findids}
1694    if {[info exists findprocpid]} {
1695        if {!$done} {
1696            catch {exec kill $findprocpid}
1697        }
1698        catch {close $findprocfile}
1699        unset findprocpid
1700    }
1701    if {[info exists findinprogress]} {
1702        unset findinprogress
1703        if {$phase != "incrdraw"} {
1704            . config -cursor $maincursor
1705            settextcursor $textcursor
1706        }
1707    }
1708}
1709
1710proc findpatches {} {
1711    global findstring selectedline numcommits
1712    global findprocpid findprocfile
1713    global finddidsel ctext lineid findinprogress
1714    global findinsertpos
1715
1716    if {$numcommits == 0} return
1717
1718    # make a list of all the ids to search, starting at the one
1719    # after the selected line (if any)
1720    if {[info exists selectedline]} {
1721        set l $selectedline
1722    } else {
1723        set l -1
1724    }
1725    set inputids {}
1726    for {set i 0} {$i < $numcommits} {incr i} {
1727        if {[incr l] >= $numcommits} {
1728            set l 0
1729        }
1730        append inputids $lineid($l) "\n"
1731    }
1732
1733    if {[catch {
1734        set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1735                         << $inputids] r]
1736    } err]} {
1737        error_popup "Error starting search process: $err"
1738        return
1739    }
1740
1741    set findinsertpos end
1742    set findprocfile $f
1743    set findprocpid [pid $f]
1744    fconfigure $f -blocking 0
1745    fileevent $f readable readfindproc
1746    set finddidsel 0
1747    . config -cursor watch
1748    settextcursor watch
1749    set findinprogress 1
1750}
1751
1752proc readfindproc {} {
1753    global findprocfile finddidsel
1754    global idline matchinglines findinsertpos
1755
1756    set n [gets $findprocfile line]
1757    if {$n < 0} {
1758        if {[eof $findprocfile]} {
1759            stopfindproc 1
1760            if {!$finddidsel} {
1761                bell
1762            }
1763        }
1764        return
1765    }
1766    if {![regexp {^[0-9a-f]{40}} $line id]} {
1767        error_popup "Can't parse git-diff-tree output: $line"
1768        stopfindproc
1769        return
1770    }
1771    if {![info exists idline($id)]} {
1772        puts stderr "spurious id: $id"
1773        return
1774    }
1775    set l $idline($id)
1776    insertmatch $l $id
1777}
1778
1779proc insertmatch {l id} {
1780    global matchinglines findinsertpos finddidsel
1781
1782    if {$findinsertpos == "end"} {
1783        if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1784            set matchinglines [linsert $matchinglines 0 $l]
1785            set findinsertpos 1
1786        } else {
1787            lappend matchinglines $l
1788        }
1789    } else {
1790        set matchinglines [linsert $matchinglines $findinsertpos $l]
1791        incr findinsertpos
1792    }
1793    markheadline $l $id
1794    if {!$finddidsel} {
1795        findselectline $l
1796        set finddidsel 1
1797    }
1798}
1799
1800proc findfiles {} {
1801    global selectedline numcommits lineid ctext
1802    global ffileline finddidsel parents nparents
1803    global findinprogress findstartline findinsertpos
1804    global treediffs fdiffids fdiffsneeded fdiffpos
1805    global findmergefiles
1806
1807    if {$numcommits == 0} return
1808
1809    if {[info exists selectedline]} {
1810        set l [expr {$selectedline + 1}]
1811    } else {
1812        set l 0
1813    }
1814    set ffileline $l
1815    set findstartline $l
1816    set diffsneeded {}
1817    set fdiffsneeded {}
1818    while 1 {
1819        set id $lineid($l)
1820        if {$findmergefiles || $nparents($id) == 1} {
1821            foreach p $parents($id) {
1822                if {![info exists treediffs([list $id $p])]} {
1823                    append diffsneeded "$id $p\n"
1824                    lappend fdiffsneeded [list $id $p]
1825                }
1826            }
1827        }
1828        if {[incr l] >= $numcommits} {
1829            set l 0
1830        }
1831        if {$l == $findstartline} break
1832    }
1833
1834    # start off a git-diff-tree process if needed
1835    if {$diffsneeded ne {}} {
1836        if {[catch {
1837            set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1838        } err ]} {
1839            error_popup "Error starting search process: $err"
1840            return
1841        }
1842        catch {unset fdiffids}
1843        set fdiffpos 0
1844        fconfigure $df -blocking 0
1845        fileevent $df readable [list readfilediffs $df]
1846    }
1847
1848    set finddidsel 0
1849    set findinsertpos end
1850    set id $lineid($l)
1851    set p [lindex $parents($id) 0]
1852    . config -cursor watch
1853    settextcursor watch
1854    set findinprogress 1
1855    findcont [list $id $p]
1856    update
1857}
1858
1859proc readfilediffs {df} {
1860    global findids fdiffids fdiffs
1861
1862    set n [gets $df line]
1863    if {$n < 0} {
1864        if {[eof $df]} {
1865            donefilediff
1866            if {[catch {close $df} err]} {
1867                stopfindproc
1868                bell
1869                error_popup "Error in git-diff-tree: $err"
1870            } elseif {[info exists findids]} {
1871                set ids $findids
1872                stopfindproc
1873                bell
1874                error_popup "Couldn't find diffs for {$ids}"
1875            }
1876        }
1877        return
1878    }
1879    if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1880        # start of a new string of diffs
1881        donefilediff
1882        set fdiffids [list $id $p]
1883        set fdiffs {}
1884    } elseif {[string match ":*" $line]} {
1885        lappend fdiffs [lindex $line 5]
1886    }
1887}
1888
1889proc donefilediff {} {
1890    global fdiffids fdiffs treediffs findids
1891    global fdiffsneeded fdiffpos
1892
1893    if {[info exists fdiffids]} {
1894        while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1895               && $fdiffpos < [llength $fdiffsneeded]} {
1896            # git-diff-tree doesn't output anything for a commit
1897            # which doesn't change anything
1898            set nullids [lindex $fdiffsneeded $fdiffpos]
1899            set treediffs($nullids) {}
1900            if {[info exists findids] && $nullids eq $findids} {
1901                unset findids
1902                findcont $nullids
1903            }
1904            incr fdiffpos
1905        }
1906        incr fdiffpos
1907
1908        if {![info exists treediffs($fdiffids)]} {
1909            set treediffs($fdiffids) $fdiffs
1910        }
1911        if {[info exists findids] && $fdiffids eq $findids} {
1912            unset findids
1913            findcont $fdiffids
1914        }
1915    }
1916}
1917
1918proc findcont {ids} {
1919    global findids treediffs parents nparents
1920    global ffileline findstartline finddidsel
1921    global lineid numcommits matchinglines findinprogress
1922    global findmergefiles
1923
1924    set id [lindex $ids 0]
1925    set p [lindex $ids 1]
1926    set pi [lsearch -exact $parents($id) $p]
1927    set l $ffileline
1928    while 1 {
1929        if {$findmergefiles || $nparents($id) == 1} {
1930            if {![info exists treediffs($ids)]} {
1931                set findids $ids
1932                set ffileline $l
1933                return
1934            }
1935            set doesmatch 0
1936            foreach f $treediffs($ids) {
1937                set x [findmatches $f]
1938                if {$x != {}} {
1939                    set doesmatch 1
1940                    break
1941                }
1942            }
1943            if {$doesmatch} {
1944                insertmatch $l $id
1945                set pi $nparents($id)
1946            }
1947        } else {
1948            set pi $nparents($id)
1949        }
1950        if {[incr pi] >= $nparents($id)} {
1951            set pi 0
1952            if {[incr l] >= $numcommits} {
1953                set l 0
1954            }
1955            if {$l == $findstartline} break
1956            set id $lineid($l)
1957        }
1958        set p [lindex $parents($id) $pi]
1959        set ids [list $id $p]
1960    }
1961    stopfindproc
1962    if {!$finddidsel} {
1963        bell
1964    }
1965}
1966
1967# mark a commit as matching by putting a yellow background
1968# behind the headline
1969proc markheadline {l id} {
1970    global canv mainfont linehtag commitinfo
1971
1972    set bbox [$canv bbox $linehtag($l)]
1973    set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1974    $canv lower $t
1975}
1976
1977# mark the bits of a headline, author or date that match a find string
1978proc markmatches {canv l str tag matches font} {
1979    set bbox [$canv bbox $tag]
1980    set x0 [lindex $bbox 0]
1981    set y0 [lindex $bbox 1]
1982    set y1 [lindex $bbox 3]
1983    foreach match $matches {
1984        set start [lindex $match 0]
1985        set end [lindex $match 1]
1986        if {$start > $end} continue
1987        set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
1988        set xlen [font measure $font [string range $str 0 [expr {$end}]]]
1989        set t [$canv create rect [expr {$x0+$xoff}] $y0 \
1990                   [expr {$x0+$xlen+2}] $y1 \
1991                   -outline {} -tags matches -fill yellow]
1992        $canv lower $t
1993    }
1994}
1995
1996proc unmarkmatches {} {
1997    global matchinglines findids
1998    allcanvs delete matches
1999    catch {unset matchinglines}
2000    catch {unset findids}
2001}
2002
2003proc selcanvline {w x y} {
2004    global canv canvy0 ctext linespc
2005    global lineid linehtag linentag linedtag rowtextx
2006    set ymax [lindex [$canv cget -scrollregion] 3]
2007    if {$ymax == {}} return
2008    set yfrac [lindex [$canv yview] 0]
2009    set y [expr {$y + $yfrac * $ymax}]
2010    set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
2011    if {$l < 0} {
2012        set l 0
2013    }
2014    if {$w eq $canv} {
2015        if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
2016    }
2017    unmarkmatches
2018    selectline $l 1
2019}
2020
2021proc commit_descriptor {p} {
2022    global commitinfo
2023    set l "..."
2024    if {[info exists commitinfo($p)]} {
2025        set l [lindex $commitinfo($p) 0]
2026    }
2027    return "$p ($l)"
2028}
2029
2030# append some text to the ctext widget, and make any SHA1 ID
2031# that we know about be a clickable link.
2032proc appendwithlinks {text} {
2033    global ctext idline linknum
2034
2035    set start [$ctext index "end - 1c"]
2036    $ctext insert end $text
2037    $ctext insert end "\n"
2038    set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
2039    foreach l $links {
2040        set s [lindex $l 0]
2041        set e [lindex $l 1]
2042        set linkid [string range $text $s $e]
2043        if {![info exists idline($linkid)]} continue
2044        incr e
2045        $ctext tag add link "$start + $s c" "$start + $e c"
2046        $ctext tag add link$linknum "$start + $s c" "$start + $e c"
2047        $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1]
2048        incr linknum
2049    }
2050    $ctext tag conf link -foreground blue -underline 1
2051    $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2052    $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2053}
2054
2055proc selectline {l isnew} {
2056    global canv canv2 canv3 ctext commitinfo selectedline
2057    global lineid linehtag linentag linedtag
2058    global canvy0 linespc parents nparents children
2059    global cflist currentid sha1entry
2060    global commentend idtags idline linknum
2061
2062    $canv delete hover
2063    normalline
2064    if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
2065    $canv delete secsel
2066    set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
2067               -tags secsel -fill [$canv cget -selectbackground]]
2068    $canv lower $t
2069    $canv2 delete secsel
2070    set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
2071               -tags secsel -fill [$canv2 cget -selectbackground]]
2072    $canv2 lower $t
2073    $canv3 delete secsel
2074    set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
2075               -tags secsel -fill [$canv3 cget -selectbackground]]
2076    $canv3 lower $t
2077    set y [expr {$canvy0 + $l * $linespc}]
2078    set ymax [lindex [$canv cget -scrollregion] 3]
2079    set ytop [expr {$y - $linespc - 1}]
2080    set ybot [expr {$y + $linespc + 1}]
2081    set wnow [$canv yview]
2082    set wtop [expr {[lindex $wnow 0] * $ymax}]
2083    set wbot [expr {[lindex $wnow 1] * $ymax}]
2084    set wh [expr {$wbot - $wtop}]
2085    set newtop $wtop
2086    if {$ytop < $wtop} {
2087        if {$ybot < $wtop} {
2088            set newtop [expr {$y - $wh / 2.0}]
2089        } else {
2090            set newtop $ytop
2091            if {$newtop > $wtop - $linespc} {
2092                set newtop [expr {$wtop - $linespc}]
2093            }
2094        }
2095    } elseif {$ybot > $wbot} {
2096        if {$ytop > $wbot} {
2097            set newtop [expr {$y - $wh / 2.0}]
2098        } else {
2099            set newtop [expr {$ybot - $wh}]
2100            if {$newtop < $wtop + $linespc} {
2101                set newtop [expr {$wtop + $linespc}]
2102            }
2103        }
2104    }
2105    if {$newtop != $wtop} {
2106        if {$newtop < 0} {
2107            set newtop 0
2108        }
2109        allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
2110    }
2111
2112    if {$isnew} {
2113        addtohistory [list selectline $l 0]
2114    }
2115
2116    set selectedline $l
2117
2118    set id $lineid($l)
2119    set currentid $id
2120    $sha1entry delete 0 end
2121    $sha1entry insert 0 $id
2122    $sha1entry selection from 0
2123    $sha1entry selection to end
2124
2125    $ctext conf -state normal
2126    $ctext delete 0.0 end
2127    set linknum 0
2128    $ctext mark set fmark.0 0.0
2129    $ctext mark gravity fmark.0 left
2130    set info $commitinfo($id)
2131    set date [formatdate [lindex $info 2]]
2132    $ctext insert end "Author: [lindex $info 1]  $date\n"
2133    set date [formatdate [lindex $info 4]]
2134    $ctext insert end "Committer: [lindex $info 3]  $date\n"
2135    if {[info exists idtags($id)]} {
2136        $ctext insert end "Tags:"
2137        foreach tag $idtags($id) {
2138            $ctext insert end " $tag"
2139        }
2140        $ctext insert end "\n"
2141    }
2142 
2143    set comment {}
2144    if {[info exists parents($id)]} {
2145        foreach p $parents($id) {
2146            append comment "Parent: [commit_descriptor $p]\n"
2147        }
2148    }
2149    if {[info exists children($id)]} {
2150        foreach c $children($id) {
2151            append comment "Child:  [commit_descriptor $c]\n"
2152        }
2153    }
2154    append comment "\n"
2155    append comment [lindex $info 5]
2156
2157    # make anything that looks like a SHA1 ID be a clickable link
2158    appendwithlinks $comment
2159
2160    $ctext tag delete Comments
2161    $ctext tag remove found 1.0 end
2162    $ctext conf -state disabled
2163    set commentend [$ctext index "end - 1c"]
2164
2165    $cflist delete 0 end
2166    $cflist insert end "Comments"
2167    if {$nparents($id) == 1} {
2168        startdiff $id
2169    } elseif {$nparents($id) > 1} {
2170        mergediff $id
2171    }
2172}
2173
2174proc selnextline {dir} {
2175    global selectedline
2176    if {![info exists selectedline]} return
2177    set l [expr {$selectedline + $dir}]
2178    unmarkmatches
2179    selectline $l 1
2180}
2181
2182proc unselectline {} {
2183    global selectedline
2184
2185    catch {unset selectedline}
2186    allcanvs delete secsel
2187}
2188
2189proc addtohistory {cmd} {
2190    global history historyindex
2191
2192    if {$historyindex > 0
2193        && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
2194        return
2195    }
2196
2197    if {$historyindex < [llength $history]} {
2198        set history [lreplace $history $historyindex end $cmd]
2199    } else {
2200        lappend history $cmd
2201    }
2202    incr historyindex
2203    if {$historyindex > 1} {
2204        .ctop.top.bar.leftbut conf -state normal
2205    } else {
2206        .ctop.top.bar.leftbut conf -state disabled
2207    }
2208    .ctop.top.bar.rightbut conf -state disabled
2209}
2210
2211proc goback {} {
2212    global history historyindex
2213
2214    if {$historyindex > 1} {
2215        incr historyindex -1
2216        set cmd [lindex $history [expr {$historyindex - 1}]]
2217        eval $cmd
2218        .ctop.top.bar.rightbut conf -state normal
2219    }
2220    if {$historyindex <= 1} {
2221        .ctop.top.bar.leftbut conf -state disabled
2222    }
2223}
2224
2225proc goforw {} {
2226    global history historyindex
2227
2228    if {$historyindex < [llength $history]} {
2229        set cmd [lindex $history $historyindex]
2230        incr historyindex
2231        eval $cmd
2232        .ctop.top.bar.leftbut conf -state normal
2233    }
2234    if {$historyindex >= [llength $history]} {
2235        .ctop.top.bar.rightbut conf -state disabled
2236    }
2237}
2238
2239proc mergediff {id} {
2240    global parents diffmergeid diffmergegca mergefilelist diffpindex
2241
2242    set diffmergeid $id
2243    set diffpindex -1
2244    set diffmergegca [findgca $parents($id)]
2245    if {[info exists mergefilelist($id)]} {
2246        if {$mergefilelist($id) ne {}} {
2247            showmergediff
2248        }
2249    } else {
2250        contmergediff {}
2251    }
2252}
2253
2254proc findgca {ids} {
2255    set gca {}
2256    foreach id $ids {
2257        if {$gca eq {}} {
2258            set gca $id
2259        } else {
2260            if {[catch {
2261                set gca [exec git-merge-base $gca $id]
2262            } err]} {
2263                return {}
2264            }
2265        }
2266    }
2267    return $gca
2268}
2269
2270proc contmergediff {ids} {
2271    global diffmergeid diffpindex parents nparents diffmergegca
2272    global treediffs mergefilelist diffids treepending
2273
2274    # diff the child against each of the parents, and diff
2275    # each of the parents against the GCA.
2276    while 1 {
2277        if {[lindex $ids 1] == $diffmergeid && $diffmergegca ne {}} {
2278            set ids [list $diffmergegca [lindex $ids 0]]
2279        } else {
2280            if {[incr diffpindex] >= $nparents($diffmergeid)} break
2281            set p [lindex $parents($diffmergeid) $diffpindex]
2282            set ids [list $p $diffmergeid]
2283        }
2284        if {![info exists treediffs($ids)]} {
2285            set diffids $ids
2286            if {![info exists treepending]} {
2287                gettreediffs $ids
2288            }
2289            return
2290        }
2291    }
2292
2293    # If a file in some parent is different from the child and also
2294    # different from the GCA, then it's interesting.
2295    # If we don't have a GCA, then a file is interesting if it is
2296    # different from the child in all the parents.
2297    if {$diffmergegca ne {}} {
2298        set files {}
2299        foreach p $parents($diffmergeid) {
2300            set gcadiffs $treediffs([list $diffmergegca $p])
2301            foreach f $treediffs([list $p $diffmergeid]) {
2302                if {[lsearch -exact $files $f] < 0
2303                    && [lsearch -exact $gcadiffs $f] >= 0} {
2304                    lappend files $f
2305                }
2306            }
2307        }
2308        set files [lsort $files]
2309    } else {
2310        set p [lindex $parents($diffmergeid) 0]
2311        set files $treediffs([list $diffmergeid $p])
2312        for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2313            set p [lindex $parents($diffmergeid) $i]
2314            set df $treediffs([list $p $diffmergeid])
2315            set nf {}
2316            foreach f $files {
2317                if {[lsearch -exact $df $f] >= 0} {
2318                    lappend nf $f
2319                }
2320            }
2321            set files $nf
2322        }
2323    }
2324
2325    set mergefilelist($diffmergeid) $files
2326    if {$files ne {}} {
2327        showmergediff
2328    }
2329}
2330
2331proc showmergediff {} {
2332    global cflist diffmergeid mergefilelist parents
2333    global diffopts diffinhunk currentfile currenthunk filelines
2334    global diffblocked groupfilelast mergefds groupfilenum grouphunks
2335
2336    set files $mergefilelist($diffmergeid)
2337    foreach f $files {
2338        $cflist insert end $f
2339    }
2340    set env(GIT_DIFF_OPTS) $diffopts
2341    set flist {}
2342    catch {unset currentfile}
2343    catch {unset currenthunk}
2344    catch {unset filelines}
2345    catch {unset groupfilenum}
2346    catch {unset grouphunks}
2347    set groupfilelast -1
2348    foreach p $parents($diffmergeid) {
2349        set cmd [list | git-diff-tree -p $p $diffmergeid]
2350        set cmd [concat $cmd $mergefilelist($diffmergeid)]
2351        if {[catch {set f [open $cmd r]} err]} {
2352            error_popup "Error getting diffs: $err"
2353            foreach f $flist {
2354                catch {close $f}
2355            }
2356            return
2357        }
2358        lappend flist $f
2359        set ids [list $diffmergeid $p]
2360        set mergefds($ids) $f
2361        set diffinhunk($ids) 0
2362        set diffblocked($ids) 0
2363        fconfigure $f -blocking 0
2364        fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2365    }
2366}
2367
2368proc getmergediffline {f ids id} {
2369    global diffmergeid diffinhunk diffoldlines diffnewlines
2370    global currentfile currenthunk
2371    global diffoldstart diffnewstart diffoldlno diffnewlno
2372    global diffblocked mergefilelist
2373    global noldlines nnewlines difflcounts filelines
2374
2375    set n [gets $f line]
2376    if {$n < 0} {
2377        if {![eof $f]} return
2378    }
2379
2380    if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2381        if {$n < 0} {
2382            close $f
2383        }
2384        return
2385    }
2386
2387    if {$diffinhunk($ids) != 0} {
2388        set fi $currentfile($ids)
2389        if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2390            # continuing an existing hunk
2391            set line [string range $line 1 end]
2392            set p [lindex $ids 1]
2393            if {$match eq "-" || $match eq " "} {
2394                set filelines($p,$fi,$diffoldlno($ids)) $line
2395                incr diffoldlno($ids)
2396            }
2397            if {$match eq "+" || $match eq " "} {
2398                set filelines($id,$fi,$diffnewlno($ids)) $line
2399                incr diffnewlno($ids)
2400            }
2401            if {$match eq " "} {
2402                if {$diffinhunk($ids) == 2} {
2403                    lappend difflcounts($ids) \
2404                        [list $noldlines($ids) $nnewlines($ids)]
2405                    set noldlines($ids) 0
2406                    set diffinhunk($ids) 1
2407                }
2408                incr noldlines($ids)
2409            } elseif {$match eq "-" || $match eq "+"} {
2410                if {$diffinhunk($ids) == 1} {
2411                    lappend difflcounts($ids) [list $noldlines($ids)]
2412                    set noldlines($ids) 0
2413                    set nnewlines($ids) 0
2414                    set diffinhunk($ids) 2
2415                }
2416                if {$match eq "-"} {
2417                    incr noldlines($ids)
2418                } else {
2419                    incr nnewlines($ids)
2420                }
2421            }
2422            # and if it's \ No newline at end of line, then what?
2423            return
2424        }
2425        # end of a hunk
2426        if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2427            lappend difflcounts($ids) [list $noldlines($ids)]
2428        } elseif {$diffinhunk($ids) == 2
2429                  && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2430            lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2431        }
2432        set currenthunk($ids) [list $currentfile($ids) \
2433                                   $diffoldstart($ids) $diffnewstart($ids) \
2434                                   $diffoldlno($ids) $diffnewlno($ids) \
2435                                   $difflcounts($ids)]
2436        set diffinhunk($ids) 0
2437        # -1 = need to block, 0 = unblocked, 1 = is blocked
2438        set diffblocked($ids) -1
2439        processhunks
2440        if {$diffblocked($ids) == -1} {
2441            fileevent $f readable {}
2442            set diffblocked($ids) 1
2443        }
2444    }
2445
2446    if {$n < 0} {
2447        # eof
2448        if {!$diffblocked($ids)} {
2449            close $f
2450            set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2451            set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2452            processhunks
2453        }
2454    } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2455        # start of a new file
2456        set currentfile($ids) \
2457            [lsearch -exact $mergefilelist($diffmergeid) $fname]
2458    } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2459                   $line match f1l f1c f2l f2c rest]} {
2460        if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2461            # start of a new hunk
2462            if {$f1l == 0 && $f1c == 0} {
2463                set f1l 1
2464            }
2465            if {$f2l == 0 && $f2c == 0} {
2466                set f2l 1
2467            }
2468            set diffinhunk($ids) 1
2469            set diffoldstart($ids) $f1l
2470            set diffnewstart($ids) $f2l
2471            set diffoldlno($ids) $f1l
2472            set diffnewlno($ids) $f2l
2473            set difflcounts($ids) {}
2474            set noldlines($ids) 0
2475            set nnewlines($ids) 0
2476        }
2477    }
2478}
2479
2480proc processhunks {} {
2481    global diffmergeid parents nparents currenthunk
2482    global mergefilelist diffblocked mergefds
2483    global grouphunks grouplinestart grouplineend groupfilenum
2484
2485    set nfiles [llength $mergefilelist($diffmergeid)]
2486    while 1 {
2487        set fi $nfiles
2488        set lno 0
2489        # look for the earliest hunk
2490        foreach p $parents($diffmergeid) {
2491            set ids [list $diffmergeid $p]
2492            if {![info exists currenthunk($ids)]} return
2493            set i [lindex $currenthunk($ids) 0]
2494            set l [lindex $currenthunk($ids) 2]
2495            if {$i < $fi || ($i == $fi && $l < $lno)} {
2496                set fi $i
2497                set lno $l
2498                set pi $p
2499            }
2500        }
2501
2502        if {$fi < $nfiles} {
2503            set ids [list $diffmergeid $pi]
2504            set hunk $currenthunk($ids)
2505            unset currenthunk($ids)
2506            if {$diffblocked($ids) > 0} {
2507                fileevent $mergefds($ids) readable \
2508                    [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2509            }
2510            set diffblocked($ids) 0
2511
2512            if {[info exists groupfilenum] && $groupfilenum == $fi
2513                && $lno <= $grouplineend} {
2514                # add this hunk to the pending group
2515                lappend grouphunks($pi) $hunk
2516                set endln [lindex $hunk 4]
2517                if {$endln > $grouplineend} {
2518                    set grouplineend $endln
2519                }
2520                continue
2521            }
2522        }
2523
2524        # succeeding stuff doesn't belong in this group, so
2525        # process the group now
2526        if {[info exists groupfilenum]} {
2527            processgroup
2528            unset groupfilenum
2529            unset grouphunks
2530        }
2531
2532        if {$fi >= $nfiles} break
2533
2534        # start a new group
2535        set groupfilenum $fi
2536        set grouphunks($pi) [list $hunk]
2537        set grouplinestart $lno
2538        set grouplineend [lindex $hunk 4]
2539    }
2540}
2541
2542proc processgroup {} {
2543    global groupfilelast groupfilenum difffilestart
2544    global mergefilelist diffmergeid ctext filelines
2545    global parents diffmergeid diffoffset
2546    global grouphunks grouplinestart grouplineend nparents
2547    global mergemax
2548
2549    $ctext conf -state normal
2550    set id $diffmergeid
2551    set f $groupfilenum
2552    if {$groupfilelast != $f} {
2553        $ctext insert end "\n"
2554        set here [$ctext index "end - 1c"]
2555        set difffilestart($f) $here
2556        set mark fmark.[expr {$f + 1}]
2557        $ctext mark set $mark $here
2558        $ctext mark gravity $mark left
2559        set header [lindex $mergefilelist($id) $f]
2560        set l [expr {(78 - [string length $header]) / 2}]
2561        set pad [string range "----------------------------------------" 1 $l]
2562        $ctext insert end "$pad $header $pad\n" filesep
2563        set groupfilelast $f
2564        foreach p $parents($id) {
2565            set diffoffset($p) 0
2566        }
2567    }
2568
2569    $ctext insert end "@@" msep
2570    set nlines [expr {$grouplineend - $grouplinestart}]
2571    set events {}
2572    set pnum 0
2573    foreach p $parents($id) {
2574        set startline [expr {$grouplinestart + $diffoffset($p)}]
2575        set ol $startline
2576        set nl $grouplinestart
2577        if {[info exists grouphunks($p)]} {
2578            foreach h $grouphunks($p) {
2579                set l [lindex $h 2]
2580                if {$nl < $l} {
2581                    for {} {$nl < $l} {incr nl} {
2582                        set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2583                        incr ol
2584                    }
2585                }
2586                foreach chunk [lindex $h 5] {
2587                    if {[llength $chunk] == 2} {
2588                        set olc [lindex $chunk 0]
2589                        set nlc [lindex $chunk 1]
2590                        set nnl [expr {$nl + $nlc}]
2591                        lappend events [list $nl $nnl $pnum $olc $nlc]
2592                        incr ol $olc
2593                        set nl $nnl
2594                    } else {
2595                        incr ol [lindex $chunk 0]
2596                        incr nl [lindex $chunk 0]
2597                    }
2598                }
2599            }
2600        }
2601        if {$nl < $grouplineend} {
2602            for {} {$nl < $grouplineend} {incr nl} {
2603                set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2604                incr ol
2605            }
2606        }
2607        set nlines [expr {$ol - $startline}]
2608        $ctext insert end " -$startline,$nlines" msep
2609        incr pnum
2610    }
2611
2612    set nlines [expr {$grouplineend - $grouplinestart}]
2613    $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2614
2615    set events [lsort -integer -index 0 $events]
2616    set nevents [llength $events]
2617    set nmerge $nparents($diffmergeid)
2618    set l $grouplinestart
2619    for {set i 0} {$i < $nevents} {set i $j} {
2620        set nl [lindex $events $i 0]
2621        while {$l < $nl} {
2622            $ctext insert end " $filelines($id,$f,$l)\n"
2623            incr l
2624        }
2625        set e [lindex $events $i]
2626        set enl [lindex $e 1]
2627        set j $i
2628        set active {}
2629        while 1 {
2630            set pnum [lindex $e 2]
2631            set olc [lindex $e 3]
2632            set nlc [lindex $e 4]
2633            if {![info exists delta($pnum)]} {
2634                set delta($pnum) [expr {$olc - $nlc}]
2635                lappend active $pnum
2636            } else {
2637                incr delta($pnum) [expr {$olc - $nlc}]
2638            }
2639            if {[incr j] >= $nevents} break
2640            set e [lindex $events $j]
2641            if {[lindex $e 0] >= $enl} break
2642            if {[lindex $e 1] > $enl} {
2643                set enl [lindex $e 1]
2644            }
2645        }
2646        set nlc [expr {$enl - $l}]
2647        set ncol mresult
2648        set bestpn -1
2649        if {[llength $active] == $nmerge - 1} {
2650            # no diff for one of the parents, i.e. it's identical
2651            for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2652                if {![info exists delta($pnum)]} {
2653                    if {$pnum < $mergemax} {
2654                        lappend ncol m$pnum
2655                    } else {
2656                        lappend ncol mmax
2657                    }
2658                    break
2659                }
2660            }
2661        } elseif {[llength $active] == $nmerge} {
2662            # all parents are different, see if one is very similar
2663            set bestsim 30
2664            for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2665                set sim [similarity $pnum $l $nlc $f \
2666                             [lrange $events $i [expr {$j-1}]]]
2667                if {$sim > $bestsim} {
2668                    set bestsim $sim
2669                    set bestpn $pnum
2670                }
2671            }
2672            if {$bestpn >= 0} {
2673                lappend ncol m$bestpn
2674            }
2675        }
2676        set pnum -1
2677        foreach p $parents($id) {
2678            incr pnum
2679            if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2680            set olc [expr {$nlc + $delta($pnum)}]
2681            set ol [expr {$l + $diffoffset($p)}]
2682            incr diffoffset($p) $delta($pnum)
2683            unset delta($pnum)
2684            for {} {$olc > 0} {incr olc -1} {
2685                $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2686                incr ol
2687            }
2688        }
2689        set endl [expr {$l + $nlc}]
2690        if {$bestpn >= 0} {
2691            # show this pretty much as a normal diff
2692            set p [lindex $parents($id) $bestpn]
2693            set ol [expr {$l + $diffoffset($p)}]
2694            incr diffoffset($p) $delta($bestpn)
2695            unset delta($bestpn)
2696            for {set k $i} {$k < $j} {incr k} {
2697                set e [lindex $events $k]
2698                if {[lindex $e 2] != $bestpn} continue
2699                set nl [lindex $e 0]
2700                set ol [expr {$ol + $nl - $l}]
2701                for {} {$l < $nl} {incr l} {
2702                    $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2703                }
2704                set c [lindex $e 3]
2705                for {} {$c > 0} {incr c -1} {
2706                    $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2707                    incr ol
2708                }
2709                set nl [lindex $e 1]
2710                for {} {$l < $nl} {incr l} {
2711                    $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2712                }
2713            }
2714        }
2715        for {} {$l < $endl} {incr l} {
2716            $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2717        }
2718    }
2719    while {$l < $grouplineend} {
2720        $ctext insert end " $filelines($id,$f,$l)\n"
2721        incr l
2722    }
2723    $ctext conf -state disabled
2724}
2725
2726proc similarity {pnum l nlc f events} {
2727    global diffmergeid parents diffoffset filelines
2728
2729    set id $diffmergeid
2730    set p [lindex $parents($id) $pnum]
2731    set ol [expr {$l + $diffoffset($p)}]
2732    set endl [expr {$l + $nlc}]
2733    set same 0
2734    set diff 0
2735    foreach e $events {
2736        if {[lindex $e 2] != $pnum} continue
2737        set nl [lindex $e 0]
2738        set ol [expr {$ol + $nl - $l}]
2739        for {} {$l < $nl} {incr l} {
2740            incr same [string length $filelines($id,$f,$l)]
2741            incr same
2742        }
2743        set oc [lindex $e 3]
2744        for {} {$oc > 0} {incr oc -1} {
2745            incr diff [string length $filelines($p,$f,$ol)]
2746            incr diff
2747            incr ol
2748        }
2749        set nl [lindex $e 1]
2750        for {} {$l < $nl} {incr l} {
2751            incr diff [string length $filelines($id,$f,$l)]
2752            incr diff
2753        }
2754    }
2755    for {} {$l < $endl} {incr l} {
2756        incr same [string length $filelines($id,$f,$l)]
2757        incr same
2758    }
2759    if {$same == 0} {
2760        return 0
2761    }
2762    return [expr {200 * $same / (2 * $same + $diff)}]
2763}
2764
2765proc startdiff {ids} {
2766    global treediffs diffids treepending diffmergeid
2767
2768    set diffids $ids
2769    catch {unset diffmergeid}
2770    if {![info exists treediffs($ids)]} {
2771        if {![info exists treepending]} {
2772            gettreediffs $ids
2773        }
2774    } else {
2775        addtocflist $ids
2776    }
2777}
2778
2779proc addtocflist {ids} {
2780    global treediffs cflist
2781    foreach f $treediffs($ids) {
2782        $cflist insert end $f
2783    }
2784    getblobdiffs $ids
2785}
2786
2787proc gettreediffs {ids} {
2788    global treediff parents treepending
2789    set treepending $ids
2790    set treediff {}
2791    if [catch {set gdtf [open [concat | git-diff-tree --no-commit-id -r $ids] r]}] return
2792    fconfigure $gdtf -blocking 0
2793    fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2794}
2795
2796proc gettreediffline {gdtf ids} {
2797    global treediff treediffs treepending diffids diffmergeid
2798
2799    set n [gets $gdtf line]
2800    if {$n < 0} {
2801        if {![eof $gdtf]} return
2802        close $gdtf
2803        set treediffs($ids) $treediff
2804        unset treepending
2805        if {$ids != $diffids} {
2806            gettreediffs $diffids
2807        } else {
2808            if {[info exists diffmergeid]} {
2809                contmergediff $ids
2810            } else {
2811                addtocflist $ids
2812            }
2813        }
2814        return
2815    }
2816    set file [lindex $line 5]
2817    lappend treediff $file
2818}
2819
2820proc getblobdiffs {ids} {
2821    global diffopts blobdifffd diffids env curdifftag curtagstart
2822    global difffilestart nextupdate diffinhdr treediffs
2823
2824    set env(GIT_DIFF_OPTS) $diffopts
2825    set cmd [concat | git-diff-tree --no-commit-id -r -p -C $ids]
2826    if {[catch {set bdf [open $cmd r]} err]} {
2827        puts "error getting diffs: $err"
2828        return
2829    }
2830    set diffinhdr 0
2831    fconfigure $bdf -blocking 0
2832    set blobdifffd($ids) $bdf
2833    set curdifftag Comments
2834    set curtagstart 0.0
2835    catch {unset difffilestart}
2836    fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2837    set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2838}
2839
2840proc getblobdiffline {bdf ids} {
2841    global diffids blobdifffd ctext curdifftag curtagstart
2842    global diffnexthead diffnextnote difffilestart
2843    global nextupdate diffinhdr treediffs
2844    global gaudydiff
2845
2846    set n [gets $bdf line]
2847    if {$n < 0} {
2848        if {[eof $bdf]} {
2849            close $bdf
2850            if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2851                $ctext tag add $curdifftag $curtagstart end
2852            }
2853        }
2854        return
2855    }
2856    if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2857        return
2858    }
2859    $ctext conf -state normal
2860    if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2861        # start of a new file
2862        $ctext insert end "\n"
2863        $ctext tag add $curdifftag $curtagstart end
2864        set curtagstart [$ctext index "end - 1c"]
2865        set header $newname
2866        set here [$ctext index "end - 1c"]
2867        set i [lsearch -exact $treediffs($diffids) $fname]
2868        if {$i >= 0} {
2869            set difffilestart($i) $here
2870            incr i
2871            $ctext mark set fmark.$i $here
2872            $ctext mark gravity fmark.$i left
2873        }
2874        if {$newname != $fname} {
2875            set i [lsearch -exact $treediffs($diffids) $newname]
2876            if {$i >= 0} {
2877                set difffilestart($i) $here
2878                incr i
2879                $ctext mark set fmark.$i $here
2880                $ctext mark gravity fmark.$i left
2881            }
2882        }
2883        set curdifftag "f:$fname"
2884        $ctext tag delete $curdifftag
2885        set l [expr {(78 - [string length $header]) / 2}]
2886        set pad [string range "----------------------------------------" 1 $l]
2887        $ctext insert end "$pad $header $pad\n" filesep
2888        set diffinhdr 1
2889    } elseif {[regexp {^(---|\+\+\+)} $line]} {
2890        set diffinhdr 0
2891    } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2892                   $line match f1l f1c f2l f2c rest]} {
2893        if {$gaudydiff} {
2894            $ctext insert end "\t" hunksep
2895            $ctext insert end "    $f1l    " d0 "    $f2l    " d1
2896            $ctext insert end "    $rest \n" hunksep
2897        } else {
2898            $ctext insert end "$line\n" hunksep
2899        }
2900        set diffinhdr 0
2901    } else {
2902        set x [string range $line 0 0]
2903        if {$x == "-" || $x == "+"} {
2904            set tag [expr {$x == "+"}]
2905            if {$gaudydiff} {
2906                set line [string range $line 1 end]
2907            }
2908            $ctext insert end "$line\n" d$tag
2909        } elseif {$x == " "} {
2910            if {$gaudydiff} {
2911                set line [string range $line 1 end]
2912            }
2913            $ctext insert end "$line\n"
2914        } elseif {$diffinhdr || $x == "\\"} {
2915            # e.g. "\ No newline at end of file"
2916            $ctext insert end "$line\n" filesep
2917        } else {
2918            # Something else we don't recognize
2919            if {$curdifftag != "Comments"} {
2920                $ctext insert end "\n"
2921                $ctext tag add $curdifftag $curtagstart end
2922                set curtagstart [$ctext index "end - 1c"]
2923                set curdifftag Comments
2924            }
2925            $ctext insert end "$line\n" filesep
2926        }
2927    }
2928    $ctext conf -state disabled
2929    if {[clock clicks -milliseconds] >= $nextupdate} {
2930        incr nextupdate 100
2931        fileevent $bdf readable {}
2932        update
2933        fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2934    }
2935}
2936
2937proc nextfile {} {
2938    global difffilestart ctext
2939    set here [$ctext index @0,0]
2940    for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2941        if {[$ctext compare $difffilestart($i) > $here]} {
2942            if {![info exists pos]
2943                || [$ctext compare $difffilestart($i) < $pos]} {
2944                set pos $difffilestart($i)
2945            }
2946        }
2947    }
2948    if {[info exists pos]} {
2949        $ctext yview $pos
2950    }
2951}
2952
2953proc listboxsel {} {
2954    global ctext cflist currentid
2955    if {![info exists currentid]} return
2956    set sel [lsort [$cflist curselection]]
2957    if {$sel eq {}} return
2958    set first [lindex $sel 0]
2959    catch {$ctext yview fmark.$first}
2960}
2961
2962proc setcoords {} {
2963    global linespc charspc canvx0 canvy0 mainfont
2964    global xspc1 xspc2 lthickness
2965
2966    set linespc [font metrics $mainfont -linespace]
2967    set charspc [font measure $mainfont "m"]
2968    set canvy0 [expr {3 + 0.5 * $linespc}]
2969    set canvx0 [expr {3 + 0.5 * $linespc}]
2970    set lthickness [expr {int($linespc / 9) + 1}]
2971    set xspc1(0) $linespc
2972    set xspc2 $linespc
2973}
2974
2975proc redisplay {} {
2976    global stopped redisplaying phase
2977    if {$stopped > 1} return
2978    if {$phase == "getcommits"} return
2979    set redisplaying 1
2980    if {$phase == "drawgraph" || $phase == "incrdraw"} {
2981        set stopped 1
2982    } else {
2983        drawgraph
2984    }
2985}
2986
2987proc incrfont {inc} {
2988    global mainfont namefont textfont ctext canv phase
2989    global stopped entries
2990    unmarkmatches
2991    set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2992    set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2993    set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2994    setcoords
2995    $ctext conf -font $textfont
2996    $ctext tag conf filesep -font [concat $textfont bold]
2997    foreach e $entries {
2998        $e conf -font $mainfont
2999    }
3000    if {$phase == "getcommits"} {
3001        $canv itemconf textitems -font $mainfont
3002    }
3003    redisplay
3004}
3005
3006proc clearsha1 {} {
3007    global sha1entry sha1string
3008    if {[string length $sha1string] == 40} {
3009        $sha1entry delete 0 end
3010    }
3011}
3012
3013proc sha1change {n1 n2 op} {
3014    global sha1string currentid sha1but
3015    if {$sha1string == {}
3016        || ([info exists currentid] && $sha1string == $currentid)} {
3017        set state disabled
3018    } else {
3019        set state normal
3020    }
3021    if {[$sha1but cget -state] == $state} return
3022    if {$state == "normal"} {
3023        $sha1but conf -state normal -relief raised -text "Goto: "
3024    } else {
3025        $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
3026    }
3027}
3028
3029proc gotocommit {} {
3030    global sha1string currentid idline tagids
3031    global lineid numcommits
3032
3033    if {$sha1string == {}
3034        || ([info exists currentid] && $sha1string == $currentid)} return
3035    if {[info exists tagids($sha1string)]} {
3036        set id $tagids($sha1string)
3037    } else {
3038        set id [string tolower $sha1string]
3039        if {[regexp {^[0-9a-f]{4,39}$} $id]} {
3040            set matches {}
3041            for {set l 0} {$l < $numcommits} {incr l} {
3042                if {[string match $id* $lineid($l)]} {
3043                    lappend matches $lineid($l)
3044                }
3045            }
3046            if {$matches ne {}} {
3047                if {[llength $matches] > 1} {
3048                    error_popup "Short SHA1 id $id is ambiguous"
3049                    return
3050                }
3051                set id [lindex $matches 0]
3052            }
3053        }
3054    }
3055    if {[info exists idline($id)]} {
3056        selectline $idline($id) 1
3057        return
3058    }
3059    if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
3060        set type "SHA1 id"
3061    } else {
3062        set type "Tag"
3063    }
3064    error_popup "$type $sha1string is not known"
3065}
3066
3067proc lineenter {x y id} {
3068    global hoverx hovery hoverid hovertimer
3069    global commitinfo canv
3070
3071    if {![info exists commitinfo($id)]} return
3072    set hoverx $x
3073    set hovery $y
3074    set hoverid $id
3075    if {[info exists hovertimer]} {
3076        after cancel $hovertimer
3077    }
3078    set hovertimer [after 500 linehover]
3079    $canv delete hover
3080}
3081
3082proc linemotion {x y id} {
3083    global hoverx hovery hoverid hovertimer
3084
3085    if {[info exists hoverid] && $id == $hoverid} {
3086        set hoverx $x
3087        set hovery $y
3088        if {[info exists hovertimer]} {
3089            after cancel $hovertimer
3090        }
3091        set hovertimer [after 500 linehover]
3092    }
3093}
3094
3095proc lineleave {id} {
3096    global hoverid hovertimer canv
3097
3098    if {[info exists hoverid] && $id == $hoverid} {
3099        $canv delete hover
3100        if {[info exists hovertimer]} {
3101            after cancel $hovertimer
3102            unset hovertimer
3103        }
3104        unset hoverid
3105    }
3106}
3107
3108proc linehover {} {
3109    global hoverx hovery hoverid hovertimer
3110    global canv linespc lthickness
3111    global commitinfo mainfont
3112
3113    set text [lindex $commitinfo($hoverid) 0]
3114    set ymax [lindex [$canv cget -scrollregion] 3]
3115    if {$ymax == {}} return
3116    set yfrac [lindex [$canv yview] 0]
3117    set x [expr {$hoverx + 2 * $linespc}]
3118    set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
3119    set x0 [expr {$x - 2 * $lthickness}]
3120    set y0 [expr {$y - 2 * $lthickness}]
3121    set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
3122    set y1 [expr {$y + $linespc + 2 * $lthickness}]
3123    set t [$canv create rectangle $x0 $y0 $x1 $y1 \
3124               -fill \#ffff80 -outline black -width 1 -tags hover]
3125    $canv raise $t
3126    set t [$canv create text $x $y -anchor nw -text $text -tags hover -font $mainfont]
3127    $canv raise $t
3128}
3129
3130proc clickisonarrow {id y} {
3131    global mainline mainlinearrow sidelines lthickness
3132
3133    set thresh [expr {2 * $lthickness + 6}]
3134    if {[info exists mainline($id)]} {
3135        if {$mainlinearrow($id) ne "none"} {
3136            if {abs([lindex $mainline($id) 1] - $y) < $thresh} {
3137                return "up"
3138            }
3139        }
3140    }
3141    if {[info exists sidelines($id)]} {
3142        foreach ls $sidelines($id) {
3143            set coords [lindex $ls 0]
3144            set arrow [lindex $ls 2]
3145            if {$arrow eq "first" || $arrow eq "both"} {
3146                if {abs([lindex $coords 1] - $y) < $thresh} {
3147                    return "up"
3148                }
3149            }
3150            if {$arrow eq "last" || $arrow eq "both"} {
3151                if {abs([lindex $coords end] - $y) < $thresh} {
3152                    return "down"
3153                }
3154            }
3155        }
3156    }
3157    return {}
3158}
3159
3160proc arrowjump {id dirn y} {
3161    global mainline sidelines canv canv2 canv3
3162
3163    set yt {}
3164    if {$dirn eq "down"} {
3165        if {[info exists mainline($id)]} {
3166            set y1 [lindex $mainline($id) 1]
3167            if {$y1 > $y} {
3168                set yt $y1
3169            }
3170        }
3171        if {[info exists sidelines($id)]} {
3172            foreach ls $sidelines($id) {
3173                set y1 [lindex $ls 0 1]
3174                if {$y1 > $y && ($yt eq {} || $y1 < $yt)} {
3175                    set yt $y1
3176                }
3177            }
3178        }
3179    } else {
3180        if {[info exists sidelines($id)]} {
3181            foreach ls $sidelines($id) {
3182                set y1 [lindex $ls 0 end]
3183                if {$y1 < $y && ($yt eq {} || $y1 > $yt)} {
3184                    set yt $y1
3185                }
3186            }
3187        }
3188    }
3189    if {$yt eq {}} return
3190    set ymax [lindex [$canv cget -scrollregion] 3]
3191    if {$ymax eq {} || $ymax <= 0} return
3192    set view [$canv yview]
3193    set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
3194    set yfrac [expr {$yt / $ymax - $yspan / 2}]
3195    if {$yfrac < 0} {
3196        set yfrac 0
3197    }
3198    $canv yview moveto $yfrac
3199    $canv2 yview moveto $yfrac
3200    $canv3 yview moveto $yfrac
3201}
3202
3203proc lineclick {x y id isnew} {
3204    global ctext commitinfo children cflist canv thickerline
3205
3206    unmarkmatches
3207    unselectline
3208    normalline
3209    $canv delete hover
3210    # draw this line thicker than normal
3211    drawlines $id 1 1
3212    set thickerline $id
3213    if {$isnew} {
3214        set ymax [lindex [$canv cget -scrollregion] 3]
3215        if {$ymax eq {}} return
3216        set yfrac [lindex [$canv yview] 0]
3217        set y [expr {$y + $yfrac * $ymax}]
3218    }
3219    set dirn [clickisonarrow $id $y]
3220    if {$dirn ne {}} {
3221        arrowjump $id $dirn $y
3222        return
3223    }
3224
3225    if {$isnew} {
3226        addtohistory [list lineclick $x $y $id 0]
3227    }
3228    # fill the details pane with info about this line
3229    $ctext conf -state normal
3230    $ctext delete 0.0 end
3231    $ctext tag conf link -foreground blue -underline 1
3232    $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3233    $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3234    $ctext insert end "Parent:\t"
3235    $ctext insert end $id [list link link0]
3236    $ctext tag bind link0 <1> [list selbyid $id]
3237    set info $commitinfo($id)
3238    $ctext insert end "\n\t[lindex $info 0]\n"
3239    $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
3240    set date [formatdate [lindex $info 2]]
3241    $ctext insert end "\tDate:\t$date\n"
3242    if {[info exists children($id)]} {
3243        $ctext insert end "\nChildren:"
3244        set i 0
3245        foreach child $children($id) {
3246            incr i
3247            set info $commitinfo($child)
3248            $ctext insert end "\n\t"
3249            $ctext insert end $child [list link link$i]
3250            $ctext tag bind link$i <1> [list selbyid $child]
3251            $ctext insert end "\n\t[lindex $info 0]"
3252            $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
3253            set date [formatdate [lindex $info 2]]
3254            $ctext insert end "\n\tDate:\t$date\n"
3255        }
3256    }
3257    $ctext conf -state disabled
3258
3259    $cflist delete 0 end
3260}
3261
3262proc normalline {} {
3263    global thickerline
3264    if {[info exists thickerline]} {
3265        drawlines $thickerline 0 1
3266        unset thickerline
3267    }
3268}
3269
3270proc selbyid {id} {
3271    global idline
3272    if {[info exists idline($id)]} {
3273        selectline $idline($id) 1
3274    }
3275}
3276
3277proc mstime {} {
3278    global startmstime
3279    if {![info exists startmstime]} {
3280        set startmstime [clock clicks -milliseconds]
3281    }
3282    return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
3283}
3284
3285proc rowmenu {x y id} {
3286    global rowctxmenu idline selectedline rowmenuid
3287
3288    if {![info exists selectedline] || $idline($id) eq $selectedline} {
3289        set state disabled
3290    } else {
3291        set state normal
3292    }
3293    $rowctxmenu entryconfigure 0 -state $state
3294    $rowctxmenu entryconfigure 1 -state $state
3295    $rowctxmenu entryconfigure 2 -state $state
3296    set rowmenuid $id
3297    tk_popup $rowctxmenu $x $y
3298}
3299
3300proc diffvssel {dirn} {
3301    global rowmenuid selectedline lineid
3302
3303    if {![info exists selectedline]} return
3304    if {$dirn} {
3305        set oldid $lineid($selectedline)
3306        set newid $rowmenuid
3307    } else {
3308        set oldid $rowmenuid
3309        set newid $lineid($selectedline)
3310    }
3311    addtohistory [list doseldiff $oldid $newid]
3312    doseldiff $oldid $newid
3313}
3314
3315proc doseldiff {oldid newid} {
3316    global ctext cflist
3317    global commitinfo
3318
3319    $ctext conf -state normal
3320    $ctext delete 0.0 end
3321    $ctext mark set fmark.0 0.0
3322    $ctext mark gravity fmark.0 left
3323    $cflist delete 0 end
3324    $cflist insert end "Top"
3325    $ctext insert end "From "
3326    $ctext tag conf link -foreground blue -underline 1
3327    $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3328    $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3329    $ctext tag bind link0 <1> [list selbyid $oldid]
3330    $ctext insert end $oldid [list link link0]
3331    $ctext insert end "\n     "
3332    $ctext insert end [lindex $commitinfo($oldid) 0]
3333    $ctext insert end "\n\nTo   "
3334    $ctext tag bind link1 <1> [list selbyid $newid]
3335    $ctext insert end $newid [list link link1]
3336    $ctext insert end "\n     "
3337    $ctext insert end [lindex $commitinfo($newid) 0]
3338    $ctext insert end "\n"
3339    $ctext conf -state disabled
3340    $ctext tag delete Comments
3341    $ctext tag remove found 1.0 end
3342    startdiff [list $oldid $newid]
3343}
3344
3345proc mkpatch {} {
3346    global rowmenuid currentid commitinfo patchtop patchnum
3347
3348    if {![info exists currentid]} return
3349    set oldid $currentid
3350    set oldhead [lindex $commitinfo($oldid) 0]
3351    set newid $rowmenuid
3352    set newhead [lindex $commitinfo($newid) 0]
3353    set top .patch
3354    set patchtop $top
3355    catch {destroy $top}
3356    toplevel $top
3357    label $top.title -text "Generate patch"
3358    grid $top.title - -pady 10
3359    label $top.from -text "From:"
3360    entry $top.fromsha1 -width 40 -relief flat
3361    $top.fromsha1 insert 0 $oldid
3362    $top.fromsha1 conf -state readonly
3363    grid $top.from $top.fromsha1 -sticky w
3364    entry $top.fromhead -width 60 -relief flat
3365    $top.fromhead insert 0 $oldhead
3366    $top.fromhead conf -state readonly
3367    grid x $top.fromhead -sticky w
3368    label $top.to -text "To:"
3369    entry $top.tosha1 -width 40 -relief flat
3370    $top.tosha1 insert 0 $newid
3371    $top.tosha1 conf -state readonly
3372    grid $top.to $top.tosha1 -sticky w
3373    entry $top.tohead -width 60 -relief flat
3374    $top.tohead insert 0 $newhead
3375    $top.tohead conf -state readonly
3376    grid x $top.tohead -sticky w
3377    button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3378    grid $top.rev x -pady 10
3379    label $top.flab -text "Output file:"
3380    entry $top.fname -width 60
3381    $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3382    incr patchnum
3383    grid $top.flab $top.fname -sticky w
3384    frame $top.buts
3385    button $top.buts.gen -text "Generate" -command mkpatchgo
3386    button $top.buts.can -text "Cancel" -command mkpatchcan
3387    grid $top.buts.gen $top.buts.can
3388    grid columnconfigure $top.buts 0 -weight 1 -uniform a
3389    grid columnconfigure $top.buts 1 -weight 1 -uniform a
3390    grid $top.buts - -pady 10 -sticky ew
3391    focus $top.fname
3392}
3393
3394proc mkpatchrev {} {
3395    global patchtop
3396
3397    set oldid [$patchtop.fromsha1 get]
3398    set oldhead [$patchtop.fromhead get]
3399    set newid [$patchtop.tosha1 get]
3400    set newhead [$patchtop.tohead get]
3401    foreach e [list fromsha1 fromhead tosha1 tohead] \
3402            v [list $newid $newhead $oldid $oldhead] {
3403        $patchtop.$e conf -state normal
3404        $patchtop.$e delete 0 end
3405        $patchtop.$e insert 0 $v
3406        $patchtop.$e conf -state readonly
3407    }
3408}
3409
3410proc mkpatchgo {} {
3411    global patchtop
3412
3413    set oldid [$patchtop.fromsha1 get]
3414    set newid [$patchtop.tosha1 get]
3415    set fname [$patchtop.fname get]
3416    if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3417        error_popup "Error creating patch: $err"
3418    }
3419    catch {destroy $patchtop}
3420    unset patchtop
3421}
3422
3423proc mkpatchcan {} {
3424    global patchtop
3425
3426    catch {destroy $patchtop}
3427    unset patchtop
3428}
3429
3430proc mktag {} {
3431    global rowmenuid mktagtop commitinfo
3432
3433    set top .maketag
3434    set mktagtop $top
3435    catch {destroy $top}
3436    toplevel $top
3437    label $top.title -text "Create tag"
3438    grid $top.title - -pady 10
3439    label $top.id -text "ID:"
3440    entry $top.sha1 -width 40 -relief flat
3441    $top.sha1 insert 0 $rowmenuid
3442    $top.sha1 conf -state readonly
3443    grid $top.id $top.sha1 -sticky w
3444    entry $top.head -width 60 -relief flat
3445    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3446    $top.head conf -state readonly
3447    grid x $top.head -sticky w
3448    label $top.tlab -text "Tag name:"
3449    entry $top.tag -width 60
3450    grid $top.tlab $top.tag -sticky w
3451    frame $top.buts
3452    button $top.buts.gen -text "Create" -command mktaggo
3453    button $top.buts.can -text "Cancel" -command mktagcan
3454    grid $top.buts.gen $top.buts.can
3455    grid columnconfigure $top.buts 0 -weight 1 -uniform a
3456    grid columnconfigure $top.buts 1 -weight 1 -uniform a
3457    grid $top.buts - -pady 10 -sticky ew
3458    focus $top.tag
3459}
3460
3461proc domktag {} {
3462    global mktagtop env tagids idtags
3463
3464    set id [$mktagtop.sha1 get]
3465    set tag [$mktagtop.tag get]
3466    if {$tag == {}} {
3467        error_popup "No tag name specified"
3468        return
3469    }
3470    if {[info exists tagids($tag)]} {
3471        error_popup "Tag \"$tag\" already exists"
3472        return
3473    }
3474    if {[catch {
3475        set dir [gitdir]
3476        set fname [file join $dir "refs/tags" $tag]
3477        set f [open $fname w]
3478        puts $f $id
3479        close $f
3480    } err]} {
3481        error_popup "Error creating tag: $err"
3482        return
3483    }
3484
3485    set tagids($tag) $id
3486    lappend idtags($id) $tag
3487    redrawtags $id
3488}
3489
3490proc redrawtags {id} {
3491    global canv linehtag idline idpos selectedline
3492
3493    if {![info exists idline($id)]} return
3494    $canv delete tag.$id
3495    set xt [eval drawtags $id $idpos($id)]
3496    $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3497    if {[info exists selectedline] && $selectedline == $idline($id)} {
3498        selectline $selectedline 0
3499    }
3500}
3501
3502proc mktagcan {} {
3503    global mktagtop
3504
3505    catch {destroy $mktagtop}
3506    unset mktagtop
3507}
3508
3509proc mktaggo {} {
3510    domktag
3511    mktagcan
3512}
3513
3514proc writecommit {} {
3515    global rowmenuid wrcomtop commitinfo wrcomcmd
3516
3517    set top .writecommit
3518    set wrcomtop $top
3519    catch {destroy $top}
3520    toplevel $top
3521    label $top.title -text "Write commit to file"
3522    grid $top.title - -pady 10
3523    label $top.id -text "ID:"
3524    entry $top.sha1 -width 40 -relief flat
3525    $top.sha1 insert 0 $rowmenuid
3526    $top.sha1 conf -state readonly
3527    grid $top.id $top.sha1 -sticky w
3528    entry $top.head -width 60 -relief flat
3529    $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3530    $top.head conf -state readonly
3531    grid x $top.head -sticky w
3532    label $top.clab -text "Command:"
3533    entry $top.cmd -width 60 -textvariable wrcomcmd
3534    grid $top.clab $top.cmd -sticky w -pady 10
3535    label $top.flab -text "Output file:"
3536    entry $top.fname -width 60
3537    $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3538    grid $top.flab $top.fname -sticky w
3539    frame $top.buts
3540    button $top.buts.gen -text "Write" -command wrcomgo
3541    button $top.buts.can -text "Cancel" -command wrcomcan
3542    grid $top.buts.gen $top.buts.can
3543    grid columnconfigure $top.buts 0 -weight 1 -uniform a
3544    grid columnconfigure $top.buts 1 -weight 1 -uniform a
3545    grid $top.buts - -pady 10 -sticky ew
3546    focus $top.fname
3547}
3548
3549proc wrcomgo {} {
3550    global wrcomtop
3551
3552    set id [$wrcomtop.sha1 get]
3553    set cmd "echo $id | [$wrcomtop.cmd get]"
3554    set fname [$wrcomtop.fname get]
3555    if {[catch {exec sh -c $cmd >$fname &} err]} {
3556        error_popup "Error writing commit: $err"
3557    }
3558    catch {destroy $wrcomtop}
3559    unset wrcomtop
3560}
3561
3562proc wrcomcan {} {
3563    global wrcomtop
3564
3565    catch {destroy $wrcomtop}
3566    unset wrcomtop
3567}
3568
3569proc listrefs {id} {
3570    global idtags idheads idotherrefs
3571
3572    set x {}
3573    if {[info exists idtags($id)]} {
3574        set x $idtags($id)
3575    }
3576    set y {}
3577    if {[info exists idheads($id)]} {
3578        set y $idheads($id)
3579    }
3580    set z {}
3581    if {[info exists idotherrefs($id)]} {
3582        set z $idotherrefs($id)
3583    }
3584    return [list $x $y $z]
3585}
3586
3587proc rereadrefs {} {
3588    global idtags idheads idotherrefs
3589    global tagids headids otherrefids
3590
3591    set refids [concat [array names idtags] \
3592                    [array names idheads] [array names idotherrefs]]
3593    foreach id $refids {
3594        if {![info exists ref($id)]} {
3595            set ref($id) [listrefs $id]
3596        }
3597    }
3598    foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
3599        catch {unset $v}
3600    }
3601    readrefs
3602    set refids [lsort -unique [concat $refids [array names idtags] \
3603                        [array names idheads] [array names idotherrefs]]]
3604    foreach id $refids {
3605        set v [listrefs $id]
3606        if {![info exists ref($id)] || $ref($id) != $v} {
3607            redrawtags $id
3608        }
3609    }
3610}
3611
3612proc showtag {tag isnew} {
3613    global ctext cflist tagcontents tagids linknum
3614
3615    if {$isnew} {
3616        addtohistory [list showtag $tag 0]
3617    }
3618    $ctext conf -state normal
3619    $ctext delete 0.0 end
3620    set linknum 0
3621    if {[info exists tagcontents($tag)]} {
3622        set text $tagcontents($tag)
3623    } else {
3624        set text "Tag: $tag\nId:  $tagids($tag)"
3625    }
3626    appendwithlinks $text
3627    $ctext conf -state disabled
3628    $cflist delete 0 end
3629}
3630
3631proc doquit {} {
3632    global stopped
3633    set stopped 100
3634    destroy .
3635}
3636
3637proc formatdate {d} {
3638    global hours nhours tfd fastdate
3639
3640    if {!$fastdate} {
3641        return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
3642    }
3643    set hr [expr {$d / 3600}]
3644    set ms [expr {$d % 3600}]
3645    if {![info exists hours($hr)]} {
3646        set hours($hr) [clock format $d -format "%Y-%m-%d %H"]
3647        set nhours($hr) 0
3648    }
3649    incr nhours($hr)
3650    set minsec [format "%.2d:%.2d" [expr {$ms/60}] [expr {$ms%60}]]
3651    return "$hours($hr):$minsec"
3652}
3653
3654# defaults...
3655set datemode 0
3656set boldnames 0
3657set diffopts "-U 5 -p"
3658set wrcomcmd "git-diff-tree --stdin -p --pretty"
3659
3660set gitencoding ""
3661catch {
3662    set gitencoding [exec git-repo-config --get i18n.commitencoding]
3663}
3664if {$gitencoding == ""} {
3665        set gitencoding "utf-8"
3666}
3667
3668set mainfont {Helvetica 9}
3669set textfont {Courier 9}
3670set findmergefiles 0
3671set gaudydiff 0
3672set maxgraphpct 50
3673set maxwidth 16
3674set revlistorder 0
3675set fastdate 0
3676
3677set colors {green red blue magenta darkgrey brown orange}
3678
3679catch {source ~/.gitk}
3680
3681set namefont $mainfont
3682if {$boldnames} {
3683    lappend namefont bold
3684}
3685
3686set revtreeargs {}
3687foreach arg $argv {
3688    switch -regexp -- $arg {
3689        "^$" { }
3690        "^-b" { set boldnames 1 }
3691        "^-d" { set datemode 1 }
3692        "^-r" { set revlistorder 1 }
3693        default {
3694            lappend revtreeargs $arg
3695        }
3696    }
3697}
3698
3699set history {}
3700set historyindex 0
3701
3702set stopped 0
3703set redisplaying 0
3704set stuffsaved 0
3705set patchnum 0
3706setcoords
3707makewindow
3708readrefs
3709getcommits $revtreeargs