gitk

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