gitk

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