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