Mercurial > hg > pyhgsh
annotate contrib/hgk @ 274:5da941efbb52
[PATCH] hgk should parse dates in the diff output
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
[PATCH] hgk should parse dates in the diff output
hgk doesn't deal well with the difflib style diffs, it expects the filename
to be the last thing on the line. This patch fixes the regexp to stop
reading the filename at the first tab.
Signed-off-by: Chris Mason <mason@suse.com>
manifest hash: 9c5bcf427455dcf306ab6f91b1986723caa83f36
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.4.0 (GNU/Linux)
iD8DBQFCpl/HywK+sNU5EO8RAgAjAKCOuZsRtJDbdurTQry+7krtLTtRQQCfXLuN
LZEFkcOGS0jiAC6vci/RLJ0=
=jkr1
-----END PGP SIGNATURE-----
| author | mpm@selenic.com |
|---|---|
| date | Tue, 07 Jun 2005 19:02:31 -0800 |
| parents | 497aa6d276d2 |
| children | a69c3b2957d1 |
| rev | line source |
|---|---|
| 267 | 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 lappend treediffs($id) $file | |
| 1185 } | |
| 1186 | |
| 1187 proc getblobdiffs {id} { | |
| 1188 global parents diffopts blobdifffd env curdifftag curtagstart | |
| 1189 global diffindex difffilestart | |
| 1190 set p [lindex $parents($id) 0] | |
| 1191 set env(GIT_DIFF_OPTS) $diffopts | |
| 1192 if [catch {set bdf [open "|hgit diff-tree -r -p $p $id" r]} err] { | |
| 1193 puts "error getting diffs: $err" | |
| 1194 return | |
| 1195 } | |
| 1196 fconfigure $bdf -blocking 0 | |
| 1197 set blobdifffd($id) $bdf | |
| 1198 set curdifftag Comments | |
| 1199 set curtagstart 0.0 | |
| 1200 set diffindex 0 | |
| 1201 catch {unset difffilestart} | |
| 1202 fileevent $bdf readable "getblobdiffline $bdf $id" | |
| 1203 } | |
| 1204 | |
| 1205 proc getblobdiffline {bdf id} { | |
| 1206 global currentid blobdifffd ctext curdifftag curtagstart seenfile | |
| 1207 global diffnexthead diffnextnote diffindex difffilestart | |
| 1208 set n [gets $bdf line] | |
| 1209 if {$n < 0} { | |
| 1210 if {[eof $bdf]} { | |
| 1211 close $bdf | |
| 1212 if {$id == $currentid && $bdf == $blobdifffd($id)} { | |
| 1213 $ctext tag add $curdifftag $curtagstart end | |
| 1214 set seenfile($curdifftag) 1 | |
| 1215 } | |
| 1216 } | |
| 1217 return | |
| 1218 } | |
| 1219 if {$id != $currentid || $bdf != $blobdifffd($id)} { | |
| 1220 return | |
| 1221 } | |
| 1222 $ctext conf -state normal | |
|
274
5da941efbb52
[PATCH] hgk should parse dates in the diff output
mpm@selenic.com
parents:
267
diff
changeset
|
1223 if {[regexp {^---[ \t]+([^/])*/([^\t]*)} $line match s0 fname]} { |
| 267 | 1224 # start of a new file |
| 1225 $ctext insert end "\n" | |
| 1226 $ctext tag add $curdifftag $curtagstart end | |
| 1227 set seenfile($curdifftag) 1 | |
| 1228 set curtagstart [$ctext index "end - 1c"] | |
| 1229 set header $fname | |
| 1230 if {[info exists diffnexthead]} { | |
| 1231 set fname $diffnexthead | |
| 1232 set header "$diffnexthead ($diffnextnote)" | |
| 1233 unset diffnexthead | |
| 1234 } | |
| 1235 set difffilestart($diffindex) [$ctext index "end - 1c"] | |
| 1236 incr diffindex | |
| 1237 set curdifftag "f:$fname" | |
| 1238 $ctext tag delete $curdifftag | |
| 1239 set l [expr {(78 - [string length $header]) / 2}] | |
| 1240 set pad [string range "----------------------------------------" 1 $l] | |
| 1241 $ctext insert end "$pad $header $pad\n" filesep | |
| 1242 } elseif {[string range $line 0 2] == "+++"} { | |
| 1243 # no need to do anything with this | |
| 1244 } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} { | |
| 1245 set diffnexthead $fn | |
| 1246 set diffnextnote "created, mode $m" | |
| 1247 } elseif {[string range $line 0 8] == "Deleted: "} { | |
| 1248 set diffnexthead [string range $line 9 end] | |
| 1249 set diffnextnote "deleted" | |
| 1250 } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} { | |
| 1251 # save the filename in case the next thing is "new file mode ..." | |
| 1252 set diffnexthead $fn | |
| 1253 set diffnextnote "modified" | |
| 1254 } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} { | |
| 1255 set diffnextnote "new file, mode $m" | |
| 1256 } elseif {[string range $line 0 11] == "deleted file"} { | |
| 1257 set diffnextnote "deleted" | |
| 1258 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \ | |
| 1259 $line match f1l f1c f2l f2c rest]} { | |
| 1260 $ctext insert end "\t" hunksep | |
| 1261 $ctext insert end " $f1l " d0 " $f2l " d1 | |
| 1262 $ctext insert end " $rest \n" hunksep | |
| 1263 } else { | |
| 1264 set x [string range $line 0 0] | |
| 1265 if {$x == "-" || $x == "+"} { | |
| 1266 set tag [expr {$x == "+"}] | |
| 1267 set line [string range $line 1 end] | |
| 1268 $ctext insert end "$line\n" d$tag | |
| 1269 } elseif {$x == " "} { | |
| 1270 set line [string range $line 1 end] | |
| 1271 $ctext insert end "$line\n" | |
| 1272 } elseif {$x == "\\"} { | |
| 1273 # e.g. "\ No newline at end of file" | |
| 1274 $ctext insert end "$line\n" filesep | |
| 1275 } else { | |
| 1276 # Something else we don't recognize | |
| 1277 if {$curdifftag != "Comments"} { | |
| 1278 $ctext insert end "\n" | |
| 1279 $ctext tag add $curdifftag $curtagstart end | |
| 1280 set seenfile($curdifftag) 1 | |
| 1281 set curtagstart [$ctext index "end - 1c"] | |
| 1282 set curdifftag Comments | |
| 1283 } | |
| 1284 $ctext insert end "$line\n" filesep | |
| 1285 } | |
| 1286 } | |
| 1287 $ctext conf -state disabled | |
| 1288 } | |
| 1289 | |
| 1290 proc nextfile {} { | |
| 1291 global difffilestart ctext | |
| 1292 set here [$ctext index @0,0] | |
| 1293 for {set i 0} {[info exists difffilestart($i)]} {incr i} { | |
| 1294 if {[$ctext compare $difffilestart($i) > $here]} { | |
| 1295 $ctext yview $difffilestart($i) | |
| 1296 break | |
| 1297 } | |
| 1298 } | |
| 1299 } | |
| 1300 | |
| 1301 proc listboxsel {} { | |
| 1302 global ctext cflist currentid treediffs seenfile | |
| 1303 if {![info exists currentid]} return | |
| 1304 set sel [$cflist curselection] | |
| 1305 if {$sel == {} || [lsearch -exact $sel 0] >= 0} { | |
| 1306 # show everything | |
| 1307 $ctext tag conf Comments -elide 0 | |
| 1308 foreach f $treediffs($currentid) { | |
| 1309 if [info exists seenfile(f:$f)] { | |
| 1310 $ctext tag conf "f:$f" -elide 0 | |
| 1311 } | |
| 1312 } | |
| 1313 } else { | |
| 1314 # just show selected files | |
| 1315 $ctext tag conf Comments -elide 1 | |
| 1316 set i 1 | |
| 1317 foreach f $treediffs($currentid) { | |
| 1318 set elide [expr {[lsearch -exact $sel $i] < 0}] | |
| 1319 if [info exists seenfile(f:$f)] { | |
| 1320 $ctext tag conf "f:$f" -elide $elide | |
| 1321 } | |
| 1322 incr i | |
| 1323 } | |
| 1324 } | |
| 1325 } | |
| 1326 | |
| 1327 proc setcoords {} { | |
| 1328 global linespc charspc canvx0 canvy0 mainfont | |
| 1329 set linespc [font metrics $mainfont -linespace] | |
| 1330 set charspc [font measure $mainfont "m"] | |
| 1331 set canvy0 [expr 3 + 0.5 * $linespc] | |
| 1332 set canvx0 [expr 3 + 0.5 * $linespc] | |
| 1333 } | |
| 1334 | |
| 1335 proc redisplay {} { | |
| 1336 global selectedline stopped redisplaying phase | |
| 1337 if {$stopped > 1} return | |
| 1338 if {$phase == "getcommits"} return | |
| 1339 set redisplaying 1 | |
| 1340 if {$phase == "drawgraph"} { | |
| 1341 set stopped 1 | |
| 1342 } else { | |
| 1343 drawgraph | |
| 1344 } | |
| 1345 } | |
| 1346 | |
| 1347 proc incrfont {inc} { | |
| 1348 global mainfont namefont textfont selectedline ctext canv phase | |
| 1349 global stopped entries | |
| 1350 unmarkmatches | |
| 1351 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]] | |
| 1352 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]] | |
| 1353 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]] | |
| 1354 setcoords | |
| 1355 $ctext conf -font $textfont | |
| 1356 $ctext tag conf filesep -font [concat $textfont bold] | |
| 1357 foreach e $entries { | |
| 1358 $e conf -font $mainfont | |
| 1359 } | |
| 1360 if {$phase == "getcommits"} { | |
| 1361 $canv itemconf textitems -font $mainfont | |
| 1362 } | |
| 1363 redisplay | |
| 1364 } | |
| 1365 | |
| 1366 proc sha1change {n1 n2 op} { | |
| 1367 global sha1string currentid sha1but | |
| 1368 if {$sha1string == {} | |
| 1369 || ([info exists currentid] && $sha1string == $currentid)} { | |
| 1370 set state disabled | |
| 1371 } else { | |
| 1372 set state normal | |
| 1373 } | |
| 1374 if {[$sha1but cget -state] == $state} return | |
| 1375 if {$state == "normal"} { | |
| 1376 $sha1but conf -state normal -relief raised -text "Goto: " | |
| 1377 } else { | |
| 1378 $sha1but conf -state disabled -relief flat -text "SHA1 ID: " | |
| 1379 } | |
| 1380 } | |
| 1381 | |
| 1382 proc gotocommit {} { | |
| 1383 global sha1string currentid idline tagids | |
| 1384 if {$sha1string == {} | |
| 1385 || ([info exists currentid] && $sha1string == $currentid)} return | |
| 1386 if {[info exists tagids($sha1string)]} { | |
| 1387 set id $tagids($sha1string) | |
| 1388 } else { | |
| 1389 set id [string tolower $sha1string] | |
| 1390 } | |
| 1391 if {[info exists idline($id)]} { | |
| 1392 selectline $idline($id) | |
| 1393 return | |
| 1394 } | |
| 1395 if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} { | |
| 1396 set type "SHA1 id" | |
| 1397 } else { | |
| 1398 set type "Tag" | |
| 1399 } | |
| 1400 error_popup "$type $sha1string is not known" | |
| 1401 } | |
| 1402 | |
| 1403 proc doquit {} { | |
| 1404 global stopped | |
| 1405 set stopped 100 | |
| 1406 destroy . | |
| 1407 } | |
| 1408 | |
| 1409 # defaults... | |
| 1410 set datemode 0 | |
| 1411 set boldnames 0 | |
| 1412 set diffopts "-U 5 -p" | |
| 1413 | |
| 1414 set mainfont {Helvetica 9} | |
| 1415 set textfont {Courier 9} | |
| 1416 | |
| 1417 set colors {green red blue magenta darkgrey brown orange} | |
| 1418 set colorbycommitter false | |
| 1419 | |
| 1420 catch {source ~/.gitk} | |
| 1421 | |
| 1422 set namefont $mainfont | |
| 1423 if {$boldnames} { | |
| 1424 lappend namefont bold | |
| 1425 } | |
| 1426 | |
| 1427 set revtreeargs {} | |
| 1428 foreach arg $argv { | |
| 1429 switch -regexp -- $arg { | |
| 1430 "^$" { } | |
| 1431 "^-b" { set boldnames 1 } | |
| 1432 "^-c" { set colorbycommitter 1 } | |
| 1433 "^-d" { set datemode 1 } | |
| 1434 default { | |
| 1435 lappend revtreeargs $arg | |
| 1436 } | |
| 1437 } | |
| 1438 } | |
| 1439 | |
| 1440 set stopped 0 | |
| 1441 set redisplaying 0 | |
| 1442 set stuffsaved 0 | |
| 1443 setcoords | |
| 1444 makewindow | |
| 1445 readrefs | |
| 1446 readfullcommits $revtreeargs |