git.oblomov.eu Git - git/blob - 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 getcommits {rargs} {
  11     global commits commfd phase canv mainfont
  12     global startmsecs nextupdate
  13     global ctext maincursor textcursor leftover
  14
  15     set commits {}
  16     set phase getcommits
  17     set startmsecs [clock clicks -milliseconds]
  18     set nextupdate [expr $startmsecs + 100]
  19     if [catch {
  20         set parse_args [concat --default HEAD $rargs]
  21         set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
  22     }] {
  23         # if git-rev-parse failed for some reason...
  24         if {$rargs == {}} {
  25             set rargs HEAD
  26         }
  27         set parsed_args $rargs
  28     }
  29     if [catch {
  30         set commfd [open "|git-rev-list --header --merge-order $parsed_args" r]
  31     } err] {
  32         puts stderr "Error executing git-rev-list: $err"
  33         exit 1
  34     }
  35     set leftover {}
  36     fconfigure $commfd -blocking 0 -translation binary
  37     fileevent $commfd readable "getcommitlines $commfd"
  38     $canv delete all
  39     $canv create text 3 3 -anchor nw -text "Reading commits..." \
  40         -font $mainfont -tags textitems
  41     . config -cursor watch
  42     $ctext config -cursor watch
  43 }
  44
  45 proc getcommitlines {commfd}  {
  46     global commits parents cdate children nchildren
  47     global commitlisted phase commitinfo nextupdate
  48     global stopped redisplaying leftover
  49
  50     set stuff [read $commfd]
  51     if {$stuff == {}} {
  52         if {![eof $commfd]} return
  53         # this works around what is apparently a bug in Tcl...
  54         fconfigure $commfd -blocking 1
  55         if {![catch {close $commfd} err]} {
  56             after idle finishcommits
  57             return
  58         }
  59         if {[string range $err 0 4] == "usage"} {
  60             set err \
  61 {Gitk: error reading commits: bad arguments to git-rev-list.
  62 (Note: arguments to gitk are passed to git-rev-list
  63 to allow selection of commits to be displayed.)}
  64         } else {
  65             set err "Error reading commits: $err"
  66         }
  67         error_popup $err
  68         exit 1
  69     }
  70     set start 0
  71     while 1 {
  72         set i [string first "\0" $stuff $start]
  73         if {$i < 0} {
  74             set leftover [string range $stuff $start end]
  75             return
  76         }
  77         set cmit [string range $stuff $start [expr {$i - 1}]]
  78         if {$start == 0} {
  79             set cmit "$leftover$cmit"
  80         }
  81         set start [expr {$i + 1}]
  82         if {![regexp {^([0-9a-f]{40})\n} $cmit match id]} {
  83             error_popup "Can't parse git-rev-list output: {$cmit}"
  84             exit 1
  85         }
  86         set cmit [string range $cmit 41 end]
  87         lappend commits $id
  88         set commitlisted($id) 1
  89         parsecommit $id $cmit 1
  90         drawcommit $id
  91         if {[clock clicks -milliseconds] >= $nextupdate} {
  92             doupdate
  93         }
  94         while {$redisplaying} {
  95             set redisplaying 0
  96             if {$stopped == 1} {
  97                 set stopped 0
  98                 set phase "getcommits"
  99                 foreach id $commits {
 100                     drawcommit $id
 101                     if {$stopped} break
 102                     if {[clock clicks -milliseconds] >= $nextupdate} {
 103                         doupdate
 104                     }
 105                 }
 106             }
 107         }
 108     }
 109 }
 110
 111 proc doupdate {} {
 112     global commfd nextupdate
 113
 114     incr nextupdate 100
 115     fileevent $commfd readable {}
 116     update
 117     fileevent $commfd readable "getcommitlines $commfd"
 118 }
 119
 120 proc readcommit {id} {
 121     if [catch {set contents [exec git-cat-file commit $id]}] return
 122     parsecommit $id $contents 0
 123 }
 124
 125 proc parsecommit {id contents listed} {
 126     global commitinfo children nchildren parents nparents cdate ncleft
 127
 128     set inhdr 1
 129     set comment {}
 130     set headline {}
 131     set auname {}
 132     set audate {}
 133     set comname {}
 134     set comdate {}
 135     if {![info exists nchildren($id)]} {
 136         set children($id) {}
 137         set nchildren($id) 0
 138         set ncleft($id) 0
 139     }
 140     set parents($id) {}
 141     set nparents($id) 0
 142     foreach line [split $contents "\n"] {
 143         if {$inhdr} {
 144             if {$line == {}} {
 145                 set inhdr 0
 146             } else {
 147                 set tag [lindex $line 0]
 148                 if {$tag == "parent"} {
 149                     set p [lindex $line 1]
 150                     if {![info exists nchildren($p)]} {
 151                         set children($p) {}
 152                         set nchildren($p) 0
 153                         set ncleft($p) 0
 154                     }
 155                     lappend parents($id) $p
 156                     incr nparents($id)
 157                     # sometimes we get a commit that lists a parent twice...
 158                     if {$listed && [lsearch -exact $children($p) $id] < 0} {
 159                         lappend children($p) $id
 160                         incr nchildren($p)
 161                         incr ncleft($p)
 162                     }
 163                 } elseif {$tag == "author"} {
 164                     set x [expr {[llength $line] - 2}]
 165                     set audate [lindex $line $x]
 166                     set auname [lrange $line 1 [expr {$x - 1}]]
 167                 } elseif {$tag == "committer"} {
 168                     set x [expr {[llength $line] - 2}]
 169                     set comdate [lindex $line $x]
 170                     set comname [lrange $line 1 [expr {$x - 1}]]
 171                 }
 172             }
 173         } else {
 174             if {$comment == {}} {
 175                 set headline [string trim $line]
 176             } else {
 177                 append comment "\n"
 178             }
 179             if {!$listed} {
 180                 # git-rev-list indents the comment by 4 spaces;
 181                 # if we got this via git-cat-file, add the indentation
 182                 append comment "    "
 183             }
 184             append comment $line
 185         }
 186     }
 187     if {$audate != {}} {
 188         set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
 189     }
 190     if {$comdate != {}} {
 191         set cdate($id) $comdate
 192         set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
 193     }
 194     set commitinfo($id) [list $headline $auname $audate \
 195                              $comname $comdate $comment]
 196 }
 197
 198 proc readrefs {} {
 199     global tagids idtags headids idheads
 200     set tags [glob -nocomplain -types f .git/refs/tags/*]
 201     foreach f $tags {
 202         catch {
 203             set fd [open $f r]
 204             set line [read $fd]
 205             if {[regexp {^[0-9a-f]{40}} $line id]} {
 206                 set direct [file tail $f]
 207                 set tagids($direct) $id
 208                 lappend idtags($id) $direct
 209                 set contents [split [exec git-cat-file tag $id] "\n"]
 210                 set obj {}
 211                 set type {}
 212                 set tag {}
 213                 foreach l $contents {
 214                     if {$l == {}} break
 215                     switch -- [lindex $l 0] {
 216                         "object" {set obj [lindex $l 1]}
 217                         "type" {set type [lindex $l 1]}
 218                         "tag" {set tag [string range $l 4 end]}
 219                     }
 220                 }
 221                 if {$obj != {} && $type == "commit" && $tag != {}} {
 222                     set tagids($tag) $obj
 223                     lappend idtags($obj) $tag
 224                 }
 225             }
 226             close $fd
 227         }
 228     }
 229     set heads [glob -nocomplain -types f .git/refs/heads/*]
 230     foreach f $heads {
 231         catch {
 232             set fd [open $f r]
 233             set line [read $fd 40]
 234             if {[regexp {^[0-9a-f]{40}} $line id]} {
 235                 set head [file tail $f]
 236                 set headids($head) $line
 237                 lappend idheads($line) $head
 238             }
 239             close $fd
 240         }
 241     }
 242 }
 243
 244 proc error_popup msg {
 245     set w .error
 246     toplevel $w
 247     wm transient $w .
 248     message $w.m -text $msg -justify center -aspect 400
 249     pack $w.m -side top -fill x -padx 20 -pady 20
 250     button $w.ok -text OK -command "destroy $w"
 251     pack $w.ok -side bottom -fill x
 252     bind $w <Visibility> "grab $w; focus $w"
 253     tkwait window $w
 254 }
 255
 256 proc makewindow {} {
 257     global canv canv2 canv3 linespc charspc ctext cflist textfont
 258     global findtype findloc findstring fstring geometry
 259     global entries sha1entry sha1string sha1but
 260     global maincursor textcursor
 261     global rowctxmenu
 262
 263     menu .bar
 264     .bar add cascade -label "File" -menu .bar.file
 265     menu .bar.file
 266     .bar.file add command -label "Quit" -command doquit
 267     menu .bar.help
 268     .bar add cascade -label "Help" -menu .bar.help
 269     .bar.help add command -label "About gitk" -command about
 270     . configure -menu .bar
 271
 272     if {![info exists geometry(canv1)]} {
 273         set geometry(canv1) [expr 45 * $charspc]
 274         set geometry(canv2) [expr 30 * $charspc]
 275         set geometry(canv3) [expr 15 * $charspc]
 276         set geometry(canvh) [expr 25 * $linespc + 4]
 277         set geometry(ctextw) 80
 278         set geometry(ctexth) 30
 279         set geometry(cflistw) 30
 280     }
 281     panedwindow .ctop -orient vertical
 282     if {[info exists geometry(width)]} {
 283         .ctop conf -width $geometry(width) -height $geometry(height)
 284         set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
 285         set geometry(ctexth) [expr {($texth - 8) /
 286                                     [font metrics $textfont -linespace]}]
 287     }
 288     frame .ctop.top
 289     frame .ctop.top.bar
 290     pack .ctop.top.bar -side bottom -fill x
 291     set cscroll .ctop.top.csb
 292     scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
 293     pack $cscroll -side right -fill y
 294     panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
 295     pack .ctop.top.clist -side top -fill both -expand 1
 296     .ctop add .ctop.top
 297     set canv .ctop.top.clist.canv
 298     canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
 299         -bg white -bd 0 \
 300         -yscrollincr $linespc -yscrollcommand "$cscroll set"
 301     .ctop.top.clist add $canv
 302     set canv2 .ctop.top.clist.canv2
 303     canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
 304         -bg white -bd 0 -yscrollincr $linespc
 305     .ctop.top.clist add $canv2
 306     set canv3 .ctop.top.clist.canv3
 307     canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
 308         -bg white -bd 0 -yscrollincr $linespc
 309     .ctop.top.clist add $canv3
 310     bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
 311
 312     set sha1entry .ctop.top.bar.sha1
 313     set entries $sha1entry
 314     set sha1but .ctop.top.bar.sha1label
 315     button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
 316         -command gotocommit -width 8
 317     $sha1but conf -disabledforeground [$sha1but cget -foreground]
 318     pack .ctop.top.bar.sha1label -side left
 319     entry $sha1entry -width 40 -font $textfont -textvariable sha1string
 320     trace add variable sha1string write sha1change
 321     pack $sha1entry -side left -pady 2
 322     button .ctop.top.bar.findbut -text "Find" -command dofind
 323     pack .ctop.top.bar.findbut -side left
 324     set findstring {}
 325     set fstring .ctop.top.bar.findstring
 326     lappend entries $fstring
 327     entry $fstring -width 30 -font $textfont -textvariable findstring
 328     pack $fstring -side left -expand 1 -fill x
 329     set findtype Exact
 330     tk_optionMenu .ctop.top.bar.findtype findtype Exact IgnCase Regexp
 331     set findloc "All fields"
 332     tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
 333         Comments Author Committer
 334     pack .ctop.top.bar.findloc -side right
 335     pack .ctop.top.bar.findtype -side right
 336
 337     panedwindow .ctop.cdet -orient horizontal
 338     .ctop add .ctop.cdet
 339     frame .ctop.cdet.left
 340     set ctext .ctop.cdet.left.ctext
 341     text $ctext -bg white -state disabled -font $textfont \
 342         -width $geometry(ctextw) -height $geometry(ctexth) \
 343         -yscrollcommand ".ctop.cdet.left.sb set"
 344     scrollbar .ctop.cdet.left.sb -command "$ctext yview"
 345     pack .ctop.cdet.left.sb -side right -fill y
 346     pack $ctext -side left -fill both -expand 1
 347     .ctop.cdet add .ctop.cdet.left
 348
 349     $ctext tag conf filesep -font [concat $textfont bold]
 350     $ctext tag conf hunksep -back blue -fore white
 351     $ctext tag conf d0 -back "#ff8080"
 352     $ctext tag conf d1 -back green
 353     $ctext tag conf found -back yellow
 354
 355     frame .ctop.cdet.right
 356     set cflist .ctop.cdet.right.cfiles
 357     listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
 358         -yscrollcommand ".ctop.cdet.right.sb set"
 359     scrollbar .ctop.cdet.right.sb -command "$cflist yview"
 360     pack .ctop.cdet.right.sb -side right -fill y
 361     pack $cflist -side left -fill both -expand 1
 362     .ctop.cdet add .ctop.cdet.right
 363     bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
 364
 365     pack .ctop -side top -fill both -expand 1
 366
 367     bindall <1> {selcanvline %W %x %y}
 368     #bindall <B1-Motion> {selcanvline %W %x %y}
 369     bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
 370     bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
 371     bindall <2> "allcanvs scan mark 0 %y"
 372     bindall <B2-Motion> "allcanvs scan dragto 0 %y"
 373     bind . <Key-Up> "selnextline -1"
 374     bind . <Key-Down> "selnextline 1"
 375     bind . <Key-Prior> "allcanvs yview scroll -1 pages"
 376     bind . <Key-Next> "allcanvs yview scroll 1 pages"
 377     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
 378     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
 379     bindkey <Key-space> "$ctext yview scroll 1 pages"
 380     bindkey p "selnextline -1"
 381     bindkey n "selnextline 1"
 382     bindkey b "$ctext yview scroll -1 pages"
 383     bindkey d "$ctext yview scroll 18 units"
 384     bindkey u "$ctext yview scroll -18 units"
 385     bindkey / findnext
 386     bindkey ? findprev
 387     bindkey f nextfile
 388     bind . <Control-q> doquit
 389     bind . <Control-f> dofind
 390     bind . <Control-g> findnext
 391     bind . <Control-r> findprev
 392     bind . <Control-equal> {incrfont 1}
 393     bind . <Control-KP_Add> {incrfont 1}
 394     bind . <Control-minus> {incrfont -1}
 395     bind . <Control-KP_Subtract> {incrfont -1}
 396     bind $cflist <<ListboxSelect>> listboxsel
 397     bind . <Destroy> {savestuff %W}
 398     bind . <Button-1> "click %W"
 399     bind $fstring <Key-Return> dofind
 400     bind $sha1entry <Key-Return> gotocommit
 401     bind $sha1entry <<PasteSelection>> clearsha1
 402
 403     set maincursor [. cget -cursor]
 404     set textcursor [$ctext cget -cursor]
 405
 406     set rowctxmenu .rowctxmenu
 407     menu $rowctxmenu -tearoff 0
 408     $rowctxmenu add command -label "Diff this -> selected" \
 409         -command {diffvssel 0}
 410     $rowctxmenu add command -label "Diff selected -> this" \
 411         -command {diffvssel 1}
 412 }
 413
 414 # when we make a key binding for the toplevel, make sure
 415 # it doesn't get triggered when that key is pressed in the
 416 # find string entry widget.
 417 proc bindkey {ev script} {
 418     global entries
 419     bind . $ev $script
 420     set escript [bind Entry $ev]
 421     if {$escript == {}} {
 422         set escript [bind Entry <Key>]
 423     }
 424     foreach e $entries {
 425         bind $e $ev "$escript; break"
 426     }
 427 }
 428
 429 # set the focus back to the toplevel for any click outside
 430 # the entry widgets
 431 proc click {w} {
 432     global entries
 433     foreach e $entries {
 434         if {$w == $e} return
 435     }
 436     focus .
 437 }
 438
 439 proc savestuff {w} {
 440     global canv canv2 canv3 ctext cflist mainfont textfont
 441     global stuffsaved
 442     if {$stuffsaved} return
 443     if {![winfo viewable .]} return
 444     catch {
 445         set f [open "~/.gitk-new" w]
 446         puts $f "set mainfont {$mainfont}"
 447         puts $f "set textfont {$textfont}"
 448         puts $f "set geometry(width) [winfo width .ctop]"
 449         puts $f "set geometry(height) [winfo height .ctop]"
 450         puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
 451         puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
 452         puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
 453         puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
 454         set wid [expr {([winfo width $ctext] - 8) \
 455                            / [font measure $textfont "0"]}]
 456         puts $f "set geometry(ctextw) $wid"
 457         set wid [expr {([winfo width $cflist] - 11) \
 458                            / [font measure [$cflist cget -font] "0"]}]
 459         puts $f "set geometry(cflistw) $wid"
 460         close $f
 461         file rename -force "~/.gitk-new" "~/.gitk"
 462     }
 463     set stuffsaved 1
 464 }
 465
 466 proc resizeclistpanes {win w} {
 467     global oldwidth
 468     if [info exists oldwidth($win)] {
 469         set s0 [$win sash coord 0]
 470         set s1 [$win sash coord 1]
 471         if {$w < 60} {
 472             set sash0 [expr {int($w/2 - 2)}]
 473             set sash1 [expr {int($w*5/6 - 2)}]
 474         } else {
 475             set factor [expr {1.0 * $w / $oldwidth($win)}]
 476             set sash0 [expr {int($factor * [lindex $s0 0])}]
 477             set sash1 [expr {int($factor * [lindex $s1 0])}]
 478             if {$sash0 < 30} {
 479                 set sash0 30
 480             }
 481             if {$sash1 < $sash0 + 20} {
 482                 set sash1 [expr $sash0 + 20]
 483             }
 484             if {$sash1 > $w - 10} {
 485                 set sash1 [expr $w - 10]
 486                 if {$sash0 > $sash1 - 20} {
 487                     set sash0 [expr $sash1 - 20]
 488                 }
 489             }
 490         }
 491         $win sash place 0 $sash0 [lindex $s0 1]
 492         $win sash place 1 $sash1 [lindex $s1 1]
 493     }
 494     set oldwidth($win) $w
 495 }
 496
 497 proc resizecdetpanes {win w} {
 498     global oldwidth
 499     if [info exists oldwidth($win)] {
 500         set s0 [$win sash coord 0]
 501         if {$w < 60} {
 502             set sash0 [expr {int($w*3/4 - 2)}]
 503         } else {
 504             set factor [expr {1.0 * $w / $oldwidth($win)}]
 505             set sash0 [expr {int($factor * [lindex $s0 0])}]
 506             if {$sash0 < 45} {
 507                 set sash0 45
 508             }
 509             if {$sash0 > $w - 15} {
 510                 set sash0 [expr $w - 15]
 511             }
 512         }
 513         $win sash place 0 $sash0 [lindex $s0 1]
 514     }
 515     set oldwidth($win) $w
 516 }
 517
 518 proc allcanvs args {
 519     global canv canv2 canv3
 520     eval $canv $args
 521     eval $canv2 $args
 522     eval $canv3 $args
 523 }
 524
 525 proc bindall {event action} {
 526     global canv canv2 canv3
 527     bind $canv $event $action
 528     bind $canv2 $event $action
 529     bind $canv3 $event $action
 530 }
 531
 532 proc about {} {
 533     set w .about
 534     if {[winfo exists $w]} {
 535         raise $w
 536         return
 537     }
 538     toplevel $w
 539     wm title $w "About gitk"
 540     message $w.m -text {
 541 Gitk version 1.2
 542
 543 Copyright © 2005 Paul Mackerras
 544
 545 Use and redistribute under the terms of the GNU General Public License} \
 546             -justify center -aspect 400
 547     pack $w.m -side top -fill x -padx 20 -pady 20
 548     button $w.ok -text Close -command "destroy $w"
 549     pack $w.ok -side bottom
 550 }
 551
 552 proc assigncolor {id} {
 553     global commitinfo colormap commcolors colors nextcolor
 554     global parents nparents children nchildren
 555     global cornercrossings crossings
 556
 557     if [info exists colormap($id)] return
 558     set ncolors [llength $colors]
 559     if {$nparents($id) <= 1 && $nchildren($id) == 1} {
 560         set child [lindex $children($id) 0]
 561         if {[info exists colormap($child)]
 562             && $nparents($child) == 1} {
 563             set colormap($id) $colormap($child)
 564             return
 565         }
 566     }
 567     set badcolors {}
 568     if {[info exists cornercrossings($id)]} {
 569         foreach x $cornercrossings($id) {
 570             if {[info exists colormap($x)]
 571                 && [lsearch -exact $badcolors $colormap($x)] < 0} {
 572                 lappend badcolors $colormap($x)
 573             }
 574         }
 575         if {[llength $badcolors] >= $ncolors} {
 576             set badcolors {}
 577         }
 578     }
 579     set origbad $badcolors
 580     if {[llength $badcolors] < $ncolors - 1} {
 581         if {[info exists crossings($id)]} {
 582             foreach x $crossings($id) {
 583                 if {[info exists colormap($x)]
 584                     && [lsearch -exact $badcolors $colormap($x)] < 0} {
 585                     lappend badcolors $colormap($x)
 586                 }
 587             }
 588             if {[llength $badcolors] >= $ncolors} {
 589                 set badcolors $origbad
 590             }
 591         }
 592         set origbad $badcolors
 593     }
 594     if {[llength $badcolors] < $ncolors - 1} {
 595         foreach child $children($id) {
 596             if {[info exists colormap($child)]
 597                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
 598                 lappend badcolors $colormap($child)
 599             }
 600             if {[info exists parents($child)]} {
 601                 foreach p $parents($child) {
 602                     if {[info exists colormap($p)]
 603                         && [lsearch -exact $badcolors $colormap($p)] < 0} {
 604                         lappend badcolors $colormap($p)
 605                     }
 606                 }
 607             }
 608         }
 609         if {[llength $badcolors] >= $ncolors} {
 610             set badcolors $origbad
 611         }
 612     }
 613     for {set i 0} {$i <= $ncolors} {incr i} {
 614         set c [lindex $colors $nextcolor]
 615         if {[incr nextcolor] >= $ncolors} {
 616             set nextcolor 0
 617         }
 618         if {[lsearch -exact $badcolors $c]} break
 619     }
 620     set colormap($id) $c
 621 }
 622
 623 proc initgraph {} {
 624     global canvy canvy0 lineno numcommits lthickness nextcolor linespc
 625     global mainline sidelines
 626     global nchildren ncleft
 627
 628     allcanvs delete all
 629     set nextcolor 0
 630     set canvy $canvy0
 631     set lineno -1
 632     set numcommits 0
 633     set lthickness [expr {int($linespc / 9) + 1}]
 634     catch {unset mainline}
 635     catch {unset sidelines}
 636     foreach id [array names nchildren] {
 637         set ncleft($id) $nchildren($id)
 638     }
 639 }
 640
 641 proc bindline {t id} {
 642     global canv
 643
 644     $canv bind $t <Enter> "lineenter %x %y $id"
 645     $canv bind $t <Motion> "linemotion %x %y $id"
 646     $canv bind $t <Leave> "lineleave $id"
 647     $canv bind $t <Button-1> "lineclick %x %y $id"
 648 }
 649
 650 proc drawcommitline {level} {
 651     global parents children nparents nchildren todo
 652     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 653     global lineid linehtag linentag linedtag commitinfo
 654     global colormap numcommits currentparents dupparents
 655     global oldlevel oldnlines oldtodo
 656     global idtags idline idheads
 657     global lineno lthickness mainline sidelines
 658     global commitlisted rowtextx
 659
 660     incr numcommits
 661     incr lineno
 662     set id [lindex $todo $level]
 663     set lineid($lineno) $id
 664     set idline($id) $lineno
 665     set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
 666     if {![info exists commitinfo($id)]} {
 667         readcommit $id
 668         if {![info exists commitinfo($id)]} {
 669             set commitinfo($id) {"No commit information available"}
 670             set nparents($id) 0
 671         }
 672     }
 673     assigncolor $id
 674     set currentparents {}
 675     set dupparents {}
 676     if {[info exists commitlisted($id)] && [info exists parents($id)]} {
 677         foreach p $parents($id) {
 678             if {[lsearch -exact $currentparents $p] < 0} {
 679                 lappend currentparents $p
 680             } else {
 681                 # remember that this parent was listed twice
 682                 lappend dupparents $p
 683             }
 684         }
 685     }
 686     set x [expr $canvx0 + $level * $linespc]
 687     set y1 $canvy
 688     set canvy [expr $canvy + $linespc]
 689     allcanvs conf -scrollregion \
 690         [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
 691     if {[info exists mainline($id)]} {
 692         lappend mainline($id) $x $y1
 693         set t [$canv create line $mainline($id) \
 694                    -width $lthickness -fill $colormap($id)]
 695         $canv lower $t
 696         bindline $t $id
 697     }
 698     if {[info exists sidelines($id)]} {
 699         foreach ls $sidelines($id) {
 700             set coords [lindex $ls 0]
 701             set thick [lindex $ls 1]
 702             set t [$canv create line $coords -fill $colormap($id) \
 703                        -width [expr {$thick * $lthickness}]]
 704             $canv lower $t
 705             bindline $t $id
 706         }
 707     }
 708     set orad [expr {$linespc / 3}]
 709     set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
 710                [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
 711                -fill $ofill -outline black -width 1]
 712     $canv raise $t
 713     $canv bind $t <1> {selcanvline {} %x %y}
 714     set xt [expr $canvx0 + [llength $todo] * $linespc]
 715     if {[llength $currentparents] > 2} {
 716         set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
 717     }
 718     set rowtextx($lineno) $xt
 719     set marks {}
 720     set ntags 0
 721     if {[info exists idtags($id)]} {
 722         set marks $idtags($id)
 723         set ntags [llength $marks]
 724     }
 725     if {[info exists idheads($id)]} {
 726         set marks [concat $marks $idheads($id)]
 727     }
 728     if {$marks != {}} {
 729         set delta [expr {int(0.5 * ($linespc - $lthickness))}]
 730         set yt [expr $y1 - 0.5 * $linespc]
 731         set yb [expr $yt + $linespc - 1]
 732         set xvals {}
 733         set wvals {}
 734         foreach tag $marks {
 735             set wid [font measure $mainfont $tag]
 736             lappend xvals $xt
 737             lappend wvals $wid
 738             set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
 739         }
 740         set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
 741                    -width $lthickness -fill black]
 742         $canv lower $t
 743         foreach tag $marks x $xvals wid $wvals {
 744             set xl [expr $x + $delta]
 745             set xr [expr $x + $delta + $wid + $lthickness]
 746             if {[incr ntags -1] >= 0} {
 747                 # draw a tag
 748                 $canv create polygon $x [expr $yt + $delta] $xl $yt\
 749                     $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
 750                     -width 1 -outline black -fill yellow
 751             } else {
 752                 # draw a head
 753                 set xl [expr $xl - $delta/2]
 754                 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
 755                     -width 1 -outline black -fill green
 756             }
 757             $canv create text $xl $y1 -anchor w -text $tag \
 758                 -font $mainfont
 759         }
 760     }
 761     set headline [lindex $commitinfo($id) 0]
 762     set name [lindex $commitinfo($id) 1]
 763     set date [lindex $commitinfo($id) 2]
 764     set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
 765                                -text $headline -font $mainfont ]
 766     $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
 767     set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
 768                                -text $name -font $namefont]
 769     set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
 770                                -text $date -font $mainfont]
 771 }
 772
 773 proc updatetodo {level noshortcut} {
 774     global currentparents ncleft todo
 775     global mainline oldlevel oldtodo oldnlines
 776     global canvx0 canvy linespc mainline
 777     global commitinfo
 778
 779     set oldlevel $level
 780     set oldtodo $todo
 781     set oldnlines [llength $todo]
 782     if {!$noshortcut && [llength $currentparents] == 1} {
 783         set p [lindex $currentparents 0]
 784         if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
 785             set ncleft($p) 0
 786             set x [expr $canvx0 + $level * $linespc]
 787             set y [expr $canvy - $linespc]
 788             set mainline($p) [list $x $y]
 789             set todo [lreplace $todo $level $level $p]
 790             return 0
 791         }
 792     }
 793
 794     set todo [lreplace $todo $level $level]
 795     set i $level
 796     foreach p $currentparents {
 797         incr ncleft($p) -1
 798         set k [lsearch -exact $todo $p]
 799         if {$k < 0} {
 800             set todo [linsert $todo $i $p]
 801             incr i
 802         }
 803     }
 804     return 1
 805 }
 806
 807 proc notecrossings {id lo hi corner} {
 808     global oldtodo crossings cornercrossings
 809
 810     for {set i $lo} {[incr i] < $hi} {} {
 811         set p [lindex $oldtodo $i]
 812         if {$p == {}} continue
 813         if {$i == $corner} {
 814             if {![info exists cornercrossings($id)]
 815                 || [lsearch -exact $cornercrossings($id) $p] < 0} {
 816                 lappend cornercrossings($id) $p
 817             }
 818             if {![info exists cornercrossings($p)]
 819                 || [lsearch -exact $cornercrossings($p) $id] < 0} {
 820                 lappend cornercrossings($p) $id
 821             }
 822         } else {
 823             if {![info exists crossings($id)]
 824                 || [lsearch -exact $crossings($id) $p] < 0} {
 825                 lappend crossings($id) $p
 826             }
 827             if {![info exists crossings($p)]
 828                 || [lsearch -exact $crossings($p) $id] < 0} {
 829                 lappend crossings($p) $id
 830             }
 831         }
 832     }
 833 }
 834
 835 proc drawslants {} {
 836     global canv mainline sidelines canvx0 canvy linespc
 837     global oldlevel oldtodo todo currentparents dupparents
 838     global lthickness linespc canvy colormap
 839
 840     set y1 [expr $canvy - $linespc]
 841     set y2 $canvy
 842     set i -1
 843     foreach id $oldtodo {
 844         incr i
 845         if {$id == {}} continue
 846         set xi [expr {$canvx0 + $i * $linespc}]
 847         if {$i == $oldlevel} {
 848             foreach p $currentparents {
 849                 set j [lsearch -exact $todo $p]
 850                 set coords [list $xi $y1]
 851                 set xj [expr {$canvx0 + $j * $linespc}]
 852                 if {$j < $i - 1} {
 853                     lappend coords [expr $xj + $linespc] $y1
 854                     notecrossings $p $j $i [expr {$j + 1}]
 855                 } elseif {$j > $i + 1} {
 856                     lappend coords [expr $xj - $linespc] $y1
 857                     notecrossings $p $i $j [expr {$j - 1}]
 858                 }
 859                 if {[lsearch -exact $dupparents $p] >= 0} {
 860                     # draw a double-width line to indicate the doubled parent
 861                     lappend coords $xj $y2
 862                     lappend sidelines($p) [list $coords 2]
 863                     if {![info exists mainline($p)]} {
 864                         set mainline($p) [list $xj $y2]
 865                     }
 866                 } else {
 867                     # normal case, no parent duplicated
 868                     if {![info exists mainline($p)]} {
 869                         if {$i != $j} {
 870                             lappend coords $xj $y2
 871                         }
 872                         set mainline($p) $coords
 873                     } else {
 874                         lappend coords $xj $y2
 875                         lappend sidelines($p) [list $coords 1]
 876                     }
 877                 }
 878             }
 879         } elseif {[lindex $todo $i] != $id} {
 880             set j [lsearch -exact $todo $id]
 881             set xj [expr {$canvx0 + $j * $linespc}]
 882             lappend mainline($id) $xi $y1 $xj $y2
 883         }
 884     }
 885 }
 886
 887 proc decidenext {} {
 888     global parents children nchildren ncleft todo
 889     global canv canv2 canv3 mainfont namefont canvx0 canvy linespc
 890     global datemode cdate
 891     global lineid linehtag linentag linedtag commitinfo
 892     global currentparents oldlevel oldnlines oldtodo
 893     global lineno lthickness
 894
 895     # remove the null entry if present
 896     set nullentry [lsearch -exact $todo {}]
 897     if {$nullentry >= 0} {
 898         set todo [lreplace $todo $nullentry $nullentry]
 899     }
 900
 901     # choose which one to do next time around
 902     set todol [llength $todo]
 903     set level -1
 904     set latest {}
 905     for {set k $todol} {[incr k -1] >= 0} {} {
 906         set p [lindex $todo $k]
 907         if {$ncleft($p) == 0} {
 908             if {$datemode} {
 909                 if {$latest == {} || $cdate($p) > $latest} {
 910                     set level $k
 911                     set latest $cdate($p)
 912                 }
 913             } else {
 914                 set level $k
 915                 break
 916             }
 917         }
 918     }
 919     if {$level < 0} {
 920         if {$todo != {}} {
 921             puts "ERROR: none of the pending commits can be done yet:"
 922             foreach p $todo {
 923                 puts "  $p ($ncleft($p))"
 924             }
 925         }
 926         return -1
 927     }
 928
 929     # If we are reducing, put in a null entry
 930     if {$todol < $oldnlines} {
 931         if {$nullentry >= 0} {
 932             set i $nullentry
 933             while {$i < $todol
 934                    && [lindex $oldtodo $i] == [lindex $todo $i]} {
 935                 incr i
 936             }
 937         } else {
 938             set i $oldlevel
 939             if {$level >= $i} {
 940                 incr i
 941             }
 942         }
 943         if {$i < $todol} {
 944             set todo [linsert $todo $i {}]
 945             if {$level >= $i} {
 946                 incr level
 947             }
 948         }
 949     }
 950     return $level
 951 }
 952
 953 proc drawcommit {id} {
 954     global phase todo nchildren datemode nextupdate
 955     global startcommits
 956
 957     if {$phase != "incrdraw"} {
 958         set phase incrdraw
 959         set todo $id
 960         set startcommits $id
 961         initgraph
 962         drawcommitline 0
 963         updatetodo 0 $datemode
 964     } else {
 965         if {$nchildren($id) == 0} {
 966             lappend todo $id
 967             lappend startcommits $id
 968         }
 969         set level [decidenext]
 970         if {$id != [lindex $todo $level]} {
 971             return
 972         }
 973         while 1 {
 974             drawslants
 975             drawcommitline $level
 976             if {[updatetodo $level $datemode]} {
 977                 set level [decidenext]
 978             }
 979             set id [lindex $todo $level]
 980             if {![info exists commitlisted($id)]} {
 981                 break
 982             }
 983             if {[clock clicks -milliseconds] >= $nextupdate} {
 984                 doupdate
 985                 if {$stopped} break
 986             }
 987         }
 988     }
 989 }
 990
 991 proc finishcommits {} {
 992     global phase
 993     global startcommits
 994     global ctext maincursor textcursor
 995
 996     if {$phase != "incrdraw"} {
 997         $canv delete all
 998         $canv create text 3 3 -anchor nw -text "No commits selected" \
 999             -font $mainfont -tags textitems
1000         set phase {}
1001         return
1002     }
1003     drawslants
1004     set level [decidenext]
1005     drawrest $level [llength $startcommits]
1006     . config -cursor $maincursor
1007     $ctext config -cursor $textcursor
1008 }
1009
1010 proc drawgraph {} {
1011     global nextupdate startmsecs startcommits todo
1012
1013     if {$startcommits == {}} return
1014     set startmsecs [clock clicks -milliseconds]
1015     set nextupdate [expr $startmsecs + 100]
1016     initgraph
1017     set todo [lindex $startcommits 0]
1018     drawrest 0 1
1019 }
1020
1021 proc drawrest {level startix} {
1022     global phase stopped redisplaying selectedline
1023     global datemode currentparents todo
1024     global numcommits
1025     global nextupdate startmsecs startcommits idline
1026
1027     if {$level >= 0} {
1028         set phase drawgraph
1029         set startid [lindex $startcommits $startix]
1030         set startline -1
1031         if {$startid != {}} {
1032             set startline $idline($startid)
1033         }
1034         while 1 {
1035             if {$stopped} break
1036             drawcommitline $level
1037             set hard [updatetodo $level $datemode]
1038             if {$numcommits == $startline} {
1039                 lappend todo $startid
1040                 set hard 1
1041                 incr startix
1042                 set startid [lindex $startcommits $startix]
1043                 set startline -1
1044                 if {$startid != {}} {
1045                     set startline $idline($startid)
1046                 }
1047             }
1048             if {$hard} {
1049                 set level [decidenext]
1050                 if {$level < 0} break
1051                 drawslants
1052             }
1053             if {[clock clicks -milliseconds] >= $nextupdate} {
1054                 update
1055                 incr nextupdate 100
1056             }
1057         }
1058     }
1059     set phase {}
1060     set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1061     #puts "overall $drawmsecs ms for $numcommits commits"
1062     if {$redisplaying} {
1063         if {$stopped == 0 && [info exists selectedline]} {
1064             selectline $selectedline
1065         }
1066         if {$stopped == 1} {
1067             set stopped 0
1068             after idle drawgraph
1069         } else {
1070             set redisplaying 0
1071         }
1072     }
1073 }
1074
1075 proc findmatches {f} {
1076     global findtype foundstring foundstrlen
1077     if {$findtype == "Regexp"} {
1078         set matches [regexp -indices -all -inline $foundstring $f]
1079     } else {
1080         if {$findtype == "IgnCase"} {
1081             set str [string tolower $f]
1082         } else {
1083             set str $f
1084         }
1085         set matches {}
1086         set i 0
1087         while {[set j [string first $foundstring $str $i]] >= 0} {
1088             lappend matches [list $j [expr $j+$foundstrlen-1]]
1089             set i [expr $j + $foundstrlen]
1090         }
1091     }
1092     return $matches
1093 }
1094
1095 proc dofind {} {
1096     global findtype findloc findstring markedmatches commitinfo
1097     global numcommits lineid linehtag linentag linedtag
1098     global mainfont namefont canv canv2 canv3 selectedline
1099     global matchinglines foundstring foundstrlen
1100     unmarkmatches
1101     focus .
1102     set matchinglines {}
1103     set fldtypes {Headline Author Date Committer CDate Comment}
1104     if {$findtype == "IgnCase"} {
1105         set foundstring [string tolower $findstring]
1106     } else {
1107         set foundstring $findstring
1108     }
1109     set foundstrlen [string length $findstring]
1110     if {$foundstrlen == 0} return
1111     if {![info exists selectedline]} {
1112         set oldsel -1
1113     } else {
1114         set oldsel $selectedline
1115     }
1116     set didsel 0
1117     for {set l 0} {$l < $numcommits} {incr l} {
1118         set id $lineid($l)
1119         set info $commitinfo($id)
1120         set doesmatch 0
1121         foreach f $info ty $fldtypes {
1122             if {$findloc != "All fields" && $findloc != $ty} {
1123                 continue
1124             }
1125             set matches [findmatches $f]
1126             if {$matches == {}} continue
1127             set doesmatch 1
1128             if {$ty == "Headline"} {
1129                 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1130             } elseif {$ty == "Author"} {
1131                 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1132             } elseif {$ty == "Date"} {
1133                 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1134             }
1135         }
1136         if {$doesmatch} {
1137             lappend matchinglines $l
1138             if {!$didsel && $l > $oldsel} {
1139                 findselectline $l
1140                 set didsel 1
1141             }
1142         }
1143     }
1144     if {$matchinglines == {}} {
1145         bell
1146     } elseif {!$didsel} {
1147         findselectline [lindex $matchinglines 0]
1148     }
1149 }
1150
1151 proc findselectline {l} {
1152     global findloc commentend ctext
1153     selectline $l
1154     if {$findloc == "All fields" || $findloc == "Comments"} {
1155         # highlight the matches in the comments
1156         set f [$ctext get 1.0 $commentend]
1157         set matches [findmatches $f]
1158         foreach match $matches {
1159             set start [lindex $match 0]
1160             set end [expr [lindex $match 1] + 1]
1161             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1162         }
1163     }
1164 }
1165
1166 proc findnext {} {
1167     global matchinglines selectedline
1168     if {![info exists matchinglines]} {
1169         dofind
1170         return
1171     }
1172     if {![info exists selectedline]} return
1173     foreach l $matchinglines {
1174         if {$l > $selectedline} {
1175             findselectline $l
1176             return
1177         }
1178     }
1179     bell
1180 }
1181
1182 proc findprev {} {
1183     global matchinglines selectedline
1184     if {![info exists matchinglines]} {
1185         dofind
1186         return
1187     }
1188     if {![info exists selectedline]} return
1189     set prev {}
1190     foreach l $matchinglines {
1191         if {$l >= $selectedline} break
1192         set prev $l
1193     }
1194     if {$prev != {}} {
1195         findselectline $prev
1196     } else {
1197         bell
1198     }
1199 }
1200
1201 proc markmatches {canv l str tag matches font} {
1202     set bbox [$canv bbox $tag]
1203     set x0 [lindex $bbox 0]
1204     set y0 [lindex $bbox 1]
1205     set y1 [lindex $bbox 3]
1206     foreach match $matches {
1207         set start [lindex $match 0]
1208         set end [lindex $match 1]
1209         if {$start > $end} continue
1210         set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1211         set xlen [font measure $font [string range $str 0 [expr $end]]]
1212         set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1213                    -outline {} -tags matches -fill yellow]
1214         $canv lower $t
1215     }
1216 }
1217
1218 proc unmarkmatches {} {
1219     global matchinglines
1220     allcanvs delete matches
1221     catch {unset matchinglines}
1222 }
1223
1224 proc selcanvline {w x y} {
1225     global canv canvy0 ctext linespc selectedline
1226     global lineid linehtag linentag linedtag rowtextx
1227     set ymax [lindex [$canv cget -scrollregion] 3]
1228     if {$ymax == {}} return
1229     set yfrac [lindex [$canv yview] 0]
1230     set y [expr {$y + $yfrac * $ymax}]
1231     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1232     if {$l < 0} {
1233         set l 0
1234     }
1235     if {$w eq $canv} {
1236         if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1237     }
1238     unmarkmatches
1239     selectline $l
1240 }
1241
1242 proc selectline {l} {
1243     global canv canv2 canv3 ctext commitinfo selectedline
1244     global lineid linehtag linentag linedtag
1245     global canvy0 linespc parents nparents
1246     global cflist currentid sha1entry diffids
1247     global commentend seenfile idtags
1248     $canv delete hover
1249     if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1250     $canv delete secsel
1251     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1252                -tags secsel -fill [$canv cget -selectbackground]]
1253     $canv lower $t
1254     $canv2 delete secsel
1255     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1256                -tags secsel -fill [$canv2 cget -selectbackground]]
1257     $canv2 lower $t
1258     $canv3 delete secsel
1259     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1260                -tags secsel -fill [$canv3 cget -selectbackground]]
1261     $canv3 lower $t
1262     set y [expr {$canvy0 + $l * $linespc}]
1263     set ymax [lindex [$canv cget -scrollregion] 3]
1264     set ytop [expr {$y - $linespc - 1}]
1265     set ybot [expr {$y + $linespc + 1}]
1266     set wnow [$canv yview]
1267     set wtop [expr [lindex $wnow 0] * $ymax]
1268     set wbot [expr [lindex $wnow 1] * $ymax]
1269     set wh [expr {$wbot - $wtop}]
1270     set newtop $wtop
1271     if {$ytop < $wtop} {
1272         if {$ybot < $wtop} {
1273             set newtop [expr {$y - $wh / 2.0}]
1274         } else {
1275             set newtop $ytop
1276             if {$newtop > $wtop - $linespc} {
1277                 set newtop [expr {$wtop - $linespc}]
1278             }
1279         }
1280     } elseif {$ybot > $wbot} {
1281         if {$ytop > $wbot} {
1282             set newtop [expr {$y - $wh / 2.0}]
1283         } else {
1284             set newtop [expr {$ybot - $wh}]
1285             if {$newtop < $wtop + $linespc} {
1286                 set newtop [expr {$wtop + $linespc}]
1287             }
1288         }
1289     }
1290     if {$newtop != $wtop} {
1291         if {$newtop < 0} {
1292             set newtop 0
1293         }
1294         allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1295     }
1296     set selectedline $l
1297
1298     set id $lineid($l)
1299     set currentid $id
1300     set diffids [concat $id $parents($id)]
1301     $sha1entry delete 0 end
1302     $sha1entry insert 0 $id
1303     $sha1entry selection from 0
1304     $sha1entry selection to end
1305
1306     $ctext conf -state normal
1307     $ctext delete 0.0 end
1308     $ctext mark set fmark.0 0.0
1309     $ctext mark gravity fmark.0 left
1310     set info $commitinfo($id)
1311     $ctext insert end "Author: [lindex $info 1]  [lindex $info 2]\n"
1312     $ctext insert end "Committer: [lindex $info 3]  [lindex $info 4]\n"
1313     if {[info exists idtags($id)]} {
1314         $ctext insert end "Tags:"
1315         foreach tag $idtags($id) {
1316             $ctext insert end " $tag"
1317         }
1318         $ctext insert end "\n"
1319     }
1320     $ctext insert end "\n"
1321     $ctext insert end [lindex $info 5]
1322     $ctext insert end "\n"
1323     $ctext tag delete Comments
1324     $ctext tag remove found 1.0 end
1325     $ctext conf -state disabled
1326     set commentend [$ctext index "end - 1c"]
1327
1328     $cflist delete 0 end
1329     $cflist insert end "Comments"
1330     if {$nparents($id) == 1} {
1331         startdiff
1332     }
1333     catch {unset seenfile}
1334 }
1335
1336 proc startdiff {} {
1337     global treediffs diffids treepending
1338
1339     if {![info exists treediffs($diffids)]} {
1340         if {![info exists treepending]} {
1341             gettreediffs $diffids
1342         }
1343     } else {
1344         addtocflist $diffids
1345     }
1346 }
1347
1348 proc selnextline {dir} {
1349     global selectedline
1350     if {![info exists selectedline]} return
1351     set l [expr $selectedline + $dir]
1352     unmarkmatches
1353     selectline $l
1354 }
1355
1356 proc addtocflist {ids} {
1357     global diffids treediffs cflist
1358     if {$ids != $diffids} {
1359         gettreediffs $diffids
1360         return
1361     }
1362     foreach f $treediffs($ids) {
1363         $cflist insert end $f
1364     }
1365     getblobdiffs $ids
1366 }
1367
1368 proc gettreediffs {ids} {
1369     global treediffs parents treepending
1370     set treepending $ids
1371     set treediffs($ids) {}
1372     set id [lindex $ids 0]
1373     set p [lindex $ids 1]
1374     if [catch {set gdtf [open "|git-diff-tree -r $p $id" r]}] return
1375     fconfigure $gdtf -blocking 0
1376     fileevent $gdtf readable "gettreediffline $gdtf {$ids}"
1377 }
1378
1379 proc gettreediffline {gdtf ids} {
1380     global treediffs treepending
1381     set n [gets $gdtf line]
1382     if {$n < 0} {
1383         if {![eof $gdtf]} return
1384         close $gdtf
1385         unset treepending
1386         addtocflist $ids
1387         return
1388     }
1389     set file [lindex $line 5]
1390     lappend treediffs($ids) $file
1391 }
1392
1393 proc getblobdiffs {ids} {
1394     global diffopts blobdifffd env curdifftag curtagstart
1395     global diffindex difffilestart nextupdate
1396
1397     set id [lindex $ids 0]
1398     set p [lindex $ids 1]
1399     set env(GIT_DIFF_OPTS) $diffopts
1400     if [catch {set bdf [open "|git-diff-tree -r -p $p $id" r]} err] {
1401         puts "error getting diffs: $err"
1402         return
1403     }
1404     fconfigure $bdf -blocking 0
1405     set blobdifffd($ids) $bdf
1406     set curdifftag Comments
1407     set curtagstart 0.0
1408     set diffindex 0
1409     catch {unset difffilestart}
1410     fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1411     set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1412 }
1413
1414 proc getblobdiffline {bdf ids} {
1415     global diffids blobdifffd ctext curdifftag curtagstart seenfile
1416     global diffnexthead diffnextnote diffindex difffilestart
1417     global nextupdate
1418
1419     set n [gets $bdf line]
1420     if {$n < 0} {
1421         if {[eof $bdf]} {
1422             close $bdf
1423             if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
1424                 $ctext tag add $curdifftag $curtagstart end
1425                 set seenfile($curdifftag) 1
1426             }
1427         }
1428         return
1429     }
1430     if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
1431         return
1432     }
1433     $ctext conf -state normal
1434     if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} {
1435         # start of a new file
1436         $ctext insert end "\n"
1437         $ctext tag add $curdifftag $curtagstart end
1438         set seenfile($curdifftag) 1
1439         set curtagstart [$ctext index "end - 1c"]
1440         set header $fname
1441         if {[info exists diffnexthead]} {
1442             set fname $diffnexthead
1443             set header "$diffnexthead ($diffnextnote)"
1444             unset diffnexthead
1445         }
1446         set here [$ctext index "end - 1c"]
1447         set difffilestart($diffindex) $here
1448         incr diffindex
1449         # start mark names at fmark.1 for first file
1450         $ctext mark set fmark.$diffindex $here
1451         $ctext mark gravity fmark.$diffindex left
1452         set curdifftag "f:$fname"
1453         $ctext tag delete $curdifftag
1454         set l [expr {(78 - [string length $header]) / 2}]
1455         set pad [string range "----------------------------------------" 1 $l]
1456         $ctext insert end "$pad $header $pad\n" filesep
1457     } elseif {[string range $line 0 2] == "+++"} {
1458         # no need to do anything with this
1459     } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
1460         set diffnexthead $fn
1461         set diffnextnote "created, mode $m"
1462     } elseif {[string range $line 0 8] == "Deleted: "} {
1463         set diffnexthead [string range $line 9 end]
1464         set diffnextnote "deleted"
1465     } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1466         # save the filename in case the next thing is "new file mode ..."
1467         set diffnexthead $fn
1468         set diffnextnote "modified"
1469     } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1470         set diffnextnote "new file, mode $m"
1471     } elseif {[string range $line 0 11] == "deleted file"} {
1472         set diffnextnote "deleted"
1473     } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1474                    $line match f1l f1c f2l f2c rest]} {
1475         $ctext insert end "\t" hunksep
1476         $ctext insert end "    $f1l    " d0 "    $f2l    " d1
1477         $ctext insert end "    $rest \n" hunksep
1478     } else {
1479         set x [string range $line 0 0]
1480         if {$x == "-" || $x == "+"} {
1481             set tag [expr {$x == "+"}]
1482             set line [string range $line 1 end]
1483             $ctext insert end "$line\n" d$tag
1484         } elseif {$x == " "} {
1485             set line [string range $line 1 end]
1486             $ctext insert end "$line\n"
1487         } elseif {$x == "\\"} {
1488             # e.g. "\ No newline at end of file"
1489             $ctext insert end "$line\n" filesep
1490         } else {
1491             # Something else we don't recognize
1492             if {$curdifftag != "Comments"} {
1493                 $ctext insert end "\n"
1494                 $ctext tag add $curdifftag $curtagstart end
1495                 set seenfile($curdifftag) 1
1496                 set curtagstart [$ctext index "end - 1c"]
1497                 set curdifftag Comments
1498             }
1499             $ctext insert end "$line\n" filesep
1500         }
1501     }
1502     $ctext conf -state disabled
1503     if {[clock clicks -milliseconds] >= $nextupdate} {
1504         incr nextupdate 100
1505         fileevent $bdf readable {}
1506         update
1507         fileevent $bdf readable "getblobdiffline $bdf {$ids}"
1508     }
1509 }
1510
1511 proc nextfile {} {
1512     global difffilestart ctext
1513     set here [$ctext index @0,0]
1514     for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1515         if {[$ctext compare $difffilestart($i) > $here]} {
1516             $ctext yview $difffilestart($i)
1517             break
1518         }
1519     }
1520 }
1521
1522 proc listboxsel {} {
1523     global ctext cflist currentid treediffs seenfile
1524     if {![info exists currentid]} return
1525     set sel [lsort [$cflist curselection]]
1526     if {$sel eq {}} return
1527     set first [lindex $sel 0]
1528     catch {$ctext yview fmark.$first}
1529 }
1530
1531 proc setcoords {} {
1532     global linespc charspc canvx0 canvy0 mainfont
1533     set linespc [font metrics $mainfont -linespace]
1534     set charspc [font measure $mainfont "m"]
1535     set canvy0 [expr 3 + 0.5 * $linespc]
1536     set canvx0 [expr 3 + 0.5 * $linespc]
1537 }
1538
1539 proc redisplay {} {
1540     global selectedline stopped redisplaying phase
1541     if {$stopped > 1} return
1542     if {$phase == "getcommits"} return
1543     set redisplaying 1
1544     if {$phase == "drawgraph" || $phase == "incrdraw"} {
1545         set stopped 1
1546     } else {
1547         drawgraph
1548     }
1549 }
1550
1551 proc incrfont {inc} {
1552     global mainfont namefont textfont selectedline ctext canv phase
1553     global stopped entries
1554     unmarkmatches
1555     set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1556     set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1557     set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1558     setcoords
1559     $ctext conf -font $textfont
1560     $ctext tag conf filesep -font [concat $textfont bold]
1561     foreach e $entries {
1562         $e conf -font $mainfont
1563     }
1564     if {$phase == "getcommits"} {
1565         $canv itemconf textitems -font $mainfont
1566     }
1567     redisplay
1568 }
1569
1570 proc clearsha1 {} {
1571     global sha1entry sha1string
1572     if {[string length $sha1string] == 40} {
1573         $sha1entry delete 0 end
1574     }
1575 }
1576
1577 proc sha1change {n1 n2 op} {
1578     global sha1string currentid sha1but
1579     if {$sha1string == {}
1580         || ([info exists currentid] && $sha1string == $currentid)} {
1581         set state disabled
1582     } else {
1583         set state normal
1584     }
1585     if {[$sha1but cget -state] == $state} return
1586     if {$state == "normal"} {
1587         $sha1but conf -state normal -relief raised -text "Goto: "
1588     } else {
1589         $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1590     }
1591 }
1592
1593 proc gotocommit {} {
1594     global sha1string currentid idline tagids
1595     if {$sha1string == {}
1596         || ([info exists currentid] && $sha1string == $currentid)} return
1597     if {[info exists tagids($sha1string)]} {
1598         set id $tagids($sha1string)
1599     } else {
1600         set id [string tolower $sha1string]
1601     }
1602     if {[info exists idline($id)]} {
1603         selectline $idline($id)
1604         return
1605     }
1606     if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
1607         set type "SHA1 id"
1608     } else {
1609         set type "Tag"
1610     }
1611     error_popup "$type $sha1string is not known"
1612 }
1613
1614 proc lineenter {x y id} {
1615     global hoverx hovery hoverid hovertimer
1616     global commitinfo canv
1617
1618     if {![info exists commitinfo($id)]} return
1619     set hoverx $x
1620     set hovery $y
1621     set hoverid $id
1622     if {[info exists hovertimer]} {
1623         after cancel $hovertimer
1624     }
1625     set hovertimer [after 500 linehover]
1626     $canv delete hover
1627 }
1628
1629 proc linemotion {x y id} {
1630     global hoverx hovery hoverid hovertimer
1631
1632     if {[info exists hoverid] && $id == $hoverid} {
1633         set hoverx $x
1634         set hovery $y
1635         if {[info exists hovertimer]} {
1636             after cancel $hovertimer
1637         }
1638         set hovertimer [after 500 linehover]
1639     }
1640 }
1641
1642 proc lineleave {id} {
1643     global hoverid hovertimer canv
1644
1645     if {[info exists hoverid] && $id == $hoverid} {
1646         $canv delete hover
1647         if {[info exists hovertimer]} {
1648             after cancel $hovertimer
1649             unset hovertimer
1650         }
1651         unset hoverid
1652     }
1653 }
1654
1655 proc linehover {} {
1656     global hoverx hovery hoverid hovertimer
1657     global canv linespc lthickness
1658     global commitinfo mainfont
1659
1660     set text [lindex $commitinfo($hoverid) 0]
1661     set ymax [lindex [$canv cget -scrollregion] 3]
1662     if {$ymax == {}} return
1663     set yfrac [lindex [$canv yview] 0]
1664     set x [expr {$hoverx + 2 * $linespc}]
1665     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
1666     set x0 [expr {$x - 2 * $lthickness}]
1667     set y0 [expr {$y - 2 * $lthickness}]
1668     set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
1669     set y1 [expr {$y + $linespc + 2 * $lthickness}]
1670     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
1671                -fill \#ffff80 -outline black -width 1 -tags hover]
1672     $canv raise $t
1673     set t [$canv create text $x $y -anchor nw -text $text -tags hover]
1674     $canv raise $t
1675 }
1676
1677 proc lineclick {x y id} {
1678     global ctext commitinfo children cflist canv
1679
1680     unmarkmatches
1681     $canv delete hover
1682     # fill the details pane with info about this line
1683     $ctext conf -state normal
1684     $ctext delete 0.0 end
1685     $ctext insert end "Parent:\n "
1686     catch {destroy $ctext.$id}
1687     button $ctext.$id -text "Go:" -command "selbyid $id" \
1688         -padx 4 -pady 0
1689     $ctext window create end -window $ctext.$id -align center
1690     set info $commitinfo($id)
1691     $ctext insert end "\t[lindex $info 0]\n"
1692     $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
1693     $ctext insert end "\tDate:\t[lindex $info 2]\n"
1694     $ctext insert end "\tID:\t$id\n"
1695     if {[info exists children($id)]} {
1696         $ctext insert end "\nChildren:"
1697         foreach child $children($id) {
1698             $ctext insert end "\n "
1699             catch {destroy $ctext.$child}
1700             button $ctext.$child -text "Go:" -command "selbyid $child" \
1701                 -padx 4 -pady 0
1702             $ctext window create end -window $ctext.$child -align center
1703             set info $commitinfo($child)
1704             $ctext insert end "\t[lindex $info 0]"
1705         }
1706     }
1707     $ctext conf -state disabled
1708
1709     $cflist delete 0 end
1710 }
1711
1712 proc selbyid {id} {
1713     global idline
1714     if {[info exists idline($id)]} {
1715         selectline $idline($id)
1716     }
1717 }
1718
1719 proc mstime {} {
1720     global startmstime
1721     if {![info exists startmstime]} {
1722         set startmstime [clock clicks -milliseconds]
1723     }
1724     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
1725 }
1726
1727 proc rowmenu {x y id} {
1728     global rowctxmenu idline selectedline rowmenuid
1729
1730     if {![info exists selectedline] || $idline($id) eq $selectedline} {
1731         set state disabled
1732     } else {
1733         set state normal
1734     }
1735     $rowctxmenu entryconfigure 0 -state $state
1736     $rowctxmenu entryconfigure 1 -state $state
1737     set rowmenuid $id
1738     tk_popup $rowctxmenu $x $y
1739 }
1740
1741 proc diffvssel {dirn} {
1742     global rowmenuid selectedline lineid
1743     global ctext cflist
1744     global diffids commitinfo
1745
1746     if {![info exists selectedline]} return
1747     if {$dirn} {
1748         set oldid $lineid($selectedline)
1749         set newid $rowmenuid
1750     } else {
1751         set oldid $rowmenuid
1752         set newid $lineid($selectedline)
1753     }
1754     $ctext conf -state normal
1755     $ctext delete 0.0 end
1756     $ctext mark set fmark.0 0.0
1757     $ctext mark gravity fmark.0 left
1758     $cflist delete 0 end
1759     $cflist insert end "Top"
1760     $ctext insert end "From $oldid\n     "
1761     $ctext insert end [lindex $commitinfo($oldid) 0]
1762     $ctext insert end "\n\nTo   $newid\n     "
1763     $ctext insert end [lindex $commitinfo($newid) 0]
1764     $ctext insert end "\n"
1765     $ctext conf -state disabled
1766     $ctext tag delete Comments
1767     $ctext tag remove found 1.0 end
1768     set diffids [list $newid $oldid]
1769     startdiff
1770 }
1771
1772 proc doquit {} {
1773     global stopped
1774     set stopped 100
1775     destroy .
1776 }
1777
1778 # defaults...
1779 set datemode 0
1780 set boldnames 0
1781 set diffopts "-U 5 -p"
1782
1783 set mainfont {Helvetica 9}
1784 set textfont {Courier 9}
1785
1786 set colors {green red blue magenta darkgrey brown orange}
1787
1788 catch {source ~/.gitk}
1789
1790 set namefont $mainfont
1791 if {$boldnames} {
1792     lappend namefont bold
1793 }
1794
1795 set revtreeargs {}
1796 foreach arg $argv {
1797     switch -regexp -- $arg {
1798         "^$" { }
1799         "^-b" { set boldnames 1 }
1800         "^-d" { set datemode 1 }
1801         default {
1802             lappend revtreeargs $arg
1803         }
1804     }
1805 }
1806
1807 set stopped 0
1808 set redisplaying 0
1809 set stuffsaved 0
1810 setcoords
1811 makewindow
1812 readrefs
1813 getcommits $revtreeargs