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