5 # Copyright (C) 2005 Paul Mackerras. All rights reserved. |
5 # Copyright (C) 2005 Paul Mackerras. All rights reserved. |
6 # This program is free software; it may be used, copied, modified |
6 # This program is free software; it may be used, copied, modified |
7 # and distributed under the terms of the GNU General Public Licence, |
7 # and distributed under the terms of the GNU General Public Licence, |
8 # either version 2, or (at your option) any later version. |
8 # either version 2, or (at your option) any later version. |
9 |
9 |
10 # CVS $Revision: 1.20 $ |
10 proc gitdir {} { |
11 |
11 global env |
12 proc readfullcommits {rargs} { |
12 if {[info exists env(GIT_DIR)]} { |
13 global commits commfd phase canv mainfont curcommit allcommitstate |
13 return $env(GIT_DIR) |
14 if {$rargs == {}} { |
14 } else { |
15 set rargs HEAD |
15 return ".hg" |
|
16 } |
|
17 } |
|
18 |
|
19 proc getcommits {rargs} { |
|
20 global commits commfd phase canv mainfont env |
|
21 global startmsecs nextupdate ncmupdate |
|
22 global ctext maincursor textcursor leftover |
|
23 |
|
24 # check that we can find a .git directory somewhere... |
|
25 set gitdir [gitdir] |
|
26 if {![file isdirectory $gitdir]} { |
|
27 error_popup "Cannot find the git directory \"$gitdir\"." |
|
28 exit 1 |
16 } |
29 } |
17 set commits {} |
30 set commits {} |
18 set curcommit {} |
|
19 set allcommitstate none |
|
20 set phase getcommits |
31 set phase getcommits |
21 if [catch {set commfd [open "|hgit rev-list -c $rargs" r]} err] { |
32 set startmsecs [clock clicks -milliseconds] |
22 puts stderr "Error executing hgit rev-list: $err" |
33 set nextupdate [expr $startmsecs + 100] |
|
34 set ncmupdate 1 |
|
35 if [catch { |
|
36 set parse_args [concat --default HEAD $rargs] |
|
37 set parsed_args [split [eval exec hg git-rev-parse $parse_args] "\n"] |
|
38 }] { |
|
39 # if git-rev-parse failed for some reason... |
|
40 if {$rargs == {}} { |
|
41 set rargs HEAD |
|
42 } |
|
43 set parsed_args $rargs |
|
44 } |
|
45 if [catch { |
|
46 set commfd [open "|hg git-rev-list --header --topo-order --parents $parsed_args" r] |
|
47 } err] { |
|
48 puts stderr "Error executing hg git-rev-list: $err" |
23 exit 1 |
49 exit 1 |
24 } |
50 } |
25 fconfigure $commfd -blocking 0 |
51 set leftover {} |
26 fileevent $commfd readable "getallcommitline $commfd" |
52 fconfigure $commfd -blocking 0 -translation lf |
|
53 fileevent $commfd readable [list getcommitlines $commfd] |
27 $canv delete all |
54 $canv delete all |
28 $canv create text 3 3 -anchor nw -text "Reading all commits..." \ |
55 $canv create text 3 3 -anchor nw -text "Reading commits..." \ |
29 -font $mainfont -tags textitems |
56 -font $mainfont -tags textitems |
30 } |
57 . config -cursor watch |
31 |
58 settextcursor watch |
32 proc getcommitline {commfd} { |
59 } |
33 global commits parents cdate nparents children nchildren |
60 |
34 set n [gets $commfd line] |
61 proc getcommitlines {commfd} { |
35 if {$n < 0} { |
62 global commits parents cdate children |
|
63 global commitlisted phase commitinfo nextupdate |
|
64 global stopped redisplaying leftover |
|
65 |
|
66 set stuff [read $commfd] |
|
67 if {$stuff == {}} { |
36 if {![eof $commfd]} return |
68 if {![eof $commfd]} return |
37 # this works around what is apparently a bug in Tcl... |
69 # set it blocking so we wait for the process to terminate |
38 fconfigure $commfd -blocking 1 |
70 fconfigure $commfd -blocking 1 |
39 if {![catch {close $commfd} err]} { |
71 if {![catch {close $commfd} err]} { |
40 after idle readallcommits |
72 after idle finishcommits |
41 return |
73 return |
42 } |
74 } |
43 if {[string range $err 0 4] == "usage"} { |
75 if {[string range $err 0 4] == "usage"} { |
44 set err "\ |
76 set err \ |
45 Gitk: error reading commits: bad arguments to hgit rev-list.\n\ |
77 {Gitk: error reading commits: bad arguments to git-rev-list. |
46 (Note: arguments to gitk are passed to hgit rev-list\ |
78 (Note: arguments to gitk are passed to git-rev-list |
47 to allow selection of commits to be displayed.)" |
79 to allow selection of commits to be displayed.)} |
48 } else { |
80 } else { |
49 set err "Error reading commits: $err" |
81 set err "Error reading commits: $err" |
50 } |
82 } |
51 error_popup $err |
83 error_popup $err |
52 exit 1 |
84 exit 1 |
53 } |
85 } |
54 if {![regexp {^[0-9a-f]{40}$} $line]} { |
86 set start 0 |
55 error_popup "Can't parse hgit rev-tree output: {$line}" |
87 while 1 { |
56 exit 1 |
88 set i [string first "\0" $stuff $start] |
57 } |
89 if {$i < 0} { |
58 lappend commits $line |
90 append leftover [string range $stuff $start end] |
59 } |
91 return |
60 |
92 } |
61 proc readallcommits {} { |
93 set cmit [string range $stuff $start [expr {$i - 1}]] |
62 global commits |
94 if {$start == 0} { |
63 foreach id $commits { |
95 set cmit "$leftover$cmit" |
64 readcommit $id |
96 set leftover {} |
65 update |
97 } |
66 } |
98 set start [expr {$i + 1}] |
67 drawgraph |
99 set j [string first "\n" $cmit] |
68 } |
100 set ok 0 |
69 |
101 if {$j >= 0} { |
70 proc readonecommit {id contents} { |
102 set ids [string range $cmit 0 [expr {$j - 1}]] |
71 global commitinfo children nchildren parents nparents cdate |
103 set ok 1 |
|
104 foreach id $ids { |
|
105 if {![regexp {^[0-9a-f]{40}$} $id]} { |
|
106 set ok 0 |
|
107 break |
|
108 } |
|
109 } |
|
110 } |
|
111 if {!$ok} { |
|
112 set shortcmit $cmit |
|
113 if {[string length $shortcmit] > 80} { |
|
114 set shortcmit "[string range $shortcmit 0 80]..." |
|
115 } |
|
116 error_popup "Can't parse hg git-rev-list output: {$shortcmit}" |
|
117 exit 1 |
|
118 } |
|
119 set id [lindex $ids 0] |
|
120 set olds [lrange $ids 1 end] |
|
121 set cmit [string range $cmit [expr {$j + 1}] end] |
|
122 lappend commits $id |
|
123 set commitlisted($id) 1 |
|
124 parsecommit $id $cmit 1 [lrange $ids 1 end] |
|
125 drawcommit $id |
|
126 if {[clock clicks -milliseconds] >= $nextupdate} { |
|
127 doupdate 1 |
|
128 } |
|
129 while {$redisplaying} { |
|
130 set redisplaying 0 |
|
131 if {$stopped == 1} { |
|
132 set stopped 0 |
|
133 set phase "getcommits" |
|
134 foreach id $commits { |
|
135 drawcommit $id |
|
136 if {$stopped} break |
|
137 if {[clock clicks -milliseconds] >= $nextupdate} { |
|
138 doupdate 1 |
|
139 } |
|
140 } |
|
141 } |
|
142 } |
|
143 } |
|
144 } |
|
145 |
|
146 proc doupdate {reading} { |
|
147 global commfd nextupdate numcommits ncmupdate |
|
148 |
|
149 if {$reading} { |
|
150 fileevent $commfd readable {} |
|
151 } |
|
152 update |
|
153 set nextupdate [expr {[clock clicks -milliseconds] + 100}] |
|
154 if {$numcommits < 100} { |
|
155 set ncmupdate [expr {$numcommits + 1}] |
|
156 } elseif {$numcommits < 10000} { |
|
157 set ncmupdate [expr {$numcommits + 10}] |
|
158 } else { |
|
159 set ncmupdate [expr {$numcommits + 100}] |
|
160 } |
|
161 if {$reading} { |
|
162 fileevent $commfd readable [list getcommitlines $commfd] |
|
163 } |
|
164 } |
|
165 |
|
166 proc readcommit {id} { |
|
167 if [catch {set contents [exec hg git-cat-file commit $id]}] return |
|
168 parsecommit $id $contents 0 {} |
|
169 } |
|
170 |
|
171 proc parsecommit {id contents listed olds} { |
|
172 global commitinfo children nchildren parents nparents cdate ncleft |
|
173 |
72 set inhdr 1 |
174 set inhdr 1 |
73 set comment {} |
175 set comment {} |
74 set headline {} |
176 set headline {} |
75 set auname {} |
177 set auname {} |
76 set audate {} |
178 set audate {} |
77 set comname {} |
179 set comname {} |
78 set comdate {} |
180 set comdate {} |
79 if {![info exists nchildren($id)]} { |
181 if {![info exists nchildren($id)]} { |
80 set children($id) {} |
182 set children($id) {} |
81 set nchildren($id) 0 |
183 set nchildren($id) 0 |
82 } |
184 set ncleft($id) 0 |
83 set parents($id) {} |
185 } |
84 set nparents($id) 0 |
186 set parents($id) $olds |
|
187 set nparents($id) [llength $olds] |
|
188 foreach p $olds { |
|
189 if {![info exists nchildren($p)]} { |
|
190 set children($p) [list $id] |
|
191 set nchildren($p) 1 |
|
192 set ncleft($p) 1 |
|
193 } elseif {[lsearch -exact $children($p) $id] < 0} { |
|
194 lappend children($p) $id |
|
195 incr nchildren($p) |
|
196 incr ncleft($p) |
|
197 } |
|
198 } |
85 foreach line [split $contents "\n"] { |
199 foreach line [split $contents "\n"] { |
86 if {$inhdr} { |
200 if {$inhdr} { |
87 if {$line == {}} { |
201 if {$line == {}} { |
88 set inhdr 0 |
202 set inhdr 0 |
89 } else { |
203 } else { |
90 set tag [lindex $line 0] |
204 set tag [lindex $line 0] |
91 if {$tag == "parent"} { |
205 if {$tag == "author"} { |
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}] |
206 set x [expr {[llength $line] - 2}] |
105 set audate [lindex $line $x] |
207 set audate [lindex $line $x] |
106 set auname [lrange $line 1 [expr {$x - 1}]] |
208 set auname [lrange $line 1 [expr {$x - 1}]] |
107 } elseif {$tag == "committer"} { |
209 } elseif {$tag == "committer"} { |
108 set x [expr {[llength $line] - 2}] |
210 set x [expr {[llength $line] - 2}] |
315 $sha1but conf -disabledforeground [$sha1but cget -foreground] |
355 $sha1but conf -disabledforeground [$sha1but cget -foreground] |
316 pack .ctop.top.bar.sha1label -side left |
356 pack .ctop.top.bar.sha1label -side left |
317 entry $sha1entry -width 40 -font $textfont -textvariable sha1string |
357 entry $sha1entry -width 40 -font $textfont -textvariable sha1string |
318 trace add variable sha1string write sha1change |
358 trace add variable sha1string write sha1change |
319 pack $sha1entry -side left -pady 2 |
359 pack $sha1entry -side left -pady 2 |
|
360 |
|
361 image create bitmap bm-left -data { |
|
362 #define left_width 16 |
|
363 #define left_height 16 |
|
364 static unsigned char left_bits[] = { |
|
365 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00, |
|
366 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00, |
|
367 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01}; |
|
368 } |
|
369 image create bitmap bm-right -data { |
|
370 #define right_width 16 |
|
371 #define right_height 16 |
|
372 static unsigned char right_bits[] = { |
|
373 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c, |
|
374 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c, |
|
375 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01}; |
|
376 } |
|
377 button .ctop.top.bar.leftbut -image bm-left -command goback \ |
|
378 -state disabled -width 26 |
|
379 pack .ctop.top.bar.leftbut -side left -fill y |
|
380 button .ctop.top.bar.rightbut -image bm-right -command goforw \ |
|
381 -state disabled -width 26 |
|
382 pack .ctop.top.bar.rightbut -side left -fill y |
|
383 |
320 button .ctop.top.bar.findbut -text "Find" -command dofind |
384 button .ctop.top.bar.findbut -text "Find" -command dofind |
321 pack .ctop.top.bar.findbut -side left |
385 pack .ctop.top.bar.findbut -side left |
322 set findstring {} |
386 set findstring {} |
323 set fstring .ctop.top.bar.findstring |
387 set fstring .ctop.top.bar.findstring |
324 lappend entries $fstring |
388 lappend entries $fstring |
325 entry $fstring -width 30 -font $textfont -textvariable findstring |
389 entry $fstring -width 30 -font $textfont -textvariable findstring |
326 pack $fstring -side left -expand 1 -fill x |
390 pack $fstring -side left -expand 1 -fill x |
327 set findtype Exact |
391 set findtype Exact |
328 tk_optionMenu .ctop.top.bar.findtype findtype Exact IgnCase Regexp |
392 set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \ |
|
393 findtype Exact IgnCase Regexp] |
329 set findloc "All fields" |
394 set findloc "All fields" |
330 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \ |
395 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \ |
331 Comments Author Committer |
396 Comments Author Committer Files Pickaxe |
332 pack .ctop.top.bar.findloc -side right |
397 pack .ctop.top.bar.findloc -side right |
333 pack .ctop.top.bar.findtype -side right |
398 pack .ctop.top.bar.findtype -side right |
|
399 # for making sure type==Exact whenever loc==Pickaxe |
|
400 trace add variable findloc write findlocchange |
334 |
401 |
335 panedwindow .ctop.cdet -orient horizontal |
402 panedwindow .ctop.cdet -orient horizontal |
336 .ctop add .ctop.cdet |
403 .ctop add .ctop.cdet |
337 frame .ctop.cdet.left |
404 frame .ctop.cdet.left |
338 set ctext .ctop.cdet.left.ctext |
405 set ctext .ctop.cdet.left.ctext |
339 text $ctext -bg white -state disabled -font $textfont \ |
406 text $ctext -bg white -state disabled -font $textfont \ |
340 -width $geometry(ctextw) -height $geometry(ctexth) \ |
407 -width $geometry(ctextw) -height $geometry(ctexth) \ |
341 -yscrollcommand ".ctop.cdet.left.sb set" |
408 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none |
342 scrollbar .ctop.cdet.left.sb -command "$ctext yview" |
409 scrollbar .ctop.cdet.left.sb -command "$ctext yview" |
343 pack .ctop.cdet.left.sb -side right -fill y |
410 pack .ctop.cdet.left.sb -side right -fill y |
344 pack $ctext -side left -fill both -expand 1 |
411 pack $ctext -side left -fill both -expand 1 |
345 .ctop.cdet add .ctop.cdet.left |
412 .ctop.cdet add .ctop.cdet.left |
346 |
413 |
347 $ctext tag conf filesep -font [concat $textfont bold] |
414 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa" |
348 $ctext tag conf hunksep -back blue -fore white |
415 if {$gaudydiff} { |
349 $ctext tag conf d0 -back "#ff8080" |
416 $ctext tag conf hunksep -back blue -fore white |
350 $ctext tag conf d1 -back green |
417 $ctext tag conf d0 -back "#ff8080" |
351 $ctext tag conf found -back yellow |
418 $ctext tag conf d1 -back green |
|
419 } else { |
|
420 $ctext tag conf hunksep -fore blue |
|
421 $ctext tag conf d0 -fore red |
|
422 $ctext tag conf d1 -fore "#00a000" |
|
423 $ctext tag conf m0 -fore red |
|
424 $ctext tag conf m1 -fore blue |
|
425 $ctext tag conf m2 -fore green |
|
426 $ctext tag conf m3 -fore purple |
|
427 $ctext tag conf m4 -fore brown |
|
428 $ctext tag conf mmax -fore darkgrey |
|
429 set mergemax 5 |
|
430 $ctext tag conf mresult -font [concat $textfont bold] |
|
431 $ctext tag conf msep -font [concat $textfont bold] |
|
432 $ctext tag conf found -back yellow |
|
433 } |
352 |
434 |
353 frame .ctop.cdet.right |
435 frame .ctop.cdet.right |
354 set cflist .ctop.cdet.right.cfiles |
436 set cflist .ctop.cdet.right.cfiles |
355 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \ |
437 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \ |
356 -yscrollcommand ".ctop.cdet.right.sb set" |
438 -yscrollcommand ".ctop.cdet.right.sb set" |
598 } |
696 } |
599 } |
697 } |
600 } |
698 } |
601 } |
699 } |
602 if {[llength $badcolors] >= $ncolors} { |
700 if {[llength $badcolors] >= $ncolors} { |
603 set badcolors {} |
701 set badcolors $origbad |
604 } |
702 } |
605 for {set i 0} {$i <= $ncolors} {incr i} { |
703 } |
606 set c [lindex $colors $nextcolor] |
704 for {set i 0} {$i <= $ncolors} {incr i} { |
607 if {[incr nextcolor] >= $ncolors} { |
705 set c [lindex $colors $nextcolor] |
608 set nextcolor 0 |
706 if {[incr nextcolor] >= $ncolors} { |
609 } |
707 set nextcolor 0 |
610 if {[lsearch -exact $badcolors $c]} break |
708 } |
611 } |
709 if {[lsearch -exact $badcolors $c]} break |
612 set colormap($id) $c |
710 } |
613 } |
711 set colormap($id) $c |
614 } |
712 } |
615 |
713 |
616 proc drawgraph {} { |
714 proc initgraph {} { |
617 global parents children nparents nchildren commits |
715 global canvy canvy0 lineno numcommits nextcolor linespc |
618 global canv canv2 canv3 mainfont namefont canvx0 canvy0 canvy linespc |
716 global mainline mainlinearrow sidelines |
619 global datemode cdate |
717 global nchildren ncleft |
620 global lineid linehtag linentag linedtag commitinfo |
718 global displist nhyperspace |
621 global nextcolor colormap numcommits |
|
622 global stopped phase redisplaying selectedline idtags idline |
|
623 |
719 |
624 allcanvs delete all |
720 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 |
721 set nextcolor 0 |
641 foreach id $start { |
722 set canvy $canvy0 |
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 |
723 set lineno -1 |
649 set numcommits 0 |
724 set numcommits 0 |
650 set phase drawgraph |
725 catch {unset mainline} |
651 set lthickness [expr {($linespc / 9) + 1}] |
726 catch {unset mainlinearrow} |
652 while 1 { |
727 catch {unset sidelines} |
653 set canvy $y2 |
728 foreach id [array names nchildren] { |
654 allcanvs conf -scrollregion \ |
729 set ncleft($id) $nchildren($id) |
655 [list 0 0 0 [expr $canvy + 0.5 * $linespc + 2]] |
730 } |
656 update |
731 set displist {} |
657 if {$stopped} break |
732 set nhyperspace 0 |
658 incr numcommits |
733 } |
659 incr lineno |
734 |
660 set nlines [llength $todo] |
735 proc bindline {t id} { |
661 set id [lindex $todo $level] |
736 global canv |
662 set lineid($lineno) $id |
737 |
663 set idline($id) $lineno |
738 $canv bind $t <Enter> "lineenter %x %y $id" |
664 set actualparents {} |
739 $canv bind $t <Motion> "linemotion %x %y $id" |
665 set ofill white |
740 $canv bind $t <Leave> "lineleave $id" |
666 if {[info exists parents($id)]} { |
741 $canv bind $t <Button-1> "lineclick %x %y $id 1" |
667 foreach p $parents($id) { |
742 } |
668 if {[info exists ncleft($p)]} { |
743 |
669 incr ncleft($p) -1 |
744 proc drawlines {id xtra} { |
670 if {![info exists commitinfo($p)]} { |
745 global mainline mainlinearrow sidelines lthickness colormap canv |
671 readcommit $p |
746 |
672 if {![info exists commitinfo($p)]} continue |
747 $canv delete lines.$id |
673 } |
748 if {[info exists mainline($id)]} { |
674 lappend actualparents $p |
749 set t [$canv create line $mainline($id) \ |
675 set ofill blue |
750 -width [expr {($xtra + 1) * $lthickness}] \ |
676 } |
751 -fill $colormap($id) -tags lines.$id \ |
677 } |
752 -arrow $mainlinearrow($id)] |
678 } |
753 $canv lower $t |
|
754 bindline $t $id |
|
755 } |
|
756 if {[info exists sidelines($id)]} { |
|
757 foreach ls $sidelines($id) { |
|
758 set coords [lindex $ls 0] |
|
759 set thick [lindex $ls 1] |
|
760 set arrow [lindex $ls 2] |
|
761 set t [$canv create line $coords -fill $colormap($id) \ |
|
762 -width [expr {($thick + $xtra) * $lthickness}] \ |
|
763 -arrow $arrow -tags lines.$id] |
|
764 $canv lower $t |
|
765 bindline $t $id |
|
766 } |
|
767 } |
|
768 } |
|
769 |
|
770 # level here is an index in displist |
|
771 proc drawcommitline {level} { |
|
772 global parents children nparents displist |
|
773 global canv canv2 canv3 mainfont namefont canvy linespc |
|
774 global lineid linehtag linentag linedtag commitinfo |
|
775 global colormap numcommits currentparents dupparents |
|
776 global idtags idline idheads idotherrefs |
|
777 global lineno lthickness mainline mainlinearrow sidelines |
|
778 global commitlisted rowtextx idpos lastuse displist |
|
779 global oldnlines olddlevel olddisplist |
|
780 |
|
781 incr numcommits |
|
782 incr lineno |
|
783 set id [lindex $displist $level] |
|
784 set lastuse($id) $lineno |
|
785 set lineid($lineno) $id |
|
786 set idline($id) $lineno |
|
787 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}] |
|
788 if {![info exists commitinfo($id)]} { |
|
789 readcommit $id |
679 if {![info exists commitinfo($id)]} { |
790 if {![info exists commitinfo($id)]} { |
680 readcommit $id |
791 set commitinfo($id) {"No commit information available"} |
681 if {![info exists commitinfo($id)]} { |
792 set nparents($id) 0 |
682 set commitinfo($id) {"No commit information available"} |
793 } |
683 } |
794 } |
684 } |
795 assigncolor $id |
685 set x [expr $canvx0 + $level * $linespc] |
796 set currentparents {} |
686 set y2 [expr $canvy + $linespc] |
797 set dupparents {} |
687 if {[info exists linestarty($level)] && $linestarty($level) < $canvy} { |
798 if {[info exists commitlisted($id)] && [info exists parents($id)]} { |
688 set t [$canv create line $x $linestarty($level) $x $canvy \ |
799 foreach p $parents($id) { |
689 -width $lthickness -fill $colormap($id)] |
800 if {[lsearch -exact $currentparents $p] < 0} { |
690 $canv lower $t |
801 lappend currentparents $p |
691 } |
802 } else { |
692 set linestarty($level) $canvy |
803 # remember that this parent was listed twice |
693 set orad [expr {$linespc / 3}] |
804 lappend dupparents $p |
694 set t [$canv create oval [expr $x - $orad] [expr $canvy - $orad] \ |
805 } |
695 [expr $x + $orad - 1] [expr $canvy + $orad - 1] \ |
806 } |
696 -fill $ofill -outline black -width 1] |
807 } |
697 $canv raise $t |
808 set x [xcoord $level $level $lineno] |
698 set xt [expr $canvx0 + $nlines * $linespc] |
809 set y1 $canvy |
699 if {$nparents($id) > 2} { |
810 set canvy [expr $canvy + $linespc] |
700 set xt [expr {$xt + ($nparents($id) - 2) * $linespc}] |
811 allcanvs conf -scrollregion \ |
701 } |
812 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]] |
702 if {[info exists idtags($id)] && $idtags($id) != {}} { |
813 if {[info exists mainline($id)]} { |
703 set delta [expr {int(0.5 * ($linespc - $lthickness))}] |
814 lappend mainline($id) $x $y1 |
704 set yt [expr $canvy - 0.5 * $linespc] |
815 if {$mainlinearrow($id) ne "none"} { |
705 set yb [expr $yt + $linespc - 1] |
816 set mainline($id) [trimdiagstart $mainline($id)] |
706 set xvals {} |
817 } |
707 set wvals {} |
818 } |
708 foreach tag $idtags($id) { |
819 drawlines $id 0 |
709 set wid [font measure $mainfont $tag] |
820 set orad [expr {$linespc / 3}] |
710 lappend xvals $xt |
821 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \ |
711 lappend wvals $wid |
822 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \ |
712 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}] |
823 -fill $ofill -outline black -width 1] |
713 } |
824 $canv raise $t |
714 set t [$canv create line $x $canvy [lindex $xvals end] $canvy \ |
825 $canv bind $t <1> {selcanvline {} %x %y} |
715 -width $lthickness -fill black] |
826 set xt [xcoord [llength $displist] $level $lineno] |
716 $canv lower $t |
827 if {[llength $currentparents] > 2} { |
717 foreach tag $idtags($id) x $xvals wid $wvals { |
828 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}] |
718 set xl [expr $x + $delta] |
829 } |
719 set xr [expr $x + $delta + $wid + $lthickness] |
830 set rowtextx($lineno) $xt |
720 $canv create polygon $x [expr $yt + $delta] $xl $yt\ |
831 set idpos($id) [list $x $xt $y1] |
721 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \ |
832 if {[info exists idtags($id)] || [info exists idheads($id)] |
722 -width 1 -outline black -fill yellow |
833 || [info exists idotherrefs($id)]} { |
723 $canv create text $xl $canvy -anchor w -text $tag \ |
834 set xt [drawtags $id $x $xt $y1] |
724 -font $mainfont |
835 } |
725 } |
836 set headline [lindex $commitinfo($id) 0] |
726 } |
837 set name [lindex $commitinfo($id) 1] |
727 set headline [lindex $commitinfo($id) 0] |
838 set date [lindex $commitinfo($id) 2] |
728 set name [lindex $commitinfo($id) 1] |
839 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \ |
729 set date [lindex $commitinfo($id) 2] |
840 -text $headline -font $mainfont ] |
730 set linehtag($lineno) [$canv create text $xt $canvy -anchor w \ |
841 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id" |
731 -text $headline -font $mainfont ] |
842 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \ |
732 set linentag($lineno) [$canv2 create text 3 $canvy -anchor w \ |
843 -text $name -font $namefont] |
733 -text $name -font $namefont] |
844 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \ |
734 set linedtag($lineno) [$canv3 create text 3 $canvy -anchor w \ |
845 -text $date -font $mainfont] |
735 -text $date -font $mainfont] |
846 |
736 if {!$datemode && [llength $actualparents] == 1} { |
847 set olddlevel $level |
737 set p [lindex $actualparents 0] |
848 set olddisplist $displist |
738 if {$ncleft($p) == 0 && [lsearch -exact $todo $p] < 0} { |
849 set oldnlines [llength $displist] |
739 assigncolor $p |
850 } |
740 set todo [lreplace $todo $level $level $p] |
851 |
741 continue |
852 proc drawtags {id x xt y1} { |
742 } |
853 global idtags idheads idotherrefs |
743 } |
854 global linespc lthickness |
744 |
855 global canv mainfont idline rowtextx |
745 set oldtodo $todo |
856 |
746 set oldlevel $level |
857 set marks {} |
747 set lines {} |
858 set ntags 0 |
748 for {set i 0} {$i < $nlines} {incr i} { |
859 set nheads 0 |
749 if {[lindex $todo $i] == {}} continue |
860 if {[info exists idtags($id)]} { |
750 if {[info exists linestarty($i)]} { |
861 set marks $idtags($id) |
751 set oldstarty($i) $linestarty($i) |
862 set ntags [llength $marks] |
752 unset linestarty($i) |
863 } |
753 } |
864 if {[info exists idheads($id)]} { |
754 if {$i != $level} { |
865 set marks [concat $marks $idheads($id)] |
755 lappend lines [list $i [lindex $todo $i]] |
866 set nheads [llength $idheads($id)] |
756 } |
867 } |
757 } |
868 if {[info exists idotherrefs($id)]} { |
758 if {$nullentry >= 0} { |
869 set marks [concat $marks $idotherrefs($id)] |
759 set todo [lreplace $todo $nullentry $nullentry] |
870 } |
760 if {$nullentry < $level} { |
871 if {$marks eq {}} { |
761 incr level -1 |
872 return $xt |
762 } |
873 } |
763 } |
874 |
764 |
875 set delta [expr {int(0.5 * ($linespc - $lthickness))}] |
765 set todo [lreplace $todo $level $level] |
876 set yt [expr $y1 - 0.5 * $linespc] |
766 if {$nullentry > $level} { |
877 set yb [expr $yt + $linespc - 1] |
767 incr nullentry -1 |
878 set xvals {} |
768 } |
879 set wvals {} |
769 set i $level |
880 foreach tag $marks { |
770 foreach p $actualparents { |
881 set wid [font measure $mainfont $tag] |
771 set k [lsearch -exact $todo $p] |
882 lappend xvals $xt |
772 if {$k < 0} { |
883 lappend wvals $wid |
773 assigncolor $p |
884 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}] |
774 set todo [linsert $todo $i $p] |
885 } |
775 if {$nullentry >= $i} { |
886 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \ |
776 incr nullentry |
887 -width $lthickness -fill black -tags tag.$id] |
777 } |
888 $canv lower $t |
|
889 foreach tag $marks x $xvals wid $wvals { |
|
890 set xl [expr $x + $delta] |
|
891 set xr [expr $x + $delta + $wid + $lthickness] |
|
892 if {[incr ntags -1] >= 0} { |
|
893 # draw a tag |
|
894 set t [$canv create polygon $x [expr $yt + $delta] $xl $yt \ |
|
895 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \ |
|
896 -width 1 -outline black -fill yellow -tags tag.$id] |
|
897 $canv bind $t <1> [list showtag $tag 1] |
|
898 set rowtextx($idline($id)) [expr {$xr + $linespc}] |
|
899 } else { |
|
900 # draw a head or other ref |
|
901 if {[incr nheads -1] >= 0} { |
|
902 set col green |
|
903 } else { |
|
904 set col "#ddddff" |
|
905 } |
|
906 set xl [expr $xl - $delta/2] |
|
907 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \ |
|
908 -width 1 -outline black -fill $col -tags tag.$id |
|
909 } |
|
910 set t [$canv create text $xl $y1 -anchor w -text $tag \ |
|
911 -font $mainfont -tags tag.$id] |
|
912 if {$ntags >= 0} { |
|
913 $canv bind $t <1> [list showtag $tag 1] |
|
914 } |
|
915 } |
|
916 return $xt |
|
917 } |
|
918 |
|
919 proc notecrossings {id lo hi corner} { |
|
920 global olddisplist crossings cornercrossings |
|
921 |
|
922 for {set i $lo} {[incr i] < $hi} {} { |
|
923 set p [lindex $olddisplist $i] |
|
924 if {$p == {}} continue |
|
925 if {$i == $corner} { |
|
926 if {![info exists cornercrossings($id)] |
|
927 || [lsearch -exact $cornercrossings($id) $p] < 0} { |
|
928 lappend cornercrossings($id) $p |
|
929 } |
|
930 if {![info exists cornercrossings($p)] |
|
931 || [lsearch -exact $cornercrossings($p) $id] < 0} { |
|
932 lappend cornercrossings($p) $id |
|
933 } |
|
934 } else { |
|
935 if {![info exists crossings($id)] |
|
936 || [lsearch -exact $crossings($id) $p] < 0} { |
|
937 lappend crossings($id) $p |
|
938 } |
|
939 if {![info exists crossings($p)] |
|
940 || [lsearch -exact $crossings($p) $id] < 0} { |
|
941 lappend crossings($p) $id |
|
942 } |
|
943 } |
|
944 } |
|
945 } |
|
946 |
|
947 proc xcoord {i level ln} { |
|
948 global canvx0 xspc1 xspc2 |
|
949 |
|
950 set x [expr {$canvx0 + $i * $xspc1($ln)}] |
|
951 if {$i > 0 && $i == $level} { |
|
952 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}] |
|
953 } elseif {$i > $level} { |
|
954 set x [expr {$x + $xspc2 - $xspc1($ln)}] |
|
955 } |
|
956 return $x |
|
957 } |
|
958 |
|
959 # it seems Tk can't draw arrows on the end of diagonal line segments... |
|
960 proc trimdiagend {line} { |
|
961 while {[llength $line] > 4} { |
|
962 set x1 [lindex $line end-3] |
|
963 set y1 [lindex $line end-2] |
|
964 set x2 [lindex $line end-1] |
|
965 set y2 [lindex $line end] |
|
966 if {($x1 == $x2) != ($y1 == $y2)} break |
|
967 set line [lreplace $line end-1 end] |
|
968 } |
|
969 return $line |
|
970 } |
|
971 |
|
972 proc trimdiagstart {line} { |
|
973 while {[llength $line] > 4} { |
|
974 set x1 [lindex $line 0] |
|
975 set y1 [lindex $line 1] |
|
976 set x2 [lindex $line 2] |
|
977 set y2 [lindex $line 3] |
|
978 if {($x1 == $x2) != ($y1 == $y2)} break |
|
979 set line [lreplace $line 0 1] |
|
980 } |
|
981 return $line |
|
982 } |
|
983 |
|
984 proc drawslants {id needonscreen nohs} { |
|
985 global canv mainline mainlinearrow sidelines |
|
986 global canvx0 canvy xspc1 xspc2 lthickness |
|
987 global currentparents dupparents |
|
988 global lthickness linespc canvy colormap lineno geometry |
|
989 global maxgraphpct maxwidth |
|
990 global displist onscreen lastuse |
|
991 global parents commitlisted |
|
992 global oldnlines olddlevel olddisplist |
|
993 global nhyperspace numcommits nnewparents |
|
994 |
|
995 if {$lineno < 0} { |
|
996 lappend displist $id |
|
997 set onscreen($id) 1 |
|
998 return 0 |
|
999 } |
|
1000 |
|
1001 set y1 [expr {$canvy - $linespc}] |
|
1002 set y2 $canvy |
|
1003 |
|
1004 # work out what we need to get back on screen |
|
1005 set reins {} |
|
1006 if {$onscreen($id) < 0} { |
|
1007 # next to do isn't displayed, better get it on screen... |
|
1008 lappend reins [list $id 0] |
|
1009 } |
|
1010 # make sure all the previous commits's parents are on the screen |
|
1011 foreach p $currentparents { |
|
1012 if {$onscreen($p) < 0} { |
|
1013 lappend reins [list $p 0] |
|
1014 } |
|
1015 } |
|
1016 # bring back anything requested by caller |
|
1017 if {$needonscreen ne {}} { |
|
1018 lappend reins $needonscreen |
|
1019 } |
|
1020 |
|
1021 # try the shortcut |
|
1022 if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} { |
|
1023 set dlevel $olddlevel |
|
1024 set x [xcoord $dlevel $dlevel $lineno] |
|
1025 set mainline($id) [list $x $y1] |
|
1026 set mainlinearrow($id) none |
|
1027 set lastuse($id) $lineno |
|
1028 set displist [lreplace $displist $dlevel $dlevel $id] |
|
1029 set onscreen($id) 1 |
|
1030 set xspc1([expr {$lineno + 1}]) $xspc1($lineno) |
|
1031 return $dlevel |
|
1032 } |
|
1033 |
|
1034 # update displist |
|
1035 set displist [lreplace $displist $olddlevel $olddlevel] |
|
1036 set j $olddlevel |
|
1037 foreach p $currentparents { |
|
1038 set lastuse($p) $lineno |
|
1039 if {$onscreen($p) == 0} { |
|
1040 set displist [linsert $displist $j $p] |
|
1041 set onscreen($p) 1 |
|
1042 incr j |
|
1043 } |
|
1044 } |
|
1045 if {$onscreen($id) == 0} { |
|
1046 lappend displist $id |
|
1047 set onscreen($id) 1 |
|
1048 } |
|
1049 |
|
1050 # remove the null entry if present |
|
1051 set nullentry [lsearch -exact $displist {}] |
|
1052 if {$nullentry >= 0} { |
|
1053 set displist [lreplace $displist $nullentry $nullentry] |
|
1054 } |
|
1055 |
|
1056 # bring back the ones we need now (if we did it earlier |
|
1057 # it would change displist and invalidate olddlevel) |
|
1058 foreach pi $reins { |
|
1059 # test again in case of duplicates in reins |
|
1060 set p [lindex $pi 0] |
|
1061 if {$onscreen($p) < 0} { |
|
1062 set onscreen($p) 1 |
|
1063 set lastuse($p) $lineno |
|
1064 set displist [linsert $displist [lindex $pi 1] $p] |
|
1065 incr nhyperspace -1 |
|
1066 } |
|
1067 } |
|
1068 |
|
1069 set lastuse($id) $lineno |
|
1070 |
|
1071 # see if we need to make any lines jump off into hyperspace |
|
1072 set displ [llength $displist] |
|
1073 if {$displ > $maxwidth} { |
|
1074 set ages {} |
|
1075 foreach x $displist { |
|
1076 lappend ages [list $lastuse($x) $x] |
|
1077 } |
|
1078 set ages [lsort -integer -index 0 $ages] |
|
1079 set k 0 |
|
1080 while {$displ > $maxwidth} { |
|
1081 set use [lindex $ages $k 0] |
|
1082 set victim [lindex $ages $k 1] |
|
1083 if {$use >= $lineno - 5} break |
|
1084 incr k |
|
1085 if {[lsearch -exact $nohs $victim] >= 0} continue |
|
1086 set i [lsearch -exact $displist $victim] |
|
1087 set displist [lreplace $displist $i $i] |
|
1088 set onscreen($victim) -1 |
|
1089 incr nhyperspace |
|
1090 incr displ -1 |
|
1091 if {$i < $nullentry} { |
|
1092 incr nullentry -1 |
|
1093 } |
|
1094 set x [lindex $mainline($victim) end-1] |
|
1095 lappend mainline($victim) $x $y1 |
|
1096 set line [trimdiagend $mainline($victim)] |
|
1097 set arrow "last" |
|
1098 if {$mainlinearrow($victim) ne "none"} { |
|
1099 set line [trimdiagstart $line] |
|
1100 set arrow "both" |
|
1101 } |
|
1102 lappend sidelines($victim) [list $line 1 $arrow] |
|
1103 unset mainline($victim) |
|
1104 } |
|
1105 } |
|
1106 |
|
1107 set dlevel [lsearch -exact $displist $id] |
|
1108 |
|
1109 # If we are reducing, put in a null entry |
|
1110 if {$displ < $oldnlines} { |
|
1111 # does the next line look like a merge? |
|
1112 # i.e. does it have > 1 new parent? |
|
1113 if {$nnewparents($id) > 1} { |
|
1114 set i [expr {$dlevel + 1}] |
|
1115 } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} { |
|
1116 set i $olddlevel |
|
1117 if {$nullentry >= 0 && $nullentry < $i} { |
|
1118 incr i -1 |
|
1119 } |
|
1120 } elseif {$nullentry >= 0} { |
|
1121 set i $nullentry |
|
1122 while {$i < $displ |
|
1123 && [lindex $olddisplist $i] == [lindex $displist $i]} { |
778 incr i |
1124 incr i |
779 } |
1125 } |
780 lappend lines [list $oldlevel $p] |
1126 } else { |
781 } |
1127 set i $olddlevel |
782 |
1128 if {$dlevel >= $i} { |
783 # choose which one to do next time around |
1129 incr i |
784 set todol [llength $todo] |
1130 } |
785 set level -1 |
1131 } |
786 set latest {} |
1132 if {$i < $displ} { |
787 for {set k $todol} {[incr k -1] >= 0} {} { |
1133 set displist [linsert $displist $i {}] |
788 set p [lindex $todo $k] |
1134 incr displ |
789 if {$p == {}} continue |
1135 if {$dlevel >= $i} { |
790 if {$ncleft($p) == 0} { |
1136 incr dlevel |
791 if {$datemode} { |
1137 } |
792 if {$latest == {} || $cdate($p) > $latest} { |
1138 } |
793 set level $k |
1139 } |
794 set latest $cdate($p) |
1140 |
|
1141 # decide on the line spacing for the next line |
|
1142 set lj [expr {$lineno + 1}] |
|
1143 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}] |
|
1144 if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} { |
|
1145 set xspc1($lj) $xspc2 |
|
1146 } else { |
|
1147 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}] |
|
1148 if {$xspc1($lj) < $lthickness} { |
|
1149 set xspc1($lj) $lthickness |
|
1150 } |
|
1151 } |
|
1152 |
|
1153 foreach idi $reins { |
|
1154 set id [lindex $idi 0] |
|
1155 set j [lsearch -exact $displist $id] |
|
1156 set xj [xcoord $j $dlevel $lj] |
|
1157 set mainline($id) [list $xj $y2] |
|
1158 set mainlinearrow($id) first |
|
1159 } |
|
1160 |
|
1161 set i -1 |
|
1162 foreach id $olddisplist { |
|
1163 incr i |
|
1164 if {$id == {}} continue |
|
1165 if {$onscreen($id) <= 0} continue |
|
1166 set xi [xcoord $i $olddlevel $lineno] |
|
1167 if {$i == $olddlevel} { |
|
1168 foreach p $currentparents { |
|
1169 set j [lsearch -exact $displist $p] |
|
1170 set coords [list $xi $y1] |
|
1171 set xj [xcoord $j $dlevel $lj] |
|
1172 if {$xj < $xi - $linespc} { |
|
1173 lappend coords [expr {$xj + $linespc}] $y1 |
|
1174 notecrossings $p $j $i [expr {$j + 1}] |
|
1175 } elseif {$xj > $xi + $linespc} { |
|
1176 lappend coords [expr {$xj - $linespc}] $y1 |
|
1177 notecrossings $p $i $j [expr {$j - 1}] |
|
1178 } |
|
1179 if {[lsearch -exact $dupparents $p] >= 0} { |
|
1180 # draw a double-width line to indicate the doubled parent |
|
1181 lappend coords $xj $y2 |
|
1182 lappend sidelines($p) [list $coords 2 none] |
|
1183 if {![info exists mainline($p)]} { |
|
1184 set mainline($p) [list $xj $y2] |
|
1185 set mainlinearrow($p) none |
795 } |
1186 } |
796 } else { |
1187 } else { |
|
1188 # normal case, no parent duplicated |
|
1189 set yb $y2 |
|
1190 set dx [expr {abs($xi - $xj)}] |
|
1191 if {0 && $dx < $linespc} { |
|
1192 set yb [expr {$y1 + $dx}] |
|
1193 } |
|
1194 if {![info exists mainline($p)]} { |
|
1195 if {$xi != $xj} { |
|
1196 lappend coords $xj $yb |
|
1197 } |
|
1198 set mainline($p) $coords |
|
1199 set mainlinearrow($p) none |
|
1200 } else { |
|
1201 lappend coords $xj $yb |
|
1202 if {$yb < $y2} { |
|
1203 lappend coords $xj $y2 |
|
1204 } |
|
1205 lappend sidelines($p) [list $coords 1 none] |
|
1206 } |
|
1207 } |
|
1208 } |
|
1209 } else { |
|
1210 set j $i |
|
1211 if {[lindex $displist $i] != $id} { |
|
1212 set j [lsearch -exact $displist $id] |
|
1213 } |
|
1214 if {$j != $i || $xspc1($lineno) != $xspc1($lj) |
|
1215 || ($olddlevel < $i && $i < $dlevel) |
|
1216 || ($dlevel < $i && $i < $olddlevel)} { |
|
1217 set xj [xcoord $j $dlevel $lj] |
|
1218 lappend mainline($id) $xi $y1 $xj $y2 |
|
1219 } |
|
1220 } |
|
1221 } |
|
1222 return $dlevel |
|
1223 } |
|
1224 |
|
1225 # search for x in a list of lists |
|
1226 proc llsearch {llist x} { |
|
1227 set i 0 |
|
1228 foreach l $llist { |
|
1229 if {$l == $x || [lsearch -exact $l $x] >= 0} { |
|
1230 return $i |
|
1231 } |
|
1232 incr i |
|
1233 } |
|
1234 return -1 |
|
1235 } |
|
1236 |
|
1237 proc drawmore {reading} { |
|
1238 global displayorder numcommits ncmupdate nextupdate |
|
1239 global stopped nhyperspace parents commitlisted |
|
1240 global maxwidth onscreen displist currentparents olddlevel |
|
1241 |
|
1242 set n [llength $displayorder] |
|
1243 while {$numcommits < $n} { |
|
1244 set id [lindex $displayorder $numcommits] |
|
1245 set ctxend [expr {$numcommits + 10}] |
|
1246 if {!$reading && $ctxend > $n} { |
|
1247 set ctxend $n |
|
1248 } |
|
1249 set dlist {} |
|
1250 if {$numcommits > 0} { |
|
1251 set dlist [lreplace $displist $olddlevel $olddlevel] |
|
1252 set i $olddlevel |
|
1253 foreach p $currentparents { |
|
1254 if {$onscreen($p) == 0} { |
|
1255 set dlist [linsert $dlist $i $p] |
|
1256 incr i |
|
1257 } |
|
1258 } |
|
1259 } |
|
1260 set nohs {} |
|
1261 set reins {} |
|
1262 set isfat [expr {[llength $dlist] > $maxwidth}] |
|
1263 if {$nhyperspace > 0 || $isfat} { |
|
1264 if {$ctxend > $n} break |
|
1265 # work out what to bring back and |
|
1266 # what we want to don't want to send into hyperspace |
|
1267 set room 1 |
|
1268 for {set k $numcommits} {$k < $ctxend} {incr k} { |
|
1269 set x [lindex $displayorder $k] |
|
1270 set i [llsearch $dlist $x] |
|
1271 if {$i < 0} { |
|
1272 set i [llength $dlist] |
|
1273 lappend dlist $x |
|
1274 } |
|
1275 if {[lsearch -exact $nohs $x] < 0} { |
|
1276 lappend nohs $x |
|
1277 } |
|
1278 if {$reins eq {} && $onscreen($x) < 0 && $room} { |
|
1279 set reins [list $x $i] |
|
1280 } |
|
1281 set newp {} |
|
1282 if {[info exists commitlisted($x)]} { |
|
1283 set right 0 |
|
1284 foreach p $parents($x) { |
|
1285 if {[llsearch $dlist $p] < 0} { |
|
1286 lappend newp $p |
|
1287 if {[lsearch -exact $nohs $p] < 0} { |
|
1288 lappend nohs $p |
|
1289 } |
|
1290 if {$reins eq {} && $onscreen($p) < 0 && $room} { |
|
1291 set reins [list $p [expr {$i + $right}]] |
|
1292 } |
|
1293 } |
|
1294 set right 1 |
|
1295 } |
|
1296 } |
|
1297 set l [lindex $dlist $i] |
|
1298 if {[llength $l] == 1} { |
|
1299 set l $newp |
|
1300 } else { |
|
1301 set j [lsearch -exact $l $x] |
|
1302 set l [concat [lreplace $l $j $j] $newp] |
|
1303 } |
|
1304 set dlist [lreplace $dlist $i $i $l] |
|
1305 if {$room && $isfat && [llength $newp] <= 1} { |
|
1306 set room 0 |
|
1307 } |
|
1308 } |
|
1309 } |
|
1310 |
|
1311 set dlevel [drawslants $id $reins $nohs] |
|
1312 drawcommitline $dlevel |
|
1313 if {[clock clicks -milliseconds] >= $nextupdate |
|
1314 && $numcommits >= $ncmupdate} { |
|
1315 doupdate $reading |
|
1316 if {$stopped} break |
|
1317 } |
|
1318 } |
|
1319 } |
|
1320 |
|
1321 # level here is an index in todo |
|
1322 proc updatetodo {level noshortcut} { |
|
1323 global ncleft todo nnewparents |
|
1324 global commitlisted parents onscreen |
|
1325 |
|
1326 set id [lindex $todo $level] |
|
1327 set olds {} |
|
1328 if {[info exists commitlisted($id)]} { |
|
1329 foreach p $parents($id) { |
|
1330 if {[lsearch -exact $olds $p] < 0} { |
|
1331 lappend olds $p |
|
1332 } |
|
1333 } |
|
1334 } |
|
1335 if {!$noshortcut && [llength $olds] == 1} { |
|
1336 set p [lindex $olds 0] |
|
1337 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} { |
|
1338 set ncleft($p) 0 |
|
1339 set todo [lreplace $todo $level $level $p] |
|
1340 set onscreen($p) 0 |
|
1341 set nnewparents($id) 1 |
|
1342 return 0 |
|
1343 } |
|
1344 } |
|
1345 |
|
1346 set todo [lreplace $todo $level $level] |
|
1347 set i $level |
|
1348 set n 0 |
|
1349 foreach p $olds { |
|
1350 incr ncleft($p) -1 |
|
1351 set k [lsearch -exact $todo $p] |
|
1352 if {$k < 0} { |
|
1353 set todo [linsert $todo $i $p] |
|
1354 set onscreen($p) 0 |
|
1355 incr i |
|
1356 incr n |
|
1357 } |
|
1358 } |
|
1359 set nnewparents($id) $n |
|
1360 |
|
1361 return 1 |
|
1362 } |
|
1363 |
|
1364 proc decidenext {{noread 0}} { |
|
1365 global ncleft todo |
|
1366 global datemode cdate |
|
1367 global commitinfo |
|
1368 |
|
1369 # choose which one to do next time around |
|
1370 set todol [llength $todo] |
|
1371 set level -1 |
|
1372 set latest {} |
|
1373 for {set k $todol} {[incr k -1] >= 0} {} { |
|
1374 set p [lindex $todo $k] |
|
1375 if {$ncleft($p) == 0} { |
|
1376 if {$datemode} { |
|
1377 if {![info exists commitinfo($p)]} { |
|
1378 if {$noread} { |
|
1379 return {} |
|
1380 } |
|
1381 readcommit $p |
|
1382 } |
|
1383 if {$latest == {} || $cdate($p) > $latest} { |
797 set level $k |
1384 set level $k |
798 break |
1385 set latest $cdate($p) |
799 } |
1386 } |
800 } |
1387 } else { |
801 } |
1388 set level $k |
802 if {$level < 0} { |
1389 break |
803 if {$todo != {}} { |
1390 } |
804 puts "ERROR: none of the pending commits can be done yet:" |
1391 } |
805 foreach p $todo { |
1392 } |
806 puts " $p" |
1393 if {$level < 0} { |
807 } |
1394 if {$todo != {}} { |
808 } |
1395 puts "ERROR: none of the pending commits can be done yet:" |
|
1396 foreach p $todo { |
|
1397 puts " $p ($ncleft($p))" |
|
1398 } |
|
1399 } |
|
1400 return -1 |
|
1401 } |
|
1402 |
|
1403 return $level |
|
1404 } |
|
1405 |
|
1406 proc drawcommit {id} { |
|
1407 global phase todo nchildren datemode nextupdate |
|
1408 global numcommits ncmupdate displayorder todo onscreen |
|
1409 |
|
1410 if {$phase != "incrdraw"} { |
|
1411 set phase incrdraw |
|
1412 set displayorder {} |
|
1413 set todo {} |
|
1414 initgraph |
|
1415 } |
|
1416 if {$nchildren($id) == 0} { |
|
1417 lappend todo $id |
|
1418 set onscreen($id) 0 |
|
1419 } |
|
1420 set level [decidenext 1] |
|
1421 if {$level == {} || $id != [lindex $todo $level]} { |
|
1422 return |
|
1423 } |
|
1424 while 1 { |
|
1425 lappend displayorder [lindex $todo $level] |
|
1426 if {[updatetodo $level $datemode]} { |
|
1427 set level [decidenext 1] |
|
1428 if {$level == {}} break |
|
1429 } |
|
1430 set id [lindex $todo $level] |
|
1431 if {![info exists commitlisted($id)]} { |
809 break |
1432 break |
810 } |
1433 } |
811 |
1434 } |
812 # If we are reducing, put in a null entry |
1435 drawmore 1 |
813 if {$todol < $nlines} { |
1436 } |
814 if {$nullentry >= 0} { |
1437 |
815 set i $nullentry |
1438 proc finishcommits {} { |
816 while {$i < $todol |
1439 global phase |
817 && [lindex $oldtodo $i] == [lindex $todo $i]} { |
1440 global canv mainfont ctext maincursor textcursor |
818 incr i |
1441 |
819 } |
1442 if {$phase != "incrdraw"} { |
820 } else { |
1443 $canv delete all |
821 set i $oldlevel |
1444 $canv create text 3 3 -anchor nw -text "No commits selected" \ |
822 if {$level >= $i} { |
1445 -font $mainfont -tags textitems |
823 incr i |
1446 set phase {} |
824 } |
1447 } else { |
825 } |
1448 drawrest |
826 if {$i >= $todol} { |
1449 } |
827 set nullentry -1 |
1450 . config -cursor $maincursor |
828 } else { |
1451 settextcursor $textcursor |
829 set nullentry $i |
1452 } |
830 set todo [linsert $todo $nullentry {}] |
1453 |
831 if {$level >= $i} { |
1454 # Don't change the text pane cursor if it is currently the hand cursor, |
832 incr level |
1455 # showing that we are over a sha1 ID link. |
833 } |
1456 proc settextcursor {c} { |
834 } |
1457 global ctext curtextcursor |
835 } else { |
1458 |
836 set nullentry -1 |
1459 if {[$ctext cget -cursor] == $curtextcursor} { |
837 } |
1460 $ctext config -cursor $c |
838 |
1461 } |
839 foreach l $lines { |
1462 set curtextcursor $c |
840 set i [lindex $l 0] |
1463 } |
841 set dst [lindex $l 1] |
1464 |
842 set j [lsearch -exact $todo $dst] |
1465 proc drawgraph {} { |
843 if {$i == $j} { |
1466 global nextupdate startmsecs ncmupdate |
844 if {[info exists oldstarty($i)]} { |
1467 global displayorder onscreen |
845 set linestarty($i) $oldstarty($i) |
1468 |
846 } |
1469 if {$displayorder == {}} return |
847 continue |
1470 set startmsecs [clock clicks -milliseconds] |
848 } |
1471 set nextupdate [expr $startmsecs + 100] |
849 set xi [expr {$canvx0 + $i * $linespc}] |
1472 set ncmupdate 1 |
850 set xj [expr {$canvx0 + $j * $linespc}] |
1473 initgraph |
851 set coords {} |
1474 foreach id $displayorder { |
852 if {[info exists oldstarty($i)] && $oldstarty($i) < $canvy} { |
1475 set onscreen($id) 0 |
853 lappend coords $xi $oldstarty($i) |
1476 } |
854 } |
1477 drawmore 0 |
855 lappend coords $xi $canvy |
1478 } |
856 if {$j < $i - 1} { |
1479 |
857 lappend coords [expr $xj + $linespc] $canvy |
1480 proc drawrest {} { |
858 } elseif {$j > $i + 1} { |
1481 global phase stopped redisplaying selectedline |
859 lappend coords [expr $xj - $linespc] $canvy |
1482 global datemode todo displayorder |
860 } |
1483 global numcommits ncmupdate |
861 lappend coords $xj $y2 |
1484 global nextupdate startmsecs |
862 set t [$canv create line $coords -width $lthickness \ |
1485 |
863 -fill $colormap($dst)] |
1486 set level [decidenext] |
864 $canv lower $t |
1487 if {$level >= 0} { |
865 if {![info exists linestarty($j)]} { |
1488 set phase drawgraph |
866 set linestarty($j) $y2 |
1489 while 1 { |
867 } |
1490 lappend displayorder [lindex $todo $level] |
868 } |
1491 set hard [updatetodo $level $datemode] |
|
1492 if {$hard} { |
|
1493 set level [decidenext] |
|
1494 if {$level < 0} break |
|
1495 } |
|
1496 } |
|
1497 drawmore 0 |
869 } |
1498 } |
870 set phase {} |
1499 set phase {} |
|
1500 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs] |
|
1501 #puts "overall $drawmsecs ms for $numcommits commits" |
871 if {$redisplaying} { |
1502 if {$redisplaying} { |
872 if {$stopped == 0 && [info exists selectedline]} { |
1503 if {$stopped == 0 && [info exists selectedline]} { |
873 selectline $selectedline |
1504 selectline $selectedline 0 |
874 } |
1505 } |
875 if {$stopped == 1} { |
1506 if {$stopped == 1} { |
876 set stopped 0 |
1507 set stopped 0 |
877 after idle drawgraph |
1508 after idle drawgraph |
878 } else { |
1509 } else { |
1005 } else { |
1648 } else { |
1006 bell |
1649 bell |
1007 } |
1650 } |
1008 } |
1651 } |
1009 |
1652 |
|
1653 proc findlocchange {name ix op} { |
|
1654 global findloc findtype findtypemenu |
|
1655 if {$findloc == "Pickaxe"} { |
|
1656 set findtype Exact |
|
1657 set state disabled |
|
1658 } else { |
|
1659 set state normal |
|
1660 } |
|
1661 $findtypemenu entryconf 1 -state $state |
|
1662 $findtypemenu entryconf 2 -state $state |
|
1663 } |
|
1664 |
|
1665 proc stopfindproc {{done 0}} { |
|
1666 global findprocpid findprocfile findids |
|
1667 global ctext findoldcursor phase maincursor textcursor |
|
1668 global findinprogress |
|
1669 |
|
1670 catch {unset findids} |
|
1671 if {[info exists findprocpid]} { |
|
1672 if {!$done} { |
|
1673 catch {exec kill $findprocpid} |
|
1674 } |
|
1675 catch {close $findprocfile} |
|
1676 unset findprocpid |
|
1677 } |
|
1678 if {[info exists findinprogress]} { |
|
1679 unset findinprogress |
|
1680 if {$phase != "incrdraw"} { |
|
1681 . config -cursor $maincursor |
|
1682 settextcursor $textcursor |
|
1683 } |
|
1684 } |
|
1685 } |
|
1686 |
|
1687 proc findpatches {} { |
|
1688 global findstring selectedline numcommits |
|
1689 global findprocpid findprocfile |
|
1690 global finddidsel ctext lineid findinprogress |
|
1691 global findinsertpos |
|
1692 |
|
1693 if {$numcommits == 0} return |
|
1694 |
|
1695 # make a list of all the ids to search, starting at the one |
|
1696 # after the selected line (if any) |
|
1697 if {[info exists selectedline]} { |
|
1698 set l $selectedline |
|
1699 } else { |
|
1700 set l -1 |
|
1701 } |
|
1702 set inputids {} |
|
1703 for {set i 0} {$i < $numcommits} {incr i} { |
|
1704 if {[incr l] >= $numcommits} { |
|
1705 set l 0 |
|
1706 } |
|
1707 append inputids $lineid($l) "\n" |
|
1708 } |
|
1709 |
|
1710 if {[catch { |
|
1711 set f [open [list | hg git-diff-tree --stdin -s -r -S$findstring \ |
|
1712 << $inputids] r] |
|
1713 } err]} { |
|
1714 error_popup "Error starting search process: $err" |
|
1715 return |
|
1716 } |
|
1717 |
|
1718 set findinsertpos end |
|
1719 set findprocfile $f |
|
1720 set findprocpid [pid $f] |
|
1721 fconfigure $f -blocking 0 |
|
1722 fileevent $f readable readfindproc |
|
1723 set finddidsel 0 |
|
1724 . config -cursor watch |
|
1725 settextcursor watch |
|
1726 set findinprogress 1 |
|
1727 } |
|
1728 |
|
1729 proc readfindproc {} { |
|
1730 global findprocfile finddidsel |
|
1731 global idline matchinglines findinsertpos |
|
1732 |
|
1733 set n [gets $findprocfile line] |
|
1734 if {$n < 0} { |
|
1735 if {[eof $findprocfile]} { |
|
1736 stopfindproc 1 |
|
1737 if {!$finddidsel} { |
|
1738 bell |
|
1739 } |
|
1740 } |
|
1741 return |
|
1742 } |
|
1743 if {![regexp {^[0-9a-f]{40}} $line id]} { |
|
1744 error_popup "Can't parse git-diff-tree output: $line" |
|
1745 stopfindproc |
|
1746 return |
|
1747 } |
|
1748 if {![info exists idline($id)]} { |
|
1749 puts stderr "spurious id: $id" |
|
1750 return |
|
1751 } |
|
1752 set l $idline($id) |
|
1753 insertmatch $l $id |
|
1754 } |
|
1755 |
|
1756 proc insertmatch {l id} { |
|
1757 global matchinglines findinsertpos finddidsel |
|
1758 |
|
1759 if {$findinsertpos == "end"} { |
|
1760 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} { |
|
1761 set matchinglines [linsert $matchinglines 0 $l] |
|
1762 set findinsertpos 1 |
|
1763 } else { |
|
1764 lappend matchinglines $l |
|
1765 } |
|
1766 } else { |
|
1767 set matchinglines [linsert $matchinglines $findinsertpos $l] |
|
1768 incr findinsertpos |
|
1769 } |
|
1770 markheadline $l $id |
|
1771 if {!$finddidsel} { |
|
1772 findselectline $l |
|
1773 set finddidsel 1 |
|
1774 } |
|
1775 } |
|
1776 |
|
1777 proc findfiles {} { |
|
1778 global selectedline numcommits lineid ctext |
|
1779 global ffileline finddidsel parents nparents |
|
1780 global findinprogress findstartline findinsertpos |
|
1781 global treediffs fdiffids fdiffsneeded fdiffpos |
|
1782 global findmergefiles |
|
1783 |
|
1784 if {$numcommits == 0} return |
|
1785 |
|
1786 if {[info exists selectedline]} { |
|
1787 set l [expr {$selectedline + 1}] |
|
1788 } else { |
|
1789 set l 0 |
|
1790 } |
|
1791 set ffileline $l |
|
1792 set findstartline $l |
|
1793 set diffsneeded {} |
|
1794 set fdiffsneeded {} |
|
1795 while 1 { |
|
1796 set id $lineid($l) |
|
1797 if {$findmergefiles || $nparents($id) == 1} { |
|
1798 foreach p $parents($id) { |
|
1799 if {![info exists treediffs([list $id $p])]} { |
|
1800 append diffsneeded "$id $p\n" |
|
1801 lappend fdiffsneeded [list $id $p] |
|
1802 } |
|
1803 } |
|
1804 } |
|
1805 if {[incr l] >= $numcommits} { |
|
1806 set l 0 |
|
1807 } |
|
1808 if {$l == $findstartline} break |
|
1809 } |
|
1810 |
|
1811 # start off a git-diff-tree process if needed |
|
1812 if {$diffsneeded ne {}} { |
|
1813 if {[catch { |
|
1814 set df [open [list | hg git-diff-tree -r --stdin << $diffsneeded] r] |
|
1815 } err ]} { |
|
1816 error_popup "Error starting search process: $err" |
|
1817 return |
|
1818 } |
|
1819 catch {unset fdiffids} |
|
1820 set fdiffpos 0 |
|
1821 fconfigure $df -blocking 0 |
|
1822 fileevent $df readable [list readfilediffs $df] |
|
1823 } |
|
1824 |
|
1825 set finddidsel 0 |
|
1826 set findinsertpos end |
|
1827 set id $lineid($l) |
|
1828 set p [lindex $parents($id) 0] |
|
1829 . config -cursor watch |
|
1830 settextcursor watch |
|
1831 set findinprogress 1 |
|
1832 findcont [list $id $p] |
|
1833 update |
|
1834 } |
|
1835 |
|
1836 proc readfilediffs {df} { |
|
1837 global findids fdiffids fdiffs |
|
1838 |
|
1839 set n [gets $df line] |
|
1840 if {$n < 0} { |
|
1841 if {[eof $df]} { |
|
1842 donefilediff |
|
1843 if {[catch {close $df} err]} { |
|
1844 stopfindproc |
|
1845 bell |
|
1846 error_popup "Error in hg git-diff-tree: $err" |
|
1847 } elseif {[info exists findids]} { |
|
1848 set ids $findids |
|
1849 stopfindproc |
|
1850 bell |
|
1851 error_popup "Couldn't find diffs for {$ids}" |
|
1852 } |
|
1853 } |
|
1854 return |
|
1855 } |
|
1856 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} { |
|
1857 # start of a new string of diffs |
|
1858 donefilediff |
|
1859 set fdiffids [list $id $p] |
|
1860 set fdiffs {} |
|
1861 } elseif {[string match ":*" $line]} { |
|
1862 lappend fdiffs [lindex $line 5] |
|
1863 } |
|
1864 } |
|
1865 |
|
1866 proc donefilediff {} { |
|
1867 global fdiffids fdiffs treediffs findids |
|
1868 global fdiffsneeded fdiffpos |
|
1869 |
|
1870 if {[info exists fdiffids]} { |
|
1871 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids |
|
1872 && $fdiffpos < [llength $fdiffsneeded]} { |
|
1873 # git-diff-tree doesn't output anything for a commit |
|
1874 # which doesn't change anything |
|
1875 set nullids [lindex $fdiffsneeded $fdiffpos] |
|
1876 set treediffs($nullids) {} |
|
1877 if {[info exists findids] && $nullids eq $findids} { |
|
1878 unset findids |
|
1879 findcont $nullids |
|
1880 } |
|
1881 incr fdiffpos |
|
1882 } |
|
1883 incr fdiffpos |
|
1884 |
|
1885 if {![info exists treediffs($fdiffids)]} { |
|
1886 set treediffs($fdiffids) $fdiffs |
|
1887 } |
|
1888 if {[info exists findids] && $fdiffids eq $findids} { |
|
1889 unset findids |
|
1890 findcont $fdiffids |
|
1891 } |
|
1892 } |
|
1893 } |
|
1894 |
|
1895 proc findcont {ids} { |
|
1896 global findids treediffs parents nparents |
|
1897 global ffileline findstartline finddidsel |
|
1898 global lineid numcommits matchinglines findinprogress |
|
1899 global findmergefiles |
|
1900 |
|
1901 set id [lindex $ids 0] |
|
1902 set p [lindex $ids 1] |
|
1903 set pi [lsearch -exact $parents($id) $p] |
|
1904 set l $ffileline |
|
1905 while 1 { |
|
1906 if {$findmergefiles || $nparents($id) == 1} { |
|
1907 if {![info exists treediffs($ids)]} { |
|
1908 set findids $ids |
|
1909 set ffileline $l |
|
1910 return |
|
1911 } |
|
1912 set doesmatch 0 |
|
1913 foreach f $treediffs($ids) { |
|
1914 set x [findmatches $f] |
|
1915 if {$x != {}} { |
|
1916 set doesmatch 1 |
|
1917 break |
|
1918 } |
|
1919 } |
|
1920 if {$doesmatch} { |
|
1921 insertmatch $l $id |
|
1922 set pi $nparents($id) |
|
1923 } |
|
1924 } else { |
|
1925 set pi $nparents($id) |
|
1926 } |
|
1927 if {[incr pi] >= $nparents($id)} { |
|
1928 set pi 0 |
|
1929 if {[incr l] >= $numcommits} { |
|
1930 set l 0 |
|
1931 } |
|
1932 if {$l == $findstartline} break |
|
1933 set id $lineid($l) |
|
1934 } |
|
1935 set p [lindex $parents($id) $pi] |
|
1936 set ids [list $id $p] |
|
1937 } |
|
1938 stopfindproc |
|
1939 if {!$finddidsel} { |
|
1940 bell |
|
1941 } |
|
1942 } |
|
1943 |
|
1944 # mark a commit as matching by putting a yellow background |
|
1945 # behind the headline |
|
1946 proc markheadline {l id} { |
|
1947 global canv mainfont linehtag commitinfo |
|
1948 |
|
1949 set bbox [$canv bbox $linehtag($l)] |
|
1950 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow] |
|
1951 $canv lower $t |
|
1952 } |
|
1953 |
|
1954 # mark the bits of a headline, author or date that match a find string |
1010 proc markmatches {canv l str tag matches font} { |
1955 proc markmatches {canv l str tag matches font} { |
1011 set bbox [$canv bbox $tag] |
1956 set bbox [$canv bbox $tag] |
1012 set x0 [lindex $bbox 0] |
1957 set x0 [lindex $bbox 0] |
1013 set y0 [lindex $bbox 1] |
1958 set y0 [lindex $bbox 1] |
1014 set y1 [lindex $bbox 3] |
1959 set y1 [lindex $bbox 3] |
1108 $sha1entry selection from 0 |
2098 $sha1entry selection from 0 |
1109 $sha1entry selection to end |
2099 $sha1entry selection to end |
1110 |
2100 |
1111 $ctext conf -state normal |
2101 $ctext conf -state normal |
1112 $ctext delete 0.0 end |
2102 $ctext delete 0.0 end |
|
2103 set linknum 0 |
|
2104 $ctext mark set fmark.0 0.0 |
|
2105 $ctext mark gravity fmark.0 left |
1113 set info $commitinfo($id) |
2106 set info $commitinfo($id) |
1114 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n" |
2107 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n" |
1115 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n" |
2108 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n" |
1116 if {[info exists idtags($id)]} { |
2109 if {[info exists idtags($id)]} { |
1117 $ctext insert end "Tags:" |
2110 $ctext insert end "Tags:" |
1118 foreach tag $idtags($id) { |
2111 foreach tag $idtags($id) { |
1119 $ctext insert end " $tag" |
2112 $ctext insert end " $tag" |
1120 } |
2113 } |
1121 $ctext insert end "\n" |
2114 $ctext insert end "\n" |
1122 } |
2115 } |
1123 $ctext insert end "\n" |
2116 |
1124 $ctext insert end [lindex $info 5] |
2117 set comment {} |
1125 $ctext insert end "\n" |
2118 if {[info exists parents($id)]} { |
|
2119 foreach p $parents($id) { |
|
2120 append comment "Parent: [commit_descriptor $p]\n" |
|
2121 } |
|
2122 } |
|
2123 if {[info exists children($id)]} { |
|
2124 foreach c $children($id) { |
|
2125 append comment "Child: [commit_descriptor $c]\n" |
|
2126 } |
|
2127 } |
|
2128 append comment "\n" |
|
2129 append comment [lindex $info 5] |
|
2130 |
|
2131 # make anything that looks like a SHA1 ID be a clickable link |
|
2132 appendwithlinks $comment |
|
2133 |
1126 $ctext tag delete Comments |
2134 $ctext tag delete Comments |
1127 $ctext tag remove found 1.0 end |
2135 $ctext tag remove found 1.0 end |
1128 $ctext conf -state disabled |
2136 $ctext conf -state disabled |
1129 set commentend [$ctext index "end - 1c"] |
2137 set commentend [$ctext index "end - 1c"] |
1130 |
2138 |
1131 $cflist delete 0 end |
2139 $cflist delete 0 end |
|
2140 $cflist insert end "Comments" |
1132 if {$nparents($id) == 1} { |
2141 if {$nparents($id) == 1} { |
1133 if {![info exists treediffs($id)]} { |
2142 startdiff [concat $id $parents($id)] |
1134 if {![info exists treepending]} { |
2143 } elseif {$nparents($id) > 1} { |
1135 gettreediffs $id |
2144 mergediff $id |
1136 } |
2145 } |
1137 } else { |
|
1138 addtocflist $id |
|
1139 } |
|
1140 } |
|
1141 catch {unset seenfile} |
|
1142 } |
2146 } |
1143 |
2147 |
1144 proc selnextline {dir} { |
2148 proc selnextline {dir} { |
1145 global selectedline |
2149 global selectedline |
1146 if {![info exists selectedline]} return |
2150 if {![info exists selectedline]} return |
1147 set l [expr $selectedline + $dir] |
2151 set l [expr $selectedline + $dir] |
1148 unmarkmatches |
2152 unmarkmatches |
1149 selectline $l |
2153 selectline $l 1 |
1150 } |
2154 } |
1151 |
2155 |
1152 proc addtocflist {id} { |
2156 proc unselectline {} { |
1153 global currentid treediffs cflist treepending |
2157 global selectedline |
1154 if {$id != $currentid} { |
2158 |
1155 gettreediffs $currentid |
2159 catch {unset selectedline} |
|
2160 allcanvs delete secsel |
|
2161 } |
|
2162 |
|
2163 proc addtohistory {cmd} { |
|
2164 global history historyindex |
|
2165 |
|
2166 if {$historyindex > 0 |
|
2167 && [lindex $history [expr {$historyindex - 1}]] == $cmd} { |
1156 return |
2168 return |
1157 } |
2169 } |
1158 $cflist insert end "All files" |
2170 |
1159 foreach f $treediffs($currentid) { |
2171 if {$historyindex < [llength $history]} { |
|
2172 set history [lreplace $history $historyindex end $cmd] |
|
2173 } else { |
|
2174 lappend history $cmd |
|
2175 } |
|
2176 incr historyindex |
|
2177 if {$historyindex > 1} { |
|
2178 .ctop.top.bar.leftbut conf -state normal |
|
2179 } else { |
|
2180 .ctop.top.bar.leftbut conf -state disabled |
|
2181 } |
|
2182 .ctop.top.bar.rightbut conf -state disabled |
|
2183 } |
|
2184 |
|
2185 proc goback {} { |
|
2186 global history historyindex |
|
2187 |
|
2188 if {$historyindex > 1} { |
|
2189 incr historyindex -1 |
|
2190 set cmd [lindex $history [expr {$historyindex - 1}]] |
|
2191 eval $cmd |
|
2192 .ctop.top.bar.rightbut conf -state normal |
|
2193 } |
|
2194 if {$historyindex <= 1} { |
|
2195 .ctop.top.bar.leftbut conf -state disabled |
|
2196 } |
|
2197 } |
|
2198 |
|
2199 proc goforw {} { |
|
2200 global history historyindex |
|
2201 |
|
2202 if {$historyindex < [llength $history]} { |
|
2203 set cmd [lindex $history $historyindex] |
|
2204 incr historyindex |
|
2205 eval $cmd |
|
2206 .ctop.top.bar.leftbut conf -state normal |
|
2207 } |
|
2208 if {$historyindex >= [llength $history]} { |
|
2209 .ctop.top.bar.rightbut conf -state disabled |
|
2210 } |
|
2211 } |
|
2212 |
|
2213 proc mergediff {id} { |
|
2214 global parents diffmergeid diffmergegca mergefilelist diffpindex |
|
2215 |
|
2216 set diffmergeid $id |
|
2217 set diffpindex -1 |
|
2218 set diffmergegca [findgca $parents($id)] |
|
2219 if {[info exists mergefilelist($id)]} { |
|
2220 if {$mergefilelist($id) ne {}} { |
|
2221 showmergediff |
|
2222 } |
|
2223 } else { |
|
2224 contmergediff {} |
|
2225 } |
|
2226 } |
|
2227 |
|
2228 proc findgca {ids} { |
|
2229 set gca {} |
|
2230 foreach id $ids { |
|
2231 if {$gca eq {}} { |
|
2232 set gca $id |
|
2233 } else { |
|
2234 if {[catch { |
|
2235 set gca [exec hg git-merge-base $gca $id] |
|
2236 } err]} { |
|
2237 return {} |
|
2238 } |
|
2239 } |
|
2240 } |
|
2241 return $gca |
|
2242 } |
|
2243 |
|
2244 proc contmergediff {ids} { |
|
2245 global diffmergeid diffpindex parents nparents diffmergegca |
|
2246 global treediffs mergefilelist diffids treepending |
|
2247 |
|
2248 # diff the child against each of the parents, and diff |
|
2249 # each of the parents against the GCA. |
|
2250 while 1 { |
|
2251 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} { |
|
2252 set ids [list [lindex $ids 1] $diffmergegca] |
|
2253 } else { |
|
2254 if {[incr diffpindex] >= $nparents($diffmergeid)} break |
|
2255 set p [lindex $parents($diffmergeid) $diffpindex] |
|
2256 set ids [list $diffmergeid $p] |
|
2257 } |
|
2258 if {![info exists treediffs($ids)]} { |
|
2259 set diffids $ids |
|
2260 if {![info exists treepending]} { |
|
2261 gettreediffs $ids |
|
2262 } |
|
2263 return |
|
2264 } |
|
2265 } |
|
2266 |
|
2267 # If a file in some parent is different from the child and also |
|
2268 # different from the GCA, then it's interesting. |
|
2269 # If we don't have a GCA, then a file is interesting if it is |
|
2270 # different from the child in all the parents. |
|
2271 if {$diffmergegca ne {}} { |
|
2272 set files {} |
|
2273 foreach p $parents($diffmergeid) { |
|
2274 set gcadiffs $treediffs([list $p $diffmergegca]) |
|
2275 foreach f $treediffs([list $diffmergeid $p]) { |
|
2276 if {[lsearch -exact $files $f] < 0 |
|
2277 && [lsearch -exact $gcadiffs $f] >= 0} { |
|
2278 lappend files $f |
|
2279 } |
|
2280 } |
|
2281 } |
|
2282 set files [lsort $files] |
|
2283 } else { |
|
2284 set p [lindex $parents($diffmergeid) 0] |
|
2285 set files $treediffs([list $diffmergeid $p]) |
|
2286 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} { |
|
2287 set p [lindex $parents($diffmergeid) $i] |
|
2288 set df $treediffs([list $diffmergeid $p]) |
|
2289 set nf {} |
|
2290 foreach f $files { |
|
2291 if {[lsearch -exact $df $f] >= 0} { |
|
2292 lappend nf $f |
|
2293 } |
|
2294 } |
|
2295 set files $nf |
|
2296 } |
|
2297 } |
|
2298 |
|
2299 set mergefilelist($diffmergeid) $files |
|
2300 if {$files ne {}} { |
|
2301 showmergediff |
|
2302 } |
|
2303 } |
|
2304 |
|
2305 proc showmergediff {} { |
|
2306 global cflist diffmergeid mergefilelist parents |
|
2307 global diffopts diffinhunk currentfile currenthunk filelines |
|
2308 global diffblocked groupfilelast mergefds groupfilenum grouphunks |
|
2309 |
|
2310 set files $mergefilelist($diffmergeid) |
|
2311 foreach f $files { |
1160 $cflist insert end $f |
2312 $cflist insert end $f |
1161 } |
2313 } |
1162 getblobdiffs $id |
2314 set env(GIT_DIFF_OPTS) $diffopts |
1163 } |
2315 set flist {} |
1164 |
2316 catch {unset currentfile} |
1165 proc gettreediffs {id} { |
2317 catch {unset currenthunk} |
1166 global treediffs parents treepending |
2318 catch {unset filelines} |
1167 set treepending $id |
2319 catch {unset groupfilenum} |
1168 set treediffs($id) {} |
2320 catch {unset grouphunks} |
1169 set p [lindex $parents($id) 0] |
2321 set groupfilelast -1 |
1170 if [catch {set gdtf [open "|hgit diff-tree -r $p $id" r]}] return |
2322 foreach p $parents($diffmergeid) { |
|
2323 set cmd [list | hg git-diff-tree -p $p $diffmergeid] |
|
2324 set cmd [concat $cmd $mergefilelist($diffmergeid)] |
|
2325 if {[catch {set f [open $cmd r]} err]} { |
|
2326 error_popup "Error getting diffs: $err" |
|
2327 foreach f $flist { |
|
2328 catch {close $f} |
|
2329 } |
|
2330 return |
|
2331 } |
|
2332 lappend flist $f |
|
2333 set ids [list $diffmergeid $p] |
|
2334 set mergefds($ids) $f |
|
2335 set diffinhunk($ids) 0 |
|
2336 set diffblocked($ids) 0 |
|
2337 fconfigure $f -blocking 0 |
|
2338 fileevent $f readable [list getmergediffline $f $ids $diffmergeid] |
|
2339 } |
|
2340 } |
|
2341 |
|
2342 proc getmergediffline {f ids id} { |
|
2343 global diffmergeid diffinhunk diffoldlines diffnewlines |
|
2344 global currentfile currenthunk |
|
2345 global diffoldstart diffnewstart diffoldlno diffnewlno |
|
2346 global diffblocked mergefilelist |
|
2347 global noldlines nnewlines difflcounts filelines |
|
2348 |
|
2349 set n [gets $f line] |
|
2350 if {$n < 0} { |
|
2351 if {![eof $f]} return |
|
2352 } |
|
2353 |
|
2354 if {!([info exists diffmergeid] && $diffmergeid == $id)} { |
|
2355 if {$n < 0} { |
|
2356 close $f |
|
2357 } |
|
2358 return |
|
2359 } |
|
2360 |
|
2361 if {$diffinhunk($ids) != 0} { |
|
2362 set fi $currentfile($ids) |
|
2363 if {$n > 0 && [regexp {^[-+ \\]} $line match]} { |
|
2364 # continuing an existing hunk |
|
2365 set line [string range $line 1 end] |
|
2366 set p [lindex $ids 1] |
|
2367 if {$match eq "-" || $match eq " "} { |
|
2368 set filelines($p,$fi,$diffoldlno($ids)) $line |
|
2369 incr diffoldlno($ids) |
|
2370 } |
|
2371 if {$match eq "+" || $match eq " "} { |
|
2372 set filelines($id,$fi,$diffnewlno($ids)) $line |
|
2373 incr diffnewlno($ids) |
|
2374 } |
|
2375 if {$match eq " "} { |
|
2376 if {$diffinhunk($ids) == 2} { |
|
2377 lappend difflcounts($ids) \ |
|
2378 [list $noldlines($ids) $nnewlines($ids)] |
|
2379 set noldlines($ids) 0 |
|
2380 set diffinhunk($ids) 1 |
|
2381 } |
|
2382 incr noldlines($ids) |
|
2383 } elseif {$match eq "-" || $match eq "+"} { |
|
2384 if {$diffinhunk($ids) == 1} { |
|
2385 lappend difflcounts($ids) [list $noldlines($ids)] |
|
2386 set noldlines($ids) 0 |
|
2387 set nnewlines($ids) 0 |
|
2388 set diffinhunk($ids) 2 |
|
2389 } |
|
2390 if {$match eq "-"} { |
|
2391 incr noldlines($ids) |
|
2392 } else { |
|
2393 incr nnewlines($ids) |
|
2394 } |
|
2395 } |
|
2396 # and if it's \ No newline at end of line, then what? |
|
2397 return |
|
2398 } |
|
2399 # end of a hunk |
|
2400 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} { |
|
2401 lappend difflcounts($ids) [list $noldlines($ids)] |
|
2402 } elseif {$diffinhunk($ids) == 2 |
|
2403 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} { |
|
2404 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)] |
|
2405 } |
|
2406 set currenthunk($ids) [list $currentfile($ids) \ |
|
2407 $diffoldstart($ids) $diffnewstart($ids) \ |
|
2408 $diffoldlno($ids) $diffnewlno($ids) \ |
|
2409 $difflcounts($ids)] |
|
2410 set diffinhunk($ids) 0 |
|
2411 # -1 = need to block, 0 = unblocked, 1 = is blocked |
|
2412 set diffblocked($ids) -1 |
|
2413 processhunks |
|
2414 if {$diffblocked($ids) == -1} { |
|
2415 fileevent $f readable {} |
|
2416 set diffblocked($ids) 1 |
|
2417 } |
|
2418 } |
|
2419 |
|
2420 if {$n < 0} { |
|
2421 # eof |
|
2422 if {!$diffblocked($ids)} { |
|
2423 close $f |
|
2424 set currentfile($ids) [llength $mergefilelist($diffmergeid)] |
|
2425 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}] |
|
2426 processhunks |
|
2427 } |
|
2428 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} { |
|
2429 # start of a new file |
|
2430 set currentfile($ids) \ |
|
2431 [lsearch -exact $mergefilelist($diffmergeid) $fname] |
|
2432 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \ |
|
2433 $line match f1l f1c f2l f2c rest]} { |
|
2434 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} { |
|
2435 # start of a new hunk |
|
2436 if {$f1l == 0 && $f1c == 0} { |
|
2437 set f1l 1 |
|
2438 } |
|
2439 if {$f2l == 0 && $f2c == 0} { |
|
2440 set f2l 1 |
|
2441 } |
|
2442 set diffinhunk($ids) 1 |
|
2443 set diffoldstart($ids) $f1l |
|
2444 set diffnewstart($ids) $f2l |
|
2445 set diffoldlno($ids) $f1l |
|
2446 set diffnewlno($ids) $f2l |
|
2447 set difflcounts($ids) {} |
|
2448 set noldlines($ids) 0 |
|
2449 set nnewlines($ids) 0 |
|
2450 } |
|
2451 } |
|
2452 } |
|
2453 |
|
2454 proc processhunks {} { |
|
2455 global diffmergeid parents nparents currenthunk |
|
2456 global mergefilelist diffblocked mergefds |
|
2457 global grouphunks grouplinestart grouplineend groupfilenum |
|
2458 |
|
2459 set nfiles [llength $mergefilelist($diffmergeid)] |
|
2460 while 1 { |
|
2461 set fi $nfiles |
|
2462 set lno 0 |
|
2463 # look for the earliest hunk |
|
2464 foreach p $parents($diffmergeid) { |
|
2465 set ids [list $diffmergeid $p] |
|
2466 if {![info exists currenthunk($ids)]} return |
|
2467 set i [lindex $currenthunk($ids) 0] |
|
2468 set l [lindex $currenthunk($ids) 2] |
|
2469 if {$i < $fi || ($i == $fi && $l < $lno)} { |
|
2470 set fi $i |
|
2471 set lno $l |
|
2472 set pi $p |
|
2473 } |
|
2474 } |
|
2475 |
|
2476 if {$fi < $nfiles} { |
|
2477 set ids [list $diffmergeid $pi] |
|
2478 set hunk $currenthunk($ids) |
|
2479 unset currenthunk($ids) |
|
2480 if {$diffblocked($ids) > 0} { |
|
2481 fileevent $mergefds($ids) readable \ |
|
2482 [list getmergediffline $mergefds($ids) $ids $diffmergeid] |
|
2483 } |
|
2484 set diffblocked($ids) 0 |
|
2485 |
|
2486 if {[info exists groupfilenum] && $groupfilenum == $fi |
|
2487 && $lno <= $grouplineend} { |
|
2488 # add this hunk to the pending group |
|
2489 lappend grouphunks($pi) $hunk |
|
2490 set endln [lindex $hunk 4] |
|
2491 if {$endln > $grouplineend} { |
|
2492 set grouplineend $endln |
|
2493 } |
|
2494 continue |
|
2495 } |
|
2496 } |
|
2497 |
|
2498 # succeeding stuff doesn't belong in this group, so |
|
2499 # process the group now |
|
2500 if {[info exists groupfilenum]} { |
|
2501 processgroup |
|
2502 unset groupfilenum |
|
2503 unset grouphunks |
|
2504 } |
|
2505 |
|
2506 if {$fi >= $nfiles} break |
|
2507 |
|
2508 # start a new group |
|
2509 set groupfilenum $fi |
|
2510 set grouphunks($pi) [list $hunk] |
|
2511 set grouplinestart $lno |
|
2512 set grouplineend [lindex $hunk 4] |
|
2513 } |
|
2514 } |
|
2515 |
|
2516 proc processgroup {} { |
|
2517 global groupfilelast groupfilenum difffilestart |
|
2518 global mergefilelist diffmergeid ctext filelines |
|
2519 global parents diffmergeid diffoffset |
|
2520 global grouphunks grouplinestart grouplineend nparents |
|
2521 global mergemax |
|
2522 |
|
2523 $ctext conf -state normal |
|
2524 set id $diffmergeid |
|
2525 set f $groupfilenum |
|
2526 if {$groupfilelast != $f} { |
|
2527 $ctext insert end "\n" |
|
2528 set here [$ctext index "end - 1c"] |
|
2529 set difffilestart($f) $here |
|
2530 set mark fmark.[expr {$f + 1}] |
|
2531 $ctext mark set $mark $here |
|
2532 $ctext mark gravity $mark left |
|
2533 set header [lindex $mergefilelist($id) $f] |
|
2534 set l [expr {(78 - [string length $header]) / 2}] |
|
2535 set pad [string range "----------------------------------------" 1 $l] |
|
2536 $ctext insert end "$pad $header $pad\n" filesep |
|
2537 set groupfilelast $f |
|
2538 foreach p $parents($id) { |
|
2539 set diffoffset($p) 0 |
|
2540 } |
|
2541 } |
|
2542 |
|
2543 $ctext insert end "@@" msep |
|
2544 set nlines [expr {$grouplineend - $grouplinestart}] |
|
2545 set events {} |
|
2546 set pnum 0 |
|
2547 foreach p $parents($id) { |
|
2548 set startline [expr {$grouplinestart + $diffoffset($p)}] |
|
2549 set ol $startline |
|
2550 set nl $grouplinestart |
|
2551 if {[info exists grouphunks($p)]} { |
|
2552 foreach h $grouphunks($p) { |
|
2553 set l [lindex $h 2] |
|
2554 if {$nl < $l} { |
|
2555 for {} {$nl < $l} {incr nl} { |
|
2556 set filelines($p,$f,$ol) $filelines($id,$f,$nl) |
|
2557 incr ol |
|
2558 } |
|
2559 } |
|
2560 foreach chunk [lindex $h 5] { |
|
2561 if {[llength $chunk] == 2} { |
|
2562 set olc [lindex $chunk 0] |
|
2563 set nlc [lindex $chunk 1] |
|
2564 set nnl [expr {$nl + $nlc}] |
|
2565 lappend events [list $nl $nnl $pnum $olc $nlc] |
|
2566 incr ol $olc |
|
2567 set nl $nnl |
|
2568 } else { |
|
2569 incr ol [lindex $chunk 0] |
|
2570 incr nl [lindex $chunk 0] |
|
2571 } |
|
2572 } |
|
2573 } |
|
2574 } |
|
2575 if {$nl < $grouplineend} { |
|
2576 for {} {$nl < $grouplineend} {incr nl} { |
|
2577 set filelines($p,$f,$ol) $filelines($id,$f,$nl) |
|
2578 incr ol |
|
2579 } |
|
2580 } |
|
2581 set nlines [expr {$ol - $startline}] |
|
2582 $ctext insert end " -$startline,$nlines" msep |
|
2583 incr pnum |
|
2584 } |
|
2585 |
|
2586 set nlines [expr {$grouplineend - $grouplinestart}] |
|
2587 $ctext insert end " +$grouplinestart,$nlines @@\n" msep |
|
2588 |
|
2589 set events [lsort -integer -index 0 $events] |
|
2590 set nevents [llength $events] |
|
2591 set nmerge $nparents($diffmergeid) |
|
2592 set l $grouplinestart |
|
2593 for {set i 0} {$i < $nevents} {set i $j} { |
|
2594 set nl [lindex $events $i 0] |
|
2595 while {$l < $nl} { |
|
2596 $ctext insert end " $filelines($id,$f,$l)\n" |
|
2597 incr l |
|
2598 } |
|
2599 set e [lindex $events $i] |
|
2600 set enl [lindex $e 1] |
|
2601 set j $i |
|
2602 set active {} |
|
2603 while 1 { |
|
2604 set pnum [lindex $e 2] |
|
2605 set olc [lindex $e 3] |
|
2606 set nlc [lindex $e 4] |
|
2607 if {![info exists delta($pnum)]} { |
|
2608 set delta($pnum) [expr {$olc - $nlc}] |
|
2609 lappend active $pnum |
|
2610 } else { |
|
2611 incr delta($pnum) [expr {$olc - $nlc}] |
|
2612 } |
|
2613 if {[incr j] >= $nevents} break |
|
2614 set e [lindex $events $j] |
|
2615 if {[lindex $e 0] >= $enl} break |
|
2616 if {[lindex $e 1] > $enl} { |
|
2617 set enl [lindex $e 1] |
|
2618 } |
|
2619 } |
|
2620 set nlc [expr {$enl - $l}] |
|
2621 set ncol mresult |
|
2622 set bestpn -1 |
|
2623 if {[llength $active] == $nmerge - 1} { |
|
2624 # no diff for one of the parents, i.e. it's identical |
|
2625 for {set pnum 0} {$pnum < $nmerge} {incr pnum} { |
|
2626 if {![info exists delta($pnum)]} { |
|
2627 if {$pnum < $mergemax} { |
|
2628 lappend ncol m$pnum |
|
2629 } else { |
|
2630 lappend ncol mmax |
|
2631 } |
|
2632 break |
|
2633 } |
|
2634 } |
|
2635 } elseif {[llength $active] == $nmerge} { |
|
2636 # all parents are different, see if one is very similar |
|
2637 set bestsim 30 |
|
2638 for {set pnum 0} {$pnum < $nmerge} {incr pnum} { |
|
2639 set sim [similarity $pnum $l $nlc $f \ |
|
2640 [lrange $events $i [expr {$j-1}]]] |
|
2641 if {$sim > $bestsim} { |
|
2642 set bestsim $sim |
|
2643 set bestpn $pnum |
|
2644 } |
|
2645 } |
|
2646 if {$bestpn >= 0} { |
|
2647 lappend ncol m$bestpn |
|
2648 } |
|
2649 } |
|
2650 set pnum -1 |
|
2651 foreach p $parents($id) { |
|
2652 incr pnum |
|
2653 if {![info exists delta($pnum)] || $pnum == $bestpn} continue |
|
2654 set olc [expr {$nlc + $delta($pnum)}] |
|
2655 set ol [expr {$l + $diffoffset($p)}] |
|
2656 incr diffoffset($p) $delta($pnum) |
|
2657 unset delta($pnum) |
|
2658 for {} {$olc > 0} {incr olc -1} { |
|
2659 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum |
|
2660 incr ol |
|
2661 } |
|
2662 } |
|
2663 set endl [expr {$l + $nlc}] |
|
2664 if {$bestpn >= 0} { |
|
2665 # show this pretty much as a normal diff |
|
2666 set p [lindex $parents($id) $bestpn] |
|
2667 set ol [expr {$l + $diffoffset($p)}] |
|
2668 incr diffoffset($p) $delta($bestpn) |
|
2669 unset delta($bestpn) |
|
2670 for {set k $i} {$k < $j} {incr k} { |
|
2671 set e [lindex $events $k] |
|
2672 if {[lindex $e 2] != $bestpn} continue |
|
2673 set nl [lindex $e 0] |
|
2674 set ol [expr {$ol + $nl - $l}] |
|
2675 for {} {$l < $nl} {incr l} { |
|
2676 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol |
|
2677 } |
|
2678 set c [lindex $e 3] |
|
2679 for {} {$c > 0} {incr c -1} { |
|
2680 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn |
|
2681 incr ol |
|
2682 } |
|
2683 set nl [lindex $e 1] |
|
2684 for {} {$l < $nl} {incr l} { |
|
2685 $ctext insert end "+$filelines($id,$f,$l)\n" mresult |
|
2686 } |
|
2687 } |
|
2688 } |
|
2689 for {} {$l < $endl} {incr l} { |
|
2690 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol |
|
2691 } |
|
2692 } |
|
2693 while {$l < $grouplineend} { |
|
2694 $ctext insert end " $filelines($id,$f,$l)\n" |
|
2695 incr l |
|
2696 } |
|
2697 $ctext conf -state disabled |
|
2698 } |
|
2699 |
|
2700 proc similarity {pnum l nlc f events} { |
|
2701 global diffmergeid parents diffoffset filelines |
|
2702 |
|
2703 set id $diffmergeid |
|
2704 set p [lindex $parents($id) $pnum] |
|
2705 set ol [expr {$l + $diffoffset($p)}] |
|
2706 set endl [expr {$l + $nlc}] |
|
2707 set same 0 |
|
2708 set diff 0 |
|
2709 foreach e $events { |
|
2710 if {[lindex $e 2] != $pnum} continue |
|
2711 set nl [lindex $e 0] |
|
2712 set ol [expr {$ol + $nl - $l}] |
|
2713 for {} {$l < $nl} {incr l} { |
|
2714 incr same [string length $filelines($id,$f,$l)] |
|
2715 incr same |
|
2716 } |
|
2717 set oc [lindex $e 3] |
|
2718 for {} {$oc > 0} {incr oc -1} { |
|
2719 incr diff [string length $filelines($p,$f,$ol)] |
|
2720 incr diff |
|
2721 incr ol |
|
2722 } |
|
2723 set nl [lindex $e 1] |
|
2724 for {} {$l < $nl} {incr l} { |
|
2725 incr diff [string length $filelines($id,$f,$l)] |
|
2726 incr diff |
|
2727 } |
|
2728 } |
|
2729 for {} {$l < $endl} {incr l} { |
|
2730 incr same [string length $filelines($id,$f,$l)] |
|
2731 incr same |
|
2732 } |
|
2733 if {$same == 0} { |
|
2734 return 0 |
|
2735 } |
|
2736 return [expr {200 * $same / (2 * $same + $diff)}] |
|
2737 } |
|
2738 |
|
2739 proc startdiff {ids} { |
|
2740 global treediffs diffids treepending diffmergeid |
|
2741 |
|
2742 set diffids $ids |
|
2743 catch {unset diffmergeid} |
|
2744 if {![info exists treediffs($ids)]} { |
|
2745 if {![info exists treepending]} { |
|
2746 gettreediffs $ids |
|
2747 } |
|
2748 } else { |
|
2749 addtocflist $ids |
|
2750 } |
|
2751 } |
|
2752 |
|
2753 proc addtocflist {ids} { |
|
2754 global treediffs cflist |
|
2755 foreach f $treediffs($ids) { |
|
2756 $cflist insert end $f |
|
2757 } |
|
2758 getblobdiffs $ids |
|
2759 } |
|
2760 |
|
2761 proc gettreediffs {ids} { |
|
2762 global treediff parents treepending |
|
2763 set treepending $ids |
|
2764 set treediff {} |
|
2765 set id [lindex $ids 0] |
|
2766 set p [lindex $ids 1] |
|
2767 if [catch {set gdtf [open "|hg git-diff-tree -r $p $id" r]}] return |
1171 fconfigure $gdtf -blocking 0 |
2768 fconfigure $gdtf -blocking 0 |
1172 fileevent $gdtf readable "gettreediffline $gdtf $id" |
2769 fileevent $gdtf readable [list gettreediffline $gdtf $ids] |
1173 } |
2770 } |
1174 |
2771 |
1175 proc gettreediffline {gdtf id} { |
2772 proc gettreediffline {gdtf ids} { |
1176 global treediffs treepending |
2773 global treediff treediffs treepending diffids diffmergeid |
|
2774 |
1177 set n [gets $gdtf line] |
2775 set n [gets $gdtf line] |
1178 if {$n < 0} { |
2776 if {$n < 0} { |
1179 if {![eof $gdtf]} return |
2777 if {![eof $gdtf]} return |
1180 close $gdtf |
2778 close $gdtf |
|
2779 set treediffs($ids) $treediff |
1181 unset treepending |
2780 unset treepending |
1182 addtocflist $id |
2781 if {$ids != $diffids} { |
|
2782 gettreediffs $diffids |
|
2783 } else { |
|
2784 if {[info exists diffmergeid]} { |
|
2785 contmergediff $ids |
|
2786 } else { |
|
2787 addtocflist $ids |
|
2788 } |
|
2789 } |
1183 return |
2790 return |
1184 } |
2791 } |
1185 set file [lindex $line 5] |
2792 set file [lindex $line 5] |
1186 lappend treediffs($id) $file |
2793 lappend treediff $file |
1187 } |
2794 } |
1188 |
2795 |
1189 proc getblobdiffs {id} { |
2796 proc getblobdiffs {ids} { |
1190 global parents diffopts blobdifffd env curdifftag curtagstart |
2797 global diffopts blobdifffd diffids env curdifftag curtagstart |
1191 global diffindex difffilestart |
2798 global difffilestart nextupdate diffinhdr treediffs |
1192 set p [lindex $parents($id) 0] |
2799 |
|
2800 set id [lindex $ids 0] |
|
2801 set p [lindex $ids 1] |
1193 set env(GIT_DIFF_OPTS) $diffopts |
2802 set env(GIT_DIFF_OPTS) $diffopts |
1194 if [catch {set bdf [open "|hgit diff-tree -r -p $p $id" r]} err] { |
2803 set cmd [list | hg git-diff-tree -r -p -C $p $id] |
|
2804 if {[catch {set bdf [open $cmd r]} err]} { |
1195 puts "error getting diffs: $err" |
2805 puts "error getting diffs: $err" |
1196 return |
2806 return |
1197 } |
2807 } |
|
2808 set diffinhdr 0 |
1198 fconfigure $bdf -blocking 0 |
2809 fconfigure $bdf -blocking 0 |
1199 set blobdifffd($id) $bdf |
2810 set blobdifffd($ids) $bdf |
1200 set curdifftag Comments |
2811 set curdifftag Comments |
1201 set curtagstart 0.0 |
2812 set curtagstart 0.0 |
1202 set diffindex 0 |
|
1203 catch {unset difffilestart} |
2813 catch {unset difffilestart} |
1204 fileevent $bdf readable "getblobdiffline $bdf $id" |
2814 fileevent $bdf readable [list getblobdiffline $bdf $diffids] |
1205 } |
2815 set nextupdate [expr {[clock clicks -milliseconds] + 100}] |
1206 |
2816 } |
1207 proc getblobdiffline {bdf id} { |
2817 |
1208 global currentid blobdifffd ctext curdifftag curtagstart seenfile |
2818 proc getblobdiffline {bdf ids} { |
1209 global diffnexthead diffnextnote diffindex difffilestart |
2819 global diffids blobdifffd ctext curdifftag curtagstart |
|
2820 global diffnexthead diffnextnote difffilestart |
|
2821 global nextupdate diffinhdr treediffs |
|
2822 global gaudydiff |
|
2823 |
1210 set n [gets $bdf line] |
2824 set n [gets $bdf line] |
1211 if {$n < 0} { |
2825 if {$n < 0} { |
1212 if {[eof $bdf]} { |
2826 if {[eof $bdf]} { |
1213 close $bdf |
2827 close $bdf |
1214 if {$id == $currentid && $bdf == $blobdifffd($id)} { |
2828 if {$ids == $diffids && $bdf == $blobdifffd($ids)} { |
1215 $ctext tag add $curdifftag $curtagstart end |
2829 $ctext tag add $curdifftag $curtagstart end |
1216 set seenfile($curdifftag) 1 |
|
1217 } |
2830 } |
1218 } |
2831 } |
1219 return |
2832 return |
1220 } |
2833 } |
1221 if {$id != $currentid || $bdf != $blobdifffd($id)} { |
2834 if {$ids != $diffids || $bdf != $blobdifffd($ids)} { |
1222 return |
2835 return |
1223 } |
2836 } |
1224 $ctext conf -state normal |
2837 $ctext conf -state normal |
1225 if {[regexp {^---[ \t]+([^/])*/([^\t]*)} $line match s0 fname]} { |
2838 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} { |
1226 # start of a new file |
2839 # start of a new file |
1227 $ctext insert end "\n" |
2840 $ctext insert end "\n" |
1228 $ctext tag add $curdifftag $curtagstart end |
2841 $ctext tag add $curdifftag $curtagstart end |
1229 set seenfile($curdifftag) 1 |
|
1230 set curtagstart [$ctext index "end - 1c"] |
2842 set curtagstart [$ctext index "end - 1c"] |
1231 set header $fname |
2843 set header $newname |
1232 if {[info exists diffnexthead]} { |
2844 set here [$ctext index "end - 1c"] |
1233 set fname $diffnexthead |
2845 set i [lsearch -exact $treediffs($diffids) $fname] |
1234 set header "$diffnexthead ($diffnextnote)" |
2846 if {$i >= 0} { |
1235 unset diffnexthead |
2847 set difffilestart($i) $here |
1236 } |
2848 incr i |
1237 set difffilestart($diffindex) [$ctext index "end - 1c"] |
2849 $ctext mark set fmark.$i $here |
1238 incr diffindex |
2850 $ctext mark gravity fmark.$i left |
|
2851 } |
|
2852 if {$newname != $fname} { |
|
2853 set i [lsearch -exact $treediffs($diffids) $newname] |
|
2854 if {$i >= 0} { |
|
2855 set difffilestart($i) $here |
|
2856 incr i |
|
2857 $ctext mark set fmark.$i $here |
|
2858 $ctext mark gravity fmark.$i left |
|
2859 } |
|
2860 } |
1239 set curdifftag "f:$fname" |
2861 set curdifftag "f:$fname" |
1240 $ctext tag delete $curdifftag |
2862 $ctext tag delete $curdifftag |
1241 set l [expr {(78 - [string length $header]) / 2}] |
2863 set l [expr {(78 - [string length $header]) / 2}] |
1242 set pad [string range "----------------------------------------" 1 $l] |
2864 set pad [string range "----------------------------------------" 1 $l] |
1243 $ctext insert end "$pad $header $pad\n" filesep |
2865 $ctext insert end "$pad $header $pad\n" filesep |
1244 } elseif {[string range $line 0 2] == "+++"} { |
2866 set diffinhdr 1 |
1245 # no need to do anything with this |
2867 } elseif {[regexp {^(---|\+\+\+)} $line]} { |
1246 } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} { |
2868 set diffinhdr 0 |
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]+) @@(.*)} \ |
2869 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \ |
1261 $line match f1l f1c f2l f2c rest]} { |
2870 $line match f1l f1c f2l f2c rest]} { |
1262 $ctext insert end "\t" hunksep |
2871 if {$gaudydiff} { |
1263 $ctext insert end " $f1l " d0 " $f2l " d1 |
2872 $ctext insert end "\t" hunksep |
1264 $ctext insert end " $rest \n" hunksep |
2873 $ctext insert end " $f1l " d0 " $f2l " d1 |
|
2874 $ctext insert end " $rest \n" hunksep |
|
2875 } else { |
|
2876 $ctext insert end "$line\n" hunksep |
|
2877 } |
|
2878 set diffinhdr 0 |
1265 } else { |
2879 } else { |
1266 set x [string range $line 0 0] |
2880 set x [string range $line 0 0] |
1267 if {$x == "-" || $x == "+"} { |
2881 if {$x == "-" || $x == "+"} { |
1268 set tag [expr {$x == "+"}] |
2882 set tag [expr {$x == "+"}] |
1269 set line [string range $line 1 end] |
2883 if {$gaudydiff} { |
|
2884 set line [string range $line 1 end] |
|
2885 } |
1270 $ctext insert end "$line\n" d$tag |
2886 $ctext insert end "$line\n" d$tag |
1271 } elseif {$x == " "} { |
2887 } elseif {$x == " "} { |
1272 set line [string range $line 1 end] |
2888 if {$gaudydiff} { |
|
2889 set line [string range $line 1 end] |
|
2890 } |
1273 $ctext insert end "$line\n" |
2891 $ctext insert end "$line\n" |
1274 } elseif {$x == "\\"} { |
2892 } elseif {$diffinhdr || $x == "\\"} { |
1275 # e.g. "\ No newline at end of file" |
2893 # e.g. "\ No newline at end of file" |
1276 $ctext insert end "$line\n" filesep |
2894 $ctext insert end "$line\n" filesep |
1277 } else { |
2895 } else { |
1278 # Something else we don't recognize |
2896 # Something else we don't recognize |
1279 if {$curdifftag != "Comments"} { |
2897 if {$curdifftag != "Comments"} { |
1280 $ctext insert end "\n" |
2898 $ctext insert end "\n" |
1281 $ctext tag add $curdifftag $curtagstart end |
2899 $ctext tag add $curdifftag $curtagstart end |
1282 set seenfile($curdifftag) 1 |
|
1283 set curtagstart [$ctext index "end - 1c"] |
2900 set curtagstart [$ctext index "end - 1c"] |
1284 set curdifftag Comments |
2901 set curdifftag Comments |
1285 } |
2902 } |
1286 $ctext insert end "$line\n" filesep |
2903 $ctext insert end "$line\n" filesep |
1287 } |
2904 } |
1288 } |
2905 } |
1289 $ctext conf -state disabled |
2906 $ctext conf -state disabled |
|
2907 if {[clock clicks -milliseconds] >= $nextupdate} { |
|
2908 incr nextupdate 100 |
|
2909 fileevent $bdf readable {} |
|
2910 update |
|
2911 fileevent $bdf readable "getblobdiffline $bdf {$ids}" |
|
2912 } |
1290 } |
2913 } |
1291 |
2914 |
1292 proc nextfile {} { |
2915 proc nextfile {} { |
1293 global difffilestart ctext |
2916 global difffilestart ctext |
1294 set here [$ctext index @0,0] |
2917 set here [$ctext index @0,0] |
1295 for {set i 0} {[info exists difffilestart($i)]} {incr i} { |
2918 for {set i 0} {[info exists difffilestart($i)]} {incr i} { |
1296 if {[$ctext compare $difffilestart($i) > $here]} { |
2919 if {[$ctext compare $difffilestart($i) > $here]} { |
1297 $ctext yview $difffilestart($i) |
2920 if {![info exists pos] |
1298 break |
2921 || [$ctext compare $difffilestart($i) < $pos]} { |
1299 } |
2922 set pos $difffilestart($i) |
|
2923 } |
|
2924 } |
|
2925 } |
|
2926 if {[info exists pos]} { |
|
2927 $ctext yview $pos |
1300 } |
2928 } |
1301 } |
2929 } |
1302 |
2930 |
1303 proc listboxsel {} { |
2931 proc listboxsel {} { |
1304 global ctext cflist currentid treediffs seenfile |
2932 global ctext cflist currentid |
1305 if {![info exists currentid]} return |
2933 if {![info exists currentid]} return |
1306 set sel [$cflist curselection] |
2934 set sel [lsort [$cflist curselection]] |
1307 if {$sel == {} || [lsearch -exact $sel 0] >= 0} { |
2935 if {$sel eq {}} return |
1308 # show everything |
2936 set first [lindex $sel 0] |
1309 $ctext tag conf Comments -elide 0 |
2937 catch {$ctext yview fmark.$first} |
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 } |
2938 } |
1328 |
2939 |
1329 proc setcoords {} { |
2940 proc setcoords {} { |
1330 global linespc charspc canvx0 canvy0 mainfont |
2941 global linespc charspc canvx0 canvy0 mainfont |
|
2942 global xspc1 xspc2 lthickness |
|
2943 |
1331 set linespc [font metrics $mainfont -linespace] |
2944 set linespc [font metrics $mainfont -linespace] |
1332 set charspc [font measure $mainfont "m"] |
2945 set charspc [font measure $mainfont "m"] |
1333 set canvy0 [expr 3 + 0.5 * $linespc] |
2946 set canvy0 [expr 3 + 0.5 * $linespc] |
1334 set canvx0 [expr 3 + 0.5 * $linespc] |
2947 set canvx0 [expr 3 + 0.5 * $linespc] |
|
2948 set lthickness [expr {int($linespc / 9) + 1}] |
|
2949 set xspc1(0) $linespc |
|
2950 set xspc2 $linespc |
1335 } |
2951 } |
1336 |
2952 |
1337 proc redisplay {} { |
2953 proc redisplay {} { |
1338 global selectedline stopped redisplaying phase |
2954 global stopped redisplaying phase |
1339 if {$stopped > 1} return |
2955 if {$stopped > 1} return |
1340 if {$phase == "getcommits"} return |
2956 if {$phase == "getcommits"} return |
1341 set redisplaying 1 |
2957 set redisplaying 1 |
1342 if {$phase == "drawgraph"} { |
2958 if {$phase == "drawgraph" || $phase == "incrdraw"} { |
1343 set stopped 1 |
2959 set stopped 1 |
1344 } else { |
2960 } else { |
1345 drawgraph |
2961 drawgraph |
1346 } |
2962 } |
1347 } |
2963 } |
1348 |
2964 |
1349 proc incrfont {inc} { |
2965 proc incrfont {inc} { |
1350 global mainfont namefont textfont selectedline ctext canv phase |
2966 global mainfont namefont textfont ctext canv phase |
1351 global stopped entries |
2967 global stopped entries |
1352 unmarkmatches |
2968 unmarkmatches |
1353 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]] |
2969 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]] |
1354 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]] |
2970 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]] |
1355 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]] |
2971 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]] |
1381 } |
3004 } |
1382 } |
3005 } |
1383 |
3006 |
1384 proc gotocommit {} { |
3007 proc gotocommit {} { |
1385 global sha1string currentid idline tagids |
3008 global sha1string currentid idline tagids |
|
3009 global lineid numcommits |
|
3010 |
1386 if {$sha1string == {} |
3011 if {$sha1string == {} |
1387 || ([info exists currentid] && $sha1string == $currentid)} return |
3012 || ([info exists currentid] && $sha1string == $currentid)} return |
1388 if {[info exists tagids($sha1string)]} { |
3013 if {[info exists tagids($sha1string)]} { |
1389 set id $tagids($sha1string) |
3014 set id $tagids($sha1string) |
1390 } else { |
3015 } else { |
1391 set id [string tolower $sha1string] |
3016 set id [string tolower $sha1string] |
|
3017 if {[regexp {^[0-9a-f]{4,39}$} $id]} { |
|
3018 set matches {} |
|
3019 for {set l 0} {$l < $numcommits} {incr l} { |
|
3020 if {[string match $id* $lineid($l)]} { |
|
3021 lappend matches $lineid($l) |
|
3022 } |
|
3023 } |
|
3024 if {$matches ne {}} { |
|
3025 if {[llength $matches] > 1} { |
|
3026 error_popup "Short SHA1 id $id is ambiguous" |
|
3027 return |
|
3028 } |
|
3029 set id [lindex $matches 0] |
|
3030 } |
|
3031 } |
1392 } |
3032 } |
1393 if {[info exists idline($id)]} { |
3033 if {[info exists idline($id)]} { |
1394 selectline $idline($id) |
3034 selectline $idline($id) 1 |
1395 return |
3035 return |
1396 } |
3036 } |
1397 if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} { |
3037 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} { |
1398 set type "SHA1 id" |
3038 set type "SHA1 id" |
1399 } else { |
3039 } else { |
1400 set type "Tag" |
3040 set type "Tag" |
1401 } |
3041 } |
1402 error_popup "$type $sha1string is not known" |
3042 error_popup "$type $sha1string is not known" |
|
3043 } |
|
3044 |
|
3045 proc lineenter {x y id} { |
|
3046 global hoverx hovery hoverid hovertimer |
|
3047 global commitinfo canv |
|
3048 |
|
3049 if {![info exists commitinfo($id)]} return |
|
3050 set hoverx $x |
|
3051 set hovery $y |
|
3052 set hoverid $id |
|
3053 if {[info exists hovertimer]} { |
|
3054 after cancel $hovertimer |
|
3055 } |
|
3056 set hovertimer [after 500 linehover] |
|
3057 $canv delete hover |
|
3058 } |
|
3059 |
|
3060 proc linemotion {x y id} { |
|
3061 global hoverx hovery hoverid hovertimer |
|
3062 |
|
3063 if {[info exists hoverid] && $id == $hoverid} { |
|
3064 set hoverx $x |
|
3065 set hovery $y |
|
3066 if {[info exists hovertimer]} { |
|
3067 after cancel $hovertimer |
|
3068 } |
|
3069 set hovertimer [after 500 linehover] |
|
3070 } |
|
3071 } |
|
3072 |
|
3073 proc lineleave {id} { |
|
3074 global hoverid hovertimer canv |
|
3075 |
|
3076 if {[info exists hoverid] && $id == $hoverid} { |
|
3077 $canv delete hover |
|
3078 if {[info exists hovertimer]} { |
|
3079 after cancel $hovertimer |
|
3080 unset hovertimer |
|
3081 } |
|
3082 unset hoverid |
|
3083 } |
|
3084 } |
|
3085 |
|
3086 proc linehover {} { |
|
3087 global hoverx hovery hoverid hovertimer |
|
3088 global canv linespc lthickness |
|
3089 global commitinfo mainfont |
|
3090 |
|
3091 set text [lindex $commitinfo($hoverid) 0] |
|
3092 set ymax [lindex [$canv cget -scrollregion] 3] |
|
3093 if {$ymax == {}} return |
|
3094 set yfrac [lindex [$canv yview] 0] |
|
3095 set x [expr {$hoverx + 2 * $linespc}] |
|
3096 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}] |
|
3097 set x0 [expr {$x - 2 * $lthickness}] |
|
3098 set y0 [expr {$y - 2 * $lthickness}] |
|
3099 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}] |
|
3100 set y1 [expr {$y + $linespc + 2 * $lthickness}] |
|
3101 set t [$canv create rectangle $x0 $y0 $x1 $y1 \ |
|
3102 -fill \#ffff80 -outline black -width 1 -tags hover] |
|
3103 $canv raise $t |
|
3104 set t [$canv create text $x $y -anchor nw -text $text -tags hover] |
|
3105 $canv raise $t |
|
3106 } |
|
3107 |
|
3108 proc clickisonarrow {id y} { |
|
3109 global mainline mainlinearrow sidelines lthickness |
|
3110 |
|
3111 set thresh [expr {2 * $lthickness + 6}] |
|
3112 if {[info exists mainline($id)]} { |
|
3113 if {$mainlinearrow($id) ne "none"} { |
|
3114 if {abs([lindex $mainline($id) 1] - $y) < $thresh} { |
|
3115 return "up" |
|
3116 } |
|
3117 } |
|
3118 } |
|
3119 if {[info exists sidelines($id)]} { |
|
3120 foreach ls $sidelines($id) { |
|
3121 set coords [lindex $ls 0] |
|
3122 set arrow [lindex $ls 2] |
|
3123 if {$arrow eq "first" || $arrow eq "both"} { |
|
3124 if {abs([lindex $coords 1] - $y) < $thresh} { |
|
3125 return "up" |
|
3126 } |
|
3127 } |
|
3128 if {$arrow eq "last" || $arrow eq "both"} { |
|
3129 if {abs([lindex $coords end] - $y) < $thresh} { |
|
3130 return "down" |
|
3131 } |
|
3132 } |
|
3133 } |
|
3134 } |
|
3135 return {} |
|
3136 } |
|
3137 |
|
3138 proc arrowjump {id dirn y} { |
|
3139 global mainline sidelines canv |
|
3140 |
|
3141 set yt {} |
|
3142 if {$dirn eq "down"} { |
|
3143 if {[info exists mainline($id)]} { |
|
3144 set y1 [lindex $mainline($id) 1] |
|
3145 if {$y1 > $y} { |
|
3146 set yt $y1 |
|
3147 } |
|
3148 } |
|
3149 if {[info exists sidelines($id)]} { |
|
3150 foreach ls $sidelines($id) { |
|
3151 set y1 [lindex $ls 0 1] |
|
3152 if {$y1 > $y && ($yt eq {} || $y1 < $yt)} { |
|
3153 set yt $y1 |
|
3154 } |
|
3155 } |
|
3156 } |
|
3157 } else { |
|
3158 if {[info exists sidelines($id)]} { |
|
3159 foreach ls $sidelines($id) { |
|
3160 set y1 [lindex $ls 0 end] |
|
3161 if {$y1 < $y && ($yt eq {} || $y1 > $yt)} { |
|
3162 set yt $y1 |
|
3163 } |
|
3164 } |
|
3165 } |
|
3166 } |
|
3167 if {$yt eq {}} return |
|
3168 set ymax [lindex [$canv cget -scrollregion] 3] |
|
3169 if {$ymax eq {} || $ymax <= 0} return |
|
3170 set view [$canv yview] |
|
3171 set yspan [expr {[lindex $view 1] - [lindex $view 0]}] |
|
3172 set yfrac [expr {$yt / $ymax - $yspan / 2}] |
|
3173 if {$yfrac < 0} { |
|
3174 set yfrac 0 |
|
3175 } |
|
3176 $canv yview moveto $yfrac |
|
3177 } |
|
3178 |
|
3179 proc lineclick {x y id isnew} { |
|
3180 global ctext commitinfo children cflist canv thickerline |
|
3181 |
|
3182 unmarkmatches |
|
3183 unselectline |
|
3184 normalline |
|
3185 $canv delete hover |
|
3186 # draw this line thicker than normal |
|
3187 drawlines $id 1 |
|
3188 set thickerline $id |
|
3189 if {$isnew} { |
|
3190 set ymax [lindex [$canv cget -scrollregion] 3] |
|
3191 if {$ymax eq {}} return |
|
3192 set yfrac [lindex [$canv yview] 0] |
|
3193 set y [expr {$y + $yfrac * $ymax}] |
|
3194 } |
|
3195 set dirn [clickisonarrow $id $y] |
|
3196 if {$dirn ne {}} { |
|
3197 arrowjump $id $dirn $y |
|
3198 return |
|
3199 } |
|
3200 |
|
3201 if {$isnew} { |
|
3202 addtohistory [list lineclick $x $y $id 0] |
|
3203 } |
|
3204 # fill the details pane with info about this line |
|
3205 $ctext conf -state normal |
|
3206 $ctext delete 0.0 end |
|
3207 $ctext tag conf link -foreground blue -underline 1 |
|
3208 $ctext tag bind link <Enter> { %W configure -cursor hand2 } |
|
3209 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor } |
|
3210 $ctext insert end "Parent:\t" |
|
3211 $ctext insert end $id [list link link0] |
|
3212 $ctext tag bind link0 <1> [list selbyid $id] |
|
3213 set info $commitinfo($id) |
|
3214 $ctext insert end "\n\t[lindex $info 0]\n" |
|
3215 $ctext insert end "\tAuthor:\t[lindex $info 1]\n" |
|
3216 $ctext insert end "\tDate:\t[lindex $info 2]\n" |
|
3217 if {[info exists children($id)]} { |
|
3218 $ctext insert end "\nChildren:" |
|
3219 set i 0 |
|
3220 foreach child $children($id) { |
|
3221 incr i |
|
3222 set info $commitinfo($child) |
|
3223 $ctext insert end "\n\t" |
|
3224 $ctext insert end $child [list link link$i] |
|
3225 $ctext tag bind link$i <1> [list selbyid $child] |
|
3226 $ctext insert end "\n\t[lindex $info 0]" |
|
3227 $ctext insert end "\n\tAuthor:\t[lindex $info 1]" |
|
3228 $ctext insert end "\n\tDate:\t[lindex $info 2]\n" |
|
3229 } |
|
3230 } |
|
3231 $ctext conf -state disabled |
|
3232 |
|
3233 $cflist delete 0 end |
|
3234 } |
|
3235 |
|
3236 proc normalline {} { |
|
3237 global thickerline |
|
3238 if {[info exists thickerline]} { |
|
3239 drawlines $thickerline 0 |
|
3240 unset thickerline |
|
3241 } |
|
3242 } |
|
3243 |
|
3244 proc selbyid {id} { |
|
3245 global idline |
|
3246 if {[info exists idline($id)]} { |
|
3247 selectline $idline($id) 1 |
|
3248 } |
|
3249 } |
|
3250 |
|
3251 proc mstime {} { |
|
3252 global startmstime |
|
3253 if {![info exists startmstime]} { |
|
3254 set startmstime [clock clicks -milliseconds] |
|
3255 } |
|
3256 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]] |
|
3257 } |
|
3258 |
|
3259 proc rowmenu {x y id} { |
|
3260 global rowctxmenu idline selectedline rowmenuid |
|
3261 |
|
3262 if {![info exists selectedline] || $idline($id) eq $selectedline} { |
|
3263 set state disabled |
|
3264 } else { |
|
3265 set state normal |
|
3266 } |
|
3267 $rowctxmenu entryconfigure 0 -state $state |
|
3268 $rowctxmenu entryconfigure 1 -state $state |
|
3269 $rowctxmenu entryconfigure 2 -state $state |
|
3270 set rowmenuid $id |
|
3271 tk_popup $rowctxmenu $x $y |
|
3272 } |
|
3273 |
|
3274 proc diffvssel {dirn} { |
|
3275 global rowmenuid selectedline lineid |
|
3276 |
|
3277 if {![info exists selectedline]} return |
|
3278 if {$dirn} { |
|
3279 set oldid $lineid($selectedline) |
|
3280 set newid $rowmenuid |
|
3281 } else { |
|
3282 set oldid $rowmenuid |
|
3283 set newid $lineid($selectedline) |
|
3284 } |
|
3285 addtohistory [list doseldiff $oldid $newid] |
|
3286 doseldiff $oldid $newid |
|
3287 } |
|
3288 |
|
3289 proc doseldiff {oldid newid} { |
|
3290 global ctext cflist |
|
3291 global commitinfo |
|
3292 |
|
3293 $ctext conf -state normal |
|
3294 $ctext delete 0.0 end |
|
3295 $ctext mark set fmark.0 0.0 |
|
3296 $ctext mark gravity fmark.0 left |
|
3297 $cflist delete 0 end |
|
3298 $cflist insert end "Top" |
|
3299 $ctext insert end "From " |
|
3300 $ctext tag conf link -foreground blue -underline 1 |
|
3301 $ctext tag bind link <Enter> { %W configure -cursor hand2 } |
|
3302 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor } |
|
3303 $ctext tag bind link0 <1> [list selbyid $oldid] |
|
3304 $ctext insert end $oldid [list link link0] |
|
3305 $ctext insert end "\n " |
|
3306 $ctext insert end [lindex $commitinfo($oldid) 0] |
|
3307 $ctext insert end "\n\nTo " |
|
3308 $ctext tag bind link1 <1> [list selbyid $newid] |
|
3309 $ctext insert end $newid [list link link1] |
|
3310 $ctext insert end "\n " |
|
3311 $ctext insert end [lindex $commitinfo($newid) 0] |
|
3312 $ctext insert end "\n" |
|
3313 $ctext conf -state disabled |
|
3314 $ctext tag delete Comments |
|
3315 $ctext tag remove found 1.0 end |
|
3316 startdiff [list $newid $oldid] |
|
3317 } |
|
3318 |
|
3319 proc mkpatch {} { |
|
3320 global rowmenuid currentid commitinfo patchtop patchnum |
|
3321 |
|
3322 if {![info exists currentid]} return |
|
3323 set oldid $currentid |
|
3324 set oldhead [lindex $commitinfo($oldid) 0] |
|
3325 set newid $rowmenuid |
|
3326 set newhead [lindex $commitinfo($newid) 0] |
|
3327 set top .patch |
|
3328 set patchtop $top |
|
3329 catch {destroy $top} |
|
3330 toplevel $top |
|
3331 label $top.title -text "Generate patch" |
|
3332 grid $top.title - -pady 10 |
|
3333 label $top.from -text "From:" |
|
3334 entry $top.fromsha1 -width 40 -relief flat |
|
3335 $top.fromsha1 insert 0 $oldid |
|
3336 $top.fromsha1 conf -state readonly |
|
3337 grid $top.from $top.fromsha1 -sticky w |
|
3338 entry $top.fromhead -width 60 -relief flat |
|
3339 $top.fromhead insert 0 $oldhead |
|
3340 $top.fromhead conf -state readonly |
|
3341 grid x $top.fromhead -sticky w |
|
3342 label $top.to -text "To:" |
|
3343 entry $top.tosha1 -width 40 -relief flat |
|
3344 $top.tosha1 insert 0 $newid |
|
3345 $top.tosha1 conf -state readonly |
|
3346 grid $top.to $top.tosha1 -sticky w |
|
3347 entry $top.tohead -width 60 -relief flat |
|
3348 $top.tohead insert 0 $newhead |
|
3349 $top.tohead conf -state readonly |
|
3350 grid x $top.tohead -sticky w |
|
3351 button $top.rev -text "Reverse" -command mkpatchrev -padx 5 |
|
3352 grid $top.rev x -pady 10 |
|
3353 label $top.flab -text "Output file:" |
|
3354 entry $top.fname -width 60 |
|
3355 $top.fname insert 0 [file normalize "patch$patchnum.patch"] |
|
3356 incr patchnum |
|
3357 grid $top.flab $top.fname -sticky w |
|
3358 frame $top.buts |
|
3359 button $top.buts.gen -text "Generate" -command mkpatchgo |
|
3360 button $top.buts.can -text "Cancel" -command mkpatchcan |
|
3361 grid $top.buts.gen $top.buts.can |
|
3362 grid columnconfigure $top.buts 0 -weight 1 -uniform a |
|
3363 grid columnconfigure $top.buts 1 -weight 1 -uniform a |
|
3364 grid $top.buts - -pady 10 -sticky ew |
|
3365 focus $top.fname |
|
3366 } |
|
3367 |
|
3368 proc mkpatchrev {} { |
|
3369 global patchtop |
|
3370 |
|
3371 set oldid [$patchtop.fromsha1 get] |
|
3372 set oldhead [$patchtop.fromhead get] |
|
3373 set newid [$patchtop.tosha1 get] |
|
3374 set newhead [$patchtop.tohead get] |
|
3375 foreach e [list fromsha1 fromhead tosha1 tohead] \ |
|
3376 v [list $newid $newhead $oldid $oldhead] { |
|
3377 $patchtop.$e conf -state normal |
|
3378 $patchtop.$e delete 0 end |
|
3379 $patchtop.$e insert 0 $v |
|
3380 $patchtop.$e conf -state readonly |
|
3381 } |
|
3382 } |
|
3383 |
|
3384 proc mkpatchgo {} { |
|
3385 global patchtop |
|
3386 |
|
3387 set oldid [$patchtop.fromsha1 get] |
|
3388 set newid [$patchtop.tosha1 get] |
|
3389 set fname [$patchtop.fname get] |
|
3390 if {[catch {exec hg git-diff-tree -p $oldid $newid >$fname &} err]} { |
|
3391 error_popup "Error creating patch: $err" |
|
3392 } |
|
3393 catch {destroy $patchtop} |
|
3394 unset patchtop |
|
3395 } |
|
3396 |
|
3397 proc mkpatchcan {} { |
|
3398 global patchtop |
|
3399 |
|
3400 catch {destroy $patchtop} |
|
3401 unset patchtop |
|
3402 } |
|
3403 |
|
3404 proc mktag {} { |
|
3405 global rowmenuid mktagtop commitinfo |
|
3406 |
|
3407 set top .maketag |
|
3408 set mktagtop $top |
|
3409 catch {destroy $top} |
|
3410 toplevel $top |
|
3411 label $top.title -text "Create tag" |
|
3412 grid $top.title - -pady 10 |
|
3413 label $top.id -text "ID:" |
|
3414 entry $top.sha1 -width 40 -relief flat |
|
3415 $top.sha1 insert 0 $rowmenuid |
|
3416 $top.sha1 conf -state readonly |
|
3417 grid $top.id $top.sha1 -sticky w |
|
3418 entry $top.head -width 60 -relief flat |
|
3419 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0] |
|
3420 $top.head conf -state readonly |
|
3421 grid x $top.head -sticky w |
|
3422 label $top.tlab -text "Tag name:" |
|
3423 entry $top.tag -width 60 |
|
3424 grid $top.tlab $top.tag -sticky w |
|
3425 frame $top.buts |
|
3426 button $top.buts.gen -text "Create" -command mktaggo |
|
3427 button $top.buts.can -text "Cancel" -command mktagcan |
|
3428 grid $top.buts.gen $top.buts.can |
|
3429 grid columnconfigure $top.buts 0 -weight 1 -uniform a |
|
3430 grid columnconfigure $top.buts 1 -weight 1 -uniform a |
|
3431 grid $top.buts - -pady 10 -sticky ew |
|
3432 focus $top.tag |
|
3433 } |
|
3434 |
|
3435 proc domktag {} { |
|
3436 global mktagtop env tagids idtags |
|
3437 |
|
3438 set id [$mktagtop.sha1 get] |
|
3439 set tag [$mktagtop.tag get] |
|
3440 if {$tag == {}} { |
|
3441 error_popup "No tag name specified" |
|
3442 return |
|
3443 } |
|
3444 if {[info exists tagids($tag)]} { |
|
3445 error_popup "Tag \"$tag\" already exists" |
|
3446 return |
|
3447 } |
|
3448 if {[catch { |
|
3449 set out [exec hg tag $tag $id] |
|
3450 } err]} { |
|
3451 error_popup "Error creating tag: $err" |
|
3452 return |
|
3453 } |
|
3454 |
|
3455 set tagids($tag) $id |
|
3456 lappend idtags($id) $tag |
|
3457 redrawtags $id |
|
3458 } |
|
3459 |
|
3460 proc redrawtags {id} { |
|
3461 global canv linehtag idline idpos selectedline |
|
3462 |
|
3463 if {![info exists idline($id)]} return |
|
3464 $canv delete tag.$id |
|
3465 set xt [eval drawtags $id $idpos($id)] |
|
3466 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2] |
|
3467 if {[info exists selectedline] && $selectedline == $idline($id)} { |
|
3468 selectline $selectedline 0 |
|
3469 } |
|
3470 } |
|
3471 |
|
3472 proc mktagcan {} { |
|
3473 global mktagtop |
|
3474 |
|
3475 catch {destroy $mktagtop} |
|
3476 unset mktagtop |
|
3477 } |
|
3478 |
|
3479 proc mktaggo {} { |
|
3480 domktag |
|
3481 mktagcan |
|
3482 } |
|
3483 |
|
3484 proc writecommit {} { |
|
3485 global rowmenuid wrcomtop commitinfo wrcomcmd |
|
3486 |
|
3487 set top .writecommit |
|
3488 set wrcomtop $top |
|
3489 catch {destroy $top} |
|
3490 toplevel $top |
|
3491 label $top.title -text "Write commit to file" |
|
3492 grid $top.title - -pady 10 |
|
3493 label $top.id -text "ID:" |
|
3494 entry $top.sha1 -width 40 -relief flat |
|
3495 $top.sha1 insert 0 $rowmenuid |
|
3496 $top.sha1 conf -state readonly |
|
3497 grid $top.id $top.sha1 -sticky w |
|
3498 entry $top.head -width 60 -relief flat |
|
3499 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0] |
|
3500 $top.head conf -state readonly |
|
3501 grid x $top.head -sticky w |
|
3502 label $top.clab -text "Command:" |
|
3503 entry $top.cmd -width 60 -textvariable wrcomcmd |
|
3504 grid $top.clab $top.cmd -sticky w -pady 10 |
|
3505 label $top.flab -text "Output file:" |
|
3506 entry $top.fname -width 60 |
|
3507 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"] |
|
3508 grid $top.flab $top.fname -sticky w |
|
3509 frame $top.buts |
|
3510 button $top.buts.gen -text "Write" -command wrcomgo |
|
3511 button $top.buts.can -text "Cancel" -command wrcomcan |
|
3512 grid $top.buts.gen $top.buts.can |
|
3513 grid columnconfigure $top.buts 0 -weight 1 -uniform a |
|
3514 grid columnconfigure $top.buts 1 -weight 1 -uniform a |
|
3515 grid $top.buts - -pady 10 -sticky ew |
|
3516 focus $top.fname |
|
3517 } |
|
3518 |
|
3519 proc wrcomgo {} { |
|
3520 global wrcomtop |
|
3521 |
|
3522 set id [$wrcomtop.sha1 get] |
|
3523 set cmd "echo $id | [$wrcomtop.cmd get]" |
|
3524 set fname [$wrcomtop.fname get] |
|
3525 if {[catch {exec sh -c $cmd >$fname &} err]} { |
|
3526 error_popup "Error writing commit: $err" |
|
3527 } |
|
3528 catch {destroy $wrcomtop} |
|
3529 unset wrcomtop |
|
3530 } |
|
3531 |
|
3532 proc wrcomcan {} { |
|
3533 global wrcomtop |
|
3534 |
|
3535 catch {destroy $wrcomtop} |
|
3536 unset wrcomtop |
|
3537 } |
|
3538 |
|
3539 proc listrefs {id} { |
|
3540 global idtags idheads idotherrefs |
|
3541 |
|
3542 set x {} |
|
3543 if {[info exists idtags($id)]} { |
|
3544 set x $idtags($id) |
|
3545 } |
|
3546 set y {} |
|
3547 if {[info exists idheads($id)]} { |
|
3548 set y $idheads($id) |
|
3549 } |
|
3550 set z {} |
|
3551 if {[info exists idotherrefs($id)]} { |
|
3552 set z $idotherrefs($id) |
|
3553 } |
|
3554 return [list $x $y $z] |
|
3555 } |
|
3556 |
|
3557 proc rereadrefs {} { |
|
3558 global idtags idheads idotherrefs |
|
3559 global tagids headids otherrefids |
|
3560 |
|
3561 set refids [concat [array names idtags] \ |
|
3562 [array names idheads] [array names idotherrefs]] |
|
3563 foreach id $refids { |
|
3564 if {![info exists ref($id)]} { |
|
3565 set ref($id) [listrefs $id] |
|
3566 } |
|
3567 } |
|
3568 foreach v {tagids idtags headids idheads otherrefids idotherrefs} { |
|
3569 catch {unset $v} |
|
3570 } |
|
3571 readrefs |
|
3572 set refids [lsort -unique [concat $refids [array names idtags] \ |
|
3573 [array names idheads] [array names idotherrefs]]] |
|
3574 foreach id $refids { |
|
3575 set v [listrefs $id] |
|
3576 if {![info exists ref($id)] || $ref($id) != $v} { |
|
3577 redrawtags $id |
|
3578 } |
|
3579 } |
|
3580 } |
|
3581 |
|
3582 proc showtag {tag isnew} { |
|
3583 global ctext cflist tagcontents tagids linknum |
|
3584 |
|
3585 if {$isnew} { |
|
3586 addtohistory [list showtag $tag 0] |
|
3587 } |
|
3588 $ctext conf -state normal |
|
3589 $ctext delete 0.0 end |
|
3590 set linknum 0 |
|
3591 if {[info exists tagcontents($tag)]} { |
|
3592 set text $tagcontents($tag) |
|
3593 } else { |
|
3594 set text "Tag: $tag\nId: $tagids($tag)" |
|
3595 } |
|
3596 appendwithlinks $text |
|
3597 $ctext conf -state disabled |
|
3598 $cflist delete 0 end |
1403 } |
3599 } |
1404 |
3600 |
1405 proc doquit {} { |
3601 proc doquit {} { |
1406 global stopped |
3602 global stopped |
1407 set stopped 100 |
3603 set stopped 100 |