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