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