Mercurial > hg > mercurial-crew-with-dirclash
annotate contrib/hgk @ 978:ea67e5b37043
hgweb: Changed file revision page to list format syntax
author | Josef "Jeff" Sipek <jeffpc@optonline.net> |
---|---|
date | Wed, 17 Aug 2005 22:08:15 -0500 |
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 |