Mercurial > hg > mercurial-crew-with-dirclash
comparison contrib/hgk @ 267:497aa6d276d2
Initial import of hgit and hgk
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
Initial import of hgit and hgk
Support for git compatibility sufficient to run gitk on top of hg
repositories. This includes:
hgit diff-tree
hgit rev-list
hgit rev-tree
hgit cat-file
Signed-off-by: Chris Mason <mason@suse.com>
hgk is a slightly modified version of gitk1.1 from Paul Mackerras. It has
been changed to use hgit commands, and has support for the extended
rev-list -c to speed up the commit listing.
Signed-off-by: Chris Mason <mason@suse.com>
manifest hash: 5a4a27135bc85bab2a3a1e35018a08a985d8d146
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.0 (GNU/Linux)
iD8DBQFCpVQ4ywK+sNU5EO8RAl3QAJ9p6VyZ8fCHfgt0p8ksgL2P215DXQCfZU47
d+u5GpZvkOTOc3+LU3Ny3nE=
=rjsC
-----END PGP SIGNATURE-----
| author | mpm@selenic.com |
|---|---|
| date | Tue, 07 Jun 2005 00:00:56 -0800 |
| parents | |
| children | 5da941efbb52 |
comparison
equal
deleted
inserted
replaced
| 266:4af7677de4a9 | 267:497aa6d276d2 |
|---|---|
| 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 # CVS $Revision: 1.20 $ | |
| 11 | |
| 12 proc readfullcommits {rargs} { | |
| 13 global commits commfd phase canv mainfont curcommit allcommitstate | |
| 14 if {$rargs == {}} { | |
| 15 set rargs HEAD | |
| 16 } | |
| 17 set commits {} | |
| 18 set curcommit {} | |
| 19 set allcommitstate none | |
| 20 set phase getcommits | |
| 21 if [catch {set commfd [open "|hgit rev-list -c $rargs" r]} err] { | |
| 22 puts stderr "Error executing hgit rev-list: $err" | |
| 23 exit 1 | |
| 24 } | |
| 25 fconfigure $commfd -blocking 0 | |
| 26 fileevent $commfd readable "getallcommitline $commfd" | |
| 27 $canv delete all | |
| 28 $canv create text 3 3 -anchor nw -text "Reading all commits..." \ | |
| 29 -font $mainfont -tags textitems | |
| 30 } | |
| 31 | |
| 32 proc getcommitline {commfd} { | |
| 33 global commits parents cdate nparents children nchildren | |
| 34 set n [gets $commfd line] | |
| 35 if {$n < 0} { | |
| 36 if {![eof $commfd]} return | |
| 37 # this works around what is apparently a bug in Tcl... | |
| 38 fconfigure $commfd -blocking 1 | |
| 39 if {![catch {close $commfd} err]} { | |
| 40 after idle readallcommits | |
| 41 return | |
| 42 } | |
| 43 if {[string range $err 0 4] == "usage"} { | |
| 44 set err "\ | |
| 45 Gitk: error reading commits: bad arguments to hgit rev-list.\n\ | |
| 46 (Note: arguments to gitk are passed to hgit rev-list\ | |
| 47 to allow selection of commits to be displayed.)" | |
| 48 } else { | |
| 49 set err "Error reading commits: $err" | |
| 50 } | |
| 51 error_popup $err | |
| 52 exit 1 | |
| 53 } | |
| 54 if {![regexp {^[0-9a-f]{40}$} $line]} { | |
| 55 error_popup "Can't parse hgit rev-tree output: {$line}" | |
| 56 exit 1 | |
| 57 } | |
| 58 lappend commits $line | |
| 59 } | |
| 60 | |
| 61 proc readallcommits {} { | |
| 62 global commits | |
| 63 foreach id $commits { | |
| 64 readcommit $id | |
| 65 update | |
| 66 } | |
| 67 drawgraph | |
| 68 } | |
| 69 | |
| 70 proc readonecommit {id contents} { | |
| 71 global commitinfo children nchildren parents nparents cdate | |
| 72 set inhdr 1 | |
| 73 set comment {} | |
| 74 set headline {} | |
| 75 set auname {} | |
| 76 set audate {} | |
| 77 set comname {} | |
| 78 set comdate {} | |
| 79 if {![info exists nchildren($id)]} { | |
| 80 set children($id) {} | |
| 81 set nchildren($id) 0 | |
| 82 } | |
| 83 set parents($id) {} | |
| 84 set nparents($id) 0 | |
| 85 foreach line [split $contents "\n"] { | |
| 86 if {$inhdr} { | |
| 87 if {$line == {}} { | |
| 88 set inhdr 0 | |
| 89 } else { | |
| 90 set tag [lindex $line 0] | |
| 91 if {$tag == "parent"} { | |
| 92 set p [lindex $line 1] | |
| 93 if {![info exists nchildren($p)]} { | |
| 94 set children($p) {} | |
| 95 set nchildren($p) 0 | |
| 96 } | |
| 97 lappend parents($id) $p | |
| 98 incr nparents($id) | |
| 99 if {[lsearch -exact $children($p) $id] < 0} { | |
| 100 lappend children($p) $id | |
| 101 incr nchildren($p) | |
| 102 } | |
| 103 } elseif {$tag == "author"} { | |
| 104 set x [expr {[llength $line] - 2}] | |
| 105 set audate [lindex $line $x] | |
| 106 set auname [lrange $line 1 [expr {$x - 1}]] | |
| 107 } elseif {$tag == "committer"} { | |
| 108 set x [expr {[llength $line] - 2}] | |
| 109 set comdate [lindex $line $x] | |
| 110 set comname [lrange $line 1 [expr {$x - 1}]] | |
| 111 } | |
| 112 } | |
| 113 } else { | |
| 114 if {$comment == {}} { | |
| 115 set headline $line | |
| 116 } else { | |
| 117 append comment "\n" | |
| 118 } | |
| 119 append comment $line | |
| 120 } | |
| 121 } | |
| 122 if {$audate != {}} { | |
| 123 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"] | |
| 124 } | |
| 125 if {$comdate != {}} { | |
| 126 set cdate($id) $comdate | |
| 127 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"] | |
| 128 } | |
| 129 set commitinfo($id) [list $headline $auname $audate \ | |
| 130 $comname $comdate $comment] | |
| 131 } | |
| 132 | |
| 133 proc getallcommitline {commfd} { | |
| 134 global commits allcommitstate curcommit curcommitid | |
| 135 set n [gets $commfd line] | |
| 136 set s "\n" | |
| 137 if {$n < 0} { | |
| 138 if {![eof $commfd]} return | |
| 139 # this works around what is apparently a bug in Tcl... | |
| 140 fconfigure $commfd -blocking 1 | |
| 141 if {![catch {close $commfd} err]} { | |
| 142 after idle drawgraph | |
| 143 return | |
| 144 } | |
| 145 if {[string range $err 0 4] == "usage"} { | |
| 146 set err "\ | |
| 147 Gitk: error reading commits: bad arguments to hgit rev-list.\n\ | |
| 148 (Note: arguments to gitk are passed to hgit rev-list\ | |
| 149 to allow selection of commits to be displayed.)" | |
| 150 } else { | |
| 151 set err "Error reading commits: $err" | |
| 152 } | |
| 153 error_popup $err | |
| 154 exit 1 | |
| 155 } | |
| 156 if {[string range $line 0 1] != " "} { | |
| 157 if {$allcommitstate == "indent"} { | |
| 158 readonecommit $curcommitid $curcommit | |
| 159 } | |
| 160 if {$allcommitstate == "start"} { | |
| 161 set curcommit $curcommit$line$s | |
| 162 set allcommitstate "indent" | |
| 163 } else { | |
| 164 set curcommitid $line | |
| 165 set curcommit {} | |
| 166 set allcommitstate "start" | |
| 167 lappend commits $line | |
| 168 } | |
| 169 } else { | |
| 170 set d [string range $line 2 end] | |
| 171 set curcommit $curcommit$d$s | |
| 172 } | |
| 173 } | |
| 174 | |
| 175 proc getcommits {rargs} { | |
| 176 global commits commfd phase canv mainfont | |
| 177 if {$rargs == {}} { | |
| 178 set rargs HEAD | |
| 179 } | |
| 180 set commits {} | |
| 181 set phase getcommits | |
| 182 if [catch {set commfd [open "|hgit rev-list $rargs" r]} err] { | |
| 183 puts stderr "Error executing hgit rev-list: $err" | |
| 184 exit 1 | |
| 185 } | |
| 186 fconfigure $commfd -blocking 0 | |
| 187 fileevent $commfd readable "getcommitline $commfd" | |
| 188 $canv delete all | |
| 189 $canv create text 3 3 -anchor nw -text "Reading commits..." \ | |
| 190 -font $mainfont -tags textitems | |
| 191 } | |
| 192 | |
| 193 proc readcommit {id} { | |
| 194 global commitinfo children nchildren parents nparents cdate | |
| 195 set inhdr 1 | |
| 196 set comment {} | |
| 197 set headline {} | |
| 198 set auname {} | |
| 199 set audate {} | |
| 200 set comname {} | |
| 201 set comdate {} | |
| 202 if {![info exists nchildren($id)]} { | |
| 203 set children($id) {} | |
| 204 set nchildren($id) 0 | |
| 205 } | |
| 206 set parents($id) {} | |
| 207 set nparents($id) 0 | |
| 208 if [catch {set contents [exec hgit cat-file commit $id]}] return | |
| 209 readonecommit $id $contents | |
| 210 } | |
| 211 | |
| 212 proc readrefs {} { | |
| 213 global tagids idtags | |
| 214 set tags [glob -nocomplain -types f .git/refs/tags/*] | |
| 215 foreach f $tags { | |
| 216 catch { | |
| 217 set fd [open $f r] | |
| 218 set line [read $fd] | |
| 219 if {[regexp {^[0-9a-f]{40}} $line id]} { | |
| 220 set contents [split [exec hgit cat-file tag $id] "\n"] | |
| 221 set obj {} | |
| 222 set type {} | |
| 223 set tag {} | |
| 224 foreach l $contents { | |
| 225 if {$l == {}} break | |
| 226 switch -- [lindex $l 0] { | |
| 227 "object" {set obj [lindex $l 1]} | |
| 228 "type" {set type [lindex $l 1]} | |
| 229 "tag" {set tag [string range $l 4 end]} | |
| 230 } | |
| 231 } | |
| 232 if {$obj != {} && $type == "commit" && $tag != {}} { | |
| 233 set tagids($tag) $obj | |
| 234 lappend idtags($obj) $tag | |
| 235 } | |
| 236 } | |
| 237 } | |
| 238 } | |
| 239 } | |
| 240 | |
| 241 proc error_popup msg { | |
| 242 set w .error | |
| 243 toplevel $w | |
| 244 wm transient $w . | |
| 245 message $w.m -text $msg -justify center -aspect 400 | |
| 246 pack $w.m -side top -fill x -padx 20 -pady 20 | |
| 247 button $w.ok -text OK -command "destroy $w" | |
| 248 pack $w.ok -side bottom -fill x | |
| 249 bind $w <Visibility> "grab $w; focus $w" | |
| 250 tkwait window $w | |
| 251 } | |
| 252 | |
| 253 proc makewindow {} { | |
| 254 global canv canv2 canv3 linespc charspc ctext cflist textfont | |
| 255 global findtype findloc findstring fstring geometry | |
| 256 global entries sha1entry sha1string sha1but | |
| 257 | |
| 258 menu .bar | |
| 259 .bar add cascade -label "File" -menu .bar.file | |
| 260 menu .bar.file | |
| 261 .bar.file add command -label "Quit" -command doquit | |
| 262 menu .bar.help | |
| 263 .bar add cascade -label "Help" -menu .bar.help | |
| 264 .bar.help add command -label "About gitk" -command about | |
| 265 . configure -menu .bar | |
| 266 | |
| 267 if {![info exists geometry(canv1)]} { | |
| 268 set geometry(canv1) [expr 45 * $charspc] | |
| 269 set geometry(canv2) [expr 30 * $charspc] | |
| 270 set geometry(canv3) [expr 15 * $charspc] | |
| 271 set geometry(canvh) [expr 25 * $linespc + 4] | |
| 272 set geometry(ctextw) 80 | |
| 273 set geometry(ctexth) 30 | |
| 274 set geometry(cflistw) 30 | |
| 275 } | |
| 276 panedwindow .ctop -orient vertical | |
| 277 if {[info exists geometry(width)]} { | |
| 278 .ctop conf -width $geometry(width) -height $geometry(height) | |
| 279 set texth [expr {$geometry(height) - $geometry(canvh) - 56}] | |
| 280 set geometry(ctexth) [expr {($texth - 8) / | |
| 281 [font metrics $textfont -linespace]}] | |
| 282 } | |
| 283 frame .ctop.top | |
| 284 frame .ctop.top.bar | |
| 285 pack .ctop.top.bar -side bottom -fill x | |
| 286 set cscroll .ctop.top.csb | |
| 287 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0 | |
| 288 pack $cscroll -side right -fill y | |
| 289 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4 | |
| 290 pack .ctop.top.clist -side top -fill both -expand 1 | |
| 291 .ctop add .ctop.top | |
| 292 set canv .ctop.top.clist.canv | |
| 293 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \ | |
| 294 -bg white -bd 0 \ | |
| 295 -yscrollincr $linespc -yscrollcommand "$cscroll set" | |
| 296 .ctop.top.clist add $canv | |
| 297 set canv2 .ctop.top.clist.canv2 | |
| 298 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \ | |
| 299 -bg white -bd 0 -yscrollincr $linespc | |
| 300 .ctop.top.clist add $canv2 | |
| 301 set canv3 .ctop.top.clist.canv3 | |
| 302 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \ | |
| 303 -bg white -bd 0 -yscrollincr $linespc | |
| 304 .ctop.top.clist add $canv3 | |
| 305 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w} | |
| 306 | |
| 307 set sha1entry .ctop.top.bar.sha1 | |
| 308 set entries $sha1entry | |
| 309 set sha1but .ctop.top.bar.sha1label | |
| 310 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \ | |
| 311 -command gotocommit -width 8 | |
| 312 $sha1but conf -disabledforeground [$sha1but cget -foreground] | |
| 313 pack .ctop.top.bar.sha1label -side left | |
| 314 entry $sha1entry -width 40 -font $textfont -textvariable sha1string | |
| 315 trace add variable sha1string write sha1change | |
| 316 pack $sha1entry -side left -pady 2 | |
| 317 button .ctop.top.bar.findbut -text "Find" -command dofind | |
| 318 pack .ctop.top.bar.findbut -side left | |
| 319 set findstring {} | |
| 320 set fstring .ctop.top.bar.findstring | |
| 321 lappend entries $fstring | |
| 322 entry $fstring -width 30 -font $textfont -textvariable findstring | |
| 323 pack $fstring -side left -expand 1 -fill x | |
| 324 set findtype Exact | |
| 325 tk_optionMenu .ctop.top.bar.findtype findtype Exact IgnCase Regexp | |
| 326 set findloc "All fields" | |
| 327 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \ | |
| 328 Comments Author Committer | |
| 329 pack .ctop.top.bar.findloc -side right | |
| 330 pack .ctop.top.bar.findtype -side right | |
| 331 | |
| 332 panedwindow .ctop.cdet -orient horizontal | |
| 333 .ctop add .ctop.cdet | |
| 334 frame .ctop.cdet.left | |
| 335 set ctext .ctop.cdet.left.ctext | |
| 336 text $ctext -bg white -state disabled -font $textfont \ | |
| 337 -width $geometry(ctextw) -height $geometry(ctexth) \ | |
| 338 -yscrollcommand ".ctop.cdet.left.sb set" | |
| 339 scrollbar .ctop.cdet.left.sb -command "$ctext yview" | |
| 340 pack .ctop.cdet.left.sb -side right -fill y | |
| 341 pack $ctext -side left -fill both -expand 1 | |
| 342 .ctop.cdet add .ctop.cdet.left | |
| 343 | |
| 344 $ctext tag conf filesep -font [concat $textfont bold] | |
| 345 $ctext tag conf hunksep -back blue -fore white | |
| 346 $ctext tag conf d0 -back "#ff8080" | |
| 347 $ctext tag conf d1 -back green | |
| 348 $ctext tag conf found -back yellow | |
| 349 | |
| 350 frame .ctop.cdet.right | |
| 351 set cflist .ctop.cdet.right.cfiles | |
| 352 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \ | |
| 353 -yscrollcommand ".ctop.cdet.right.sb set" | |
| 354 scrollbar .ctop.cdet.right.sb -command "$cflist yview" | |
| 355 pack .ctop.cdet.right.sb -side right -fill y | |
| 356 pack $cflist -side left -fill both -expand 1 | |
| 357 .ctop.cdet add .ctop.cdet.right | |
| 358 bind .ctop.cdet <Configure> {resizecdetpanes %W %w} | |
| 359 | |
| 360 pack .ctop -side top -fill both -expand 1 | |
| 361 | |
| 362 bindall <1> {selcanvline %x %y} | |
| 363 bindall <B1-Motion> {selcanvline %x %y} | |
| 364 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units" | |
| 365 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units" | |
| 366 bindall <2> "allcanvs scan mark 0 %y" | |
| 367 bindall <B2-Motion> "allcanvs scan dragto 0 %y" | |
| 368 bind . <Key-Up> "selnextline -1" | |
| 369 bind . <Key-Down> "selnextline 1" | |
| 370 bind . <Key-Prior> "allcanvs yview scroll -1 pages" | |
| 371 bind . <Key-Next> "allcanvs yview scroll 1 pages" | |
| 372 bindkey <Key-Delete> "$ctext yview scroll -1 pages" | |
| 373 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages" | |
| 374 bindkey <Key-space> "$ctext yview scroll 1 pages" | |
| 375 bindkey p "selnextline -1" | |
| 376 bindkey n "selnextline 1" | |
| 377 bindkey b "$ctext yview scroll -1 pages" | |
| 378 bindkey d "$ctext yview scroll 18 units" | |
| 379 bindkey u "$ctext yview scroll -18 units" | |
| 380 bindkey / findnext | |
| 381 bindkey ? findprev | |
| 382 bindkey f nextfile | |
| 383 bind . <Control-q> doquit | |
| 384 bind . <Control-f> dofind | |
| 385 bind . <Control-g> findnext | |
| 386 bind . <Control-r> findprev | |
| 387 bind . <Control-equal> {incrfont 1} | |
| 388 bind . <Control-KP_Add> {incrfont 1} | |
| 389 bind . <Control-minus> {incrfont -1} | |
| 390 bind . <Control-KP_Subtract> {incrfont -1} | |
| 391 bind $cflist <<ListboxSelect>> listboxsel | |
| 392 bind . <Destroy> {savestuff %W} | |
| 393 bind . <Button-1> "click %W" | |
| 394 bind $fstring <Key-Return> dofind | |
| 395 bind $sha1entry <Key-Return> gotocommit | |
| 396 } | |
| 397 | |
| 398 # when we make a key binding for the toplevel, make sure | |
| 399 # it doesn't get triggered when that key is pressed in the | |
| 400 # find string entry widget. | |
| 401 proc bindkey {ev script} { | |
| 402 global entries | |
| 403 bind . $ev $script | |
| 404 set escript [bind Entry $ev] | |
| 405 if {$escript == {}} { | |
| 406 set escript [bind Entry <Key>] | |
| 407 } | |
| 408 foreach e $entries { | |
| 409 bind $e $ev "$escript; break" | |
| 410 } | |
| 411 } | |
| 412 | |
| 413 # set the focus back to the toplevel for any click outside | |
| 414 # the entry widgets | |
| 415 proc click {w} { | |
| 416 global entries | |
| 417 foreach e $entries { | |
| 418 if {$w == $e} return | |
| 419 } | |
| 420 focus . | |
| 421 } | |
| 422 | |
| 423 proc savestuff {w} { | |
| 424 global canv canv2 canv3 ctext cflist mainfont textfont | |
| 425 global stuffsaved | |
| 426 if {$stuffsaved} return | |
| 427 if {![winfo viewable .]} return | |
| 428 catch { | |
| 429 set f [open "~/.gitk-new" w] | |
| 430 puts $f "set mainfont {$mainfont}" | |
| 431 puts $f "set textfont {$textfont}" | |
| 432 puts $f "set geometry(width) [winfo width .ctop]" | |
| 433 puts $f "set geometry(height) [winfo height .ctop]" | |
| 434 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]" | |
| 435 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]" | |
| 436 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]" | |
| 437 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]" | |
| 438 set wid [expr {([winfo width $ctext] - 8) \ | |
| 439 / [font measure $textfont "0"]}] | |
| 440 puts $f "set geometry(ctextw) $wid" | |
| 441 set wid [expr {([winfo width $cflist] - 11) \ | |
| 442 / [font measure [$cflist cget -font] "0"]}] | |
| 443 puts $f "set geometry(cflistw) $wid" | |
| 444 close $f | |
| 445 file rename -force "~/.gitk-new" "~/.gitk" | |
| 446 } | |
| 447 set stuffsaved 1 | |
| 448 } | |
| 449 | |
| 450 proc resizeclistpanes {win w} { | |
| 451 global oldwidth | |
| 452 if [info exists oldwidth($win)] { | |
| 453 set s0 [$win sash coord 0] | |
| 454 set s1 [$win sash coord 1] | |
| 455 if {$w < 60} { | |
| 456 set sash0 [expr {int($w/2 - 2)}] | |
| 457 set sash1 [expr {int($w*5/6 - 2)}] | |
| 458 } else { | |
| 459 set factor [expr {1.0 * $w / $oldwidth($win)}] | |
| 460 set sash0 [expr {int($factor * [lindex $s0 0])}] | |
| 461 set sash1 [expr {int($factor * [lindex $s1 0])}] | |
| 462 if {$sash0 < 30} { | |
| 463 set sash0 30 | |
| 464 } | |
| 465 if {$sash1 < $sash0 + 20} { | |
| 466 set sash1 [expr $sash0 + 20] | |
| 467 } | |
| 468 if {$sash1 > $w - 10} { | |
| 469 set sash1 [expr $w - 10] | |
| 470 if {$sash0 > $sash1 - 20} { | |
| 471 set sash0 [expr $sash1 - 20] | |
| 472 } | |
| 473 } | |
| 474 } | |
| 475 $win sash place 0 $sash0 [lindex $s0 1] | |
| 476 $win sash place 1 $sash1 [lindex $s1 1] | |
| 477 } | |
| 478 set oldwidth($win) $w | |
| 479 } | |
| 480 | |
| 481 proc resizecdetpanes {win w} { | |
| 482 global oldwidth | |
| 483 if [info exists oldwidth($win)] { | |
| 484 set s0 [$win sash coord 0] | |
| 485 if {$w < 60} { | |
| 486 set sash0 [expr {int($w*3/4 - 2)}] | |
| 487 } else { | |
| 488 set factor [expr {1.0 * $w / $oldwidth($win)}] | |
| 489 set sash0 [expr {int($factor * [lindex $s0 0])}] | |
| 490 if {$sash0 < 45} { | |
| 491 set sash0 45 | |
| 492 } | |
| 493 if {$sash0 > $w - 15} { | |
| 494 set sash0 [expr $w - 15] | |
| 495 } | |
| 496 } | |
| 497 $win sash place 0 $sash0 [lindex $s0 1] | |
| 498 } | |
| 499 set oldwidth($win) $w | |
| 500 } | |
| 501 | |
| 502 proc allcanvs args { | |
| 503 global canv canv2 canv3 | |
| 504 eval $canv $args | |
| 505 eval $canv2 $args | |
| 506 eval $canv3 $args | |
| 507 } | |
| 508 | |
| 509 proc bindall {event action} { | |
| 510 global canv canv2 canv3 | |
| 511 bind $canv $event $action | |
| 512 bind $canv2 $event $action | |
| 513 bind $canv3 $event $action | |
| 514 } | |
| 515 | |
| 516 proc about {} { | |
| 517 set w .about | |
| 518 if {[winfo exists $w]} { | |
| 519 raise $w | |
| 520 return | |
| 521 } | |
| 522 toplevel $w | |
| 523 wm title $w "About gitk" | |
| 524 message $w.m -text { | |
| 525 Gitk version 1.1 | |
| 526 | |
| 527 Copyright © 2005 Paul Mackerras | |
| 528 | |
| 529 Use and redistribute under the terms of the GNU General Public License | |
| 530 | |
| 531 (CVS $Revision: 1.20 $)} \ | |
| 532 -justify center -aspect 400 | |
| 533 pack $w.m -side top -fill x -padx 20 -pady 20 | |
| 534 button $w.ok -text Close -command "destroy $w" | |
| 535 pack $w.ok -side bottom | |
| 536 } | |
| 537 | |
| 538 proc truncatetofit {str width font} { | |
| 539 if {[font measure $font $str] <= $width} { | |
| 540 return $str | |
| 541 } | |
| 542 set best 0 | |
| 543 set bad [string length $str] | |
| 544 set tmp $str | |
| 545 while {$best < $bad - 1} { | |
| 546 set try [expr {int(($best + $bad) / 2)}] | |
| 547 set tmp "[string range $str 0 [expr $try-1]]..." | |
| 548 if {[font measure $font $tmp] <= $width} { | |
| 549 set best $try | |
| 550 } else { | |
| 551 set bad $try | |
| 552 } | |
| 553 } | |
| 554 return $tmp | |
| 555 } | |
| 556 | |
| 557 proc assigncolor {id} { | |
| 558 global commitinfo colormap commcolors colors nextcolor | |
| 559 global colorbycommitter | |
| 560 global parents nparents children nchildren | |
| 561 if [info exists colormap($id)] return | |
| 562 set ncolors [llength $colors] | |
| 563 if {$colorbycommitter} { | |
| 564 if {![info exists commitinfo($id)]} { | |
| 565 readcommit $id | |
| 566 } | |
| 567 set comm [lindex $commitinfo($id) 3] | |
| 568 if {![info exists commcolors($comm)]} { | |
| 569 set commcolors($comm) [lindex $colors $nextcolor] | |
| 570 if {[incr nextcolor] >= $ncolors} { | |
| 571 set nextcolor 0 | |
| 572 } | |
| 573 } | |
| 574 set colormap($id) $commcolors($comm) | |
| 575 } else { | |
| 576 if {$nparents($id) == 1 && $nchildren($id) == 1} { | |
| 577 set child [lindex $children($id) 0] | |
| 578 if {[info exists colormap($child)] | |
| 579 && $nparents($child) == 1} { | |
| 580 set colormap($id) $colormap($child) | |
| 581 return | |
| 582 } | |
| 583 } | |
| 584 set badcolors {} | |
| 585 foreach child $children($id) { | |
| 586 if {[info exists colormap($child)] | |
| 587 && [lsearch -exact $badcolors $colormap($child)] < 0} { | |
| 588 lappend badcolors $colormap($child) | |
| 589 } | |
| 590 if {[info exists parents($child)]} { | |
| 591 foreach p $parents($child) { | |
| 592 if {[info exists colormap($p)] | |
| 593 && [lsearch -exact $badcolors $colormap($p)] < 0} { | |
| 594 lappend badcolors $colormap($p) | |
| 595 } | |
| 596 } | |
| 597 } | |
| 598 } | |
| 599 if {[llength $badcolors] >= $ncolors} { | |
| 600 set badcolors {} | |
| 601 } | |
| 602 for {set i 0} {$i <= $ncolors} {incr i} { | |
| 603 set c [lindex $colors $nextcolor] | |
| 604 if {[incr nextcolor] >= $ncolors} { | |
| 605 set nextcolor 0 | |
| 606 } | |
| 607 if {[lsearch -exact $badcolors $c]} break | |
| 608 } | |
| 609 set colormap($id) $c | |
| 610 } | |
| 611 } | |
| 612 | |
| 613 proc drawgraph {} { | |
| 614 global parents children nparents nchildren commits | |
| 615 global canv canv2 canv3 mainfont namefont canvx0 canvy0 canvy linespc | |
| 616 global datemode cdate | |
| 617 global lineid linehtag linentag linedtag commitinfo | |
| 618 global nextcolor colormap numcommits | |
| 619 global stopped phase redisplaying selectedline idtags idline | |
| 620 | |
| 621 allcanvs delete all | |
| 622 set start {} | |
| 623 foreach id [array names nchildren] { | |
| 624 if {$nchildren($id) == 0} { | |
| 625 lappend start $id | |
| 626 } | |
| 627 set ncleft($id) $nchildren($id) | |
| 628 if {![info exists nparents($id)]} { | |
| 629 set nparents($id) 0 | |
| 630 } | |
| 631 } | |
| 632 if {$start == {}} { | |
| 633 error_popup "Gitk: ERROR: No starting commits found" | |
| 634 exit 1 | |
| 635 } | |
| 636 | |
| 637 set nextcolor 0 | |
| 638 foreach id $start { | |
| 639 assigncolor $id | |
| 640 } | |
| 641 set todo $start | |
| 642 set level [expr [llength $todo] - 1] | |
| 643 set y2 $canvy0 | |
| 644 set nullentry -1 | |
| 645 set lineno -1 | |
| 646 set numcommits 0 | |
| 647 set phase drawgraph | |
| 648 set lthickness [expr {($linespc / 9) + 1}] | |
| 649 while 1 { | |
| 650 set canvy $y2 | |
| 651 allcanvs conf -scrollregion \ | |
| 652 [list 0 0 0 [expr $canvy + 0.5 * $linespc + 2]] | |
| 653 update | |
| 654 if {$stopped} break | |
| 655 incr numcommits | |
| 656 incr lineno | |
| 657 set nlines [llength $todo] | |
| 658 set id [lindex $todo $level] | |
| 659 set lineid($lineno) $id | |
| 660 set idline($id) $lineno | |
| 661 set actualparents {} | |
| 662 set ofill white | |
| 663 if {[info exists parents($id)]} { | |
| 664 foreach p $parents($id) { | |
| 665 if {[info exists ncleft($p)]} { | |
| 666 incr ncleft($p) -1 | |
| 667 if {![info exists commitinfo($p)]} { | |
| 668 readcommit $p | |
| 669 if {![info exists commitinfo($p)]} continue | |
| 670 } | |
| 671 lappend actualparents $p | |
| 672 set ofill blue | |
| 673 } | |
| 674 } | |
| 675 } | |
| 676 if {![info exists commitinfo($id)]} { | |
| 677 readcommit $id | |
| 678 if {![info exists commitinfo($id)]} { | |
| 679 set commitinfo($id) {"No commit information available"} | |
| 680 } | |
| 681 } | |
| 682 set x [expr $canvx0 + $level * $linespc] | |
| 683 set y2 [expr $canvy + $linespc] | |
| 684 if {[info exists linestarty($level)] && $linestarty($level) < $canvy} { | |
| 685 set t [$canv create line $x $linestarty($level) $x $canvy \ | |
| 686 -width $lthickness -fill $colormap($id)] | |
| 687 $canv lower $t | |
| 688 } | |
| 689 set linestarty($level) $canvy | |
| 690 set orad [expr {$linespc / 3}] | |
| 691 set t [$canv create oval [expr $x - $orad] [expr $canvy - $orad] \ | |
| 692 [expr $x + $orad - 1] [expr $canvy + $orad - 1] \ | |
| 693 -fill $ofill -outline black -width 1] | |
| 694 $canv raise $t | |
| 695 set xt [expr $canvx0 + $nlines * $linespc] | |
| 696 if {$nparents($id) > 2} { | |
| 697 set xt [expr {$xt + ($nparents($id) - 2) * $linespc}] | |
| 698 } | |
| 699 if {[info exists idtags($id)] && $idtags($id) != {}} { | |
| 700 set delta [expr {int(0.5 * ($linespc - $lthickness))}] | |
| 701 set yt [expr $canvy - 0.5 * $linespc] | |
| 702 set yb [expr $yt + $linespc - 1] | |
| 703 set xvals {} | |
| 704 set wvals {} | |
| 705 foreach tag $idtags($id) { | |
| 706 set wid [font measure $mainfont $tag] | |
| 707 lappend xvals $xt | |
| 708 lappend wvals $wid | |
| 709 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}] | |
| 710 } | |
| 711 set t [$canv create line $x $canvy [lindex $xvals end] $canvy \ | |
| 712 -width $lthickness -fill black] | |
| 713 $canv lower $t | |
| 714 foreach tag $idtags($id) x $xvals wid $wvals { | |
| 715 set xl [expr $x + $delta] | |
| 716 set xr [expr $x + $delta + $wid + $lthickness] | |
| 717 $canv create polygon $x [expr $yt + $delta] $xl $yt\ | |
| 718 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \ | |
| 719 -width 1 -outline black -fill yellow | |
| 720 $canv create text $xl $canvy -anchor w -text $tag \ | |
| 721 -font $mainfont | |
| 722 } | |
| 723 } | |
| 724 set headline [lindex $commitinfo($id) 0] | |
| 725 set name [lindex $commitinfo($id) 1] | |
| 726 set date [lindex $commitinfo($id) 2] | |
| 727 set linehtag($lineno) [$canv create text $xt $canvy -anchor w \ | |
| 728 -text $headline -font $mainfont ] | |
| 729 set linentag($lineno) [$canv2 create text 3 $canvy -anchor w \ | |
| 730 -text $name -font $namefont] | |
| 731 set linedtag($lineno) [$canv3 create text 3 $canvy -anchor w \ | |
| 732 -text $date -font $mainfont] | |
| 733 if {!$datemode && [llength $actualparents] == 1} { | |
| 734 set p [lindex $actualparents 0] | |
| 735 if {$ncleft($p) == 0 && [lsearch -exact $todo $p] < 0} { | |
| 736 assigncolor $p | |
| 737 set todo [lreplace $todo $level $level $p] | |
| 738 continue | |
| 739 } | |
| 740 } | |
| 741 | |
| 742 set oldtodo $todo | |
| 743 set oldlevel $level | |
| 744 set lines {} | |
| 745 for {set i 0} {$i < $nlines} {incr i} { | |
| 746 if {[lindex $todo $i] == {}} continue | |
| 747 if {[info exists linestarty($i)]} { | |
| 748 set oldstarty($i) $linestarty($i) | |
| 749 unset linestarty($i) | |
| 750 } | |
| 751 if {$i != $level} { | |
| 752 lappend lines [list $i [lindex $todo $i]] | |
| 753 } | |
| 754 } | |
| 755 if {$nullentry >= 0} { | |
| 756 set todo [lreplace $todo $nullentry $nullentry] | |
| 757 if {$nullentry < $level} { | |
| 758 incr level -1 | |
| 759 } | |
| 760 } | |
| 761 | |
| 762 set todo [lreplace $todo $level $level] | |
| 763 if {$nullentry > $level} { | |
| 764 incr nullentry -1 | |
| 765 } | |
| 766 set i $level | |
| 767 foreach p $actualparents { | |
| 768 set k [lsearch -exact $todo $p] | |
| 769 if {$k < 0} { | |
| 770 assigncolor $p | |
| 771 set todo [linsert $todo $i $p] | |
| 772 if {$nullentry >= $i} { | |
| 773 incr nullentry | |
| 774 } | |
| 775 incr i | |
| 776 } | |
| 777 lappend lines [list $oldlevel $p] | |
| 778 } | |
| 779 | |
| 780 # choose which one to do next time around | |
| 781 set todol [llength $todo] | |
| 782 set level -1 | |
| 783 set latest {} | |
| 784 for {set k $todol} {[incr k -1] >= 0} {} { | |
| 785 set p [lindex $todo $k] | |
| 786 if {$p == {}} continue | |
| 787 if {$ncleft($p) == 0} { | |
| 788 if {$datemode} { | |
| 789 if {$latest == {} || $cdate($p) > $latest} { | |
| 790 set level $k | |
| 791 set latest $cdate($p) | |
| 792 } | |
| 793 } else { | |
| 794 set level $k | |
| 795 break | |
| 796 } | |
| 797 } | |
| 798 } | |
| 799 if {$level < 0} { | |
| 800 if {$todo != {}} { | |
| 801 puts "ERROR: none of the pending commits can be done yet:" | |
| 802 foreach p $todo { | |
| 803 puts " $p" | |
| 804 } | |
| 805 } | |
| 806 break | |
| 807 } | |
| 808 | |
| 809 # If we are reducing, put in a null entry | |
| 810 if {$todol < $nlines} { | |
| 811 if {$nullentry >= 0} { | |
| 812 set i $nullentry | |
| 813 while {$i < $todol | |
| 814 && [lindex $oldtodo $i] == [lindex $todo $i]} { | |
| 815 incr i | |
| 816 } | |
| 817 } else { | |
| 818 set i $oldlevel | |
| 819 if {$level >= $i} { | |
| 820 incr i | |
| 821 } | |
| 822 } | |
| 823 if {$i >= $todol} { | |
| 824 set nullentry -1 | |
| 825 } else { | |
| 826 set nullentry $i | |
| 827 set todo [linsert $todo $nullentry {}] | |
| 828 if {$level >= $i} { | |
| 829 incr level | |
| 830 } | |
| 831 } | |
| 832 } else { | |
| 833 set nullentry -1 | |
| 834 } | |
| 835 | |
| 836 foreach l $lines { | |
| 837 set i [lindex $l 0] | |
| 838 set dst [lindex $l 1] | |
| 839 set j [lsearch -exact $todo $dst] | |
| 840 if {$i == $j} { | |
| 841 if {[info exists oldstarty($i)]} { | |
| 842 set linestarty($i) $oldstarty($i) | |
| 843 } | |
| 844 continue | |
| 845 } | |
| 846 set xi [expr {$canvx0 + $i * $linespc}] | |
| 847 set xj [expr {$canvx0 + $j * $linespc}] | |
| 848 set coords {} | |
| 849 if {[info exists oldstarty($i)] && $oldstarty($i) < $canvy} { | |
| 850 lappend coords $xi $oldstarty($i) | |
| 851 } | |
| 852 lappend coords $xi $canvy | |
| 853 if {$j < $i - 1} { | |
| 854 lappend coords [expr $xj + $linespc] $canvy | |
| 855 } elseif {$j > $i + 1} { | |
| 856 lappend coords [expr $xj - $linespc] $canvy | |
| 857 } | |
| 858 lappend coords $xj $y2 | |
| 859 set t [$canv create line $coords -width $lthickness \ | |
| 860 -fill $colormap($dst)] | |
| 861 $canv lower $t | |
| 862 if {![info exists linestarty($j)]} { | |
| 863 set linestarty($j) $y2 | |
| 864 } | |
| 865 } | |
| 866 } | |
| 867 set phase {} | |
| 868 if {$redisplaying} { | |
| 869 if {$stopped == 0 && [info exists selectedline]} { | |
| 870 selectline $selectedline | |
| 871 } | |
| 872 if {$stopped == 1} { | |
| 873 set stopped 0 | |
| 874 after idle drawgraph | |
| 875 } else { | |
| 876 set redisplaying 0 | |
| 877 } | |
| 878 } | |
| 879 } | |
| 880 | |
| 881 proc findmatches {f} { | |
| 882 global findtype foundstring foundstrlen | |
| 883 if {$findtype == "Regexp"} { | |
| 884 set matches [regexp -indices -all -inline $foundstring $f] | |
| 885 } else { | |
| 886 if {$findtype == "IgnCase"} { | |
| 887 set str [string tolower $f] | |
| 888 } else { | |
| 889 set str $f | |
| 890 } | |
| 891 set matches {} | |
| 892 set i 0 | |
| 893 while {[set j [string first $foundstring $str $i]] >= 0} { | |
| 894 lappend matches [list $j [expr $j+$foundstrlen-1]] | |
| 895 set i [expr $j + $foundstrlen] | |
| 896 } | |
| 897 } | |
| 898 return $matches | |
| 899 } | |
| 900 | |
| 901 proc dofind {} { | |
| 902 global findtype findloc findstring markedmatches commitinfo | |
| 903 global numcommits lineid linehtag linentag linedtag | |
| 904 global mainfont namefont canv canv2 canv3 selectedline | |
| 905 global matchinglines foundstring foundstrlen idtags | |
| 906 unmarkmatches | |
| 907 focus . | |
| 908 set matchinglines {} | |
| 909 set fldtypes {Headline Author Date Committer CDate Comment} | |
| 910 if {$findtype == "IgnCase"} { | |
| 911 set foundstring [string tolower $findstring] | |
| 912 } else { | |
| 913 set foundstring $findstring | |
| 914 } | |
| 915 set foundstrlen [string length $findstring] | |
| 916 if {$foundstrlen == 0} return | |
| 917 if {![info exists selectedline]} { | |
| 918 set oldsel -1 | |
| 919 } else { | |
| 920 set oldsel $selectedline | |
| 921 } | |
| 922 set didsel 0 | |
| 923 for {set l 0} {$l < $numcommits} {incr l} { | |
| 924 set id $lineid($l) | |
| 925 set info $commitinfo($id) | |
| 926 set doesmatch 0 | |
| 927 foreach f $info ty $fldtypes { | |
| 928 if {$findloc != "All fields" && $findloc != $ty} { | |
| 929 continue | |
| 930 } | |
| 931 set matches [findmatches $f] | |
| 932 if {$matches == {}} continue | |
| 933 set doesmatch 1 | |
| 934 if {$ty == "Headline"} { | |
| 935 markmatches $canv $l $f $linehtag($l) $matches $mainfont | |
| 936 } elseif {$ty == "Author"} { | |
| 937 markmatches $canv2 $l $f $linentag($l) $matches $namefont | |
| 938 } elseif {$ty == "Date"} { | |
| 939 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont | |
| 940 } | |
| 941 } | |
| 942 if {$doesmatch} { | |
| 943 lappend matchinglines $l | |
| 944 if {!$didsel && $l > $oldsel} { | |
| 945 findselectline $l | |
| 946 set didsel 1 | |
| 947 } | |
| 948 } | |
| 949 } | |
| 950 if {$matchinglines == {}} { | |
| 951 bell | |
| 952 } elseif {!$didsel} { | |
| 953 findselectline [lindex $matchinglines 0] | |
| 954 } | |
| 955 } | |
| 956 | |
| 957 proc findselectline {l} { | |
| 958 global findloc commentend ctext | |
| 959 selectline $l | |
| 960 if {$findloc == "All fields" || $findloc == "Comments"} { | |
| 961 # highlight the matches in the comments | |
| 962 set f [$ctext get 1.0 $commentend] | |
| 963 set matches [findmatches $f] | |
| 964 foreach match $matches { | |
| 965 set start [lindex $match 0] | |
| 966 set end [expr [lindex $match 1] + 1] | |
| 967 $ctext tag add found "1.0 + $start c" "1.0 + $end c" | |
| 968 } | |
| 969 } | |
| 970 } | |
| 971 | |
| 972 proc findnext {} { | |
| 973 global matchinglines selectedline | |
| 974 if {![info exists matchinglines]} { | |
| 975 dofind | |
| 976 return | |
| 977 } | |
| 978 if {![info exists selectedline]} return | |
| 979 foreach l $matchinglines { | |
| 980 if {$l > $selectedline} { | |
| 981 findselectline $l | |
| 982 return | |
| 983 } | |
| 984 } | |
| 985 bell | |
| 986 } | |
| 987 | |
| 988 proc findprev {} { | |
| 989 global matchinglines selectedline | |
| 990 if {![info exists matchinglines]} { | |
| 991 dofind | |
| 992 return | |
| 993 } | |
| 994 if {![info exists selectedline]} return | |
| 995 set prev {} | |
| 996 foreach l $matchinglines { | |
| 997 if {$l >= $selectedline} break | |
| 998 set prev $l | |
| 999 } | |
| 1000 if {$prev != {}} { | |
| 1001 findselectline $prev | |
| 1002 } else { | |
| 1003 bell | |
| 1004 } | |
| 1005 } | |
| 1006 | |
| 1007 proc markmatches {canv l str tag matches font} { | |
| 1008 set bbox [$canv bbox $tag] | |
| 1009 set x0 [lindex $bbox 0] | |
| 1010 set y0 [lindex $bbox 1] | |
| 1011 set y1 [lindex $bbox 3] | |
| 1012 foreach match $matches { | |
| 1013 set start [lindex $match 0] | |
| 1014 set end [lindex $match 1] | |
| 1015 if {$start > $end} continue | |
| 1016 set xoff [font measure $font [string range $str 0 [expr $start-1]]] | |
| 1017 set xlen [font measure $font [string range $str 0 [expr $end]]] | |
| 1018 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \ | |
| 1019 -outline {} -tags matches -fill yellow] | |
| 1020 $canv lower $t | |
| 1021 } | |
| 1022 } | |
| 1023 | |
| 1024 proc unmarkmatches {} { | |
| 1025 global matchinglines | |
| 1026 allcanvs delete matches | |
| 1027 catch {unset matchinglines} | |
| 1028 } | |
| 1029 | |
| 1030 proc selcanvline {x y} { | |
| 1031 global canv canvy0 ctext linespc selectedline | |
| 1032 global lineid linehtag linentag linedtag | |
| 1033 set ymax [lindex [$canv cget -scrollregion] 3] | |
| 1034 if {$ymax == {}} return | |
| 1035 set yfrac [lindex [$canv yview] 0] | |
| 1036 set y [expr {$y + $yfrac * $ymax}] | |
| 1037 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}] | |
| 1038 if {$l < 0} { | |
| 1039 set l 0 | |
| 1040 } | |
| 1041 if {[info exists selectedline] && $selectedline == $l} return | |
| 1042 unmarkmatches | |
| 1043 selectline $l | |
| 1044 } | |
| 1045 | |
| 1046 proc selectline {l} { | |
| 1047 global canv canv2 canv3 ctext commitinfo selectedline | |
| 1048 global lineid linehtag linentag linedtag | |
| 1049 global canvy0 linespc nparents treepending | |
| 1050 global cflist treediffs currentid sha1entry | |
| 1051 global commentend seenfile numcommits idtags | |
| 1052 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return | |
| 1053 $canv delete secsel | |
| 1054 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \ | |
| 1055 -tags secsel -fill [$canv cget -selectbackground]] | |
| 1056 $canv lower $t | |
| 1057 $canv2 delete secsel | |
| 1058 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \ | |
| 1059 -tags secsel -fill [$canv2 cget -selectbackground]] | |
| 1060 $canv2 lower $t | |
| 1061 $canv3 delete secsel | |
| 1062 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \ | |
| 1063 -tags secsel -fill [$canv3 cget -selectbackground]] | |
| 1064 $canv3 lower $t | |
| 1065 set y [expr {$canvy0 + $l * $linespc}] | |
| 1066 set ymax [lindex [$canv cget -scrollregion] 3] | |
| 1067 set ytop [expr {$y - $linespc - 1}] | |
| 1068 set ybot [expr {$y + $linespc + 1}] | |
| 1069 set wnow [$canv yview] | |
| 1070 set wtop [expr [lindex $wnow 0] * $ymax] | |
| 1071 set wbot [expr [lindex $wnow 1] * $ymax] | |
| 1072 set wh [expr {$wbot - $wtop}] | |
| 1073 set newtop $wtop | |
| 1074 if {$ytop < $wtop} { | |
| 1075 if {$ybot < $wtop} { | |
| 1076 set newtop [expr {$y - $wh / 2.0}] | |
| 1077 } else { | |
| 1078 set newtop $ytop | |
| 1079 if {$newtop > $wtop - $linespc} { | |
| 1080 set newtop [expr {$wtop - $linespc}] | |
| 1081 } | |
| 1082 } | |
| 1083 } elseif {$ybot > $wbot} { | |
| 1084 if {$ytop > $wbot} { | |
| 1085 set newtop [expr {$y - $wh / 2.0}] | |
| 1086 } else { | |
| 1087 set newtop [expr {$ybot - $wh}] | |
| 1088 if {$newtop < $wtop + $linespc} { | |
| 1089 set newtop [expr {$wtop + $linespc}] | |
| 1090 } | |
| 1091 } | |
| 1092 } | |
| 1093 if {$newtop != $wtop} { | |
| 1094 if {$newtop < 0} { | |
| 1095 set newtop 0 | |
| 1096 } | |
| 1097 allcanvs yview moveto [expr $newtop * 1.0 / $ymax] | |
| 1098 } | |
| 1099 set selectedline $l | |
| 1100 | |
| 1101 set id $lineid($l) | |
| 1102 set currentid $id | |
| 1103 $sha1entry delete 0 end | |
| 1104 $sha1entry insert 0 $id | |
| 1105 $sha1entry selection from 0 | |
| 1106 $sha1entry selection to end | |
| 1107 | |
| 1108 $ctext conf -state normal | |
| 1109 $ctext delete 0.0 end | |
| 1110 set info $commitinfo($id) | |
| 1111 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n" | |
| 1112 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n" | |
| 1113 if {[info exists idtags($id)]} { | |
| 1114 $ctext insert end "Tags:" | |
| 1115 foreach tag $idtags($id) { | |
| 1116 $ctext insert end " $tag" | |
| 1117 } | |
| 1118 $ctext insert end "\n" | |
| 1119 } | |
| 1120 $ctext insert end "\n" | |
| 1121 $ctext insert end [lindex $info 5] | |
| 1122 $ctext insert end "\n" | |
| 1123 $ctext tag delete Comments | |
| 1124 $ctext tag remove found 1.0 end | |
| 1125 $ctext conf -state disabled | |
| 1126 set commentend [$ctext index "end - 1c"] | |
| 1127 | |
| 1128 $cflist delete 0 end | |
| 1129 if {$nparents($id) == 1} { | |
| 1130 if {![info exists treediffs($id)]} { | |
| 1131 if {![info exists treepending]} { | |
| 1132 gettreediffs $id | |
| 1133 } | |
| 1134 } else { | |
| 1135 addtocflist $id | |
| 1136 } | |
| 1137 } | |
| 1138 catch {unset seenfile} | |
| 1139 } | |
| 1140 | |
| 1141 proc selnextline {dir} { | |
| 1142 global selectedline | |
| 1143 if {![info exists selectedline]} return | |
| 1144 set l [expr $selectedline + $dir] | |
| 1145 unmarkmatches | |
| 1146 selectline $l | |
| 1147 } | |
| 1148 | |
| 1149 proc addtocflist {id} { | |
| 1150 global currentid treediffs cflist treepending | |
| 1151 if {$id != $currentid} { | |
| 1152 gettreediffs $currentid | |
| 1153 return | |
| 1154 } | |
| 1155 $cflist insert end "All files" | |
| 1156 foreach f $treediffs($currentid) { | |
| 1157 $cflist insert end $f | |
| 1158 } | |
| 1159 getblobdiffs $id | |
| 1160 } | |
| 1161 | |
| 1162 proc gettreediffs {id} { | |
| 1163 global treediffs parents treepending | |
| 1164 set treepending $id | |
| 1165 set treediffs($id) {} | |
| 1166 set p [lindex $parents($id) 0] | |
| 1167 puts stderr "hgit diff-tree -r $p $id" | |
| 1168 if [catch {set gdtf [open "|hgit diff-tree -r $p $id" r]}] return | |
| 1169 fconfigure $gdtf -blocking 0 | |
| 1170 fileevent $gdtf readable "gettreediffline $gdtf $id" | |
| 1171 } | |
| 1172 | |
| 1173 proc gettreediffline {gdtf id} { | |
| 1174 global treediffs treepending | |
| 1175 set n [gets $gdtf line] | |
| 1176 if {$n < 0} { | |
| 1177 if {![eof $gdtf]} return | |
| 1178 close $gdtf | |
| 1179 unset treepending | |
| 1180 addtocflist $id | |
| 1181 return | |
| 1182 } | |
| 1183 set file [lindex $line 5] | |
| 1184 puts stderr "line $file\n" | |
| 1185 lappend treediffs($id) $file | |
| 1186 } | |
| 1187 | |
| 1188 proc getblobdiffs {id} { | |
| 1189 global parents diffopts blobdifffd env curdifftag curtagstart | |
| 1190 global diffindex difffilestart | |
| 1191 set p [lindex $parents($id) 0] | |
| 1192 set env(GIT_DIFF_OPTS) $diffopts | |
| 1193 if [catch {set bdf [open "|hgit diff-tree -r -p $p $id" r]} err] { | |
| 1194 puts "error getting diffs: $err" | |
| 1195 return | |
| 1196 } | |
| 1197 fconfigure $bdf -blocking 0 | |
| 1198 set blobdifffd($id) $bdf | |
| 1199 set curdifftag Comments | |
| 1200 set curtagstart 0.0 | |
| 1201 set diffindex 0 | |
| 1202 catch {unset difffilestart} | |
| 1203 fileevent $bdf readable "getblobdiffline $bdf $id" | |
| 1204 } | |
| 1205 | |
| 1206 proc getblobdiffline {bdf id} { | |
| 1207 global currentid blobdifffd ctext curdifftag curtagstart seenfile | |
| 1208 global diffnexthead diffnextnote diffindex difffilestart | |
| 1209 set n [gets $bdf line] | |
| 1210 if {$n < 0} { | |
| 1211 if {[eof $bdf]} { | |
| 1212 close $bdf | |
| 1213 if {$id == $currentid && $bdf == $blobdifffd($id)} { | |
| 1214 $ctext tag add $curdifftag $curtagstart end | |
| 1215 set seenfile($curdifftag) 1 | |
| 1216 } | |
| 1217 } | |
| 1218 return | |
| 1219 } | |
| 1220 if {$id != $currentid || $bdf != $blobdifffd($id)} { | |
| 1221 return | |
| 1222 } | |
| 1223 $ctext conf -state normal | |
| 1224 if {[regexp {^---[ \t]+([^/])*/(.*)} $line match s1 fname]} { | |
| 1225 # start of a new file | |
| 1226 $ctext insert end "\n" | |
| 1227 $ctext tag add $curdifftag $curtagstart end | |
| 1228 set seenfile($curdifftag) 1 | |
| 1229 set curtagstart [$ctext index "end - 1c"] | |
| 1230 set header $fname | |
| 1231 if {[info exists diffnexthead]} { | |
| 1232 set fname $diffnexthead | |
| 1233 set header "$diffnexthead ($diffnextnote)" | |
| 1234 unset diffnexthead | |
| 1235 } | |
| 1236 set difffilestart($diffindex) [$ctext index "end - 1c"] | |
| 1237 incr diffindex | |
| 1238 set curdifftag "f:$fname" | |
| 1239 $ctext tag delete $curdifftag | |
| 1240 set l [expr {(78 - [string length $header]) / 2}] | |
| 1241 set pad [string range "----------------------------------------" 1 $l] | |
| 1242 $ctext insert end "$pad $header $pad\n" filesep | |
| 1243 } elseif {[string range $line 0 2] == "+++"} { | |
| 1244 # no need to do anything with this | |
| 1245 } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} { | |
| 1246 set diffnexthead $fn | |
| 1247 set diffnextnote "created, mode $m" | |
| 1248 } elseif {[string range $line 0 8] == "Deleted: "} { | |
| 1249 set diffnexthead [string range $line 9 end] | |
| 1250 set diffnextnote "deleted" | |
| 1251 } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} { | |
| 1252 # save the filename in case the next thing is "new file mode ..." | |
| 1253 set diffnexthead $fn | |
| 1254 set diffnextnote "modified" | |
| 1255 } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} { | |
| 1256 set diffnextnote "new file, mode $m" | |
| 1257 } elseif {[string range $line 0 11] == "deleted file"} { | |
| 1258 set diffnextnote "deleted" | |
| 1259 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \ | |
| 1260 $line match f1l f1c f2l f2c rest]} { | |
| 1261 $ctext insert end "\t" hunksep | |
| 1262 $ctext insert end " $f1l " d0 " $f2l " d1 | |
| 1263 $ctext insert end " $rest \n" hunksep | |
| 1264 } else { | |
| 1265 set x [string range $line 0 0] | |
| 1266 if {$x == "-" || $x == "+"} { | |
| 1267 set tag [expr {$x == "+"}] | |
| 1268 set line [string range $line 1 end] | |
| 1269 $ctext insert end "$line\n" d$tag | |
| 1270 } elseif {$x == " "} { | |
| 1271 set line [string range $line 1 end] | |
| 1272 $ctext insert end "$line\n" | |
| 1273 } elseif {$x == "\\"} { | |
| 1274 # e.g. "\ No newline at end of file" | |
| 1275 $ctext insert end "$line\n" filesep | |
| 1276 } else { | |
| 1277 # Something else we don't recognize | |
| 1278 if {$curdifftag != "Comments"} { | |
| 1279 $ctext insert end "\n" | |
| 1280 $ctext tag add $curdifftag $curtagstart end | |
| 1281 set seenfile($curdifftag) 1 | |
| 1282 set curtagstart [$ctext index "end - 1c"] | |
| 1283 set curdifftag Comments | |
| 1284 } | |
| 1285 $ctext insert end "$line\n" filesep | |
| 1286 } | |
| 1287 } | |
| 1288 $ctext conf -state disabled | |
| 1289 } | |
| 1290 | |
| 1291 proc nextfile {} { | |
| 1292 global difffilestart ctext | |
| 1293 set here [$ctext index @0,0] | |
| 1294 for {set i 0} {[info exists difffilestart($i)]} {incr i} { | |
| 1295 if {[$ctext compare $difffilestart($i) > $here]} { | |
| 1296 $ctext yview $difffilestart($i) | |
| 1297 break | |
| 1298 } | |
| 1299 } | |
| 1300 } | |
| 1301 | |
| 1302 proc listboxsel {} { | |
| 1303 global ctext cflist currentid treediffs seenfile | |
| 1304 if {![info exists currentid]} return | |
| 1305 set sel [$cflist curselection] | |
| 1306 if {$sel == {} || [lsearch -exact $sel 0] >= 0} { | |
| 1307 # show everything | |
| 1308 $ctext tag conf Comments -elide 0 | |
| 1309 foreach f $treediffs($currentid) { | |
| 1310 if [info exists seenfile(f:$f)] { | |
| 1311 $ctext tag conf "f:$f" -elide 0 | |
| 1312 } | |
| 1313 } | |
| 1314 } else { | |
| 1315 # just show selected files | |
| 1316 $ctext tag conf Comments -elide 1 | |
| 1317 set i 1 | |
| 1318 foreach f $treediffs($currentid) { | |
| 1319 set elide [expr {[lsearch -exact $sel $i] < 0}] | |
| 1320 if [info exists seenfile(f:$f)] { | |
| 1321 $ctext tag conf "f:$f" -elide $elide | |
| 1322 } | |
| 1323 incr i | |
| 1324 } | |
| 1325 } | |
| 1326 } | |
| 1327 | |
| 1328 proc setcoords {} { | |
| 1329 global linespc charspc canvx0 canvy0 mainfont | |
| 1330 set linespc [font metrics $mainfont -linespace] | |
| 1331 set charspc [font measure $mainfont "m"] | |
| 1332 set canvy0 [expr 3 + 0.5 * $linespc] | |
| 1333 set canvx0 [expr 3 + 0.5 * $linespc] | |
| 1334 } | |
| 1335 | |
| 1336 proc redisplay {} { | |
| 1337 global selectedline stopped redisplaying phase | |
| 1338 if {$stopped > 1} return | |
| 1339 if {$phase == "getcommits"} return | |
| 1340 set redisplaying 1 | |
| 1341 if {$phase == "drawgraph"} { | |
| 1342 set stopped 1 | |
| 1343 } else { | |
| 1344 drawgraph | |
| 1345 } | |
| 1346 } | |
| 1347 | |
| 1348 proc incrfont {inc} { | |
| 1349 global mainfont namefont textfont selectedline ctext canv phase | |
| 1350 global stopped entries | |
| 1351 unmarkmatches | |
| 1352 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]] | |
| 1353 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]] | |
| 1354 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]] | |
| 1355 setcoords | |
| 1356 $ctext conf -font $textfont | |
| 1357 $ctext tag conf filesep -font [concat $textfont bold] | |
| 1358 foreach e $entries { | |
| 1359 $e conf -font $mainfont | |
| 1360 } | |
| 1361 if {$phase == "getcommits"} { | |
| 1362 $canv itemconf textitems -font $mainfont | |
| 1363 } | |
| 1364 redisplay | |
| 1365 } | |
| 1366 | |
| 1367 proc sha1change {n1 n2 op} { | |
| 1368 global sha1string currentid sha1but | |
| 1369 if {$sha1string == {} | |
| 1370 || ([info exists currentid] && $sha1string == $currentid)} { | |
| 1371 set state disabled | |
| 1372 } else { | |
| 1373 set state normal | |
| 1374 } | |
| 1375 if {[$sha1but cget -state] == $state} return | |
| 1376 if {$state == "normal"} { | |
| 1377 $sha1but conf -state normal -relief raised -text "Goto: " | |
| 1378 } else { | |
| 1379 $sha1but conf -state disabled -relief flat -text "SHA1 ID: " | |
| 1380 } | |
| 1381 } | |
| 1382 | |
| 1383 proc gotocommit {} { | |
| 1384 global sha1string currentid idline tagids | |
| 1385 if {$sha1string == {} | |
| 1386 || ([info exists currentid] && $sha1string == $currentid)} return | |
| 1387 if {[info exists tagids($sha1string)]} { | |
| 1388 set id $tagids($sha1string) | |
| 1389 } else { | |
| 1390 set id [string tolower $sha1string] | |
| 1391 } | |
| 1392 if {[info exists idline($id)]} { | |
| 1393 selectline $idline($id) | |
| 1394 return | |
| 1395 } | |
| 1396 if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} { | |
| 1397 set type "SHA1 id" | |
| 1398 } else { | |
| 1399 set type "Tag" | |
| 1400 } | |
| 1401 error_popup "$type $sha1string is not known" | |
| 1402 } | |
| 1403 | |
| 1404 proc doquit {} { | |
| 1405 global stopped | |
| 1406 set stopped 100 | |
| 1407 destroy . | |
| 1408 } | |
| 1409 | |
| 1410 # defaults... | |
| 1411 set datemode 0 | |
| 1412 set boldnames 0 | |
| 1413 set diffopts "-U 5 -p" | |
| 1414 | |
| 1415 set mainfont {Helvetica 9} | |
| 1416 set textfont {Courier 9} | |
| 1417 | |
| 1418 set colors {green red blue magenta darkgrey brown orange} | |
| 1419 set colorbycommitter false | |
| 1420 | |
| 1421 catch {source ~/.gitk} | |
| 1422 | |
| 1423 set namefont $mainfont | |
| 1424 if {$boldnames} { | |
| 1425 lappend namefont bold | |
| 1426 } | |
| 1427 | |
| 1428 set revtreeargs {} | |
| 1429 foreach arg $argv { | |
| 1430 switch -regexp -- $arg { | |
| 1431 "^$" { } | |
| 1432 "^-b" { set boldnames 1 } | |
| 1433 "^-c" { set colorbycommitter 1 } | |
| 1434 "^-d" { set datemode 1 } | |
| 1435 default { | |
| 1436 lappend revtreeargs $arg | |
| 1437 } | |
| 1438 } | |
| 1439 } | |
| 1440 | |
| 1441 set stopped 0 | |
| 1442 set redisplaying 0 | |
| 1443 set stuffsaved 0 | |
| 1444 setcoords | |
| 1445 makewindow | |
| 1446 readrefs | |
| 1447 readfullcommits $revtreeargs |