Show More
@@ -1,3888 +1,3888 | |||||
1 | #!/usr/bin/env wish |
|
1 | #!/usr/bin/env wish | |
2 |
|
2 | |||
3 | # Copyright (C) 2005 Paul Mackerras. All rights reserved. |
|
3 | # Copyright (C) 2005 Paul Mackerras. All rights reserved. | |
4 | # This program is free software; it may be used, copied, modified |
|
4 | # This program is free software; it may be used, copied, modified | |
5 | # and distributed under the terms of the GNU General Public Licence, |
|
5 | # and distributed under the terms of the GNU General Public Licence, | |
6 | # either version 2, or (at your option) any later version. |
|
6 | # either version 2, or (at your option) any later version. | |
7 | # |
|
7 | # | |
8 | # See hgk.py for extension usage and configuration. |
|
8 | # See hgk.py for extension usage and configuration. | |
9 |
|
9 | |||
10 |
|
10 | |||
11 | # Modified version of Tip 171: |
|
11 | # Modified version of Tip 171: | |
12 | # http://www.tcl.tk/cgi-bin/tct/tip/171.html |
|
12 | # http://www.tcl.tk/cgi-bin/tct/tip/171.html | |
13 | # |
|
13 | # | |
14 | # The in_mousewheel global was added to fix strange reentrancy issues. |
|
14 | # The in_mousewheel global was added to fix strange reentrancy issues. | |
15 | # The whole snipped is activated only under windows, mouse wheel |
|
15 | # The whole snipped is activated only under windows, mouse wheel | |
16 | # bindings working already under MacOSX and Linux. |
|
16 | # bindings working already under MacOSX and Linux. | |
17 |
|
17 | |||
18 | if {[tk windowingsystem] eq "win32"} { |
|
18 | if {[tk windowingsystem] eq "win32"} { | |
19 |
|
19 | |||
20 | set mw_classes [list Text Listbox Table TreeCtrl] |
|
20 | set mw_classes [list Text Listbox Table TreeCtrl] | |
21 | foreach class $mw_classes { bind $class <MouseWheel> {} } |
|
21 | foreach class $mw_classes { bind $class <MouseWheel> {} } | |
22 |
|
22 | |||
23 | set in_mousewheel 0 |
|
23 | set in_mousewheel 0 | |
24 |
|
24 | |||
25 | proc ::tk::MouseWheel {wFired X Y D {shifted 0}} { |
|
25 | proc ::tk::MouseWheel {wFired X Y D {shifted 0}} { | |
26 | global in_mousewheel |
|
26 | global in_mousewheel | |
27 | if { $in_mousewheel != 0 } { return } |
|
27 | if { $in_mousewheel != 0 } { return } | |
28 | # Set event to check based on call |
|
28 | # Set event to check based on call | |
29 | set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>" |
|
29 | set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>" | |
30 | # do not double-fire in case the class already has a binding |
|
30 | # do not double-fire in case the class already has a binding | |
31 | if {[bind [winfo class $wFired] $evt] ne ""} { return } |
|
31 | if {[bind [winfo class $wFired] $evt] ne ""} { return } | |
32 | # obtain the window the mouse is over |
|
32 | # obtain the window the mouse is over | |
33 | set w [winfo containing $X $Y] |
|
33 | set w [winfo containing $X $Y] | |
34 | # if we are outside the app, try and scroll the focus widget |
|
34 | # if we are outside the app, try and scroll the focus widget | |
35 | if {![winfo exists $w]} { catch {set w [focus]} } |
|
35 | if {![winfo exists $w]} { catch {set w [focus]} } | |
36 | if {[winfo exists $w]} { |
|
36 | if {[winfo exists $w]} { | |
37 |
|
37 | |||
38 | if {[bind $w $evt] ne ""} { |
|
38 | if {[bind $w $evt] ne ""} { | |
39 | # Awkward ... this widget has a MouseWheel binding, but to |
|
39 | # Awkward ... this widget has a MouseWheel binding, but to | |
40 | # trigger successfully in it, we must give it focus. |
|
40 | # trigger successfully in it, we must give it focus. | |
41 | catch {focus} old |
|
41 | catch {focus} old | |
42 | if {$w ne $old} { focus $w } |
|
42 | if {$w ne $old} { focus $w } | |
43 | set in_mousewheel 1 |
|
43 | set in_mousewheel 1 | |
44 | event generate $w $evt -rootx $X -rooty $Y -delta $D |
|
44 | event generate $w $evt -rootx $X -rooty $Y -delta $D | |
45 | set in_mousewheel 0 |
|
45 | set in_mousewheel 0 | |
46 | if {$w ne $old} { focus $old } |
|
46 | if {$w ne $old} { focus $old } | |
47 | return |
|
47 | return | |
48 | } |
|
48 | } | |
49 |
|
49 | |||
50 | # aqua and x11/win32 have different delta handling |
|
50 | # aqua and x11/win32 have different delta handling | |
51 | if {[tk windowingsystem] ne "aqua"} { |
|
51 | if {[tk windowingsystem] ne "aqua"} { | |
52 | set delta [expr {- ($D / 30)}] |
|
52 | set delta [expr {- ($D / 30)}] | |
53 | } else { |
|
53 | } else { | |
54 | set delta [expr {- ($D)}] |
|
54 | set delta [expr {- ($D)}] | |
55 | } |
|
55 | } | |
56 | # scrollbars have different call conventions |
|
56 | # scrollbars have different call conventions | |
57 | if {[string match "*Scrollbar" [winfo class $w]]} { |
|
57 | if {[string match "*Scrollbar" [winfo class $w]]} { | |
58 | catch {tk::ScrollByUnits $w \ |
|
58 | catch {tk::ScrollByUnits $w \ | |
59 | [string index [$w cget -orient] 0] $delta} |
|
59 | [string index [$w cget -orient] 0] $delta} | |
60 | } else { |
|
60 | } else { | |
61 | set cmd [list $w [expr {$shifted ? "xview" : "yview"}] \ |
|
61 | set cmd [list $w [expr {$shifted ? "xview" : "yview"}] \ | |
62 | scroll $delta units] |
|
62 | scroll $delta units] | |
63 | # Walking up to find the proper widget (handles cases like |
|
63 | # Walking up to find the proper widget (handles cases like | |
64 | # embedded widgets in a canvas) |
|
64 | # embedded widgets in a canvas) | |
65 | while {[catch $cmd] && [winfo toplevel $w] ne $w} { |
|
65 | while {[catch $cmd] && [winfo toplevel $w] ne $w} { | |
66 | set w [winfo parent $w] |
|
66 | set w [winfo parent $w] | |
67 | } |
|
67 | } | |
68 | } |
|
68 | } | |
69 | } |
|
69 | } | |
70 | } |
|
70 | } | |
71 |
|
71 | |||
72 | bind all <MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 0] |
|
72 | bind all <MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 0] | |
73 |
|
73 | |||
74 | # end of win32 section |
|
74 | # end of win32 section | |
75 | } |
|
75 | } | |
76 |
|
76 | |||
77 |
|
77 | |||
78 | # Unify right mouse button handling. |
|
78 | # Unify right mouse button handling. | |
79 | # See "mouse buttons on macintosh" thread on comp.lang.tcl |
|
79 | # See "mouse buttons on macintosh" thread on comp.lang.tcl | |
80 | if {[tk windowingsystem] eq "aqua"} { |
|
80 | if {[tk windowingsystem] eq "aqua"} { | |
81 | event add <<B3>> <Control-ButtonPress-1> |
|
81 | event add <<B3>> <Control-ButtonPress-1> | |
82 | event add <<B3>> <Button-2> |
|
82 | event add <<B3>> <Button-2> | |
83 | } else { |
|
83 | } else { | |
84 | event add <<B3>> <Button-3> |
|
84 | event add <<B3>> <Button-3> | |
85 | } |
|
85 | } | |
86 |
|
86 | |||
87 | proc gitdir {} { |
|
87 | proc gitdir {} { | |
88 | global env |
|
88 | global env | |
89 | if {[info exists env(GIT_DIR)]} { |
|
89 | if {[info exists env(GIT_DIR)]} { | |
90 | return $env(GIT_DIR) |
|
90 | return $env(GIT_DIR) | |
91 | } else { |
|
91 | } else { | |
92 | return ".hg" |
|
92 | return ".hg" | |
93 | } |
|
93 | } | |
94 | } |
|
94 | } | |
95 |
|
95 | |||
96 | proc getcommits {rargs} { |
|
96 | proc getcommits {rargs} { | |
97 | global commits commfd phase canv mainfont env |
|
97 | global commits commfd phase canv mainfont env | |
98 | global startmsecs nextupdate ncmupdate |
|
98 | global startmsecs nextupdate ncmupdate | |
99 | global ctext maincursor textcursor leftover |
|
99 | global ctext maincursor textcursor leftover | |
100 |
|
100 | |||
101 | # check that we can find a .git directory somewhere... |
|
101 | # check that we can find a .git directory somewhere... | |
102 | set gitdir [gitdir] |
|
102 | set gitdir [gitdir] | |
103 | if {![file isdirectory $gitdir]} { |
|
103 | if {![file isdirectory $gitdir]} { | |
104 | error_popup "Cannot find the git directory \"$gitdir\"." |
|
104 | error_popup "Cannot find the git directory \"$gitdir\"." | |
105 | exit 1 |
|
105 | exit 1 | |
106 | } |
|
106 | } | |
107 | set commits {} |
|
107 | set commits {} | |
108 | set phase getcommits |
|
108 | set phase getcommits | |
109 | set startmsecs [clock clicks -milliseconds] |
|
109 | set startmsecs [clock clicks -milliseconds] | |
110 | set nextupdate [expr $startmsecs + 100] |
|
110 | set nextupdate [expr $startmsecs + 100] | |
111 | set ncmupdate 1 |
|
111 | set ncmupdate 1 | |
112 | set limit 0 |
|
112 | set limit 0 | |
113 | set revargs {} |
|
113 | set revargs {} | |
114 | for {set i 0} {$i < [llength $rargs]} {incr i} { |
|
114 | for {set i 0} {$i < [llength $rargs]} {incr i} { | |
115 | set opt [lindex $rargs $i] |
|
115 | set opt [lindex $rargs $i] | |
116 | if {$opt == "--limit"} { |
|
116 | if {$opt == "--limit"} { | |
117 | incr i |
|
117 | incr i | |
118 | set limit [lindex $rargs $i] |
|
118 | set limit [lindex $rargs $i] | |
119 | } else { |
|
119 | } else { | |
120 | lappend revargs $opt |
|
120 | lappend revargs $opt | |
121 | } |
|
121 | } | |
122 | } |
|
122 | } | |
123 | if [catch { |
|
123 | if [catch { | |
124 | set parse_args [concat --default HEAD $revargs] |
|
124 | set parse_args [concat --default HEAD $revargs] | |
125 | set parse_temp [eval exec {$env(HG)} --config ui.report_untrusted=false debug-rev-parse $parse_args] |
|
125 | set parse_temp [eval exec {$env(HG)} --config ui.report_untrusted=false debug-rev-parse $parse_args] | |
126 | regsub -all "\r\n" $parse_temp "\n" parse_temp |
|
126 | regsub -all "\r\n" $parse_temp "\n" parse_temp | |
127 | set parsed_args [split $parse_temp "\n"] |
|
127 | set parsed_args [split $parse_temp "\n"] | |
128 | } err] { |
|
128 | } err] { | |
129 | # if git-rev-parse failed for some reason... |
|
129 | # if git-rev-parse failed for some reason... | |
130 | if {$rargs == {}} { |
|
130 | if {$rargs == {}} { | |
131 | set revargs HEAD |
|
131 | set revargs HEAD | |
132 | } |
|
132 | } | |
133 | set parsed_args $revargs |
|
133 | set parsed_args $revargs | |
134 | } |
|
134 | } | |
135 | if {$limit > 0} { |
|
135 | if {$limit > 0} { | |
136 | set parsed_args [concat -n $limit $parsed_args] |
|
136 | set parsed_args [concat -n $limit $parsed_args] | |
137 | } |
|
137 | } | |
138 | if [catch { |
|
138 | if [catch { | |
139 | set commfd [open "|{$env(HG)} --config ui.report_untrusted=false debug-rev-list --header --topo-order --parents $parsed_args" r] |
|
139 | set commfd [open "|{$env(HG)} --config ui.report_untrusted=false debug-rev-list --header --topo-order --parents $parsed_args" r] | |
140 | } err] { |
|
140 | } err] { | |
141 | puts stderr "Error executing hg debug-rev-list: $err" |
|
141 | puts stderr "Error executing hg debug-rev-list: $err" | |
142 | exit 1 |
|
142 | exit 1 | |
143 | } |
|
143 | } | |
144 | set leftover {} |
|
144 | set leftover {} | |
145 | fconfigure $commfd -blocking 0 -translation lf |
|
145 | fconfigure $commfd -blocking 0 -translation lf | |
146 | fileevent $commfd readable [list getcommitlines $commfd] |
|
146 | fileevent $commfd readable [list getcommitlines $commfd] | |
147 | $canv delete all |
|
147 | $canv delete all | |
148 | $canv create text 3 3 -anchor nw -text "Reading commits..." \ |
|
148 | $canv create text 3 3 -anchor nw -text "Reading commits..." \ | |
149 | -font $mainfont -tags textitems |
|
149 | -font $mainfont -tags textitems | |
150 | . config -cursor watch |
|
150 | . config -cursor watch | |
151 | settextcursor watch |
|
151 | settextcursor watch | |
152 | } |
|
152 | } | |
153 |
|
153 | |||
154 | proc getcommitlines {commfd} { |
|
154 | proc getcommitlines {commfd} { | |
155 | global commits parents cdate children |
|
155 | global commits parents cdate children | |
156 | global commitlisted phase commitinfo nextupdate |
|
156 | global commitlisted phase commitinfo nextupdate | |
157 | global stopped redisplaying leftover |
|
157 | global stopped redisplaying leftover | |
158 |
|
158 | |||
159 | set stuff [read $commfd] |
|
159 | set stuff [read $commfd] | |
160 | if {$stuff == {}} { |
|
160 | if {$stuff == {}} { | |
161 | if {![eof $commfd]} return |
|
161 | if {![eof $commfd]} return | |
162 | # set it blocking so we wait for the process to terminate |
|
162 | # set it blocking so we wait for the process to terminate | |
163 | fconfigure $commfd -blocking 1 |
|
163 | fconfigure $commfd -blocking 1 | |
164 | if {![catch {close $commfd} err]} { |
|
164 | if {![catch {close $commfd} err]} { | |
165 | after idle finishcommits |
|
165 | after idle finishcommits | |
166 | return |
|
166 | return | |
167 | } |
|
167 | } | |
168 | if {[string range $err 0 4] == "usage"} { |
|
168 | if {[string range $err 0 4] == "usage"} { | |
169 | set err \ |
|
169 | set err \ | |
170 | {Gitk: error reading commits: bad arguments to git-rev-list. |
|
170 | {Gitk: error reading commits: bad arguments to git-rev-list. | |
171 | (Note: arguments to gitk are passed to git-rev-list |
|
171 | (Note: arguments to gitk are passed to git-rev-list | |
172 | to allow selection of commits to be displayed.)} |
|
172 | to allow selection of commits to be displayed.)} | |
173 | } else { |
|
173 | } else { | |
174 | set err "Error reading commits: $err" |
|
174 | set err "Error reading commits: $err" | |
175 | } |
|
175 | } | |
176 | error_popup $err |
|
176 | error_popup $err | |
177 | exit 1 |
|
177 | exit 1 | |
178 | } |
|
178 | } | |
179 | set start 0 |
|
179 | set start 0 | |
180 | while 1 { |
|
180 | while 1 { | |
181 | set i [string first "\0" $stuff $start] |
|
181 | set i [string first "\0" $stuff $start] | |
182 | if {$i < 0} { |
|
182 | if {$i < 0} { | |
183 | append leftover [string range $stuff $start end] |
|
183 | append leftover [string range $stuff $start end] | |
184 | return |
|
184 | return | |
185 | } |
|
185 | } | |
186 | set cmit [string range $stuff $start [expr {$i - 1}]] |
|
186 | set cmit [string range $stuff $start [expr {$i - 1}]] | |
187 | if {$start == 0} { |
|
187 | if {$start == 0} { | |
188 | set cmit "$leftover$cmit" |
|
188 | set cmit "$leftover$cmit" | |
189 | set leftover {} |
|
189 | set leftover {} | |
190 | } |
|
190 | } | |
191 | set start [expr {$i + 1}] |
|
191 | set start [expr {$i + 1}] | |
192 | regsub -all "\r\n" $cmit "\n" cmit |
|
192 | regsub -all "\r\n" $cmit "\n" cmit | |
193 | set j [string first "\n" $cmit] |
|
193 | set j [string first "\n" $cmit] | |
194 | set ok 0 |
|
194 | set ok 0 | |
195 | if {$j >= 0} { |
|
195 | if {$j >= 0} { | |
196 | set ids [string range $cmit 0 [expr {$j - 1}]] |
|
196 | set ids [string range $cmit 0 [expr {$j - 1}]] | |
197 | set ok 1 |
|
197 | set ok 1 | |
198 | foreach id $ids { |
|
198 | foreach id $ids { | |
199 | if {![regexp {^[0-9a-f]{12}$} $id]} { |
|
199 | if {![regexp {^[0-9a-f]{12}$} $id]} { | |
200 | set ok 0 |
|
200 | set ok 0 | |
201 | break |
|
201 | break | |
202 | } |
|
202 | } | |
203 | } |
|
203 | } | |
204 | } |
|
204 | } | |
205 | if {!$ok} { |
|
205 | if {!$ok} { | |
206 | set shortcmit $cmit |
|
206 | set shortcmit $cmit | |
207 | if {[string length $shortcmit] > 80} { |
|
207 | if {[string length $shortcmit] > 80} { | |
208 | set shortcmit "[string range $shortcmit 0 80]..." |
|
208 | set shortcmit "[string range $shortcmit 0 80]..." | |
209 | } |
|
209 | } | |
210 | error_popup "Can't parse hg debug-rev-list output: {$shortcmit}" |
|
210 | error_popup "Can't parse hg debug-rev-list output: {$shortcmit}" | |
211 | exit 1 |
|
211 | exit 1 | |
212 | } |
|
212 | } | |
213 | set id [lindex $ids 0] |
|
213 | set id [lindex $ids 0] | |
214 | set olds [lrange $ids 1 end] |
|
214 | set olds [lrange $ids 1 end] | |
215 | set cmit [string range $cmit [expr {$j + 1}] end] |
|
215 | set cmit [string range $cmit [expr {$j + 1}] end] | |
216 | lappend commits $id |
|
216 | lappend commits $id | |
217 | set commitlisted($id) 1 |
|
217 | set commitlisted($id) 1 | |
218 | parsecommit $id $cmit 1 [lrange $ids 1 end] |
|
218 | parsecommit $id $cmit 1 [lrange $ids 1 end] | |
219 | drawcommit $id |
|
219 | drawcommit $id | |
220 | if {[clock clicks -milliseconds] >= $nextupdate} { |
|
220 | if {[clock clicks -milliseconds] >= $nextupdate} { | |
221 | doupdate 1 |
|
221 | doupdate 1 | |
222 | } |
|
222 | } | |
223 | while {$redisplaying} { |
|
223 | while {$redisplaying} { | |
224 | set redisplaying 0 |
|
224 | set redisplaying 0 | |
225 | if {$stopped == 1} { |
|
225 | if {$stopped == 1} { | |
226 | set stopped 0 |
|
226 | set stopped 0 | |
227 | set phase "getcommits" |
|
227 | set phase "getcommits" | |
228 | foreach id $commits { |
|
228 | foreach id $commits { | |
229 | drawcommit $id |
|
229 | drawcommit $id | |
230 | if {$stopped} break |
|
230 | if {$stopped} break | |
231 | if {[clock clicks -milliseconds] >= $nextupdate} { |
|
231 | if {[clock clicks -milliseconds] >= $nextupdate} { | |
232 | doupdate 1 |
|
232 | doupdate 1 | |
233 | } |
|
233 | } | |
234 | } |
|
234 | } | |
235 | } |
|
235 | } | |
236 | } |
|
236 | } | |
237 | } |
|
237 | } | |
238 | } |
|
238 | } | |
239 |
|
239 | |||
240 | proc doupdate {reading} { |
|
240 | proc doupdate {reading} { | |
241 | global commfd nextupdate numcommits ncmupdate |
|
241 | global commfd nextupdate numcommits ncmupdate | |
242 |
|
242 | |||
243 | if {$reading} { |
|
243 | if {$reading} { | |
244 | fileevent $commfd readable {} |
|
244 | fileevent $commfd readable {} | |
245 | } |
|
245 | } | |
246 | update |
|
246 | update | |
247 | set nextupdate [expr {[clock clicks -milliseconds] + 100}] |
|
247 | set nextupdate [expr {[clock clicks -milliseconds] + 100}] | |
248 | if {$numcommits < 100} { |
|
248 | if {$numcommits < 100} { | |
249 | set ncmupdate [expr {$numcommits + 1}] |
|
249 | set ncmupdate [expr {$numcommits + 1}] | |
250 | } elseif {$numcommits < 10000} { |
|
250 | } elseif {$numcommits < 10000} { | |
251 | set ncmupdate [expr {$numcommits + 10}] |
|
251 | set ncmupdate [expr {$numcommits + 10}] | |
252 | } else { |
|
252 | } else { | |
253 | set ncmupdate [expr {$numcommits + 100}] |
|
253 | set ncmupdate [expr {$numcommits + 100}] | |
254 | } |
|
254 | } | |
255 | if {$reading} { |
|
255 | if {$reading} { | |
256 | fileevent $commfd readable [list getcommitlines $commfd] |
|
256 | fileevent $commfd readable [list getcommitlines $commfd] | |
257 | } |
|
257 | } | |
258 | } |
|
258 | } | |
259 |
|
259 | |||
260 | proc readcommit {id} { |
|
260 | proc readcommit {id} { | |
261 | global env |
|
261 | global env | |
262 | if [catch {set contents [exec $env(HG) --config ui.report_untrusted=false debug-cat-file commit $id]}] return |
|
262 | if [catch {set contents [exec $env(HG) --config ui.report_untrusted=false debug-cat-file commit $id]}] return | |
263 | parsecommit $id $contents 0 {} |
|
263 | parsecommit $id $contents 0 {} | |
264 | } |
|
264 | } | |
265 |
|
265 | |||
266 | proc parsecommit {id contents listed olds} { |
|
266 | proc parsecommit {id contents listed olds} { | |
267 | global commitinfo children nchildren parents nparents cdate ncleft |
|
267 | global commitinfo children nchildren parents nparents cdate ncleft | |
268 |
|
268 | |||
269 | set inhdr 1 |
|
269 | set inhdr 1 | |
270 | set comment {} |
|
270 | set comment {} | |
271 | set headline {} |
|
271 | set headline {} | |
272 | set auname {} |
|
272 | set auname {} | |
273 | set audate {} |
|
273 | set audate {} | |
274 | set comname {} |
|
274 | set comname {} | |
275 | set comdate {} |
|
275 | set comdate {} | |
276 | set rev {} |
|
276 | set rev {} | |
277 | if {![info exists nchildren($id)]} { |
|
277 | if {![info exists nchildren($id)]} { | |
278 | set children($id) {} |
|
278 | set children($id) {} | |
279 | set nchildren($id) 0 |
|
279 | set nchildren($id) 0 | |
280 | set ncleft($id) 0 |
|
280 | set ncleft($id) 0 | |
281 | } |
|
281 | } | |
282 | set parents($id) $olds |
|
282 | set parents($id) $olds | |
283 | set nparents($id) [llength $olds] |
|
283 | set nparents($id) [llength $olds] | |
284 | foreach p $olds { |
|
284 | foreach p $olds { | |
285 | if {![info exists nchildren($p)]} { |
|
285 | if {![info exists nchildren($p)]} { | |
286 | set children($p) [list $id] |
|
286 | set children($p) [list $id] | |
287 | set nchildren($p) 1 |
|
287 | set nchildren($p) 1 | |
288 | set ncleft($p) 1 |
|
288 | set ncleft($p) 1 | |
289 | } elseif {[lsearch -exact $children($p) $id] < 0} { |
|
289 | } elseif {[lsearch -exact $children($p) $id] < 0} { | |
290 | lappend children($p) $id |
|
290 | lappend children($p) $id | |
291 | incr nchildren($p) |
|
291 | incr nchildren($p) | |
292 | incr ncleft($p) |
|
292 | incr ncleft($p) | |
293 | } |
|
293 | } | |
294 | } |
|
294 | } | |
295 | regsub -all "\r\n" $contents "\n" contents |
|
295 | regsub -all "\r\n" $contents "\n" contents | |
296 | foreach line [split $contents "\n"] { |
|
296 | foreach line [split $contents "\n"] { | |
297 | if {$inhdr} { |
|
297 | if {$inhdr} { | |
298 | set line [split $line] |
|
298 | set line [split $line] | |
299 | if {$line == {}} { |
|
299 | if {$line == {}} { | |
300 | set inhdr 0 |
|
300 | set inhdr 0 | |
301 | } else { |
|
301 | } else { | |
302 | set tag [lindex $line 0] |
|
302 | set tag [lindex $line 0] | |
303 | if {$tag == "author"} { |
|
303 | if {$tag == "author"} { | |
304 | set x [expr {[llength $line] - 2}] |
|
304 | set x [expr {[llength $line] - 2}] | |
305 | set audate [lindex $line $x] |
|
305 | set audate [lindex $line $x] | |
306 | set auname [join [lrange $line 1 [expr {$x - 1}]]] |
|
306 | set auname [join [lrange $line 1 [expr {$x - 1}]]] | |
307 | } elseif {$tag == "committer"} { |
|
307 | } elseif {$tag == "committer"} { | |
308 | set x [expr {[llength $line] - 2}] |
|
308 | set x [expr {[llength $line] - 2}] | |
309 | set comdate [lindex $line $x] |
|
309 | set comdate [lindex $line $x] | |
310 | set comname [join [lrange $line 1 [expr {$x - 1}]]] |
|
310 | set comname [join [lrange $line 1 [expr {$x - 1}]]] | |
311 | } elseif {$tag == "revision"} { |
|
311 | } elseif {$tag == "revision"} { | |
312 | set rev [lindex $line 1] |
|
312 | set rev [lindex $line 1] | |
313 | } |
|
313 | } | |
314 | } |
|
314 | } | |
315 | } else { |
|
315 | } else { | |
316 | if {$comment == {}} { |
|
316 | if {$comment == {}} { | |
317 | set headline [string trim $line] |
|
317 | set headline [string trim $line] | |
318 | } else { |
|
318 | } else { | |
319 | append comment "\n" |
|
319 | append comment "\n" | |
320 | } |
|
320 | } | |
321 | if {!$listed} { |
|
321 | if {!$listed} { | |
322 | # git-rev-list indents the comment by 4 spaces; |
|
322 | # git-rev-list indents the comment by 4 spaces; | |
323 | # if we got this via git-cat-file, add the indentation |
|
323 | # if we got this via git-cat-file, add the indentation | |
324 | append comment " " |
|
324 | append comment " " | |
325 | } |
|
325 | } | |
326 | append comment $line |
|
326 | append comment $line | |
327 | } |
|
327 | } | |
328 | } |
|
328 | } | |
329 | if {$audate != {}} { |
|
329 | if {$audate != {}} { | |
330 | set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"] |
|
330 | set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"] | |
331 | } |
|
331 | } | |
332 | if {$comdate != {}} { |
|
332 | if {$comdate != {}} { | |
333 | set cdate($id) $comdate |
|
333 | set cdate($id) $comdate | |
334 | set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"] |
|
334 | set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"] | |
335 | } |
|
335 | } | |
336 | set commitinfo($id) [list $headline $auname $audate \ |
|
336 | set commitinfo($id) [list $headline $auname $audate \ | |
337 | $comname $comdate $comment $rev] |
|
337 | $comname $comdate $comment $rev] | |
338 | } |
|
338 | } | |
339 |
|
339 | |||
340 | proc readrefs {} { |
|
340 | proc readrefs {} { | |
341 | global tagids idtags headids idheads tagcontents env curid |
|
341 | global tagids idtags headids idheads tagcontents env curid | |
342 |
|
342 | |||
343 | set curid [exec $env(HG) --config ui.report_untrusted=false id] |
|
343 | set curid [exec $env(HG) --config ui.report_untrusted=false id] | |
344 | regexp -- {[[:xdigit:]]+} $curid curid |
|
344 | regexp -- {[[:xdigit:]]+} $curid curid | |
345 |
|
345 | |||
346 | set tags [exec $env(HG) --config ui.report_untrusted=false tags] |
|
346 | set tags [exec $env(HG) --config ui.report_untrusted=false tags] | |
347 | regsub -all "\r\n" $tags "\n" tags |
|
347 | regsub -all "\r\n" $tags "\n" tags | |
348 | set lines [split $tags "\n"] |
|
348 | set lines [split $tags "\n"] | |
349 | foreach f $lines { |
|
349 | foreach f $lines { | |
350 | regexp {(\S+)$} $f full |
|
350 | regexp {(\S+)$} $f full | |
351 | regsub {\s+(\S+)$} $f "" direct |
|
351 | regsub {\s+(\S+)$} $f "" direct | |
352 | set sha [split $full ':'] |
|
352 | set sha [split $full ':'] | |
353 | set tag [lindex $sha 1] |
|
353 | set tag [lindex $sha 1] | |
354 | lappend tagids($direct) $tag |
|
354 | lappend tagids($direct) $tag | |
355 | lappend idtags($tag) $direct |
|
355 | lappend idtags($tag) $direct | |
356 | } |
|
356 | } | |
357 | } |
|
357 | } | |
358 |
|
358 | |||
359 | proc readotherrefs {base dname excl} { |
|
359 | proc readotherrefs {base dname excl} { | |
360 | global otherrefids idotherrefs |
|
360 | global otherrefids idotherrefs | |
361 |
|
361 | |||
362 | set git [gitdir] |
|
362 | set git [gitdir] | |
363 | set files [glob -nocomplain -types f [file join $git $base *]] |
|
363 | set files [glob -nocomplain -types f [file join $git $base *]] | |
364 | foreach f $files { |
|
364 | foreach f $files { | |
365 | catch { |
|
365 | catch { | |
366 | set fd [open $f r] |
|
366 | set fd [open $f r] | |
367 | set line [read $fd 40] |
|
367 | set line [read $fd 40] | |
368 | if {[regexp {^[0-9a-f]{12}} $line id]} { |
|
368 | if {[regexp {^[0-9a-f]{12}} $line id]} { | |
369 | set name "$dname[file tail $f]" |
|
369 | set name "$dname[file tail $f]" | |
370 | set otherrefids($name) $id |
|
370 | set otherrefids($name) $id | |
371 | lappend idotherrefs($id) $name |
|
371 | lappend idotherrefs($id) $name | |
372 | } |
|
372 | } | |
373 | close $fd |
|
373 | close $fd | |
374 | } |
|
374 | } | |
375 | } |
|
375 | } | |
376 | set dirs [glob -nocomplain -types d [file join $git $base *]] |
|
376 | set dirs [glob -nocomplain -types d [file join $git $base *]] | |
377 | foreach d $dirs { |
|
377 | foreach d $dirs { | |
378 | set dir [file tail $d] |
|
378 | set dir [file tail $d] | |
379 | if {[lsearch -exact $excl $dir] >= 0} continue |
|
379 | if {[lsearch -exact $excl $dir] >= 0} continue | |
380 | readotherrefs [file join $base $dir] "$dname$dir/" {} |
|
380 | readotherrefs [file join $base $dir] "$dname$dir/" {} | |
381 | } |
|
381 | } | |
382 | } |
|
382 | } | |
383 |
|
383 | |||
384 | proc allcansmousewheel {delta} { |
|
384 | proc allcansmousewheel {delta} { | |
385 | set delta [expr -5*(int($delta)/abs($delta))] |
|
385 | set delta [expr -5*(int($delta)/abs($delta))] | |
386 | allcanvs yview scroll $delta units |
|
386 | allcanvs yview scroll $delta units | |
387 | } |
|
387 | } | |
388 |
|
388 | |||
389 | proc error_popup msg { |
|
389 | proc error_popup msg { | |
390 | set w .error |
|
390 | set w .error | |
391 | toplevel $w |
|
391 | toplevel $w | |
392 | wm transient $w . |
|
392 | wm transient $w . | |
393 | message $w.m -text $msg -justify center -aspect 400 |
|
393 | message $w.m -text $msg -justify center -aspect 400 | |
394 | pack $w.m -side top -fill x -padx 20 -pady 20 |
|
394 | pack $w.m -side top -fill x -padx 20 -pady 20 | |
395 | button $w.ok -text OK -command "destroy $w" |
|
395 | button $w.ok -text OK -command "destroy $w" | |
396 | pack $w.ok -side bottom -fill x |
|
396 | pack $w.ok -side bottom -fill x | |
397 | bind $w <Visibility> "grab $w; focus $w" |
|
397 | bind $w <Visibility> "grab $w; focus $w" | |
398 | tkwait window $w |
|
398 | tkwait window $w | |
399 | } |
|
399 | } | |
400 |
|
400 | |||
401 | proc makewindow {} { |
|
401 | proc makewindow {} { | |
402 | global canv canv2 canv3 linespc charspc ctext cflist textfont |
|
402 | global canv canv2 canv3 linespc charspc ctext cflist textfont | |
403 | global findtype findtypemenu findloc findstring fstring geometry |
|
403 | global findtype findtypemenu findloc findstring fstring geometry | |
404 | global entries sha1entry sha1string sha1but |
|
404 | global entries sha1entry sha1string sha1but | |
405 | global maincursor textcursor curtextcursor |
|
405 | global maincursor textcursor curtextcursor | |
406 | global rowctxmenu gaudydiff mergemax |
|
406 | global rowctxmenu gaudydiff mergemax | |
407 | global hgvdiff |
|
407 | global hgvdiff | |
408 |
|
408 | |||
409 | menu .bar |
|
409 | menu .bar | |
410 | .bar add cascade -label "File" -menu .bar.file |
|
410 | .bar add cascade -label "File" -menu .bar.file | |
411 | menu .bar.file |
|
411 | menu .bar.file | |
412 | .bar.file add command -label "Reread references" -command rereadrefs |
|
412 | .bar.file add command -label "Reread references" -command rereadrefs | |
413 | .bar.file add command -label "Quit" -command doquit |
|
413 | .bar.file add command -label "Quit" -command doquit | |
414 | menu .bar.help |
|
414 | menu .bar.help | |
415 | .bar add cascade -label "Help" -menu .bar.help |
|
415 | .bar add cascade -label "Help" -menu .bar.help | |
416 | .bar.help add command -label "About gitk" -command about |
|
416 | .bar.help add command -label "About gitk" -command about | |
417 | . configure -menu .bar |
|
417 | . configure -menu .bar | |
418 |
|
418 | |||
419 | if {![info exists geometry(canv1)]} { |
|
419 | if {![info exists geometry(canv1)]} { | |
420 | set geometry(canv1) [expr 45 * $charspc] |
|
420 | set geometry(canv1) [expr 45 * $charspc] | |
421 | set geometry(canv2) [expr 30 * $charspc] |
|
421 | set geometry(canv2) [expr 30 * $charspc] | |
422 | set geometry(canv3) [expr 15 * $charspc] |
|
422 | set geometry(canv3) [expr 15 * $charspc] | |
423 | set geometry(canvh) [expr 25 * $linespc + 4] |
|
423 | set geometry(canvh) [expr 25 * $linespc + 4] | |
424 | set geometry(ctextw) 80 |
|
424 | set geometry(ctextw) 80 | |
425 | set geometry(ctexth) 30 |
|
425 | set geometry(ctexth) 30 | |
426 | set geometry(cflistw) 30 |
|
426 | set geometry(cflistw) 30 | |
427 | } |
|
427 | } | |
428 | panedwindow .ctop -orient vertical |
|
428 | panedwindow .ctop -orient vertical | |
429 | if {[info exists geometry(width)]} { |
|
429 | if {[info exists geometry(width)]} { | |
430 | .ctop conf -width $geometry(width) -height $geometry(height) |
|
430 | .ctop conf -width $geometry(width) -height $geometry(height) | |
431 | set texth [expr {$geometry(height) - $geometry(canvh) - 56}] |
|
431 | set texth [expr {$geometry(height) - $geometry(canvh) - 56}] | |
432 | set geometry(ctexth) [expr {($texth - 8) / |
|
432 | set geometry(ctexth) [expr {($texth - 8) / | |
433 | [font metrics $textfont -linespace]}] |
|
433 | [font metrics $textfont -linespace]}] | |
434 | } |
|
434 | } | |
435 | frame .ctop.top |
|
435 | frame .ctop.top | |
436 | frame .ctop.top.bar |
|
436 | frame .ctop.top.bar | |
437 | pack .ctop.top.bar -side bottom -fill x |
|
437 | pack .ctop.top.bar -side bottom -fill x | |
438 | set cscroll .ctop.top.csb |
|
438 | set cscroll .ctop.top.csb | |
439 | scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0 |
|
439 | scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0 | |
440 | pack $cscroll -side right -fill y |
|
440 | pack $cscroll -side right -fill y | |
441 | panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4 |
|
441 | panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4 | |
442 | pack .ctop.top.clist -side top -fill both -expand 1 |
|
442 | pack .ctop.top.clist -side top -fill both -expand 1 | |
443 | .ctop add .ctop.top |
|
443 | .ctop add .ctop.top | |
444 | set canv .ctop.top.clist.canv |
|
444 | set canv .ctop.top.clist.canv | |
445 | canvas $canv -height $geometry(canvh) -width $geometry(canv1) \ |
|
445 | canvas $canv -height $geometry(canvh) -width $geometry(canv1) \ | |
446 | -bg white -bd 0 \ |
|
446 | -bg white -bd 0 \ | |
447 | -yscrollincr $linespc -yscrollcommand "$cscroll set" -selectbackground grey |
|
447 | -yscrollincr $linespc -yscrollcommand "$cscroll set" -selectbackground grey | |
448 | .ctop.top.clist add $canv |
|
448 | .ctop.top.clist add $canv | |
449 | set canv2 .ctop.top.clist.canv2 |
|
449 | set canv2 .ctop.top.clist.canv2 | |
450 | canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \ |
|
450 | canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \ | |
451 | -bg white -bd 0 -yscrollincr $linespc -selectbackground grey |
|
451 | -bg white -bd 0 -yscrollincr $linespc -selectbackground grey | |
452 | .ctop.top.clist add $canv2 |
|
452 | .ctop.top.clist add $canv2 | |
453 | set canv3 .ctop.top.clist.canv3 |
|
453 | set canv3 .ctop.top.clist.canv3 | |
454 | canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \ |
|
454 | canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \ | |
455 | -bg white -bd 0 -yscrollincr $linespc -selectbackground grey |
|
455 | -bg white -bd 0 -yscrollincr $linespc -selectbackground grey | |
456 | .ctop.top.clist add $canv3 |
|
456 | .ctop.top.clist add $canv3 | |
457 | bind .ctop.top.clist <Configure> {resizeclistpanes %W %w} |
|
457 | bind .ctop.top.clist <Configure> {resizeclistpanes %W %w} | |
458 |
|
458 | |||
459 | set sha1entry .ctop.top.bar.sha1 |
|
459 | set sha1entry .ctop.top.bar.sha1 | |
460 | set entries $sha1entry |
|
460 | set entries $sha1entry | |
461 | set sha1but .ctop.top.bar.sha1label |
|
461 | set sha1but .ctop.top.bar.sha1label | |
462 | button $sha1but -text "SHA1 ID: " -state disabled -relief flat \ |
|
462 | button $sha1but -text "SHA1 ID: " -state disabled -relief flat \ | |
463 | -command gotocommit -width 8 |
|
463 | -command gotocommit -width 8 | |
464 | $sha1but conf -disabledforeground [$sha1but cget -foreground] |
|
464 | $sha1but conf -disabledforeground [$sha1but cget -foreground] | |
465 | pack .ctop.top.bar.sha1label -side left |
|
465 | pack .ctop.top.bar.sha1label -side left | |
466 | entry $sha1entry -width 40 -font $textfont -textvariable sha1string |
|
466 | entry $sha1entry -width 40 -font $textfont -textvariable sha1string | |
467 | trace add variable sha1string write sha1change |
|
467 | trace add variable sha1string write sha1change | |
468 | pack $sha1entry -side left -pady 2 |
|
468 | pack $sha1entry -side left -pady 2 | |
469 |
|
469 | |||
470 | image create bitmap bm-left -data { |
|
470 | image create bitmap bm-left -data { | |
471 | #define left_width 16 |
|
471 | #define left_width 16 | |
472 | #define left_height 16 |
|
472 | #define left_height 16 | |
473 | static unsigned char left_bits[] = { |
|
473 | static unsigned char left_bits[] = { | |
474 | 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00, |
|
474 | 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00, | |
475 | 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00, |
|
475 | 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00, | |
476 | 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01}; |
|
476 | 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01}; | |
477 | } |
|
477 | } | |
478 | image create bitmap bm-right -data { |
|
478 | image create bitmap bm-right -data { | |
479 | #define right_width 16 |
|
479 | #define right_width 16 | |
480 | #define right_height 16 |
|
480 | #define right_height 16 | |
481 | static unsigned char right_bits[] = { |
|
481 | static unsigned char right_bits[] = { | |
482 | 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c, |
|
482 | 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c, | |
483 | 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c, |
|
483 | 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c, | |
484 | 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01}; |
|
484 | 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01}; | |
485 | } |
|
485 | } | |
486 | button .ctop.top.bar.leftbut -image bm-left -command goback \ |
|
486 | button .ctop.top.bar.leftbut -image bm-left -command goback \ | |
487 | -state disabled -width 26 |
|
487 | -state disabled -width 26 | |
488 | pack .ctop.top.bar.leftbut -side left -fill y |
|
488 | pack .ctop.top.bar.leftbut -side left -fill y | |
489 | button .ctop.top.bar.rightbut -image bm-right -command goforw \ |
|
489 | button .ctop.top.bar.rightbut -image bm-right -command goforw \ | |
490 | -state disabled -width 26 |
|
490 | -state disabled -width 26 | |
491 | pack .ctop.top.bar.rightbut -side left -fill y |
|
491 | pack .ctop.top.bar.rightbut -side left -fill y | |
492 |
|
492 | |||
493 | button .ctop.top.bar.findbut -text "Find" -command dofind |
|
493 | button .ctop.top.bar.findbut -text "Find" -command dofind | |
494 | pack .ctop.top.bar.findbut -side left |
|
494 | pack .ctop.top.bar.findbut -side left | |
495 | set findstring {} |
|
495 | set findstring {} | |
496 | set fstring .ctop.top.bar.findstring |
|
496 | set fstring .ctop.top.bar.findstring | |
497 | lappend entries $fstring |
|
497 | lappend entries $fstring | |
498 | entry $fstring -width 30 -font $textfont -textvariable findstring |
|
498 | entry $fstring -width 30 -font $textfont -textvariable findstring | |
499 | pack $fstring -side left -expand 1 -fill x |
|
499 | pack $fstring -side left -expand 1 -fill x | |
500 | set findtype Exact |
|
500 | set findtype Exact | |
501 | set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \ |
|
501 | set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \ | |
502 | findtype Exact IgnCase Regexp] |
|
502 | findtype Exact IgnCase Regexp] | |
503 | set findloc "All fields" |
|
503 | set findloc "All fields" | |
504 | tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \ |
|
504 | tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \ | |
505 | Comments Author Committer Files Pickaxe |
|
505 | Comments Author Committer Files Pickaxe | |
506 | pack .ctop.top.bar.findloc -side right |
|
506 | pack .ctop.top.bar.findloc -side right | |
507 | pack .ctop.top.bar.findtype -side right |
|
507 | pack .ctop.top.bar.findtype -side right | |
508 | # for making sure type==Exact whenever loc==Pickaxe |
|
508 | # for making sure type==Exact whenever loc==Pickaxe | |
509 | trace add variable findloc write findlocchange |
|
509 | trace add variable findloc write findlocchange | |
510 |
|
510 | |||
511 | panedwindow .ctop.cdet -orient horizontal |
|
511 | panedwindow .ctop.cdet -orient horizontal | |
512 | .ctop add .ctop.cdet |
|
512 | .ctop add .ctop.cdet | |
513 | frame .ctop.cdet.left |
|
513 | frame .ctop.cdet.left | |
514 | set ctext .ctop.cdet.left.ctext |
|
514 | set ctext .ctop.cdet.left.ctext | |
515 | text $ctext -bg white -state disabled -font $textfont \ |
|
515 | text $ctext -bg white -state disabled -font $textfont \ | |
516 | -width $geometry(ctextw) -height $geometry(ctexth) \ |
|
516 | -width $geometry(ctextw) -height $geometry(ctexth) \ | |
517 | -yscrollcommand ".ctop.cdet.left.sb set" \ |
|
517 | -yscrollcommand ".ctop.cdet.left.sb set" \ | |
518 | -xscrollcommand ".ctop.cdet.left.hb set" -wrap none |
|
518 | -xscrollcommand ".ctop.cdet.left.hb set" -wrap none | |
519 | scrollbar .ctop.cdet.left.sb -command "$ctext yview" |
|
519 | scrollbar .ctop.cdet.left.sb -command "$ctext yview" | |
520 | scrollbar .ctop.cdet.left.hb -orient horizontal -command "$ctext xview" |
|
520 | scrollbar .ctop.cdet.left.hb -orient horizontal -command "$ctext xview" | |
521 | pack .ctop.cdet.left.sb -side right -fill y |
|
521 | pack .ctop.cdet.left.sb -side right -fill y | |
522 | pack .ctop.cdet.left.hb -side bottom -fill x |
|
522 | pack .ctop.cdet.left.hb -side bottom -fill x | |
523 | pack $ctext -side left -fill both -expand 1 |
|
523 | pack $ctext -side left -fill both -expand 1 | |
524 | .ctop.cdet add .ctop.cdet.left |
|
524 | .ctop.cdet add .ctop.cdet.left | |
525 |
|
525 | |||
526 | $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa" |
|
526 | $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa" | |
527 | if {$gaudydiff} { |
|
527 | if {$gaudydiff} { | |
528 | $ctext tag conf hunksep -back blue -fore white |
|
528 | $ctext tag conf hunksep -back blue -fore white | |
529 | $ctext tag conf d0 -back "#ff8080" |
|
529 | $ctext tag conf d0 -back "#ff8080" | |
530 | $ctext tag conf d1 -back green |
|
530 | $ctext tag conf d1 -back green | |
531 | } else { |
|
531 | } else { | |
532 | $ctext tag conf hunksep -fore blue |
|
532 | $ctext tag conf hunksep -fore blue | |
533 | $ctext tag conf d0 -fore red |
|
533 | $ctext tag conf d0 -fore red | |
534 | $ctext tag conf d1 -fore "#00a000" |
|
534 | $ctext tag conf d1 -fore "#00a000" | |
535 | $ctext tag conf m0 -fore red |
|
535 | $ctext tag conf m0 -fore red | |
536 | $ctext tag conf m1 -fore blue |
|
536 | $ctext tag conf m1 -fore blue | |
537 | $ctext tag conf m2 -fore green |
|
537 | $ctext tag conf m2 -fore green | |
538 | $ctext tag conf m3 -fore purple |
|
538 | $ctext tag conf m3 -fore purple | |
539 | $ctext tag conf m4 -fore brown |
|
539 | $ctext tag conf m4 -fore brown | |
540 | $ctext tag conf mmax -fore darkgrey |
|
540 | $ctext tag conf mmax -fore darkgrey | |
541 | set mergemax 5 |
|
541 | set mergemax 5 | |
542 | $ctext tag conf mresult -font [concat $textfont bold] |
|
542 | $ctext tag conf mresult -font [concat $textfont bold] | |
543 | $ctext tag conf msep -font [concat $textfont bold] |
|
543 | $ctext tag conf msep -font [concat $textfont bold] | |
544 | $ctext tag conf found -back yellow |
|
544 | $ctext tag conf found -back yellow | |
545 | } |
|
545 | } | |
546 |
|
546 | |||
547 | frame .ctop.cdet.right |
|
547 | frame .ctop.cdet.right | |
548 | set cflist .ctop.cdet.right.cfiles |
|
548 | set cflist .ctop.cdet.right.cfiles | |
549 | listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \ |
|
549 | listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \ | |
550 | -yscrollcommand ".ctop.cdet.right.sb set" |
|
550 | -yscrollcommand ".ctop.cdet.right.sb set" | |
551 | scrollbar .ctop.cdet.right.sb -command "$cflist yview" |
|
551 | scrollbar .ctop.cdet.right.sb -command "$cflist yview" | |
552 | pack .ctop.cdet.right.sb -side right -fill y |
|
552 | pack .ctop.cdet.right.sb -side right -fill y | |
553 | pack $cflist -side left -fill both -expand 1 |
|
553 | pack $cflist -side left -fill both -expand 1 | |
554 | .ctop.cdet add .ctop.cdet.right |
|
554 | .ctop.cdet add .ctop.cdet.right | |
555 | bind .ctop.cdet <Configure> {resizecdetpanes %W %w} |
|
555 | bind .ctop.cdet <Configure> {resizecdetpanes %W %w} | |
556 |
|
556 | |||
557 | pack .ctop -side top -fill both -expand 1 |
|
557 | pack .ctop -side top -fill both -expand 1 | |
558 |
|
558 | |||
559 | bindall <1> {selcanvline %W %x %y} |
|
559 | bindall <1> {selcanvline %W %x %y} | |
560 | #bindall <B1-Motion> {selcanvline %W %x %y} |
|
560 | #bindall <B1-Motion> {selcanvline %W %x %y} | |
561 | bindall <MouseWheel> "allcansmousewheel %D" |
|
561 | bindall <MouseWheel> "allcansmousewheel %D" | |
562 | bindall <ButtonRelease-4> "allcanvs yview scroll -5 units" |
|
562 | bindall <ButtonRelease-4> "allcanvs yview scroll -5 units" | |
563 | bindall <ButtonRelease-5> "allcanvs yview scroll 5 units" |
|
563 | bindall <ButtonRelease-5> "allcanvs yview scroll 5 units" | |
564 | bindall <2> "allcanvs scan mark 0 %y" |
|
564 | bindall <2> "allcanvs scan mark 0 %y" | |
565 | bindall <B2-Motion> "allcanvs scan dragto 0 %y" |
|
565 | bindall <B2-Motion> "allcanvs scan dragto 0 %y" | |
566 | bind . <Key-Up> "selnextline -1" |
|
566 | bind . <Key-Up> "selnextline -1" | |
567 | bind . <Key-Down> "selnextline 1" |
|
567 | bind . <Key-Down> "selnextline 1" | |
568 | bind . <Key-Prior> "allcanvs yview scroll -1 pages" |
|
568 | bind . <Key-Prior> "allcanvs yview scroll -1 pages" | |
569 | bind . <Key-Next> "allcanvs yview scroll 1 pages" |
|
569 | bind . <Key-Next> "allcanvs yview scroll 1 pages" | |
570 | bindkey <Key-Delete> "$ctext yview scroll -1 pages" |
|
570 | bindkey <Key-Delete> "$ctext yview scroll -1 pages" | |
571 | bindkey <Key-BackSpace> "$ctext yview scroll -1 pages" |
|
571 | bindkey <Key-BackSpace> "$ctext yview scroll -1 pages" | |
572 | bindkey <Key-space> "$ctext yview scroll 1 pages" |
|
572 | bindkey <Key-space> "$ctext yview scroll 1 pages" | |
573 | bindkey p "selnextline -1" |
|
573 | bindkey p "selnextline -1" | |
574 | bindkey n "selnextline 1" |
|
574 | bindkey n "selnextline 1" | |
575 | bindkey b "$ctext yview scroll -1 pages" |
|
575 | bindkey b "$ctext yview scroll -1 pages" | |
576 | bindkey d "$ctext yview scroll 18 units" |
|
576 | bindkey d "$ctext yview scroll 18 units" | |
577 | bindkey u "$ctext yview scroll -18 units" |
|
577 | bindkey u "$ctext yview scroll -18 units" | |
578 | bindkey / {findnext 1} |
|
578 | bindkey / {findnext 1} | |
579 | bindkey <Key-Return> {findnext 0} |
|
579 | bindkey <Key-Return> {findnext 0} | |
580 | bindkey ? findprev |
|
580 | bindkey ? findprev | |
581 | bindkey f nextfile |
|
581 | bindkey f nextfile | |
582 | bind . <Control-q> doquit |
|
582 | bind . <Control-q> doquit | |
583 | bind . <Control-w> doquit |
|
583 | bind . <Control-w> doquit | |
584 | bind . <Control-f> dofind |
|
584 | bind . <Control-f> dofind | |
585 | bind . <Control-g> {findnext 0} |
|
585 | bind . <Control-g> {findnext 0} | |
586 | bind . <Control-r> findprev |
|
586 | bind . <Control-r> findprev | |
587 | bind . <Control-equal> {incrfont 1} |
|
587 | bind . <Control-equal> {incrfont 1} | |
588 | bind . <Control-KP_Add> {incrfont 1} |
|
588 | bind . <Control-KP_Add> {incrfont 1} | |
589 | bind . <Control-minus> {incrfont -1} |
|
589 | bind . <Control-minus> {incrfont -1} | |
590 | bind . <Control-KP_Subtract> {incrfont -1} |
|
590 | bind . <Control-KP_Subtract> {incrfont -1} | |
591 | bind $cflist <<ListboxSelect>> listboxsel |
|
591 | bind $cflist <<ListboxSelect>> listboxsel | |
592 | bind . <Destroy> {savestuff %W} |
|
592 | bind . <Destroy> {savestuff %W} | |
593 | bind . <Button-1> "click %W" |
|
593 | bind . <Button-1> "click %W" | |
594 | bind $fstring <Key-Return> dofind |
|
594 | bind $fstring <Key-Return> dofind | |
595 | bind $sha1entry <Key-Return> gotocommit |
|
595 | bind $sha1entry <Key-Return> gotocommit | |
596 | bind $sha1entry <<PasteSelection>> clearsha1 |
|
596 | bind $sha1entry <<PasteSelection>> clearsha1 | |
597 |
|
597 | |||
598 | set maincursor [. cget -cursor] |
|
598 | set maincursor [. cget -cursor] | |
599 | set textcursor [$ctext cget -cursor] |
|
599 | set textcursor [$ctext cget -cursor] | |
600 | set curtextcursor $textcursor |
|
600 | set curtextcursor $textcursor | |
601 |
|
601 | |||
602 | set rowctxmenu .rowctxmenu |
|
602 | set rowctxmenu .rowctxmenu | |
603 | menu $rowctxmenu -tearoff 0 |
|
603 | menu $rowctxmenu -tearoff 0 | |
604 | $rowctxmenu add command -label "Diff this -> selected" \ |
|
604 | $rowctxmenu add command -label "Diff this -> selected" \ | |
605 | -command {diffvssel 0} |
|
605 | -command {diffvssel 0} | |
606 | $rowctxmenu add command -label "Diff selected -> this" \ |
|
606 | $rowctxmenu add command -label "Diff selected -> this" \ | |
607 | -command {diffvssel 1} |
|
607 | -command {diffvssel 1} | |
608 | $rowctxmenu add command -label "Make patch" -command mkpatch |
|
608 | $rowctxmenu add command -label "Make patch" -command mkpatch | |
609 | $rowctxmenu add command -label "Create tag" -command mktag |
|
609 | $rowctxmenu add command -label "Create tag" -command mktag | |
610 | $rowctxmenu add command -label "Write commit to file" -command writecommit |
|
610 | $rowctxmenu add command -label "Write commit to file" -command writecommit | |
611 | if { $hgvdiff ne "" } { |
|
611 | if { $hgvdiff ne "" } { | |
612 | $rowctxmenu add command -label "Visual diff with parent" \ |
|
612 | $rowctxmenu add command -label "Visual diff with parent" \ | |
613 | -command {vdiff 1} |
|
613 | -command {vdiff 1} | |
614 | $rowctxmenu add command -label "Visual diff with selected" \ |
|
614 | $rowctxmenu add command -label "Visual diff with selected" \ | |
615 | -command {vdiff 0} |
|
615 | -command {vdiff 0} | |
616 | } |
|
616 | } | |
617 | } |
|
617 | } | |
618 |
|
618 | |||
619 | # when we make a key binding for the toplevel, make sure |
|
619 | # when we make a key binding for the toplevel, make sure | |
620 | # it doesn't get triggered when that key is pressed in the |
|
620 | # it doesn't get triggered when that key is pressed in the | |
621 | # find string entry widget. |
|
621 | # find string entry widget. | |
622 | proc bindkey {ev script} { |
|
622 | proc bindkey {ev script} { | |
623 | global entries |
|
623 | global entries | |
624 | bind . $ev $script |
|
624 | bind . $ev $script | |
625 | set escript [bind Entry $ev] |
|
625 | set escript [bind Entry $ev] | |
626 | if {$escript == {}} { |
|
626 | if {$escript == {}} { | |
627 | set escript [bind Entry <Key>] |
|
627 | set escript [bind Entry <Key>] | |
628 | } |
|
628 | } | |
629 | foreach e $entries { |
|
629 | foreach e $entries { | |
630 | bind $e $ev "$escript; break" |
|
630 | bind $e $ev "$escript; break" | |
631 | } |
|
631 | } | |
632 | } |
|
632 | } | |
633 |
|
633 | |||
634 | # set the focus back to the toplevel for any click outside |
|
634 | # set the focus back to the toplevel for any click outside | |
635 | # the entry widgets |
|
635 | # the entry widgets | |
636 | proc click {w} { |
|
636 | proc click {w} { | |
637 | global entries |
|
637 | global entries | |
638 | foreach e $entries { |
|
638 | foreach e $entries { | |
639 | if {$w == $e} return |
|
639 | if {$w == $e} return | |
640 | } |
|
640 | } | |
641 | focus . |
|
641 | focus . | |
642 | } |
|
642 | } | |
643 |
|
643 | |||
644 | proc savestuff {w} { |
|
644 | proc savestuff {w} { | |
645 | global canv canv2 canv3 ctext cflist mainfont textfont |
|
645 | global canv canv2 canv3 ctext cflist mainfont textfont | |
646 | global stuffsaved findmergefiles gaudydiff maxgraphpct |
|
646 | global stuffsaved findmergefiles gaudydiff maxgraphpct | |
647 | global maxwidth authorcolors curidfont |
|
647 | global maxwidth authorcolors curidfont | |
648 |
|
648 | |||
649 | if {$stuffsaved} return |
|
649 | if {$stuffsaved} return | |
650 | if {![winfo viewable .]} return |
|
650 | if {![winfo viewable .]} return | |
651 | catch { |
|
651 | catch { | |
652 |
set f [open "~/.g |
|
652 | set f [open "~/.hgk-new" w] | |
653 | puts $f [list set mainfont $mainfont] |
|
653 | puts $f [list set mainfont $mainfont] | |
654 | puts $f [list set curidfont $curidfont] |
|
654 | puts $f [list set curidfont $curidfont] | |
655 | puts $f [list set textfont $textfont] |
|
655 | puts $f [list set textfont $textfont] | |
656 | puts $f [list set findmergefiles $findmergefiles] |
|
656 | puts $f [list set findmergefiles $findmergefiles] | |
657 | puts $f [list set gaudydiff $gaudydiff] |
|
657 | puts $f [list set gaudydiff $gaudydiff] | |
658 | puts $f [list set maxgraphpct $maxgraphpct] |
|
658 | puts $f [list set maxgraphpct $maxgraphpct] | |
659 | puts $f [list set maxwidth $maxwidth] |
|
659 | puts $f [list set maxwidth $maxwidth] | |
660 | puts $f "set geometry(width) [winfo width .ctop]" |
|
660 | puts $f "set geometry(width) [winfo width .ctop]" | |
661 | puts $f "set geometry(height) [winfo height .ctop]" |
|
661 | puts $f "set geometry(height) [winfo height .ctop]" | |
662 | puts $f "set geometry(canv1) [expr [winfo width $canv]-2]" |
|
662 | puts $f "set geometry(canv1) [expr [winfo width $canv]-2]" | |
663 | puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]" |
|
663 | puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]" | |
664 | puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]" |
|
664 | puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]" | |
665 | puts $f "set geometry(canvh) [expr [winfo height $canv]-2]" |
|
665 | puts $f "set geometry(canvh) [expr [winfo height $canv]-2]" | |
666 | set wid [expr {([winfo width $ctext] - 8) \ |
|
666 | set wid [expr {([winfo width $ctext] - 8) \ | |
667 | / [font measure $textfont "0"]}] |
|
667 | / [font measure $textfont "0"]}] | |
668 | puts $f "set geometry(ctextw) $wid" |
|
668 | puts $f "set geometry(ctextw) $wid" | |
669 | set wid [expr {([winfo width $cflist] - 11) \ |
|
669 | set wid [expr {([winfo width $cflist] - 11) \ | |
670 | / [font measure [$cflist cget -font] "0"]}] |
|
670 | / [font measure [$cflist cget -font] "0"]}] | |
671 | puts $f "set geometry(cflistw) $wid" |
|
671 | puts $f "set geometry(cflistw) $wid" | |
672 | puts $f "#" |
|
672 | puts $f "#" | |
673 | puts $f "# authorcolors format:" |
|
673 | puts $f "# authorcolors format:" | |
674 | puts $f "#" |
|
674 | puts $f "#" | |
675 | puts $f "# zero or more sublists of" |
|
675 | puts $f "# zero or more sublists of" | |
676 | puts $f "#" |
|
676 | puts $f "#" | |
677 | puts $f "# { regex color }" |
|
677 | puts $f "# { regex color }" | |
678 | puts $f "#" |
|
678 | puts $f "#" | |
679 | puts $f "# followed by a list of colors" |
|
679 | puts $f "# followed by a list of colors" | |
680 | puts $f "#" |
|
680 | puts $f "#" | |
681 | puts $f "# If the commit author matches a regex in a sublist," |
|
681 | puts $f "# If the commit author matches a regex in a sublist," | |
682 | puts $f "# the commit will be colored by that color" |
|
682 | puts $f "# the commit will be colored by that color" | |
683 | puts $f "# otherwise the next unused entry from the list of colors" |
|
683 | puts $f "# otherwise the next unused entry from the list of colors" | |
684 | puts $f "# will be assigned to this commit and also all other commits" |
|
684 | puts $f "# will be assigned to this commit and also all other commits" | |
685 | puts $f "# of the same author. When the list of colors is exhausted," |
|
685 | puts $f "# of the same author. When the list of colors is exhausted," | |
686 | puts $f "# the last entry will be reused." |
|
686 | puts $f "# the last entry will be reused." | |
687 | puts $f "#" |
|
687 | puts $f "#" | |
688 | puts $f "set authorcolors {$authorcolors}" |
|
688 | puts $f "set authorcolors {$authorcolors}" | |
689 | close $f |
|
689 | close $f | |
690 |
file rename -force "~/.g |
|
690 | file rename -force "~/.hgk-new" "~/.hgk" | |
691 | } |
|
691 | } | |
692 | set stuffsaved 1 |
|
692 | set stuffsaved 1 | |
693 | } |
|
693 | } | |
694 |
|
694 | |||
695 | proc resizeclistpanes {win w} { |
|
695 | proc resizeclistpanes {win w} { | |
696 | global oldwidth |
|
696 | global oldwidth | |
697 | if [info exists oldwidth($win)] { |
|
697 | if [info exists oldwidth($win)] { | |
698 | set s0 [$win sash coord 0] |
|
698 | set s0 [$win sash coord 0] | |
699 | set s1 [$win sash coord 1] |
|
699 | set s1 [$win sash coord 1] | |
700 | if {$w < 60} { |
|
700 | if {$w < 60} { | |
701 | set sash0 [expr {int($w/2 - 2)}] |
|
701 | set sash0 [expr {int($w/2 - 2)}] | |
702 | set sash1 [expr {int($w*5/6 - 2)}] |
|
702 | set sash1 [expr {int($w*5/6 - 2)}] | |
703 | } else { |
|
703 | } else { | |
704 | set factor [expr {1.0 * $w / $oldwidth($win)}] |
|
704 | set factor [expr {1.0 * $w / $oldwidth($win)}] | |
705 | set sash0 [expr {int($factor * [lindex $s0 0])}] |
|
705 | set sash0 [expr {int($factor * [lindex $s0 0])}] | |
706 | set sash1 [expr {int($factor * [lindex $s1 0])}] |
|
706 | set sash1 [expr {int($factor * [lindex $s1 0])}] | |
707 | if {$sash0 < 30} { |
|
707 | if {$sash0 < 30} { | |
708 | set sash0 30 |
|
708 | set sash0 30 | |
709 | } |
|
709 | } | |
710 | if {$sash1 < $sash0 + 20} { |
|
710 | if {$sash1 < $sash0 + 20} { | |
711 | set sash1 [expr $sash0 + 20] |
|
711 | set sash1 [expr $sash0 + 20] | |
712 | } |
|
712 | } | |
713 | if {$sash1 > $w - 10} { |
|
713 | if {$sash1 > $w - 10} { | |
714 | set sash1 [expr $w - 10] |
|
714 | set sash1 [expr $w - 10] | |
715 | if {$sash0 > $sash1 - 20} { |
|
715 | if {$sash0 > $sash1 - 20} { | |
716 | set sash0 [expr $sash1 - 20] |
|
716 | set sash0 [expr $sash1 - 20] | |
717 | } |
|
717 | } | |
718 | } |
|
718 | } | |
719 | } |
|
719 | } | |
720 | $win sash place 0 $sash0 [lindex $s0 1] |
|
720 | $win sash place 0 $sash0 [lindex $s0 1] | |
721 | $win sash place 1 $sash1 [lindex $s1 1] |
|
721 | $win sash place 1 $sash1 [lindex $s1 1] | |
722 | } |
|
722 | } | |
723 | set oldwidth($win) $w |
|
723 | set oldwidth($win) $w | |
724 | } |
|
724 | } | |
725 |
|
725 | |||
726 | proc resizecdetpanes {win w} { |
|
726 | proc resizecdetpanes {win w} { | |
727 | global oldwidth |
|
727 | global oldwidth | |
728 | if [info exists oldwidth($win)] { |
|
728 | if [info exists oldwidth($win)] { | |
729 | set s0 [$win sash coord 0] |
|
729 | set s0 [$win sash coord 0] | |
730 | if {$w < 60} { |
|
730 | if {$w < 60} { | |
731 | set sash0 [expr {int($w*3/4 - 2)}] |
|
731 | set sash0 [expr {int($w*3/4 - 2)}] | |
732 | } else { |
|
732 | } else { | |
733 | set factor [expr {1.0 * $w / $oldwidth($win)}] |
|
733 | set factor [expr {1.0 * $w / $oldwidth($win)}] | |
734 | set sash0 [expr {int($factor * [lindex $s0 0])}] |
|
734 | set sash0 [expr {int($factor * [lindex $s0 0])}] | |
735 | if {$sash0 < 45} { |
|
735 | if {$sash0 < 45} { | |
736 | set sash0 45 |
|
736 | set sash0 45 | |
737 | } |
|
737 | } | |
738 | if {$sash0 > $w - 15} { |
|
738 | if {$sash0 > $w - 15} { | |
739 | set sash0 [expr $w - 15] |
|
739 | set sash0 [expr $w - 15] | |
740 | } |
|
740 | } | |
741 | } |
|
741 | } | |
742 | $win sash place 0 $sash0 [lindex $s0 1] |
|
742 | $win sash place 0 $sash0 [lindex $s0 1] | |
743 | } |
|
743 | } | |
744 | set oldwidth($win) $w |
|
744 | set oldwidth($win) $w | |
745 | } |
|
745 | } | |
746 |
|
746 | |||
747 | proc allcanvs args { |
|
747 | proc allcanvs args { | |
748 | global canv canv2 canv3 |
|
748 | global canv canv2 canv3 | |
749 | eval $canv $args |
|
749 | eval $canv $args | |
750 | eval $canv2 $args |
|
750 | eval $canv2 $args | |
751 | eval $canv3 $args |
|
751 | eval $canv3 $args | |
752 | } |
|
752 | } | |
753 |
|
753 | |||
754 | proc bindall {event action} { |
|
754 | proc bindall {event action} { | |
755 | global canv canv2 canv3 |
|
755 | global canv canv2 canv3 | |
756 | bind $canv $event $action |
|
756 | bind $canv $event $action | |
757 | bind $canv2 $event $action |
|
757 | bind $canv2 $event $action | |
758 | bind $canv3 $event $action |
|
758 | bind $canv3 $event $action | |
759 | } |
|
759 | } | |
760 |
|
760 | |||
761 | proc about {} { |
|
761 | proc about {} { | |
762 | set w .about |
|
762 | set w .about | |
763 | if {[winfo exists $w]} { |
|
763 | if {[winfo exists $w]} { | |
764 | raise $w |
|
764 | raise $w | |
765 | return |
|
765 | return | |
766 | } |
|
766 | } | |
767 | toplevel $w |
|
767 | toplevel $w | |
768 | wm title $w "About gitk" |
|
768 | wm title $w "About gitk" | |
769 | message $w.m -text { |
|
769 | message $w.m -text { | |
770 | Gitk version 1.2 |
|
770 | Gitk version 1.2 | |
771 |
|
771 | |||
772 | Copyright οΏ½ 2005 Paul Mackerras |
|
772 | Copyright οΏ½ 2005 Paul Mackerras | |
773 |
|
773 | |||
774 | Use and redistribute under the terms of the GNU General Public License} \ |
|
774 | Use and redistribute under the terms of the GNU General Public License} \ | |
775 | -justify center -aspect 400 |
|
775 | -justify center -aspect 400 | |
776 | pack $w.m -side top -fill x -padx 20 -pady 20 |
|
776 | pack $w.m -side top -fill x -padx 20 -pady 20 | |
777 | button $w.ok -text Close -command "destroy $w" |
|
777 | button $w.ok -text Close -command "destroy $w" | |
778 | pack $w.ok -side bottom |
|
778 | pack $w.ok -side bottom | |
779 | } |
|
779 | } | |
780 |
|
780 | |||
781 | set aunextcolor 0 |
|
781 | set aunextcolor 0 | |
782 | proc assignauthorcolor {name} { |
|
782 | proc assignauthorcolor {name} { | |
783 | global authorcolors aucolormap aunextcolor |
|
783 | global authorcolors aucolormap aunextcolor | |
784 | if [info exists aucolormap($name)] return |
|
784 | if [info exists aucolormap($name)] return | |
785 |
|
785 | |||
786 | set randomcolors {black} |
|
786 | set randomcolors {black} | |
787 | for {set i 0} {$i < [llength $authorcolors]} {incr i} { |
|
787 | for {set i 0} {$i < [llength $authorcolors]} {incr i} { | |
788 | set col [lindex $authorcolors $i] |
|
788 | set col [lindex $authorcolors $i] | |
789 | if {[llength $col] > 1} { |
|
789 | if {[llength $col] > 1} { | |
790 | set re [lindex $col 0] |
|
790 | set re [lindex $col 0] | |
791 | set c [lindex $col 1] |
|
791 | set c [lindex $col 1] | |
792 | if {[regexp -- $re $name]} { |
|
792 | if {[regexp -- $re $name]} { | |
793 | set aucolormap($name) $c |
|
793 | set aucolormap($name) $c | |
794 | return |
|
794 | return | |
795 | } |
|
795 | } | |
796 | } else { |
|
796 | } else { | |
797 | set randomcolors [lrange $authorcolors $i end] |
|
797 | set randomcolors [lrange $authorcolors $i end] | |
798 | break |
|
798 | break | |
799 | } |
|
799 | } | |
800 | } |
|
800 | } | |
801 |
|
801 | |||
802 | set ncolors [llength $randomcolors] |
|
802 | set ncolors [llength $randomcolors] | |
803 | set c [lindex $randomcolors $aunextcolor] |
|
803 | set c [lindex $randomcolors $aunextcolor] | |
804 | if {[incr aunextcolor] >= $ncolors} { |
|
804 | if {[incr aunextcolor] >= $ncolors} { | |
805 | incr aunextcolor -1 |
|
805 | incr aunextcolor -1 | |
806 | } |
|
806 | } | |
807 | set aucolormap($name) $c |
|
807 | set aucolormap($name) $c | |
808 | } |
|
808 | } | |
809 |
|
809 | |||
810 | proc assigncolor {id} { |
|
810 | proc assigncolor {id} { | |
811 | global commitinfo colormap commcolors colors nextcolor |
|
811 | global commitinfo colormap commcolors colors nextcolor | |
812 | global parents nparents children nchildren |
|
812 | global parents nparents children nchildren | |
813 | global cornercrossings crossings |
|
813 | global cornercrossings crossings | |
814 |
|
814 | |||
815 | if [info exists colormap($id)] return |
|
815 | if [info exists colormap($id)] return | |
816 | set ncolors [llength $colors] |
|
816 | set ncolors [llength $colors] | |
817 | if {$nparents($id) <= 1 && $nchildren($id) == 1} { |
|
817 | if {$nparents($id) <= 1 && $nchildren($id) == 1} { | |
818 | set child [lindex $children($id) 0] |
|
818 | set child [lindex $children($id) 0] | |
819 | if {[info exists colormap($child)] |
|
819 | if {[info exists colormap($child)] | |
820 | && $nparents($child) == 1} { |
|
820 | && $nparents($child) == 1} { | |
821 | set colormap($id) $colormap($child) |
|
821 | set colormap($id) $colormap($child) | |
822 | return |
|
822 | return | |
823 | } |
|
823 | } | |
824 | } |
|
824 | } | |
825 | set badcolors {} |
|
825 | set badcolors {} | |
826 | if {[info exists cornercrossings($id)]} { |
|
826 | if {[info exists cornercrossings($id)]} { | |
827 | foreach x $cornercrossings($id) { |
|
827 | foreach x $cornercrossings($id) { | |
828 | if {[info exists colormap($x)] |
|
828 | if {[info exists colormap($x)] | |
829 | && [lsearch -exact $badcolors $colormap($x)] < 0} { |
|
829 | && [lsearch -exact $badcolors $colormap($x)] < 0} { | |
830 | lappend badcolors $colormap($x) |
|
830 | lappend badcolors $colormap($x) | |
831 | } |
|
831 | } | |
832 | } |
|
832 | } | |
833 | if {[llength $badcolors] >= $ncolors} { |
|
833 | if {[llength $badcolors] >= $ncolors} { | |
834 | set badcolors {} |
|
834 | set badcolors {} | |
835 | } |
|
835 | } | |
836 | } |
|
836 | } | |
837 | set origbad $badcolors |
|
837 | set origbad $badcolors | |
838 | if {[llength $badcolors] < $ncolors - 1} { |
|
838 | if {[llength $badcolors] < $ncolors - 1} { | |
839 | if {[info exists crossings($id)]} { |
|
839 | if {[info exists crossings($id)]} { | |
840 | foreach x $crossings($id) { |
|
840 | foreach x $crossings($id) { | |
841 | if {[info exists colormap($x)] |
|
841 | if {[info exists colormap($x)] | |
842 | && [lsearch -exact $badcolors $colormap($x)] < 0} { |
|
842 | && [lsearch -exact $badcolors $colormap($x)] < 0} { | |
843 | lappend badcolors $colormap($x) |
|
843 | lappend badcolors $colormap($x) | |
844 | } |
|
844 | } | |
845 | } |
|
845 | } | |
846 | if {[llength $badcolors] >= $ncolors} { |
|
846 | if {[llength $badcolors] >= $ncolors} { | |
847 | set badcolors $origbad |
|
847 | set badcolors $origbad | |
848 | } |
|
848 | } | |
849 | } |
|
849 | } | |
850 | set origbad $badcolors |
|
850 | set origbad $badcolors | |
851 | } |
|
851 | } | |
852 | if {[llength $badcolors] < $ncolors - 1} { |
|
852 | if {[llength $badcolors] < $ncolors - 1} { | |
853 | foreach child $children($id) { |
|
853 | foreach child $children($id) { | |
854 | if {[info exists colormap($child)] |
|
854 | if {[info exists colormap($child)] | |
855 | && [lsearch -exact $badcolors $colormap($child)] < 0} { |
|
855 | && [lsearch -exact $badcolors $colormap($child)] < 0} { | |
856 | lappend badcolors $colormap($child) |
|
856 | lappend badcolors $colormap($child) | |
857 | } |
|
857 | } | |
858 | if {[info exists parents($child)]} { |
|
858 | if {[info exists parents($child)]} { | |
859 | foreach p $parents($child) { |
|
859 | foreach p $parents($child) { | |
860 | if {[info exists colormap($p)] |
|
860 | if {[info exists colormap($p)] | |
861 | && [lsearch -exact $badcolors $colormap($p)] < 0} { |
|
861 | && [lsearch -exact $badcolors $colormap($p)] < 0} { | |
862 | lappend badcolors $colormap($p) |
|
862 | lappend badcolors $colormap($p) | |
863 | } |
|
863 | } | |
864 | } |
|
864 | } | |
865 | } |
|
865 | } | |
866 | } |
|
866 | } | |
867 | if {[llength $badcolors] >= $ncolors} { |
|
867 | if {[llength $badcolors] >= $ncolors} { | |
868 | set badcolors $origbad |
|
868 | set badcolors $origbad | |
869 | } |
|
869 | } | |
870 | } |
|
870 | } | |
871 | for {set i 0} {$i <= $ncolors} {incr i} { |
|
871 | for {set i 0} {$i <= $ncolors} {incr i} { | |
872 | set c [lindex $colors $nextcolor] |
|
872 | set c [lindex $colors $nextcolor] | |
873 | if {[incr nextcolor] >= $ncolors} { |
|
873 | if {[incr nextcolor] >= $ncolors} { | |
874 | set nextcolor 0 |
|
874 | set nextcolor 0 | |
875 | } |
|
875 | } | |
876 | if {[lsearch -exact $badcolors $c]} break |
|
876 | if {[lsearch -exact $badcolors $c]} break | |
877 | } |
|
877 | } | |
878 | set colormap($id) $c |
|
878 | set colormap($id) $c | |
879 | } |
|
879 | } | |
880 |
|
880 | |||
881 | proc initgraph {} { |
|
881 | proc initgraph {} { | |
882 | global canvy canvy0 lineno numcommits nextcolor linespc |
|
882 | global canvy canvy0 lineno numcommits nextcolor linespc | |
883 | global mainline mainlinearrow sidelines |
|
883 | global mainline mainlinearrow sidelines | |
884 | global nchildren ncleft |
|
884 | global nchildren ncleft | |
885 | global displist nhyperspace |
|
885 | global displist nhyperspace | |
886 |
|
886 | |||
887 | allcanvs delete all |
|
887 | allcanvs delete all | |
888 | set nextcolor 0 |
|
888 | set nextcolor 0 | |
889 | set canvy $canvy0 |
|
889 | set canvy $canvy0 | |
890 | set lineno -1 |
|
890 | set lineno -1 | |
891 | set numcommits 0 |
|
891 | set numcommits 0 | |
892 | catch {unset mainline} |
|
892 | catch {unset mainline} | |
893 | catch {unset mainlinearrow} |
|
893 | catch {unset mainlinearrow} | |
894 | catch {unset sidelines} |
|
894 | catch {unset sidelines} | |
895 | foreach id [array names nchildren] { |
|
895 | foreach id [array names nchildren] { | |
896 | set ncleft($id) $nchildren($id) |
|
896 | set ncleft($id) $nchildren($id) | |
897 | } |
|
897 | } | |
898 | set displist {} |
|
898 | set displist {} | |
899 | set nhyperspace 0 |
|
899 | set nhyperspace 0 | |
900 | } |
|
900 | } | |
901 |
|
901 | |||
902 | proc bindline {t id} { |
|
902 | proc bindline {t id} { | |
903 | global canv |
|
903 | global canv | |
904 |
|
904 | |||
905 | $canv bind $t <Enter> "lineenter %x %y $id" |
|
905 | $canv bind $t <Enter> "lineenter %x %y $id" | |
906 | $canv bind $t <Motion> "linemotion %x %y $id" |
|
906 | $canv bind $t <Motion> "linemotion %x %y $id" | |
907 | $canv bind $t <Leave> "lineleave $id" |
|
907 | $canv bind $t <Leave> "lineleave $id" | |
908 | $canv bind $t <Button-1> "lineclick %x %y $id 1" |
|
908 | $canv bind $t <Button-1> "lineclick %x %y $id 1" | |
909 | } |
|
909 | } | |
910 |
|
910 | |||
911 | proc drawlines {id xtra} { |
|
911 | proc drawlines {id xtra} { | |
912 | global mainline mainlinearrow sidelines lthickness colormap canv |
|
912 | global mainline mainlinearrow sidelines lthickness colormap canv | |
913 |
|
913 | |||
914 | $canv delete lines.$id |
|
914 | $canv delete lines.$id | |
915 | if {[info exists mainline($id)]} { |
|
915 | if {[info exists mainline($id)]} { | |
916 | set t [$canv create line $mainline($id) \ |
|
916 | set t [$canv create line $mainline($id) \ | |
917 | -width [expr {($xtra + 1) * $lthickness}] \ |
|
917 | -width [expr {($xtra + 1) * $lthickness}] \ | |
918 | -fill $colormap($id) -tags lines.$id \ |
|
918 | -fill $colormap($id) -tags lines.$id \ | |
919 | -arrow $mainlinearrow($id)] |
|
919 | -arrow $mainlinearrow($id)] | |
920 | $canv lower $t |
|
920 | $canv lower $t | |
921 | bindline $t $id |
|
921 | bindline $t $id | |
922 | } |
|
922 | } | |
923 | if {[info exists sidelines($id)]} { |
|
923 | if {[info exists sidelines($id)]} { | |
924 | foreach ls $sidelines($id) { |
|
924 | foreach ls $sidelines($id) { | |
925 | set coords [lindex $ls 0] |
|
925 | set coords [lindex $ls 0] | |
926 | set thick [lindex $ls 1] |
|
926 | set thick [lindex $ls 1] | |
927 | set arrow [lindex $ls 2] |
|
927 | set arrow [lindex $ls 2] | |
928 | set t [$canv create line $coords -fill $colormap($id) \ |
|
928 | set t [$canv create line $coords -fill $colormap($id) \ | |
929 | -width [expr {($thick + $xtra) * $lthickness}] \ |
|
929 | -width [expr {($thick + $xtra) * $lthickness}] \ | |
930 | -arrow $arrow -tags lines.$id] |
|
930 | -arrow $arrow -tags lines.$id] | |
931 | $canv lower $t |
|
931 | $canv lower $t | |
932 | bindline $t $id |
|
932 | bindline $t $id | |
933 | } |
|
933 | } | |
934 | } |
|
934 | } | |
935 | } |
|
935 | } | |
936 |
|
936 | |||
937 | # level here is an index in displist |
|
937 | # level here is an index in displist | |
938 | proc drawcommitline {level} { |
|
938 | proc drawcommitline {level} { | |
939 | global parents children nparents displist |
|
939 | global parents children nparents displist | |
940 | global canv canv2 canv3 mainfont namefont canvy linespc |
|
940 | global canv canv2 canv3 mainfont namefont canvy linespc | |
941 | global lineid linehtag linentag linedtag commitinfo |
|
941 | global lineid linehtag linentag linedtag commitinfo | |
942 | global colormap numcommits currentparents dupparents |
|
942 | global colormap numcommits currentparents dupparents | |
943 | global idtags idline idheads idotherrefs |
|
943 | global idtags idline idheads idotherrefs | |
944 | global lineno lthickness mainline mainlinearrow sidelines |
|
944 | global lineno lthickness mainline mainlinearrow sidelines | |
945 | global commitlisted rowtextx idpos lastuse displist |
|
945 | global commitlisted rowtextx idpos lastuse displist | |
946 | global oldnlines olddlevel olddisplist |
|
946 | global oldnlines olddlevel olddisplist | |
947 | global aucolormap curid curidfont |
|
947 | global aucolormap curid curidfont | |
948 |
|
948 | |||
949 | incr numcommits |
|
949 | incr numcommits | |
950 | incr lineno |
|
950 | incr lineno | |
951 | set id [lindex $displist $level] |
|
951 | set id [lindex $displist $level] | |
952 | set lastuse($id) $lineno |
|
952 | set lastuse($id) $lineno | |
953 | set lineid($lineno) $id |
|
953 | set lineid($lineno) $id | |
954 | set idline($id) $lineno |
|
954 | set idline($id) $lineno | |
955 | set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}] |
|
955 | set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}] | |
956 | if {![info exists commitinfo($id)]} { |
|
956 | if {![info exists commitinfo($id)]} { | |
957 | readcommit $id |
|
957 | readcommit $id | |
958 | if {![info exists commitinfo($id)]} { |
|
958 | if {![info exists commitinfo($id)]} { | |
959 | set commitinfo($id) {"No commit information available"} |
|
959 | set commitinfo($id) {"No commit information available"} | |
960 | set nparents($id) 0 |
|
960 | set nparents($id) 0 | |
961 | } |
|
961 | } | |
962 | } |
|
962 | } | |
963 | assigncolor $id |
|
963 | assigncolor $id | |
964 | set currentparents {} |
|
964 | set currentparents {} | |
965 | set dupparents {} |
|
965 | set dupparents {} | |
966 | if {[info exists commitlisted($id)] && [info exists parents($id)]} { |
|
966 | if {[info exists commitlisted($id)] && [info exists parents($id)]} { | |
967 | foreach p $parents($id) { |
|
967 | foreach p $parents($id) { | |
968 | if {[lsearch -exact $currentparents $p] < 0} { |
|
968 | if {[lsearch -exact $currentparents $p] < 0} { | |
969 | lappend currentparents $p |
|
969 | lappend currentparents $p | |
970 | } else { |
|
970 | } else { | |
971 | # remember that this parent was listed twice |
|
971 | # remember that this parent was listed twice | |
972 | lappend dupparents $p |
|
972 | lappend dupparents $p | |
973 | } |
|
973 | } | |
974 | } |
|
974 | } | |
975 | } |
|
975 | } | |
976 | set x [xcoord $level $level $lineno] |
|
976 | set x [xcoord $level $level $lineno] | |
977 | set y1 $canvy |
|
977 | set y1 $canvy | |
978 | set canvy [expr $canvy + $linespc] |
|
978 | set canvy [expr $canvy + $linespc] | |
979 | allcanvs conf -scrollregion \ |
|
979 | allcanvs conf -scrollregion \ | |
980 | [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]] |
|
980 | [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]] | |
981 | if {[info exists mainline($id)]} { |
|
981 | if {[info exists mainline($id)]} { | |
982 | lappend mainline($id) $x $y1 |
|
982 | lappend mainline($id) $x $y1 | |
983 | if {$mainlinearrow($id) ne "none"} { |
|
983 | if {$mainlinearrow($id) ne "none"} { | |
984 | set mainline($id) [trimdiagstart $mainline($id)] |
|
984 | set mainline($id) [trimdiagstart $mainline($id)] | |
985 | } |
|
985 | } | |
986 | } |
|
986 | } | |
987 | drawlines $id 0 |
|
987 | drawlines $id 0 | |
988 | set orad [expr {$linespc / 3}] |
|
988 | set orad [expr {$linespc / 3}] | |
989 | set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \ |
|
989 | set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \ | |
990 | [expr $x + $orad - 1] [expr $y1 + $orad - 1] \ |
|
990 | [expr $x + $orad - 1] [expr $y1 + $orad - 1] \ | |
991 | -fill $ofill -outline black -width 1] |
|
991 | -fill $ofill -outline black -width 1] | |
992 | $canv raise $t |
|
992 | $canv raise $t | |
993 | $canv bind $t <1> {selcanvline {} %x %y} |
|
993 | $canv bind $t <1> {selcanvline {} %x %y} | |
994 | set xt [xcoord [llength $displist] $level $lineno] |
|
994 | set xt [xcoord [llength $displist] $level $lineno] | |
995 | if {[llength $currentparents] > 2} { |
|
995 | if {[llength $currentparents] > 2} { | |
996 | set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}] |
|
996 | set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}] | |
997 | } |
|
997 | } | |
998 | set rowtextx($lineno) $xt |
|
998 | set rowtextx($lineno) $xt | |
999 | set idpos($id) [list $x $xt $y1] |
|
999 | set idpos($id) [list $x $xt $y1] | |
1000 | if {[info exists idtags($id)] || [info exists idheads($id)] |
|
1000 | if {[info exists idtags($id)] || [info exists idheads($id)] | |
1001 | || [info exists idotherrefs($id)]} { |
|
1001 | || [info exists idotherrefs($id)]} { | |
1002 | set xt [drawtags $id $x $xt $y1] |
|
1002 | set xt [drawtags $id $x $xt $y1] | |
1003 | } |
|
1003 | } | |
1004 | set headline [lindex $commitinfo($id) 0] |
|
1004 | set headline [lindex $commitinfo($id) 0] | |
1005 | set name [lindex $commitinfo($id) 1] |
|
1005 | set name [lindex $commitinfo($id) 1] | |
1006 | assignauthorcolor $name |
|
1006 | assignauthorcolor $name | |
1007 | set fg $aucolormap($name) |
|
1007 | set fg $aucolormap($name) | |
1008 | if {$id == $curid} { |
|
1008 | if {$id == $curid} { | |
1009 | set fn $curidfont |
|
1009 | set fn $curidfont | |
1010 | } else { |
|
1010 | } else { | |
1011 | set fn $mainfont |
|
1011 | set fn $mainfont | |
1012 | } |
|
1012 | } | |
1013 |
|
1013 | |||
1014 | set date [lindex $commitinfo($id) 2] |
|
1014 | set date [lindex $commitinfo($id) 2] | |
1015 | set linehtag($lineno) [$canv create text $xt $y1 -anchor w \ |
|
1015 | set linehtag($lineno) [$canv create text $xt $y1 -anchor w \ | |
1016 | -text $headline -font $fn \ |
|
1016 | -text $headline -font $fn \ | |
1017 | -fill $fg] |
|
1017 | -fill $fg] | |
1018 | $canv bind $linehtag($lineno) <<B3>> "rowmenu %X %Y $id" |
|
1018 | $canv bind $linehtag($lineno) <<B3>> "rowmenu %X %Y $id" | |
1019 | set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \ |
|
1019 | set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \ | |
1020 | -text $name -font $namefont \ |
|
1020 | -text $name -font $namefont \ | |
1021 | -fill $fg] |
|
1021 | -fill $fg] | |
1022 | set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \ |
|
1022 | set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \ | |
1023 | -text $date -font $mainfont \ |
|
1023 | -text $date -font $mainfont \ | |
1024 | -fill $fg] |
|
1024 | -fill $fg] | |
1025 |
|
1025 | |||
1026 | set olddlevel $level |
|
1026 | set olddlevel $level | |
1027 | set olddisplist $displist |
|
1027 | set olddisplist $displist | |
1028 | set oldnlines [llength $displist] |
|
1028 | set oldnlines [llength $displist] | |
1029 | } |
|
1029 | } | |
1030 |
|
1030 | |||
1031 | proc drawtags {id x xt y1} { |
|
1031 | proc drawtags {id x xt y1} { | |
1032 | global idtags idheads idotherrefs |
|
1032 | global idtags idheads idotherrefs | |
1033 | global linespc lthickness |
|
1033 | global linespc lthickness | |
1034 | global canv mainfont idline rowtextx |
|
1034 | global canv mainfont idline rowtextx | |
1035 |
|
1035 | |||
1036 | set marks {} |
|
1036 | set marks {} | |
1037 | set ntags 0 |
|
1037 | set ntags 0 | |
1038 | set nheads 0 |
|
1038 | set nheads 0 | |
1039 | if {[info exists idtags($id)]} { |
|
1039 | if {[info exists idtags($id)]} { | |
1040 | set marks $idtags($id) |
|
1040 | set marks $idtags($id) | |
1041 | set ntags [llength $marks] |
|
1041 | set ntags [llength $marks] | |
1042 | } |
|
1042 | } | |
1043 | if {[info exists idheads($id)]} { |
|
1043 | if {[info exists idheads($id)]} { | |
1044 | set marks [concat $marks $idheads($id)] |
|
1044 | set marks [concat $marks $idheads($id)] | |
1045 | set nheads [llength $idheads($id)] |
|
1045 | set nheads [llength $idheads($id)] | |
1046 | } |
|
1046 | } | |
1047 | if {[info exists idotherrefs($id)]} { |
|
1047 | if {[info exists idotherrefs($id)]} { | |
1048 | set marks [concat $marks $idotherrefs($id)] |
|
1048 | set marks [concat $marks $idotherrefs($id)] | |
1049 | } |
|
1049 | } | |
1050 | if {$marks eq {}} { |
|
1050 | if {$marks eq {}} { | |
1051 | return $xt |
|
1051 | return $xt | |
1052 | } |
|
1052 | } | |
1053 |
|
1053 | |||
1054 | set delta [expr {int(0.5 * ($linespc - $lthickness))}] |
|
1054 | set delta [expr {int(0.5 * ($linespc - $lthickness))}] | |
1055 | set yt [expr $y1 - 0.5 * $linespc] |
|
1055 | set yt [expr $y1 - 0.5 * $linespc] | |
1056 | set yb [expr $yt + $linespc - 1] |
|
1056 | set yb [expr $yt + $linespc - 1] | |
1057 | set xvals {} |
|
1057 | set xvals {} | |
1058 | set wvals {} |
|
1058 | set wvals {} | |
1059 | foreach tag $marks { |
|
1059 | foreach tag $marks { | |
1060 | set wid [font measure $mainfont $tag] |
|
1060 | set wid [font measure $mainfont $tag] | |
1061 | lappend xvals $xt |
|
1061 | lappend xvals $xt | |
1062 | lappend wvals $wid |
|
1062 | lappend wvals $wid | |
1063 | set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}] |
|
1063 | set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}] | |
1064 | } |
|
1064 | } | |
1065 | set t [$canv create line $x $y1 [lindex $xvals end] $y1 \ |
|
1065 | set t [$canv create line $x $y1 [lindex $xvals end] $y1 \ | |
1066 | -width $lthickness -fill black -tags tag.$id] |
|
1066 | -width $lthickness -fill black -tags tag.$id] | |
1067 | $canv lower $t |
|
1067 | $canv lower $t | |
1068 | foreach tag $marks x $xvals wid $wvals { |
|
1068 | foreach tag $marks x $xvals wid $wvals { | |
1069 | set xl [expr $x + $delta] |
|
1069 | set xl [expr $x + $delta] | |
1070 | set xr [expr $x + $delta + $wid + $lthickness] |
|
1070 | set xr [expr $x + $delta + $wid + $lthickness] | |
1071 | if {[incr ntags -1] >= 0} { |
|
1071 | if {[incr ntags -1] >= 0} { | |
1072 | # draw a tag |
|
1072 | # draw a tag | |
1073 | set t [$canv create polygon $x [expr $yt + $delta] $xl $yt \ |
|
1073 | set t [$canv create polygon $x [expr $yt + $delta] $xl $yt \ | |
1074 | $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \ |
|
1074 | $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \ | |
1075 | -width 1 -outline black -fill yellow -tags tag.$id] |
|
1075 | -width 1 -outline black -fill yellow -tags tag.$id] | |
1076 | $canv bind $t <1> [list showtag $tag 1] |
|
1076 | $canv bind $t <1> [list showtag $tag 1] | |
1077 | set rowtextx($idline($id)) [expr {$xr + $linespc}] |
|
1077 | set rowtextx($idline($id)) [expr {$xr + $linespc}] | |
1078 | } else { |
|
1078 | } else { | |
1079 | # draw a head or other ref |
|
1079 | # draw a head or other ref | |
1080 | if {[incr nheads -1] >= 0} { |
|
1080 | if {[incr nheads -1] >= 0} { | |
1081 | set col green |
|
1081 | set col green | |
1082 | } else { |
|
1082 | } else { | |
1083 | set col "#ddddff" |
|
1083 | set col "#ddddff" | |
1084 | } |
|
1084 | } | |
1085 | set xl [expr $xl - $delta/2] |
|
1085 | set xl [expr $xl - $delta/2] | |
1086 | $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \ |
|
1086 | $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \ | |
1087 | -width 1 -outline black -fill $col -tags tag.$id |
|
1087 | -width 1 -outline black -fill $col -tags tag.$id | |
1088 | } |
|
1088 | } | |
1089 | set t [$canv create text $xl $y1 -anchor w -text $tag \ |
|
1089 | set t [$canv create text $xl $y1 -anchor w -text $tag \ | |
1090 | -font $mainfont -tags tag.$id] |
|
1090 | -font $mainfont -tags tag.$id] | |
1091 | if {$ntags >= 0} { |
|
1091 | if {$ntags >= 0} { | |
1092 | $canv bind $t <1> [list showtag $tag 1] |
|
1092 | $canv bind $t <1> [list showtag $tag 1] | |
1093 | } |
|
1093 | } | |
1094 | } |
|
1094 | } | |
1095 | return $xt |
|
1095 | return $xt | |
1096 | } |
|
1096 | } | |
1097 |
|
1097 | |||
1098 | proc notecrossings {id lo hi corner} { |
|
1098 | proc notecrossings {id lo hi corner} { | |
1099 | global olddisplist crossings cornercrossings |
|
1099 | global olddisplist crossings cornercrossings | |
1100 |
|
1100 | |||
1101 | for {set i $lo} {[incr i] < $hi} {} { |
|
1101 | for {set i $lo} {[incr i] < $hi} {} { | |
1102 | set p [lindex $olddisplist $i] |
|
1102 | set p [lindex $olddisplist $i] | |
1103 | if {$p == {}} continue |
|
1103 | if {$p == {}} continue | |
1104 | if {$i == $corner} { |
|
1104 | if {$i == $corner} { | |
1105 | if {![info exists cornercrossings($id)] |
|
1105 | if {![info exists cornercrossings($id)] | |
1106 | || [lsearch -exact $cornercrossings($id) $p] < 0} { |
|
1106 | || [lsearch -exact $cornercrossings($id) $p] < 0} { | |
1107 | lappend cornercrossings($id) $p |
|
1107 | lappend cornercrossings($id) $p | |
1108 | } |
|
1108 | } | |
1109 | if {![info exists cornercrossings($p)] |
|
1109 | if {![info exists cornercrossings($p)] | |
1110 | || [lsearch -exact $cornercrossings($p) $id] < 0} { |
|
1110 | || [lsearch -exact $cornercrossings($p) $id] < 0} { | |
1111 | lappend cornercrossings($p) $id |
|
1111 | lappend cornercrossings($p) $id | |
1112 | } |
|
1112 | } | |
1113 | } else { |
|
1113 | } else { | |
1114 | if {![info exists crossings($id)] |
|
1114 | if {![info exists crossings($id)] | |
1115 | || [lsearch -exact $crossings($id) $p] < 0} { |
|
1115 | || [lsearch -exact $crossings($id) $p] < 0} { | |
1116 | lappend crossings($id) $p |
|
1116 | lappend crossings($id) $p | |
1117 | } |
|
1117 | } | |
1118 | if {![info exists crossings($p)] |
|
1118 | if {![info exists crossings($p)] | |
1119 | || [lsearch -exact $crossings($p) $id] < 0} { |
|
1119 | || [lsearch -exact $crossings($p) $id] < 0} { | |
1120 | lappend crossings($p) $id |
|
1120 | lappend crossings($p) $id | |
1121 | } |
|
1121 | } | |
1122 | } |
|
1122 | } | |
1123 | } |
|
1123 | } | |
1124 | } |
|
1124 | } | |
1125 |
|
1125 | |||
1126 | proc xcoord {i level ln} { |
|
1126 | proc xcoord {i level ln} { | |
1127 | global canvx0 xspc1 xspc2 |
|
1127 | global canvx0 xspc1 xspc2 | |
1128 |
|
1128 | |||
1129 | set x [expr {$canvx0 + $i * $xspc1($ln)}] |
|
1129 | set x [expr {$canvx0 + $i * $xspc1($ln)}] | |
1130 | if {$i > 0 && $i == $level} { |
|
1130 | if {$i > 0 && $i == $level} { | |
1131 | set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}] |
|
1131 | set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}] | |
1132 | } elseif {$i > $level} { |
|
1132 | } elseif {$i > $level} { | |
1133 | set x [expr {$x + $xspc2 - $xspc1($ln)}] |
|
1133 | set x [expr {$x + $xspc2 - $xspc1($ln)}] | |
1134 | } |
|
1134 | } | |
1135 | return $x |
|
1135 | return $x | |
1136 | } |
|
1136 | } | |
1137 |
|
1137 | |||
1138 | # it seems Tk can't draw arrows on the end of diagonal line segments... |
|
1138 | # it seems Tk can't draw arrows on the end of diagonal line segments... | |
1139 | proc trimdiagend {line} { |
|
1139 | proc trimdiagend {line} { | |
1140 | while {[llength $line] > 4} { |
|
1140 | while {[llength $line] > 4} { | |
1141 | set x1 [lindex $line end-3] |
|
1141 | set x1 [lindex $line end-3] | |
1142 | set y1 [lindex $line end-2] |
|
1142 | set y1 [lindex $line end-2] | |
1143 | set x2 [lindex $line end-1] |
|
1143 | set x2 [lindex $line end-1] | |
1144 | set y2 [lindex $line end] |
|
1144 | set y2 [lindex $line end] | |
1145 | if {($x1 == $x2) != ($y1 == $y2)} break |
|
1145 | if {($x1 == $x2) != ($y1 == $y2)} break | |
1146 | set line [lreplace $line end-1 end] |
|
1146 | set line [lreplace $line end-1 end] | |
1147 | } |
|
1147 | } | |
1148 | return $line |
|
1148 | return $line | |
1149 | } |
|
1149 | } | |
1150 |
|
1150 | |||
1151 | proc trimdiagstart {line} { |
|
1151 | proc trimdiagstart {line} { | |
1152 | while {[llength $line] > 4} { |
|
1152 | while {[llength $line] > 4} { | |
1153 | set x1 [lindex $line 0] |
|
1153 | set x1 [lindex $line 0] | |
1154 | set y1 [lindex $line 1] |
|
1154 | set y1 [lindex $line 1] | |
1155 | set x2 [lindex $line 2] |
|
1155 | set x2 [lindex $line 2] | |
1156 | set y2 [lindex $line 3] |
|
1156 | set y2 [lindex $line 3] | |
1157 | if {($x1 == $x2) != ($y1 == $y2)} break |
|
1157 | if {($x1 == $x2) != ($y1 == $y2)} break | |
1158 | set line [lreplace $line 0 1] |
|
1158 | set line [lreplace $line 0 1] | |
1159 | } |
|
1159 | } | |
1160 | return $line |
|
1160 | return $line | |
1161 | } |
|
1161 | } | |
1162 |
|
1162 | |||
1163 | proc drawslants {id needonscreen nohs} { |
|
1163 | proc drawslants {id needonscreen nohs} { | |
1164 | global canv mainline mainlinearrow sidelines |
|
1164 | global canv mainline mainlinearrow sidelines | |
1165 | global canvx0 canvy xspc1 xspc2 lthickness |
|
1165 | global canvx0 canvy xspc1 xspc2 lthickness | |
1166 | global currentparents dupparents |
|
1166 | global currentparents dupparents | |
1167 | global lthickness linespc canvy colormap lineno geometry |
|
1167 | global lthickness linespc canvy colormap lineno geometry | |
1168 | global maxgraphpct maxwidth |
|
1168 | global maxgraphpct maxwidth | |
1169 | global displist onscreen lastuse |
|
1169 | global displist onscreen lastuse | |
1170 | global parents commitlisted |
|
1170 | global parents commitlisted | |
1171 | global oldnlines olddlevel olddisplist |
|
1171 | global oldnlines olddlevel olddisplist | |
1172 | global nhyperspace numcommits nnewparents |
|
1172 | global nhyperspace numcommits nnewparents | |
1173 |
|
1173 | |||
1174 | if {$lineno < 0} { |
|
1174 | if {$lineno < 0} { | |
1175 | lappend displist $id |
|
1175 | lappend displist $id | |
1176 | set onscreen($id) 1 |
|
1176 | set onscreen($id) 1 | |
1177 | return 0 |
|
1177 | return 0 | |
1178 | } |
|
1178 | } | |
1179 |
|
1179 | |||
1180 | set y1 [expr {$canvy - $linespc}] |
|
1180 | set y1 [expr {$canvy - $linespc}] | |
1181 | set y2 $canvy |
|
1181 | set y2 $canvy | |
1182 |
|
1182 | |||
1183 | # work out what we need to get back on screen |
|
1183 | # work out what we need to get back on screen | |
1184 | set reins {} |
|
1184 | set reins {} | |
1185 | if {$onscreen($id) < 0} { |
|
1185 | if {$onscreen($id) < 0} { | |
1186 | # next to do isn't displayed, better get it on screen... |
|
1186 | # next to do isn't displayed, better get it on screen... | |
1187 | lappend reins [list $id 0] |
|
1187 | lappend reins [list $id 0] | |
1188 | } |
|
1188 | } | |
1189 | # make sure all the previous commits's parents are on the screen |
|
1189 | # make sure all the previous commits's parents are on the screen | |
1190 | foreach p $currentparents { |
|
1190 | foreach p $currentparents { | |
1191 | if {$onscreen($p) < 0} { |
|
1191 | if {$onscreen($p) < 0} { | |
1192 | lappend reins [list $p 0] |
|
1192 | lappend reins [list $p 0] | |
1193 | } |
|
1193 | } | |
1194 | } |
|
1194 | } | |
1195 | # bring back anything requested by caller |
|
1195 | # bring back anything requested by caller | |
1196 | if {$needonscreen ne {}} { |
|
1196 | if {$needonscreen ne {}} { | |
1197 | lappend reins $needonscreen |
|
1197 | lappend reins $needonscreen | |
1198 | } |
|
1198 | } | |
1199 |
|
1199 | |||
1200 | # try the shortcut |
|
1200 | # try the shortcut | |
1201 | if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} { |
|
1201 | if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} { | |
1202 | set dlevel $olddlevel |
|
1202 | set dlevel $olddlevel | |
1203 | set x [xcoord $dlevel $dlevel $lineno] |
|
1203 | set x [xcoord $dlevel $dlevel $lineno] | |
1204 | set mainline($id) [list $x $y1] |
|
1204 | set mainline($id) [list $x $y1] | |
1205 | set mainlinearrow($id) none |
|
1205 | set mainlinearrow($id) none | |
1206 | set lastuse($id) $lineno |
|
1206 | set lastuse($id) $lineno | |
1207 | set displist [lreplace $displist $dlevel $dlevel $id] |
|
1207 | set displist [lreplace $displist $dlevel $dlevel $id] | |
1208 | set onscreen($id) 1 |
|
1208 | set onscreen($id) 1 | |
1209 | set xspc1([expr {$lineno + 1}]) $xspc1($lineno) |
|
1209 | set xspc1([expr {$lineno + 1}]) $xspc1($lineno) | |
1210 | return $dlevel |
|
1210 | return $dlevel | |
1211 | } |
|
1211 | } | |
1212 |
|
1212 | |||
1213 | # update displist |
|
1213 | # update displist | |
1214 | set displist [lreplace $displist $olddlevel $olddlevel] |
|
1214 | set displist [lreplace $displist $olddlevel $olddlevel] | |
1215 | set j $olddlevel |
|
1215 | set j $olddlevel | |
1216 | foreach p $currentparents { |
|
1216 | foreach p $currentparents { | |
1217 | set lastuse($p) $lineno |
|
1217 | set lastuse($p) $lineno | |
1218 | if {$onscreen($p) == 0} { |
|
1218 | if {$onscreen($p) == 0} { | |
1219 | set displist [linsert $displist $j $p] |
|
1219 | set displist [linsert $displist $j $p] | |
1220 | set onscreen($p) 1 |
|
1220 | set onscreen($p) 1 | |
1221 | incr j |
|
1221 | incr j | |
1222 | } |
|
1222 | } | |
1223 | } |
|
1223 | } | |
1224 | if {$onscreen($id) == 0} { |
|
1224 | if {$onscreen($id) == 0} { | |
1225 | lappend displist $id |
|
1225 | lappend displist $id | |
1226 | set onscreen($id) 1 |
|
1226 | set onscreen($id) 1 | |
1227 | } |
|
1227 | } | |
1228 |
|
1228 | |||
1229 | # remove the null entry if present |
|
1229 | # remove the null entry if present | |
1230 | set nullentry [lsearch -exact $displist {}] |
|
1230 | set nullentry [lsearch -exact $displist {}] | |
1231 | if {$nullentry >= 0} { |
|
1231 | if {$nullentry >= 0} { | |
1232 | set displist [lreplace $displist $nullentry $nullentry] |
|
1232 | set displist [lreplace $displist $nullentry $nullentry] | |
1233 | } |
|
1233 | } | |
1234 |
|
1234 | |||
1235 | # bring back the ones we need now (if we did it earlier |
|
1235 | # bring back the ones we need now (if we did it earlier | |
1236 | # it would change displist and invalidate olddlevel) |
|
1236 | # it would change displist and invalidate olddlevel) | |
1237 | foreach pi $reins { |
|
1237 | foreach pi $reins { | |
1238 | # test again in case of duplicates in reins |
|
1238 | # test again in case of duplicates in reins | |
1239 | set p [lindex $pi 0] |
|
1239 | set p [lindex $pi 0] | |
1240 | if {$onscreen($p) < 0} { |
|
1240 | if {$onscreen($p) < 0} { | |
1241 | set onscreen($p) 1 |
|
1241 | set onscreen($p) 1 | |
1242 | set lastuse($p) $lineno |
|
1242 | set lastuse($p) $lineno | |
1243 | set displist [linsert $displist [lindex $pi 1] $p] |
|
1243 | set displist [linsert $displist [lindex $pi 1] $p] | |
1244 | incr nhyperspace -1 |
|
1244 | incr nhyperspace -1 | |
1245 | } |
|
1245 | } | |
1246 | } |
|
1246 | } | |
1247 |
|
1247 | |||
1248 | set lastuse($id) $lineno |
|
1248 | set lastuse($id) $lineno | |
1249 |
|
1249 | |||
1250 | # see if we need to make any lines jump off into hyperspace |
|
1250 | # see if we need to make any lines jump off into hyperspace | |
1251 | set displ [llength $displist] |
|
1251 | set displ [llength $displist] | |
1252 | if {$displ > $maxwidth} { |
|
1252 | if {$displ > $maxwidth} { | |
1253 | set ages {} |
|
1253 | set ages {} | |
1254 | foreach x $displist { |
|
1254 | foreach x $displist { | |
1255 | lappend ages [list $lastuse($x) $x] |
|
1255 | lappend ages [list $lastuse($x) $x] | |
1256 | } |
|
1256 | } | |
1257 | set ages [lsort -integer -index 0 $ages] |
|
1257 | set ages [lsort -integer -index 0 $ages] | |
1258 | set k 0 |
|
1258 | set k 0 | |
1259 | while {$displ > $maxwidth} { |
|
1259 | while {$displ > $maxwidth} { | |
1260 | set use [lindex $ages $k 0] |
|
1260 | set use [lindex $ages $k 0] | |
1261 | set victim [lindex $ages $k 1] |
|
1261 | set victim [lindex $ages $k 1] | |
1262 | if {$use >= $lineno - 5} break |
|
1262 | if {$use >= $lineno - 5} break | |
1263 | incr k |
|
1263 | incr k | |
1264 | if {[lsearch -exact $nohs $victim] >= 0} continue |
|
1264 | if {[lsearch -exact $nohs $victim] >= 0} continue | |
1265 | set i [lsearch -exact $displist $victim] |
|
1265 | set i [lsearch -exact $displist $victim] | |
1266 | set displist [lreplace $displist $i $i] |
|
1266 | set displist [lreplace $displist $i $i] | |
1267 | set onscreen($victim) -1 |
|
1267 | set onscreen($victim) -1 | |
1268 | incr nhyperspace |
|
1268 | incr nhyperspace | |
1269 | incr displ -1 |
|
1269 | incr displ -1 | |
1270 | if {$i < $nullentry} { |
|
1270 | if {$i < $nullentry} { | |
1271 | incr nullentry -1 |
|
1271 | incr nullentry -1 | |
1272 | } |
|
1272 | } | |
1273 | set x [lindex $mainline($victim) end-1] |
|
1273 | set x [lindex $mainline($victim) end-1] | |
1274 | lappend mainline($victim) $x $y1 |
|
1274 | lappend mainline($victim) $x $y1 | |
1275 | set line [trimdiagend $mainline($victim)] |
|
1275 | set line [trimdiagend $mainline($victim)] | |
1276 | set arrow "last" |
|
1276 | set arrow "last" | |
1277 | if {$mainlinearrow($victim) ne "none"} { |
|
1277 | if {$mainlinearrow($victim) ne "none"} { | |
1278 | set line [trimdiagstart $line] |
|
1278 | set line [trimdiagstart $line] | |
1279 | set arrow "both" |
|
1279 | set arrow "both" | |
1280 | } |
|
1280 | } | |
1281 | lappend sidelines($victim) [list $line 1 $arrow] |
|
1281 | lappend sidelines($victim) [list $line 1 $arrow] | |
1282 | unset mainline($victim) |
|
1282 | unset mainline($victim) | |
1283 | } |
|
1283 | } | |
1284 | } |
|
1284 | } | |
1285 |
|
1285 | |||
1286 | set dlevel [lsearch -exact $displist $id] |
|
1286 | set dlevel [lsearch -exact $displist $id] | |
1287 |
|
1287 | |||
1288 | # If we are reducing, put in a null entry |
|
1288 | # If we are reducing, put in a null entry | |
1289 | if {$displ < $oldnlines} { |
|
1289 | if {$displ < $oldnlines} { | |
1290 | # does the next line look like a merge? |
|
1290 | # does the next line look like a merge? | |
1291 | # i.e. does it have > 1 new parent? |
|
1291 | # i.e. does it have > 1 new parent? | |
1292 | if {$nnewparents($id) > 1} { |
|
1292 | if {$nnewparents($id) > 1} { | |
1293 | set i [expr {$dlevel + 1}] |
|
1293 | set i [expr {$dlevel + 1}] | |
1294 | } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} { |
|
1294 | } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} { | |
1295 | set i $olddlevel |
|
1295 | set i $olddlevel | |
1296 | if {$nullentry >= 0 && $nullentry < $i} { |
|
1296 | if {$nullentry >= 0 && $nullentry < $i} { | |
1297 | incr i -1 |
|
1297 | incr i -1 | |
1298 | } |
|
1298 | } | |
1299 | } elseif {$nullentry >= 0} { |
|
1299 | } elseif {$nullentry >= 0} { | |
1300 | set i $nullentry |
|
1300 | set i $nullentry | |
1301 | while {$i < $displ |
|
1301 | while {$i < $displ | |
1302 | && [lindex $olddisplist $i] == [lindex $displist $i]} { |
|
1302 | && [lindex $olddisplist $i] == [lindex $displist $i]} { | |
1303 | incr i |
|
1303 | incr i | |
1304 | } |
|
1304 | } | |
1305 | } else { |
|
1305 | } else { | |
1306 | set i $olddlevel |
|
1306 | set i $olddlevel | |
1307 | if {$dlevel >= $i} { |
|
1307 | if {$dlevel >= $i} { | |
1308 | incr i |
|
1308 | incr i | |
1309 | } |
|
1309 | } | |
1310 | } |
|
1310 | } | |
1311 | if {$i < $displ} { |
|
1311 | if {$i < $displ} { | |
1312 | set displist [linsert $displist $i {}] |
|
1312 | set displist [linsert $displist $i {}] | |
1313 | incr displ |
|
1313 | incr displ | |
1314 | if {$dlevel >= $i} { |
|
1314 | if {$dlevel >= $i} { | |
1315 | incr dlevel |
|
1315 | incr dlevel | |
1316 | } |
|
1316 | } | |
1317 | } |
|
1317 | } | |
1318 | } |
|
1318 | } | |
1319 |
|
1319 | |||
1320 | # decide on the line spacing for the next line |
|
1320 | # decide on the line spacing for the next line | |
1321 | set lj [expr {$lineno + 1}] |
|
1321 | set lj [expr {$lineno + 1}] | |
1322 | set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}] |
|
1322 | set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}] | |
1323 | if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} { |
|
1323 | if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} { | |
1324 | set xspc1($lj) $xspc2 |
|
1324 | set xspc1($lj) $xspc2 | |
1325 | } else { |
|
1325 | } else { | |
1326 | set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}] |
|
1326 | set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}] | |
1327 | if {$xspc1($lj) < $lthickness} { |
|
1327 | if {$xspc1($lj) < $lthickness} { | |
1328 | set xspc1($lj) $lthickness |
|
1328 | set xspc1($lj) $lthickness | |
1329 | } |
|
1329 | } | |
1330 | } |
|
1330 | } | |
1331 |
|
1331 | |||
1332 | foreach idi $reins { |
|
1332 | foreach idi $reins { | |
1333 | set id [lindex $idi 0] |
|
1333 | set id [lindex $idi 0] | |
1334 | set j [lsearch -exact $displist $id] |
|
1334 | set j [lsearch -exact $displist $id] | |
1335 | set xj [xcoord $j $dlevel $lj] |
|
1335 | set xj [xcoord $j $dlevel $lj] | |
1336 | set mainline($id) [list $xj $y2] |
|
1336 | set mainline($id) [list $xj $y2] | |
1337 | set mainlinearrow($id) first |
|
1337 | set mainlinearrow($id) first | |
1338 | } |
|
1338 | } | |
1339 |
|
1339 | |||
1340 | set i -1 |
|
1340 | set i -1 | |
1341 | foreach id $olddisplist { |
|
1341 | foreach id $olddisplist { | |
1342 | incr i |
|
1342 | incr i | |
1343 | if {$id == {}} continue |
|
1343 | if {$id == {}} continue | |
1344 | if {$onscreen($id) <= 0} continue |
|
1344 | if {$onscreen($id) <= 0} continue | |
1345 | set xi [xcoord $i $olddlevel $lineno] |
|
1345 | set xi [xcoord $i $olddlevel $lineno] | |
1346 | if {$i == $olddlevel} { |
|
1346 | if {$i == $olddlevel} { | |
1347 | foreach p $currentparents { |
|
1347 | foreach p $currentparents { | |
1348 | set j [lsearch -exact $displist $p] |
|
1348 | set j [lsearch -exact $displist $p] | |
1349 | set coords [list $xi $y1] |
|
1349 | set coords [list $xi $y1] | |
1350 | set xj [xcoord $j $dlevel $lj] |
|
1350 | set xj [xcoord $j $dlevel $lj] | |
1351 | if {$xj < $xi - $linespc} { |
|
1351 | if {$xj < $xi - $linespc} { | |
1352 | lappend coords [expr {$xj + $linespc}] $y1 |
|
1352 | lappend coords [expr {$xj + $linespc}] $y1 | |
1353 | notecrossings $p $j $i [expr {$j + 1}] |
|
1353 | notecrossings $p $j $i [expr {$j + 1}] | |
1354 | } elseif {$xj > $xi + $linespc} { |
|
1354 | } elseif {$xj > $xi + $linespc} { | |
1355 | lappend coords [expr {$xj - $linespc}] $y1 |
|
1355 | lappend coords [expr {$xj - $linespc}] $y1 | |
1356 | notecrossings $p $i $j [expr {$j - 1}] |
|
1356 | notecrossings $p $i $j [expr {$j - 1}] | |
1357 | } |
|
1357 | } | |
1358 | if {[lsearch -exact $dupparents $p] >= 0} { |
|
1358 | if {[lsearch -exact $dupparents $p] >= 0} { | |
1359 | # draw a double-width line to indicate the doubled parent |
|
1359 | # draw a double-width line to indicate the doubled parent | |
1360 | lappend coords $xj $y2 |
|
1360 | lappend coords $xj $y2 | |
1361 | lappend sidelines($p) [list $coords 2 none] |
|
1361 | lappend sidelines($p) [list $coords 2 none] | |
1362 | if {![info exists mainline($p)]} { |
|
1362 | if {![info exists mainline($p)]} { | |
1363 | set mainline($p) [list $xj $y2] |
|
1363 | set mainline($p) [list $xj $y2] | |
1364 | set mainlinearrow($p) none |
|
1364 | set mainlinearrow($p) none | |
1365 | } |
|
1365 | } | |
1366 | } else { |
|
1366 | } else { | |
1367 | # normal case, no parent duplicated |
|
1367 | # normal case, no parent duplicated | |
1368 | set yb $y2 |
|
1368 | set yb $y2 | |
1369 | set dx [expr {abs($xi - $xj)}] |
|
1369 | set dx [expr {abs($xi - $xj)}] | |
1370 | if {0 && $dx < $linespc} { |
|
1370 | if {0 && $dx < $linespc} { | |
1371 | set yb [expr {$y1 + $dx}] |
|
1371 | set yb [expr {$y1 + $dx}] | |
1372 | } |
|
1372 | } | |
1373 | if {![info exists mainline($p)]} { |
|
1373 | if {![info exists mainline($p)]} { | |
1374 | if {$xi != $xj} { |
|
1374 | if {$xi != $xj} { | |
1375 | lappend coords $xj $yb |
|
1375 | lappend coords $xj $yb | |
1376 | } |
|
1376 | } | |
1377 | set mainline($p) $coords |
|
1377 | set mainline($p) $coords | |
1378 | set mainlinearrow($p) none |
|
1378 | set mainlinearrow($p) none | |
1379 | } else { |
|
1379 | } else { | |
1380 | lappend coords $xj $yb |
|
1380 | lappend coords $xj $yb | |
1381 | if {$yb < $y2} { |
|
1381 | if {$yb < $y2} { | |
1382 | lappend coords $xj $y2 |
|
1382 | lappend coords $xj $y2 | |
1383 | } |
|
1383 | } | |
1384 | lappend sidelines($p) [list $coords 1 none] |
|
1384 | lappend sidelines($p) [list $coords 1 none] | |
1385 | } |
|
1385 | } | |
1386 | } |
|
1386 | } | |
1387 | } |
|
1387 | } | |
1388 | } else { |
|
1388 | } else { | |
1389 | set j $i |
|
1389 | set j $i | |
1390 | if {[lindex $displist $i] != $id} { |
|
1390 | if {[lindex $displist $i] != $id} { | |
1391 | set j [lsearch -exact $displist $id] |
|
1391 | set j [lsearch -exact $displist $id] | |
1392 | } |
|
1392 | } | |
1393 | if {$j != $i || $xspc1($lineno) != $xspc1($lj) |
|
1393 | if {$j != $i || $xspc1($lineno) != $xspc1($lj) | |
1394 | || ($olddlevel < $i && $i < $dlevel) |
|
1394 | || ($olddlevel < $i && $i < $dlevel) | |
1395 | || ($dlevel < $i && $i < $olddlevel)} { |
|
1395 | || ($dlevel < $i && $i < $olddlevel)} { | |
1396 | set xj [xcoord $j $dlevel $lj] |
|
1396 | set xj [xcoord $j $dlevel $lj] | |
1397 | lappend mainline($id) $xi $y1 $xj $y2 |
|
1397 | lappend mainline($id) $xi $y1 $xj $y2 | |
1398 | } |
|
1398 | } | |
1399 | } |
|
1399 | } | |
1400 | } |
|
1400 | } | |
1401 | return $dlevel |
|
1401 | return $dlevel | |
1402 | } |
|
1402 | } | |
1403 |
|
1403 | |||
1404 | # search for x in a list of lists |
|
1404 | # search for x in a list of lists | |
1405 | proc llsearch {llist x} { |
|
1405 | proc llsearch {llist x} { | |
1406 | set i 0 |
|
1406 | set i 0 | |
1407 | foreach l $llist { |
|
1407 | foreach l $llist { | |
1408 | if {$l == $x || [lsearch -exact $l $x] >= 0} { |
|
1408 | if {$l == $x || [lsearch -exact $l $x] >= 0} { | |
1409 | return $i |
|
1409 | return $i | |
1410 | } |
|
1410 | } | |
1411 | incr i |
|
1411 | incr i | |
1412 | } |
|
1412 | } | |
1413 | return -1 |
|
1413 | return -1 | |
1414 | } |
|
1414 | } | |
1415 |
|
1415 | |||
1416 | proc drawmore {reading} { |
|
1416 | proc drawmore {reading} { | |
1417 | global displayorder numcommits ncmupdate nextupdate |
|
1417 | global displayorder numcommits ncmupdate nextupdate | |
1418 | global stopped nhyperspace parents commitlisted |
|
1418 | global stopped nhyperspace parents commitlisted | |
1419 | global maxwidth onscreen displist currentparents olddlevel |
|
1419 | global maxwidth onscreen displist currentparents olddlevel | |
1420 |
|
1420 | |||
1421 | set n [llength $displayorder] |
|
1421 | set n [llength $displayorder] | |
1422 | while {$numcommits < $n} { |
|
1422 | while {$numcommits < $n} { | |
1423 | set id [lindex $displayorder $numcommits] |
|
1423 | set id [lindex $displayorder $numcommits] | |
1424 | set ctxend [expr {$numcommits + 10}] |
|
1424 | set ctxend [expr {$numcommits + 10}] | |
1425 | if {!$reading && $ctxend > $n} { |
|
1425 | if {!$reading && $ctxend > $n} { | |
1426 | set ctxend $n |
|
1426 | set ctxend $n | |
1427 | } |
|
1427 | } | |
1428 | set dlist {} |
|
1428 | set dlist {} | |
1429 | if {$numcommits > 0} { |
|
1429 | if {$numcommits > 0} { | |
1430 | set dlist [lreplace $displist $olddlevel $olddlevel] |
|
1430 | set dlist [lreplace $displist $olddlevel $olddlevel] | |
1431 | set i $olddlevel |
|
1431 | set i $olddlevel | |
1432 | foreach p $currentparents { |
|
1432 | foreach p $currentparents { | |
1433 | if {$onscreen($p) == 0} { |
|
1433 | if {$onscreen($p) == 0} { | |
1434 | set dlist [linsert $dlist $i $p] |
|
1434 | set dlist [linsert $dlist $i $p] | |
1435 | incr i |
|
1435 | incr i | |
1436 | } |
|
1436 | } | |
1437 | } |
|
1437 | } | |
1438 | } |
|
1438 | } | |
1439 | set nohs {} |
|
1439 | set nohs {} | |
1440 | set reins {} |
|
1440 | set reins {} | |
1441 | set isfat [expr {[llength $dlist] > $maxwidth}] |
|
1441 | set isfat [expr {[llength $dlist] > $maxwidth}] | |
1442 | if {$nhyperspace > 0 || $isfat} { |
|
1442 | if {$nhyperspace > 0 || $isfat} { | |
1443 | if {$ctxend > $n} break |
|
1443 | if {$ctxend > $n} break | |
1444 | # work out what to bring back and |
|
1444 | # work out what to bring back and | |
1445 | # what we want to don't want to send into hyperspace |
|
1445 | # what we want to don't want to send into hyperspace | |
1446 | set room 1 |
|
1446 | set room 1 | |
1447 | for {set k $numcommits} {$k < $ctxend} {incr k} { |
|
1447 | for {set k $numcommits} {$k < $ctxend} {incr k} { | |
1448 | set x [lindex $displayorder $k] |
|
1448 | set x [lindex $displayorder $k] | |
1449 | set i [llsearch $dlist $x] |
|
1449 | set i [llsearch $dlist $x] | |
1450 | if {$i < 0} { |
|
1450 | if {$i < 0} { | |
1451 | set i [llength $dlist] |
|
1451 | set i [llength $dlist] | |
1452 | lappend dlist $x |
|
1452 | lappend dlist $x | |
1453 | } |
|
1453 | } | |
1454 | if {[lsearch -exact $nohs $x] < 0} { |
|
1454 | if {[lsearch -exact $nohs $x] < 0} { | |
1455 | lappend nohs $x |
|
1455 | lappend nohs $x | |
1456 | } |
|
1456 | } | |
1457 | if {$reins eq {} && $onscreen($x) < 0 && $room} { |
|
1457 | if {$reins eq {} && $onscreen($x) < 0 && $room} { | |
1458 | set reins [list $x $i] |
|
1458 | set reins [list $x $i] | |
1459 | } |
|
1459 | } | |
1460 | set newp {} |
|
1460 | set newp {} | |
1461 | if {[info exists commitlisted($x)]} { |
|
1461 | if {[info exists commitlisted($x)]} { | |
1462 | set right 0 |
|
1462 | set right 0 | |
1463 | foreach p $parents($x) { |
|
1463 | foreach p $parents($x) { | |
1464 | if {[llsearch $dlist $p] < 0} { |
|
1464 | if {[llsearch $dlist $p] < 0} { | |
1465 | lappend newp $p |
|
1465 | lappend newp $p | |
1466 | if {[lsearch -exact $nohs $p] < 0} { |
|
1466 | if {[lsearch -exact $nohs $p] < 0} { | |
1467 | lappend nohs $p |
|
1467 | lappend nohs $p | |
1468 | } |
|
1468 | } | |
1469 | if {$reins eq {} && $onscreen($p) < 0 && $room} { |
|
1469 | if {$reins eq {} && $onscreen($p) < 0 && $room} { | |
1470 | set reins [list $p [expr {$i + $right}]] |
|
1470 | set reins [list $p [expr {$i + $right}]] | |
1471 | } |
|
1471 | } | |
1472 | } |
|
1472 | } | |
1473 | set right 1 |
|
1473 | set right 1 | |
1474 | } |
|
1474 | } | |
1475 | } |
|
1475 | } | |
1476 | set l [lindex $dlist $i] |
|
1476 | set l [lindex $dlist $i] | |
1477 | if {[llength $l] == 1} { |
|
1477 | if {[llength $l] == 1} { | |
1478 | set l $newp |
|
1478 | set l $newp | |
1479 | } else { |
|
1479 | } else { | |
1480 | set j [lsearch -exact $l $x] |
|
1480 | set j [lsearch -exact $l $x] | |
1481 | set l [concat [lreplace $l $j $j] $newp] |
|
1481 | set l [concat [lreplace $l $j $j] $newp] | |
1482 | } |
|
1482 | } | |
1483 | set dlist [lreplace $dlist $i $i $l] |
|
1483 | set dlist [lreplace $dlist $i $i $l] | |
1484 | if {$room && $isfat && [llength $newp] <= 1} { |
|
1484 | if {$room && $isfat && [llength $newp] <= 1} { | |
1485 | set room 0 |
|
1485 | set room 0 | |
1486 | } |
|
1486 | } | |
1487 | } |
|
1487 | } | |
1488 | } |
|
1488 | } | |
1489 |
|
1489 | |||
1490 | set dlevel [drawslants $id $reins $nohs] |
|
1490 | set dlevel [drawslants $id $reins $nohs] | |
1491 | drawcommitline $dlevel |
|
1491 | drawcommitline $dlevel | |
1492 | if {[clock clicks -milliseconds] >= $nextupdate |
|
1492 | if {[clock clicks -milliseconds] >= $nextupdate | |
1493 | && $numcommits >= $ncmupdate} { |
|
1493 | && $numcommits >= $ncmupdate} { | |
1494 | doupdate $reading |
|
1494 | doupdate $reading | |
1495 | if {$stopped} break |
|
1495 | if {$stopped} break | |
1496 | } |
|
1496 | } | |
1497 | } |
|
1497 | } | |
1498 | } |
|
1498 | } | |
1499 |
|
1499 | |||
1500 | # level here is an index in todo |
|
1500 | # level here is an index in todo | |
1501 | proc updatetodo {level noshortcut} { |
|
1501 | proc updatetodo {level noshortcut} { | |
1502 | global ncleft todo nnewparents |
|
1502 | global ncleft todo nnewparents | |
1503 | global commitlisted parents onscreen |
|
1503 | global commitlisted parents onscreen | |
1504 |
|
1504 | |||
1505 | set id [lindex $todo $level] |
|
1505 | set id [lindex $todo $level] | |
1506 | set olds {} |
|
1506 | set olds {} | |
1507 | if {[info exists commitlisted($id)]} { |
|
1507 | if {[info exists commitlisted($id)]} { | |
1508 | foreach p $parents($id) { |
|
1508 | foreach p $parents($id) { | |
1509 | if {[lsearch -exact $olds $p] < 0} { |
|
1509 | if {[lsearch -exact $olds $p] < 0} { | |
1510 | lappend olds $p |
|
1510 | lappend olds $p | |
1511 | } |
|
1511 | } | |
1512 | } |
|
1512 | } | |
1513 | } |
|
1513 | } | |
1514 | if {!$noshortcut && [llength $olds] == 1} { |
|
1514 | if {!$noshortcut && [llength $olds] == 1} { | |
1515 | set p [lindex $olds 0] |
|
1515 | set p [lindex $olds 0] | |
1516 | if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} { |
|
1516 | if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} { | |
1517 | set ncleft($p) 0 |
|
1517 | set ncleft($p) 0 | |
1518 | set todo [lreplace $todo $level $level $p] |
|
1518 | set todo [lreplace $todo $level $level $p] | |
1519 | set onscreen($p) 0 |
|
1519 | set onscreen($p) 0 | |
1520 | set nnewparents($id) 1 |
|
1520 | set nnewparents($id) 1 | |
1521 | return 0 |
|
1521 | return 0 | |
1522 | } |
|
1522 | } | |
1523 | } |
|
1523 | } | |
1524 |
|
1524 | |||
1525 | set todo [lreplace $todo $level $level] |
|
1525 | set todo [lreplace $todo $level $level] | |
1526 | set i $level |
|
1526 | set i $level | |
1527 | set n 0 |
|
1527 | set n 0 | |
1528 | foreach p $olds { |
|
1528 | foreach p $olds { | |
1529 | incr ncleft($p) -1 |
|
1529 | incr ncleft($p) -1 | |
1530 | set k [lsearch -exact $todo $p] |
|
1530 | set k [lsearch -exact $todo $p] | |
1531 | if {$k < 0} { |
|
1531 | if {$k < 0} { | |
1532 | set todo [linsert $todo $i $p] |
|
1532 | set todo [linsert $todo $i $p] | |
1533 | set onscreen($p) 0 |
|
1533 | set onscreen($p) 0 | |
1534 | incr i |
|
1534 | incr i | |
1535 | incr n |
|
1535 | incr n | |
1536 | } |
|
1536 | } | |
1537 | } |
|
1537 | } | |
1538 | set nnewparents($id) $n |
|
1538 | set nnewparents($id) $n | |
1539 |
|
1539 | |||
1540 | return 1 |
|
1540 | return 1 | |
1541 | } |
|
1541 | } | |
1542 |
|
1542 | |||
1543 | proc decidenext {{noread 0}} { |
|
1543 | proc decidenext {{noread 0}} { | |
1544 | global ncleft todo |
|
1544 | global ncleft todo | |
1545 | global datemode cdate |
|
1545 | global datemode cdate | |
1546 | global commitinfo |
|
1546 | global commitinfo | |
1547 |
|
1547 | |||
1548 | # choose which one to do next time around |
|
1548 | # choose which one to do next time around | |
1549 | set todol [llength $todo] |
|
1549 | set todol [llength $todo] | |
1550 | set level -1 |
|
1550 | set level -1 | |
1551 | set latest {} |
|
1551 | set latest {} | |
1552 | for {set k $todol} {[incr k -1] >= 0} {} { |
|
1552 | for {set k $todol} {[incr k -1] >= 0} {} { | |
1553 | set p [lindex $todo $k] |
|
1553 | set p [lindex $todo $k] | |
1554 | if {$ncleft($p) == 0} { |
|
1554 | if {$ncleft($p) == 0} { | |
1555 | if {$datemode} { |
|
1555 | if {$datemode} { | |
1556 | if {![info exists commitinfo($p)]} { |
|
1556 | if {![info exists commitinfo($p)]} { | |
1557 | if {$noread} { |
|
1557 | if {$noread} { | |
1558 | return {} |
|
1558 | return {} | |
1559 | } |
|
1559 | } | |
1560 | readcommit $p |
|
1560 | readcommit $p | |
1561 | } |
|
1561 | } | |
1562 | if {$latest == {} || $cdate($p) > $latest} { |
|
1562 | if {$latest == {} || $cdate($p) > $latest} { | |
1563 | set level $k |
|
1563 | set level $k | |
1564 | set latest $cdate($p) |
|
1564 | set latest $cdate($p) | |
1565 | } |
|
1565 | } | |
1566 | } else { |
|
1566 | } else { | |
1567 | set level $k |
|
1567 | set level $k | |
1568 | break |
|
1568 | break | |
1569 | } |
|
1569 | } | |
1570 | } |
|
1570 | } | |
1571 | } |
|
1571 | } | |
1572 | if {$level < 0} { |
|
1572 | if {$level < 0} { | |
1573 | if {$todo != {}} { |
|
1573 | if {$todo != {}} { | |
1574 | puts "ERROR: none of the pending commits can be done yet:" |
|
1574 | puts "ERROR: none of the pending commits can be done yet:" | |
1575 | foreach p $todo { |
|
1575 | foreach p $todo { | |
1576 | puts " $p ($ncleft($p))" |
|
1576 | puts " $p ($ncleft($p))" | |
1577 | } |
|
1577 | } | |
1578 | } |
|
1578 | } | |
1579 | return -1 |
|
1579 | return -1 | |
1580 | } |
|
1580 | } | |
1581 |
|
1581 | |||
1582 | return $level |
|
1582 | return $level | |
1583 | } |
|
1583 | } | |
1584 |
|
1584 | |||
1585 | proc drawcommit {id} { |
|
1585 | proc drawcommit {id} { | |
1586 | global phase todo nchildren datemode nextupdate |
|
1586 | global phase todo nchildren datemode nextupdate | |
1587 | global numcommits ncmupdate displayorder todo onscreen |
|
1587 | global numcommits ncmupdate displayorder todo onscreen | |
1588 |
|
1588 | |||
1589 | if {$phase != "incrdraw"} { |
|
1589 | if {$phase != "incrdraw"} { | |
1590 | set phase incrdraw |
|
1590 | set phase incrdraw | |
1591 | set displayorder {} |
|
1591 | set displayorder {} | |
1592 | set todo {} |
|
1592 | set todo {} | |
1593 | initgraph |
|
1593 | initgraph | |
1594 | } |
|
1594 | } | |
1595 | if {$nchildren($id) == 0} { |
|
1595 | if {$nchildren($id) == 0} { | |
1596 | lappend todo $id |
|
1596 | lappend todo $id | |
1597 | set onscreen($id) 0 |
|
1597 | set onscreen($id) 0 | |
1598 | } |
|
1598 | } | |
1599 | set level [decidenext 1] |
|
1599 | set level [decidenext 1] | |
1600 | if {$level == {} || $id != [lindex $todo $level]} { |
|
1600 | if {$level == {} || $id != [lindex $todo $level]} { | |
1601 | return |
|
1601 | return | |
1602 | } |
|
1602 | } | |
1603 | while 1 { |
|
1603 | while 1 { | |
1604 | lappend displayorder [lindex $todo $level] |
|
1604 | lappend displayorder [lindex $todo $level] | |
1605 | if {[updatetodo $level $datemode]} { |
|
1605 | if {[updatetodo $level $datemode]} { | |
1606 | set level [decidenext 1] |
|
1606 | set level [decidenext 1] | |
1607 | if {$level == {}} break |
|
1607 | if {$level == {}} break | |
1608 | } |
|
1608 | } | |
1609 | set id [lindex $todo $level] |
|
1609 | set id [lindex $todo $level] | |
1610 | if {![info exists commitlisted($id)]} { |
|
1610 | if {![info exists commitlisted($id)]} { | |
1611 | break |
|
1611 | break | |
1612 | } |
|
1612 | } | |
1613 | } |
|
1613 | } | |
1614 | drawmore 1 |
|
1614 | drawmore 1 | |
1615 | } |
|
1615 | } | |
1616 |
|
1616 | |||
1617 | proc finishcommits {} { |
|
1617 | proc finishcommits {} { | |
1618 | global phase |
|
1618 | global phase | |
1619 | global canv mainfont ctext maincursor textcursor |
|
1619 | global canv mainfont ctext maincursor textcursor | |
1620 |
|
1620 | |||
1621 | if {$phase != "incrdraw"} { |
|
1621 | if {$phase != "incrdraw"} { | |
1622 | $canv delete all |
|
1622 | $canv delete all | |
1623 | $canv create text 3 3 -anchor nw -text "No commits selected" \ |
|
1623 | $canv create text 3 3 -anchor nw -text "No commits selected" \ | |
1624 | -font $mainfont -tags textitems |
|
1624 | -font $mainfont -tags textitems | |
1625 | set phase {} |
|
1625 | set phase {} | |
1626 | } else { |
|
1626 | } else { | |
1627 | drawrest |
|
1627 | drawrest | |
1628 | } |
|
1628 | } | |
1629 | . config -cursor $maincursor |
|
1629 | . config -cursor $maincursor | |
1630 | settextcursor $textcursor |
|
1630 | settextcursor $textcursor | |
1631 | } |
|
1631 | } | |
1632 |
|
1632 | |||
1633 | # Don't change the text pane cursor if it is currently the hand cursor, |
|
1633 | # Don't change the text pane cursor if it is currently the hand cursor, | |
1634 | # showing that we are over a sha1 ID link. |
|
1634 | # showing that we are over a sha1 ID link. | |
1635 | proc settextcursor {c} { |
|
1635 | proc settextcursor {c} { | |
1636 | global ctext curtextcursor |
|
1636 | global ctext curtextcursor | |
1637 |
|
1637 | |||
1638 | if {[$ctext cget -cursor] == $curtextcursor} { |
|
1638 | if {[$ctext cget -cursor] == $curtextcursor} { | |
1639 | $ctext config -cursor $c |
|
1639 | $ctext config -cursor $c | |
1640 | } |
|
1640 | } | |
1641 | set curtextcursor $c |
|
1641 | set curtextcursor $c | |
1642 | } |
|
1642 | } | |
1643 |
|
1643 | |||
1644 | proc drawgraph {} { |
|
1644 | proc drawgraph {} { | |
1645 | global nextupdate startmsecs ncmupdate |
|
1645 | global nextupdate startmsecs ncmupdate | |
1646 | global displayorder onscreen |
|
1646 | global displayorder onscreen | |
1647 |
|
1647 | |||
1648 | if {$displayorder == {}} return |
|
1648 | if {$displayorder == {}} return | |
1649 | set startmsecs [clock clicks -milliseconds] |
|
1649 | set startmsecs [clock clicks -milliseconds] | |
1650 | set nextupdate [expr $startmsecs + 100] |
|
1650 | set nextupdate [expr $startmsecs + 100] | |
1651 | set ncmupdate 1 |
|
1651 | set ncmupdate 1 | |
1652 | initgraph |
|
1652 | initgraph | |
1653 | foreach id $displayorder { |
|
1653 | foreach id $displayorder { | |
1654 | set onscreen($id) 0 |
|
1654 | set onscreen($id) 0 | |
1655 | } |
|
1655 | } | |
1656 | drawmore 0 |
|
1656 | drawmore 0 | |
1657 | } |
|
1657 | } | |
1658 |
|
1658 | |||
1659 | proc drawrest {} { |
|
1659 | proc drawrest {} { | |
1660 | global phase stopped redisplaying selectedline |
|
1660 | global phase stopped redisplaying selectedline | |
1661 | global datemode todo displayorder |
|
1661 | global datemode todo displayorder | |
1662 | global numcommits ncmupdate |
|
1662 | global numcommits ncmupdate | |
1663 | global nextupdate startmsecs |
|
1663 | global nextupdate startmsecs | |
1664 |
|
1664 | |||
1665 | set level [decidenext] |
|
1665 | set level [decidenext] | |
1666 | if {$level >= 0} { |
|
1666 | if {$level >= 0} { | |
1667 | set phase drawgraph |
|
1667 | set phase drawgraph | |
1668 | while 1 { |
|
1668 | while 1 { | |
1669 | lappend displayorder [lindex $todo $level] |
|
1669 | lappend displayorder [lindex $todo $level] | |
1670 | set hard [updatetodo $level $datemode] |
|
1670 | set hard [updatetodo $level $datemode] | |
1671 | if {$hard} { |
|
1671 | if {$hard} { | |
1672 | set level [decidenext] |
|
1672 | set level [decidenext] | |
1673 | if {$level < 0} break |
|
1673 | if {$level < 0} break | |
1674 | } |
|
1674 | } | |
1675 | } |
|
1675 | } | |
1676 | drawmore 0 |
|
1676 | drawmore 0 | |
1677 | } |
|
1677 | } | |
1678 | set phase {} |
|
1678 | set phase {} | |
1679 | set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs] |
|
1679 | set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs] | |
1680 | #puts "overall $drawmsecs ms for $numcommits commits" |
|
1680 | #puts "overall $drawmsecs ms for $numcommits commits" | |
1681 | if {$redisplaying} { |
|
1681 | if {$redisplaying} { | |
1682 | if {$stopped == 0 && [info exists selectedline]} { |
|
1682 | if {$stopped == 0 && [info exists selectedline]} { | |
1683 | selectline $selectedline 0 |
|
1683 | selectline $selectedline 0 | |
1684 | } |
|
1684 | } | |
1685 | if {$stopped == 1} { |
|
1685 | if {$stopped == 1} { | |
1686 | set stopped 0 |
|
1686 | set stopped 0 | |
1687 | after idle drawgraph |
|
1687 | after idle drawgraph | |
1688 | } else { |
|
1688 | } else { | |
1689 | set redisplaying 0 |
|
1689 | set redisplaying 0 | |
1690 | } |
|
1690 | } | |
1691 | } |
|
1691 | } | |
1692 | } |
|
1692 | } | |
1693 |
|
1693 | |||
1694 | proc findmatches {f} { |
|
1694 | proc findmatches {f} { | |
1695 | global findtype foundstring foundstrlen |
|
1695 | global findtype foundstring foundstrlen | |
1696 | if {$findtype == "Regexp"} { |
|
1696 | if {$findtype == "Regexp"} { | |
1697 | set matches [regexp -indices -all -inline $foundstring $f] |
|
1697 | set matches [regexp -indices -all -inline $foundstring $f] | |
1698 | } else { |
|
1698 | } else { | |
1699 | if {$findtype == "IgnCase"} { |
|
1699 | if {$findtype == "IgnCase"} { | |
1700 | set str [string tolower $f] |
|
1700 | set str [string tolower $f] | |
1701 | } else { |
|
1701 | } else { | |
1702 | set str $f |
|
1702 | set str $f | |
1703 | } |
|
1703 | } | |
1704 | set matches {} |
|
1704 | set matches {} | |
1705 | set i 0 |
|
1705 | set i 0 | |
1706 | while {[set j [string first $foundstring $str $i]] >= 0} { |
|
1706 | while {[set j [string first $foundstring $str $i]] >= 0} { | |
1707 | lappend matches [list $j [expr $j+$foundstrlen-1]] |
|
1707 | lappend matches [list $j [expr $j+$foundstrlen-1]] | |
1708 | set i [expr $j + $foundstrlen] |
|
1708 | set i [expr $j + $foundstrlen] | |
1709 | } |
|
1709 | } | |
1710 | } |
|
1710 | } | |
1711 | return $matches |
|
1711 | return $matches | |
1712 | } |
|
1712 | } | |
1713 |
|
1713 | |||
1714 | proc dofind {} { |
|
1714 | proc dofind {} { | |
1715 | global findtype findloc findstring markedmatches commitinfo |
|
1715 | global findtype findloc findstring markedmatches commitinfo | |
1716 | global numcommits lineid linehtag linentag linedtag |
|
1716 | global numcommits lineid linehtag linentag linedtag | |
1717 | global mainfont namefont canv canv2 canv3 selectedline |
|
1717 | global mainfont namefont canv canv2 canv3 selectedline | |
1718 | global matchinglines foundstring foundstrlen |
|
1718 | global matchinglines foundstring foundstrlen | |
1719 |
|
1719 | |||
1720 | stopfindproc |
|
1720 | stopfindproc | |
1721 | unmarkmatches |
|
1721 | unmarkmatches | |
1722 | focus . |
|
1722 | focus . | |
1723 | set matchinglines {} |
|
1723 | set matchinglines {} | |
1724 | if {$findloc == "Pickaxe"} { |
|
1724 | if {$findloc == "Pickaxe"} { | |
1725 | findpatches |
|
1725 | findpatches | |
1726 | return |
|
1726 | return | |
1727 | } |
|
1727 | } | |
1728 | if {$findtype == "IgnCase"} { |
|
1728 | if {$findtype == "IgnCase"} { | |
1729 | set foundstring [string tolower $findstring] |
|
1729 | set foundstring [string tolower $findstring] | |
1730 | } else { |
|
1730 | } else { | |
1731 | set foundstring $findstring |
|
1731 | set foundstring $findstring | |
1732 | } |
|
1732 | } | |
1733 | set foundstrlen [string length $findstring] |
|
1733 | set foundstrlen [string length $findstring] | |
1734 | if {$foundstrlen == 0} return |
|
1734 | if {$foundstrlen == 0} return | |
1735 | if {$findloc == "Files"} { |
|
1735 | if {$findloc == "Files"} { | |
1736 | findfiles |
|
1736 | findfiles | |
1737 | return |
|
1737 | return | |
1738 | } |
|
1738 | } | |
1739 | if {![info exists selectedline]} { |
|
1739 | if {![info exists selectedline]} { | |
1740 | set oldsel -1 |
|
1740 | set oldsel -1 | |
1741 | } else { |
|
1741 | } else { | |
1742 | set oldsel $selectedline |
|
1742 | set oldsel $selectedline | |
1743 | } |
|
1743 | } | |
1744 | set didsel 0 |
|
1744 | set didsel 0 | |
1745 | set fldtypes {Headline Author Date Committer CDate Comment} |
|
1745 | set fldtypes {Headline Author Date Committer CDate Comment} | |
1746 | for {set l 0} {$l < $numcommits} {incr l} { |
|
1746 | for {set l 0} {$l < $numcommits} {incr l} { | |
1747 | set id $lineid($l) |
|
1747 | set id $lineid($l) | |
1748 | set info $commitinfo($id) |
|
1748 | set info $commitinfo($id) | |
1749 | set doesmatch 0 |
|
1749 | set doesmatch 0 | |
1750 | foreach f $info ty $fldtypes { |
|
1750 | foreach f $info ty $fldtypes { | |
1751 | if {$findloc != "All fields" && $findloc != $ty} { |
|
1751 | if {$findloc != "All fields" && $findloc != $ty} { | |
1752 | continue |
|
1752 | continue | |
1753 | } |
|
1753 | } | |
1754 | set matches [findmatches $f] |
|
1754 | set matches [findmatches $f] | |
1755 | if {$matches == {}} continue |
|
1755 | if {$matches == {}} continue | |
1756 | set doesmatch 1 |
|
1756 | set doesmatch 1 | |
1757 | if {$ty == "Headline"} { |
|
1757 | if {$ty == "Headline"} { | |
1758 | markmatches $canv $l $f $linehtag($l) $matches $mainfont |
|
1758 | markmatches $canv $l $f $linehtag($l) $matches $mainfont | |
1759 | } elseif {$ty == "Author"} { |
|
1759 | } elseif {$ty == "Author"} { | |
1760 | markmatches $canv2 $l $f $linentag($l) $matches $namefont |
|
1760 | markmatches $canv2 $l $f $linentag($l) $matches $namefont | |
1761 | } elseif {$ty == "Date"} { |
|
1761 | } elseif {$ty == "Date"} { | |
1762 | markmatches $canv3 $l $f $linedtag($l) $matches $mainfont |
|
1762 | markmatches $canv3 $l $f $linedtag($l) $matches $mainfont | |
1763 | } |
|
1763 | } | |
1764 | } |
|
1764 | } | |
1765 | if {$doesmatch} { |
|
1765 | if {$doesmatch} { | |
1766 | lappend matchinglines $l |
|
1766 | lappend matchinglines $l | |
1767 | if {!$didsel && $l > $oldsel} { |
|
1767 | if {!$didsel && $l > $oldsel} { | |
1768 | findselectline $l |
|
1768 | findselectline $l | |
1769 | set didsel 1 |
|
1769 | set didsel 1 | |
1770 | } |
|
1770 | } | |
1771 | } |
|
1771 | } | |
1772 | } |
|
1772 | } | |
1773 | if {$matchinglines == {}} { |
|
1773 | if {$matchinglines == {}} { | |
1774 | bell |
|
1774 | bell | |
1775 | } elseif {!$didsel} { |
|
1775 | } elseif {!$didsel} { | |
1776 | findselectline [lindex $matchinglines 0] |
|
1776 | findselectline [lindex $matchinglines 0] | |
1777 | } |
|
1777 | } | |
1778 | } |
|
1778 | } | |
1779 |
|
1779 | |||
1780 | proc findselectline {l} { |
|
1780 | proc findselectline {l} { | |
1781 | global findloc commentend ctext |
|
1781 | global findloc commentend ctext | |
1782 | selectline $l 1 |
|
1782 | selectline $l 1 | |
1783 | if {$findloc == "All fields" || $findloc == "Comments"} { |
|
1783 | if {$findloc == "All fields" || $findloc == "Comments"} { | |
1784 | # highlight the matches in the comments |
|
1784 | # highlight the matches in the comments | |
1785 | set f [$ctext get 1.0 $commentend] |
|
1785 | set f [$ctext get 1.0 $commentend] | |
1786 | set matches [findmatches $f] |
|
1786 | set matches [findmatches $f] | |
1787 | foreach match $matches { |
|
1787 | foreach match $matches { | |
1788 | set start [lindex $match 0] |
|
1788 | set start [lindex $match 0] | |
1789 | set end [expr [lindex $match 1] + 1] |
|
1789 | set end [expr [lindex $match 1] + 1] | |
1790 | $ctext tag add found "1.0 + $start c" "1.0 + $end c" |
|
1790 | $ctext tag add found "1.0 + $start c" "1.0 + $end c" | |
1791 | } |
|
1791 | } | |
1792 | } |
|
1792 | } | |
1793 | } |
|
1793 | } | |
1794 |
|
1794 | |||
1795 | proc findnext {restart} { |
|
1795 | proc findnext {restart} { | |
1796 | global matchinglines selectedline |
|
1796 | global matchinglines selectedline | |
1797 | if {![info exists matchinglines]} { |
|
1797 | if {![info exists matchinglines]} { | |
1798 | if {$restart} { |
|
1798 | if {$restart} { | |
1799 | dofind |
|
1799 | dofind | |
1800 | } |
|
1800 | } | |
1801 | return |
|
1801 | return | |
1802 | } |
|
1802 | } | |
1803 | if {![info exists selectedline]} return |
|
1803 | if {![info exists selectedline]} return | |
1804 | foreach l $matchinglines { |
|
1804 | foreach l $matchinglines { | |
1805 | if {$l > $selectedline} { |
|
1805 | if {$l > $selectedline} { | |
1806 | findselectline $l |
|
1806 | findselectline $l | |
1807 | return |
|
1807 | return | |
1808 | } |
|
1808 | } | |
1809 | } |
|
1809 | } | |
1810 | bell |
|
1810 | bell | |
1811 | } |
|
1811 | } | |
1812 |
|
1812 | |||
1813 | proc findprev {} { |
|
1813 | proc findprev {} { | |
1814 | global matchinglines selectedline |
|
1814 | global matchinglines selectedline | |
1815 | if {![info exists matchinglines]} { |
|
1815 | if {![info exists matchinglines]} { | |
1816 | dofind |
|
1816 | dofind | |
1817 | return |
|
1817 | return | |
1818 | } |
|
1818 | } | |
1819 | if {![info exists selectedline]} return |
|
1819 | if {![info exists selectedline]} return | |
1820 | set prev {} |
|
1820 | set prev {} | |
1821 | foreach l $matchinglines { |
|
1821 | foreach l $matchinglines { | |
1822 | if {$l >= $selectedline} break |
|
1822 | if {$l >= $selectedline} break | |
1823 | set prev $l |
|
1823 | set prev $l | |
1824 | } |
|
1824 | } | |
1825 | if {$prev != {}} { |
|
1825 | if {$prev != {}} { | |
1826 | findselectline $prev |
|
1826 | findselectline $prev | |
1827 | } else { |
|
1827 | } else { | |
1828 | bell |
|
1828 | bell | |
1829 | } |
|
1829 | } | |
1830 | } |
|
1830 | } | |
1831 |
|
1831 | |||
1832 | proc findlocchange {name ix op} { |
|
1832 | proc findlocchange {name ix op} { | |
1833 | global findloc findtype findtypemenu |
|
1833 | global findloc findtype findtypemenu | |
1834 | if {$findloc == "Pickaxe"} { |
|
1834 | if {$findloc == "Pickaxe"} { | |
1835 | set findtype Exact |
|
1835 | set findtype Exact | |
1836 | set state disabled |
|
1836 | set state disabled | |
1837 | } else { |
|
1837 | } else { | |
1838 | set state normal |
|
1838 | set state normal | |
1839 | } |
|
1839 | } | |
1840 | $findtypemenu entryconf 1 -state $state |
|
1840 | $findtypemenu entryconf 1 -state $state | |
1841 | $findtypemenu entryconf 2 -state $state |
|
1841 | $findtypemenu entryconf 2 -state $state | |
1842 | } |
|
1842 | } | |
1843 |
|
1843 | |||
1844 | proc stopfindproc {{done 0}} { |
|
1844 | proc stopfindproc {{done 0}} { | |
1845 | global findprocpid findprocfile findids |
|
1845 | global findprocpid findprocfile findids | |
1846 | global ctext findoldcursor phase maincursor textcursor |
|
1846 | global ctext findoldcursor phase maincursor textcursor | |
1847 | global findinprogress |
|
1847 | global findinprogress | |
1848 |
|
1848 | |||
1849 | catch {unset findids} |
|
1849 | catch {unset findids} | |
1850 | if {[info exists findprocpid]} { |
|
1850 | if {[info exists findprocpid]} { | |
1851 | if {!$done} { |
|
1851 | if {!$done} { | |
1852 | catch {exec kill $findprocpid} |
|
1852 | catch {exec kill $findprocpid} | |
1853 | } |
|
1853 | } | |
1854 | catch {close $findprocfile} |
|
1854 | catch {close $findprocfile} | |
1855 | unset findprocpid |
|
1855 | unset findprocpid | |
1856 | } |
|
1856 | } | |
1857 | if {[info exists findinprogress]} { |
|
1857 | if {[info exists findinprogress]} { | |
1858 | unset findinprogress |
|
1858 | unset findinprogress | |
1859 | if {$phase != "incrdraw"} { |
|
1859 | if {$phase != "incrdraw"} { | |
1860 | . config -cursor $maincursor |
|
1860 | . config -cursor $maincursor | |
1861 | settextcursor $textcursor |
|
1861 | settextcursor $textcursor | |
1862 | } |
|
1862 | } | |
1863 | } |
|
1863 | } | |
1864 | } |
|
1864 | } | |
1865 |
|
1865 | |||
1866 | proc findpatches {} { |
|
1866 | proc findpatches {} { | |
1867 | global findstring selectedline numcommits |
|
1867 | global findstring selectedline numcommits | |
1868 | global findprocpid findprocfile |
|
1868 | global findprocpid findprocfile | |
1869 | global finddidsel ctext lineid findinprogress |
|
1869 | global finddidsel ctext lineid findinprogress | |
1870 | global findinsertpos |
|
1870 | global findinsertpos | |
1871 | global env |
|
1871 | global env | |
1872 |
|
1872 | |||
1873 | if {$numcommits == 0} return |
|
1873 | if {$numcommits == 0} return | |
1874 |
|
1874 | |||
1875 | # make a list of all the ids to search, starting at the one |
|
1875 | # make a list of all the ids to search, starting at the one | |
1876 | # after the selected line (if any) |
|
1876 | # after the selected line (if any) | |
1877 | if {[info exists selectedline]} { |
|
1877 | if {[info exists selectedline]} { | |
1878 | set l $selectedline |
|
1878 | set l $selectedline | |
1879 | } else { |
|
1879 | } else { | |
1880 | set l -1 |
|
1880 | set l -1 | |
1881 | } |
|
1881 | } | |
1882 | set inputids {} |
|
1882 | set inputids {} | |
1883 | for {set i 0} {$i < $numcommits} {incr i} { |
|
1883 | for {set i 0} {$i < $numcommits} {incr i} { | |
1884 | if {[incr l] >= $numcommits} { |
|
1884 | if {[incr l] >= $numcommits} { | |
1885 | set l 0 |
|
1885 | set l 0 | |
1886 | } |
|
1886 | } | |
1887 | append inputids $lineid($l) "\n" |
|
1887 | append inputids $lineid($l) "\n" | |
1888 | } |
|
1888 | } | |
1889 |
|
1889 | |||
1890 | if {[catch { |
|
1890 | if {[catch { | |
1891 | set f [open [list | $env(HG) --config ui.report_untrusted=false debug-diff-tree --stdin -s -r -S$findstring << $inputids] r] |
|
1891 | set f [open [list | $env(HG) --config ui.report_untrusted=false debug-diff-tree --stdin -s -r -S$findstring << $inputids] r] | |
1892 | } err]} { |
|
1892 | } err]} { | |
1893 | error_popup "Error starting search process: $err" |
|
1893 | error_popup "Error starting search process: $err" | |
1894 | return |
|
1894 | return | |
1895 | } |
|
1895 | } | |
1896 |
|
1896 | |||
1897 | set findinsertpos end |
|
1897 | set findinsertpos end | |
1898 | set findprocfile $f |
|
1898 | set findprocfile $f | |
1899 | set findprocpid [pid $f] |
|
1899 | set findprocpid [pid $f] | |
1900 | fconfigure $f -blocking 0 |
|
1900 | fconfigure $f -blocking 0 | |
1901 | fileevent $f readable readfindproc |
|
1901 | fileevent $f readable readfindproc | |
1902 | set finddidsel 0 |
|
1902 | set finddidsel 0 | |
1903 | . config -cursor watch |
|
1903 | . config -cursor watch | |
1904 | settextcursor watch |
|
1904 | settextcursor watch | |
1905 | set findinprogress 1 |
|
1905 | set findinprogress 1 | |
1906 | } |
|
1906 | } | |
1907 |
|
1907 | |||
1908 | proc readfindproc {} { |
|
1908 | proc readfindproc {} { | |
1909 | global findprocfile finddidsel |
|
1909 | global findprocfile finddidsel | |
1910 | global idline matchinglines findinsertpos |
|
1910 | global idline matchinglines findinsertpos | |
1911 |
|
1911 | |||
1912 | set n [gets $findprocfile line] |
|
1912 | set n [gets $findprocfile line] | |
1913 | if {$n < 0} { |
|
1913 | if {$n < 0} { | |
1914 | if {[eof $findprocfile]} { |
|
1914 | if {[eof $findprocfile]} { | |
1915 | stopfindproc 1 |
|
1915 | stopfindproc 1 | |
1916 | if {!$finddidsel} { |
|
1916 | if {!$finddidsel} { | |
1917 | bell |
|
1917 | bell | |
1918 | } |
|
1918 | } | |
1919 | } |
|
1919 | } | |
1920 | return |
|
1920 | return | |
1921 | } |
|
1921 | } | |
1922 | if {![regexp {^[0-9a-f]{12}} $line id]} { |
|
1922 | if {![regexp {^[0-9a-f]{12}} $line id]} { | |
1923 | error_popup "Can't parse git-diff-tree output: $line" |
|
1923 | error_popup "Can't parse git-diff-tree output: $line" | |
1924 | stopfindproc |
|
1924 | stopfindproc | |
1925 | return |
|
1925 | return | |
1926 | } |
|
1926 | } | |
1927 | if {![info exists idline($id)]} { |
|
1927 | if {![info exists idline($id)]} { | |
1928 | puts stderr "spurious id: $id" |
|
1928 | puts stderr "spurious id: $id" | |
1929 | return |
|
1929 | return | |
1930 | } |
|
1930 | } | |
1931 | set l $idline($id) |
|
1931 | set l $idline($id) | |
1932 | insertmatch $l $id |
|
1932 | insertmatch $l $id | |
1933 | } |
|
1933 | } | |
1934 |
|
1934 | |||
1935 | proc insertmatch {l id} { |
|
1935 | proc insertmatch {l id} { | |
1936 | global matchinglines findinsertpos finddidsel |
|
1936 | global matchinglines findinsertpos finddidsel | |
1937 |
|
1937 | |||
1938 | if {$findinsertpos == "end"} { |
|
1938 | if {$findinsertpos == "end"} { | |
1939 | if {$matchinglines != {} && $l < [lindex $matchinglines 0]} { |
|
1939 | if {$matchinglines != {} && $l < [lindex $matchinglines 0]} { | |
1940 | set matchinglines [linsert $matchinglines 0 $l] |
|
1940 | set matchinglines [linsert $matchinglines 0 $l] | |
1941 | set findinsertpos 1 |
|
1941 | set findinsertpos 1 | |
1942 | } else { |
|
1942 | } else { | |
1943 | lappend matchinglines $l |
|
1943 | lappend matchinglines $l | |
1944 | } |
|
1944 | } | |
1945 | } else { |
|
1945 | } else { | |
1946 | set matchinglines [linsert $matchinglines $findinsertpos $l] |
|
1946 | set matchinglines [linsert $matchinglines $findinsertpos $l] | |
1947 | incr findinsertpos |
|
1947 | incr findinsertpos | |
1948 | } |
|
1948 | } | |
1949 | markheadline $l $id |
|
1949 | markheadline $l $id | |
1950 | if {!$finddidsel} { |
|
1950 | if {!$finddidsel} { | |
1951 | findselectline $l |
|
1951 | findselectline $l | |
1952 | set finddidsel 1 |
|
1952 | set finddidsel 1 | |
1953 | } |
|
1953 | } | |
1954 | } |
|
1954 | } | |
1955 |
|
1955 | |||
1956 | proc findfiles {} { |
|
1956 | proc findfiles {} { | |
1957 | global selectedline numcommits lineid ctext |
|
1957 | global selectedline numcommits lineid ctext | |
1958 | global ffileline finddidsel parents nparents |
|
1958 | global ffileline finddidsel parents nparents | |
1959 | global findinprogress findstartline findinsertpos |
|
1959 | global findinprogress findstartline findinsertpos | |
1960 | global treediffs fdiffids fdiffsneeded fdiffpos |
|
1960 | global treediffs fdiffids fdiffsneeded fdiffpos | |
1961 | global findmergefiles |
|
1961 | global findmergefiles | |
1962 | global env |
|
1962 | global env | |
1963 |
|
1963 | |||
1964 | if {$numcommits == 0} return |
|
1964 | if {$numcommits == 0} return | |
1965 |
|
1965 | |||
1966 | if {[info exists selectedline]} { |
|
1966 | if {[info exists selectedline]} { | |
1967 | set l [expr {$selectedline + 1}] |
|
1967 | set l [expr {$selectedline + 1}] | |
1968 | } else { |
|
1968 | } else { | |
1969 | set l 0 |
|
1969 | set l 0 | |
1970 | } |
|
1970 | } | |
1971 | set ffileline $l |
|
1971 | set ffileline $l | |
1972 | set findstartline $l |
|
1972 | set findstartline $l | |
1973 | set diffsneeded {} |
|
1973 | set diffsneeded {} | |
1974 | set fdiffsneeded {} |
|
1974 | set fdiffsneeded {} | |
1975 | while 1 { |
|
1975 | while 1 { | |
1976 | set id $lineid($l) |
|
1976 | set id $lineid($l) | |
1977 | if {$findmergefiles || $nparents($id) == 1} { |
|
1977 | if {$findmergefiles || $nparents($id) == 1} { | |
1978 | foreach p $parents($id) { |
|
1978 | foreach p $parents($id) { | |
1979 | if {![info exists treediffs([list $id $p])]} { |
|
1979 | if {![info exists treediffs([list $id $p])]} { | |
1980 | append diffsneeded "$id $p\n" |
|
1980 | append diffsneeded "$id $p\n" | |
1981 | lappend fdiffsneeded [list $id $p] |
|
1981 | lappend fdiffsneeded [list $id $p] | |
1982 | } |
|
1982 | } | |
1983 | } |
|
1983 | } | |
1984 | } |
|
1984 | } | |
1985 | if {[incr l] >= $numcommits} { |
|
1985 | if {[incr l] >= $numcommits} { | |
1986 | set l 0 |
|
1986 | set l 0 | |
1987 | } |
|
1987 | } | |
1988 | if {$l == $findstartline} break |
|
1988 | if {$l == $findstartline} break | |
1989 | } |
|
1989 | } | |
1990 |
|
1990 | |||
1991 | # start off a git-diff-tree process if needed |
|
1991 | # start off a git-diff-tree process if needed | |
1992 | if {$diffsneeded ne {}} { |
|
1992 | if {$diffsneeded ne {}} { | |
1993 | if {[catch { |
|
1993 | if {[catch { | |
1994 | set df [open [list | $env(HG) --config ui.report_untrusted=false debug-diff-tree -r --stdin << $diffsneeded] r] |
|
1994 | set df [open [list | $env(HG) --config ui.report_untrusted=false debug-diff-tree -r --stdin << $diffsneeded] r] | |
1995 | } err ]} { |
|
1995 | } err ]} { | |
1996 | error_popup "Error starting search process: $err" |
|
1996 | error_popup "Error starting search process: $err" | |
1997 | return |
|
1997 | return | |
1998 | } |
|
1998 | } | |
1999 | catch {unset fdiffids} |
|
1999 | catch {unset fdiffids} | |
2000 | set fdiffpos 0 |
|
2000 | set fdiffpos 0 | |
2001 | fconfigure $df -blocking 0 |
|
2001 | fconfigure $df -blocking 0 | |
2002 | fileevent $df readable [list readfilediffs $df] |
|
2002 | fileevent $df readable [list readfilediffs $df] | |
2003 | } |
|
2003 | } | |
2004 |
|
2004 | |||
2005 | set finddidsel 0 |
|
2005 | set finddidsel 0 | |
2006 | set findinsertpos end |
|
2006 | set findinsertpos end | |
2007 | set id $lineid($l) |
|
2007 | set id $lineid($l) | |
2008 | set p [lindex $parents($id) 0] |
|
2008 | set p [lindex $parents($id) 0] | |
2009 | . config -cursor watch |
|
2009 | . config -cursor watch | |
2010 | settextcursor watch |
|
2010 | settextcursor watch | |
2011 | set findinprogress 1 |
|
2011 | set findinprogress 1 | |
2012 | findcont [list $id $p] |
|
2012 | findcont [list $id $p] | |
2013 | update |
|
2013 | update | |
2014 | } |
|
2014 | } | |
2015 |
|
2015 | |||
2016 | proc readfilediffs {df} { |
|
2016 | proc readfilediffs {df} { | |
2017 | global findids fdiffids fdiffs |
|
2017 | global findids fdiffids fdiffs | |
2018 |
|
2018 | |||
2019 | set n [gets $df line] |
|
2019 | set n [gets $df line] | |
2020 | if {$n < 0} { |
|
2020 | if {$n < 0} { | |
2021 | if {[eof $df]} { |
|
2021 | if {[eof $df]} { | |
2022 | donefilediff |
|
2022 | donefilediff | |
2023 | if {[catch {close $df} err]} { |
|
2023 | if {[catch {close $df} err]} { | |
2024 | stopfindproc |
|
2024 | stopfindproc | |
2025 | bell |
|
2025 | bell | |
2026 | error_popup "Error in hg debug-diff-tree: $err" |
|
2026 | error_popup "Error in hg debug-diff-tree: $err" | |
2027 | } elseif {[info exists findids]} { |
|
2027 | } elseif {[info exists findids]} { | |
2028 | set ids $findids |
|
2028 | set ids $findids | |
2029 | stopfindproc |
|
2029 | stopfindproc | |
2030 | bell |
|
2030 | bell | |
2031 | error_popup "Couldn't find diffs for {$ids}" |
|
2031 | error_popup "Couldn't find diffs for {$ids}" | |
2032 | } |
|
2032 | } | |
2033 | } |
|
2033 | } | |
2034 | return |
|
2034 | return | |
2035 | } |
|
2035 | } | |
2036 | if {[regexp {^([0-9a-f]{12}) \(from ([0-9a-f]{12})\)} $line match id p]} { |
|
2036 | if {[regexp {^([0-9a-f]{12}) \(from ([0-9a-f]{12})\)} $line match id p]} { | |
2037 | # start of a new string of diffs |
|
2037 | # start of a new string of diffs | |
2038 | donefilediff |
|
2038 | donefilediff | |
2039 | set fdiffids [list $id $p] |
|
2039 | set fdiffids [list $id $p] | |
2040 | set fdiffs {} |
|
2040 | set fdiffs {} | |
2041 | } elseif {[string match ":*" $line]} { |
|
2041 | } elseif {[string match ":*" $line]} { | |
2042 | lappend fdiffs [lindex $line 5] |
|
2042 | lappend fdiffs [lindex $line 5] | |
2043 | } |
|
2043 | } | |
2044 | } |
|
2044 | } | |
2045 |
|
2045 | |||
2046 | proc donefilediff {} { |
|
2046 | proc donefilediff {} { | |
2047 | global fdiffids fdiffs treediffs findids |
|
2047 | global fdiffids fdiffs treediffs findids | |
2048 | global fdiffsneeded fdiffpos |
|
2048 | global fdiffsneeded fdiffpos | |
2049 |
|
2049 | |||
2050 | if {[info exists fdiffids]} { |
|
2050 | if {[info exists fdiffids]} { | |
2051 | while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids |
|
2051 | while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids | |
2052 | && $fdiffpos < [llength $fdiffsneeded]} { |
|
2052 | && $fdiffpos < [llength $fdiffsneeded]} { | |
2053 | # git-diff-tree doesn't output anything for a commit |
|
2053 | # git-diff-tree doesn't output anything for a commit | |
2054 | # which doesn't change anything |
|
2054 | # which doesn't change anything | |
2055 | set nullids [lindex $fdiffsneeded $fdiffpos] |
|
2055 | set nullids [lindex $fdiffsneeded $fdiffpos] | |
2056 | set treediffs($nullids) {} |
|
2056 | set treediffs($nullids) {} | |
2057 | if {[info exists findids] && $nullids eq $findids} { |
|
2057 | if {[info exists findids] && $nullids eq $findids} { | |
2058 | unset findids |
|
2058 | unset findids | |
2059 | findcont $nullids |
|
2059 | findcont $nullids | |
2060 | } |
|
2060 | } | |
2061 | incr fdiffpos |
|
2061 | incr fdiffpos | |
2062 | } |
|
2062 | } | |
2063 | incr fdiffpos |
|
2063 | incr fdiffpos | |
2064 |
|
2064 | |||
2065 | if {![info exists treediffs($fdiffids)]} { |
|
2065 | if {![info exists treediffs($fdiffids)]} { | |
2066 | set treediffs($fdiffids) $fdiffs |
|
2066 | set treediffs($fdiffids) $fdiffs | |
2067 | } |
|
2067 | } | |
2068 | if {[info exists findids] && $fdiffids eq $findids} { |
|
2068 | if {[info exists findids] && $fdiffids eq $findids} { | |
2069 | unset findids |
|
2069 | unset findids | |
2070 | findcont $fdiffids |
|
2070 | findcont $fdiffids | |
2071 | } |
|
2071 | } | |
2072 | } |
|
2072 | } | |
2073 | } |
|
2073 | } | |
2074 |
|
2074 | |||
2075 | proc findcont {ids} { |
|
2075 | proc findcont {ids} { | |
2076 | global findids treediffs parents nparents |
|
2076 | global findids treediffs parents nparents | |
2077 | global ffileline findstartline finddidsel |
|
2077 | global ffileline findstartline finddidsel | |
2078 | global lineid numcommits matchinglines findinprogress |
|
2078 | global lineid numcommits matchinglines findinprogress | |
2079 | global findmergefiles |
|
2079 | global findmergefiles | |
2080 |
|
2080 | |||
2081 | set id [lindex $ids 0] |
|
2081 | set id [lindex $ids 0] | |
2082 | set p [lindex $ids 1] |
|
2082 | set p [lindex $ids 1] | |
2083 | set pi [lsearch -exact $parents($id) $p] |
|
2083 | set pi [lsearch -exact $parents($id) $p] | |
2084 | set l $ffileline |
|
2084 | set l $ffileline | |
2085 | while 1 { |
|
2085 | while 1 { | |
2086 | if {$findmergefiles || $nparents($id) == 1} { |
|
2086 | if {$findmergefiles || $nparents($id) == 1} { | |
2087 | if {![info exists treediffs($ids)]} { |
|
2087 | if {![info exists treediffs($ids)]} { | |
2088 | set findids $ids |
|
2088 | set findids $ids | |
2089 | set ffileline $l |
|
2089 | set ffileline $l | |
2090 | return |
|
2090 | return | |
2091 | } |
|
2091 | } | |
2092 | set doesmatch 0 |
|
2092 | set doesmatch 0 | |
2093 | foreach f $treediffs($ids) { |
|
2093 | foreach f $treediffs($ids) { | |
2094 | set x [findmatches $f] |
|
2094 | set x [findmatches $f] | |
2095 | if {$x != {}} { |
|
2095 | if {$x != {}} { | |
2096 | set doesmatch 1 |
|
2096 | set doesmatch 1 | |
2097 | break |
|
2097 | break | |
2098 | } |
|
2098 | } | |
2099 | } |
|
2099 | } | |
2100 | if {$doesmatch} { |
|
2100 | if {$doesmatch} { | |
2101 | insertmatch $l $id |
|
2101 | insertmatch $l $id | |
2102 | set pi $nparents($id) |
|
2102 | set pi $nparents($id) | |
2103 | } |
|
2103 | } | |
2104 | } else { |
|
2104 | } else { | |
2105 | set pi $nparents($id) |
|
2105 | set pi $nparents($id) | |
2106 | } |
|
2106 | } | |
2107 | if {[incr pi] >= $nparents($id)} { |
|
2107 | if {[incr pi] >= $nparents($id)} { | |
2108 | set pi 0 |
|
2108 | set pi 0 | |
2109 | if {[incr l] >= $numcommits} { |
|
2109 | if {[incr l] >= $numcommits} { | |
2110 | set l 0 |
|
2110 | set l 0 | |
2111 | } |
|
2111 | } | |
2112 | if {$l == $findstartline} break |
|
2112 | if {$l == $findstartline} break | |
2113 | set id $lineid($l) |
|
2113 | set id $lineid($l) | |
2114 | } |
|
2114 | } | |
2115 | set p [lindex $parents($id) $pi] |
|
2115 | set p [lindex $parents($id) $pi] | |
2116 | set ids [list $id $p] |
|
2116 | set ids [list $id $p] | |
2117 | } |
|
2117 | } | |
2118 | stopfindproc |
|
2118 | stopfindproc | |
2119 | if {!$finddidsel} { |
|
2119 | if {!$finddidsel} { | |
2120 | bell |
|
2120 | bell | |
2121 | } |
|
2121 | } | |
2122 | } |
|
2122 | } | |
2123 |
|
2123 | |||
2124 | # mark a commit as matching by putting a yellow background |
|
2124 | # mark a commit as matching by putting a yellow background | |
2125 | # behind the headline |
|
2125 | # behind the headline | |
2126 | proc markheadline {l id} { |
|
2126 | proc markheadline {l id} { | |
2127 | global canv mainfont linehtag commitinfo |
|
2127 | global canv mainfont linehtag commitinfo | |
2128 |
|
2128 | |||
2129 | set bbox [$canv bbox $linehtag($l)] |
|
2129 | set bbox [$canv bbox $linehtag($l)] | |
2130 | set t [$canv create rect $bbox -outline {} -tags matches -fill yellow] |
|
2130 | set t [$canv create rect $bbox -outline {} -tags matches -fill yellow] | |
2131 | $canv lower $t |
|
2131 | $canv lower $t | |
2132 | } |
|
2132 | } | |
2133 |
|
2133 | |||
2134 | # mark the bits of a headline, author or date that match a find string |
|
2134 | # mark the bits of a headline, author or date that match a find string | |
2135 | proc markmatches {canv l str tag matches font} { |
|
2135 | proc markmatches {canv l str tag matches font} { | |
2136 | set bbox [$canv bbox $tag] |
|
2136 | set bbox [$canv bbox $tag] | |
2137 | set x0 [lindex $bbox 0] |
|
2137 | set x0 [lindex $bbox 0] | |
2138 | set y0 [lindex $bbox 1] |
|
2138 | set y0 [lindex $bbox 1] | |
2139 | set y1 [lindex $bbox 3] |
|
2139 | set y1 [lindex $bbox 3] | |
2140 | foreach match $matches { |
|
2140 | foreach match $matches { | |
2141 | set start [lindex $match 0] |
|
2141 | set start [lindex $match 0] | |
2142 | set end [lindex $match 1] |
|
2142 | set end [lindex $match 1] | |
2143 | if {$start > $end} continue |
|
2143 | if {$start > $end} continue | |
2144 | set xoff [font measure $font [string range $str 0 [expr $start-1]]] |
|
2144 | set xoff [font measure $font [string range $str 0 [expr $start-1]]] | |
2145 | set xlen [font measure $font [string range $str 0 [expr $end]]] |
|
2145 | set xlen [font measure $font [string range $str 0 [expr $end]]] | |
2146 | set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \ |
|
2146 | set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \ | |
2147 | -outline {} -tags matches -fill yellow] |
|
2147 | -outline {} -tags matches -fill yellow] | |
2148 | $canv lower $t |
|
2148 | $canv lower $t | |
2149 | } |
|
2149 | } | |
2150 | } |
|
2150 | } | |
2151 |
|
2151 | |||
2152 | proc unmarkmatches {} { |
|
2152 | proc unmarkmatches {} { | |
2153 | global matchinglines findids |
|
2153 | global matchinglines findids | |
2154 | allcanvs delete matches |
|
2154 | allcanvs delete matches | |
2155 | catch {unset matchinglines} |
|
2155 | catch {unset matchinglines} | |
2156 | catch {unset findids} |
|
2156 | catch {unset findids} | |
2157 | } |
|
2157 | } | |
2158 |
|
2158 | |||
2159 | proc selcanvline {w x y} { |
|
2159 | proc selcanvline {w x y} { | |
2160 | global canv canvy0 ctext linespc |
|
2160 | global canv canvy0 ctext linespc | |
2161 | global lineid linehtag linentag linedtag rowtextx |
|
2161 | global lineid linehtag linentag linedtag rowtextx | |
2162 | set ymax [lindex [$canv cget -scrollregion] 3] |
|
2162 | set ymax [lindex [$canv cget -scrollregion] 3] | |
2163 | if {$ymax == {}} return |
|
2163 | if {$ymax == {}} return | |
2164 | set yfrac [lindex [$canv yview] 0] |
|
2164 | set yfrac [lindex [$canv yview] 0] | |
2165 | set y [expr {$y + $yfrac * $ymax}] |
|
2165 | set y [expr {$y + $yfrac * $ymax}] | |
2166 | set l [expr {int(($y - $canvy0) / $linespc + 0.5)}] |
|
2166 | set l [expr {int(($y - $canvy0) / $linespc + 0.5)}] | |
2167 | if {$l < 0} { |
|
2167 | if {$l < 0} { | |
2168 | set l 0 |
|
2168 | set l 0 | |
2169 | } |
|
2169 | } | |
2170 | if {$w eq $canv} { |
|
2170 | if {$w eq $canv} { | |
2171 | if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return |
|
2171 | if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return | |
2172 | } |
|
2172 | } | |
2173 | unmarkmatches |
|
2173 | unmarkmatches | |
2174 | selectline $l 1 |
|
2174 | selectline $l 1 | |
2175 | } |
|
2175 | } | |
2176 |
|
2176 | |||
2177 | proc commit_descriptor {p} { |
|
2177 | proc commit_descriptor {p} { | |
2178 | global commitinfo |
|
2178 | global commitinfo | |
2179 | set l "..." |
|
2179 | set l "..." | |
2180 | if {[info exists commitinfo($p)]} { |
|
2180 | if {[info exists commitinfo($p)]} { | |
2181 | set l [lindex $commitinfo($p) 0] |
|
2181 | set l [lindex $commitinfo($p) 0] | |
2182 | set r [lindex $commitinfo($p) 6] |
|
2182 | set r [lindex $commitinfo($p) 6] | |
2183 | } |
|
2183 | } | |
2184 | return "$r:$p ($l)" |
|
2184 | return "$r:$p ($l)" | |
2185 | } |
|
2185 | } | |
2186 |
|
2186 | |||
2187 | # append some text to the ctext widget, and make any SHA1 ID |
|
2187 | # append some text to the ctext widget, and make any SHA1 ID | |
2188 | # that we know about be a clickable link. |
|
2188 | # that we know about be a clickable link. | |
2189 | proc appendwithlinks {text} { |
|
2189 | proc appendwithlinks {text} { | |
2190 | global ctext idline linknum |
|
2190 | global ctext idline linknum | |
2191 |
|
2191 | |||
2192 | set start [$ctext index "end - 1c"] |
|
2192 | set start [$ctext index "end - 1c"] | |
2193 | $ctext insert end $text |
|
2193 | $ctext insert end $text | |
2194 | $ctext insert end "\n" |
|
2194 | $ctext insert end "\n" | |
2195 | set links [regexp -indices -all -inline {[0-9a-f]{12}} $text] |
|
2195 | set links [regexp -indices -all -inline {[0-9a-f]{12}} $text] | |
2196 | foreach l $links { |
|
2196 | foreach l $links { | |
2197 | set s [lindex $l 0] |
|
2197 | set s [lindex $l 0] | |
2198 | set e [lindex $l 1] |
|
2198 | set e [lindex $l 1] | |
2199 | set linkid [string range $text $s $e] |
|
2199 | set linkid [string range $text $s $e] | |
2200 | if {![info exists idline($linkid)]} continue |
|
2200 | if {![info exists idline($linkid)]} continue | |
2201 | incr e |
|
2201 | incr e | |
2202 | $ctext tag add link "$start + $s c" "$start + $e c" |
|
2202 | $ctext tag add link "$start + $s c" "$start + $e c" | |
2203 | $ctext tag add link$linknum "$start + $s c" "$start + $e c" |
|
2203 | $ctext tag add link$linknum "$start + $s c" "$start + $e c" | |
2204 | $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1] |
|
2204 | $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1] | |
2205 | incr linknum |
|
2205 | incr linknum | |
2206 | } |
|
2206 | } | |
2207 | $ctext tag conf link -foreground blue -underline 1 |
|
2207 | $ctext tag conf link -foreground blue -underline 1 | |
2208 | $ctext tag bind link <Enter> { %W configure -cursor hand2 } |
|
2208 | $ctext tag bind link <Enter> { %W configure -cursor hand2 } | |
2209 | $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor } |
|
2209 | $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor } | |
2210 | } |
|
2210 | } | |
2211 |
|
2211 | |||
2212 | proc selectline {l isnew} { |
|
2212 | proc selectline {l isnew} { | |
2213 | global canv canv2 canv3 ctext commitinfo selectedline |
|
2213 | global canv canv2 canv3 ctext commitinfo selectedline | |
2214 | global lineid linehtag linentag linedtag |
|
2214 | global lineid linehtag linentag linedtag | |
2215 | global canvy0 linespc parents nparents children |
|
2215 | global canvy0 linespc parents nparents children | |
2216 | global cflist currentid sha1entry |
|
2216 | global cflist currentid sha1entry | |
2217 | global commentend idtags idline linknum |
|
2217 | global commentend idtags idline linknum | |
2218 |
|
2218 | |||
2219 | $canv delete hover |
|
2219 | $canv delete hover | |
2220 | normalline |
|
2220 | normalline | |
2221 | if {![info exists lineid($l)] || ![info exists linehtag($l)]} return |
|
2221 | if {![info exists lineid($l)] || ![info exists linehtag($l)]} return | |
2222 | $canv delete secsel |
|
2222 | $canv delete secsel | |
2223 | set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \ |
|
2223 | set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \ | |
2224 | -tags secsel -fill [$canv cget -selectbackground]] |
|
2224 | -tags secsel -fill [$canv cget -selectbackground]] | |
2225 | $canv lower $t |
|
2225 | $canv lower $t | |
2226 | $canv2 delete secsel |
|
2226 | $canv2 delete secsel | |
2227 | set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \ |
|
2227 | set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \ | |
2228 | -tags secsel -fill [$canv2 cget -selectbackground]] |
|
2228 | -tags secsel -fill [$canv2 cget -selectbackground]] | |
2229 | $canv2 lower $t |
|
2229 | $canv2 lower $t | |
2230 | $canv3 delete secsel |
|
2230 | $canv3 delete secsel | |
2231 | set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \ |
|
2231 | set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \ | |
2232 | -tags secsel -fill [$canv3 cget -selectbackground]] |
|
2232 | -tags secsel -fill [$canv3 cget -selectbackground]] | |
2233 | $canv3 lower $t |
|
2233 | $canv3 lower $t | |
2234 | set y [expr {$canvy0 + $l * $linespc}] |
|
2234 | set y [expr {$canvy0 + $l * $linespc}] | |
2235 | set ymax [lindex [$canv cget -scrollregion] 3] |
|
2235 | set ymax [lindex [$canv cget -scrollregion] 3] | |
2236 | set ytop [expr {$y - $linespc - 1}] |
|
2236 | set ytop [expr {$y - $linespc - 1}] | |
2237 | set ybot [expr {$y + $linespc + 1}] |
|
2237 | set ybot [expr {$y + $linespc + 1}] | |
2238 | set wnow [$canv yview] |
|
2238 | set wnow [$canv yview] | |
2239 | set wtop [expr [lindex $wnow 0] * $ymax] |
|
2239 | set wtop [expr [lindex $wnow 0] * $ymax] | |
2240 | set wbot [expr [lindex $wnow 1] * $ymax] |
|
2240 | set wbot [expr [lindex $wnow 1] * $ymax] | |
2241 | set wh [expr {$wbot - $wtop}] |
|
2241 | set wh [expr {$wbot - $wtop}] | |
2242 | set newtop $wtop |
|
2242 | set newtop $wtop | |
2243 | if {$ytop < $wtop} { |
|
2243 | if {$ytop < $wtop} { | |
2244 | if {$ybot < $wtop} { |
|
2244 | if {$ybot < $wtop} { | |
2245 | set newtop [expr {$y - $wh / 2.0}] |
|
2245 | set newtop [expr {$y - $wh / 2.0}] | |
2246 | } else { |
|
2246 | } else { | |
2247 | set newtop $ytop |
|
2247 | set newtop $ytop | |
2248 | if {$newtop > $wtop - $linespc} { |
|
2248 | if {$newtop > $wtop - $linespc} { | |
2249 | set newtop [expr {$wtop - $linespc}] |
|
2249 | set newtop [expr {$wtop - $linespc}] | |
2250 | } |
|
2250 | } | |
2251 | } |
|
2251 | } | |
2252 | } elseif {$ybot > $wbot} { |
|
2252 | } elseif {$ybot > $wbot} { | |
2253 | if {$ytop > $wbot} { |
|
2253 | if {$ytop > $wbot} { | |
2254 | set newtop [expr {$y - $wh / 2.0}] |
|
2254 | set newtop [expr {$y - $wh / 2.0}] | |
2255 | } else { |
|
2255 | } else { | |
2256 | set newtop [expr {$ybot - $wh}] |
|
2256 | set newtop [expr {$ybot - $wh}] | |
2257 | if {$newtop < $wtop + $linespc} { |
|
2257 | if {$newtop < $wtop + $linespc} { | |
2258 | set newtop [expr {$wtop + $linespc}] |
|
2258 | set newtop [expr {$wtop + $linespc}] | |
2259 | } |
|
2259 | } | |
2260 | } |
|
2260 | } | |
2261 | } |
|
2261 | } | |
2262 | if {$newtop != $wtop} { |
|
2262 | if {$newtop != $wtop} { | |
2263 | if {$newtop < 0} { |
|
2263 | if {$newtop < 0} { | |
2264 | set newtop 0 |
|
2264 | set newtop 0 | |
2265 | } |
|
2265 | } | |
2266 | allcanvs yview moveto [expr $newtop * 1.0 / $ymax] |
|
2266 | allcanvs yview moveto [expr $newtop * 1.0 / $ymax] | |
2267 | } |
|
2267 | } | |
2268 |
|
2268 | |||
2269 | if {$isnew} { |
|
2269 | if {$isnew} { | |
2270 | addtohistory [list selectline $l 0] |
|
2270 | addtohistory [list selectline $l 0] | |
2271 | } |
|
2271 | } | |
2272 |
|
2272 | |||
2273 | set selectedline $l |
|
2273 | set selectedline $l | |
2274 |
|
2274 | |||
2275 | set id $lineid($l) |
|
2275 | set id $lineid($l) | |
2276 | set currentid $id |
|
2276 | set currentid $id | |
2277 | $sha1entry delete 0 end |
|
2277 | $sha1entry delete 0 end | |
2278 | $sha1entry insert 0 $id |
|
2278 | $sha1entry insert 0 $id | |
2279 | $sha1entry selection from 0 |
|
2279 | $sha1entry selection from 0 | |
2280 | $sha1entry selection to end |
|
2280 | $sha1entry selection to end | |
2281 |
|
2281 | |||
2282 | $ctext conf -state normal |
|
2282 | $ctext conf -state normal | |
2283 | $ctext delete 0.0 end |
|
2283 | $ctext delete 0.0 end | |
2284 | set linknum 0 |
|
2284 | set linknum 0 | |
2285 | $ctext mark set fmark.0 0.0 |
|
2285 | $ctext mark set fmark.0 0.0 | |
2286 | $ctext mark gravity fmark.0 left |
|
2286 | $ctext mark gravity fmark.0 left | |
2287 | set info $commitinfo($id) |
|
2287 | set info $commitinfo($id) | |
2288 | $ctext insert end "Revision: [lindex $info 6]\n" |
|
2288 | $ctext insert end "Revision: [lindex $info 6]\n" | |
2289 | $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n" |
|
2289 | $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n" | |
2290 | $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n" |
|
2290 | $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n" | |
2291 | if {[info exists idtags($id)]} { |
|
2291 | if {[info exists idtags($id)]} { | |
2292 | $ctext insert end "Tags:" |
|
2292 | $ctext insert end "Tags:" | |
2293 | foreach tag $idtags($id) { |
|
2293 | foreach tag $idtags($id) { | |
2294 | $ctext insert end " $tag" |
|
2294 | $ctext insert end " $tag" | |
2295 | } |
|
2295 | } | |
2296 | $ctext insert end "\n" |
|
2296 | $ctext insert end "\n" | |
2297 | } |
|
2297 | } | |
2298 |
|
2298 | |||
2299 | set comment {} |
|
2299 | set comment {} | |
2300 | if {[info exists parents($id)]} { |
|
2300 | if {[info exists parents($id)]} { | |
2301 | foreach p $parents($id) { |
|
2301 | foreach p $parents($id) { | |
2302 | append comment "Parent: [commit_descriptor $p]\n" |
|
2302 | append comment "Parent: [commit_descriptor $p]\n" | |
2303 | } |
|
2303 | } | |
2304 | } |
|
2304 | } | |
2305 | if {[info exists children($id)]} { |
|
2305 | if {[info exists children($id)]} { | |
2306 | foreach c $children($id) { |
|
2306 | foreach c $children($id) { | |
2307 | append comment "Child: [commit_descriptor $c]\n" |
|
2307 | append comment "Child: [commit_descriptor $c]\n" | |
2308 | } |
|
2308 | } | |
2309 | } |
|
2309 | } | |
2310 | append comment "\n" |
|
2310 | append comment "\n" | |
2311 | append comment [lindex $info 5] |
|
2311 | append comment [lindex $info 5] | |
2312 |
|
2312 | |||
2313 | # make anything that looks like a SHA1 ID be a clickable link |
|
2313 | # make anything that looks like a SHA1 ID be a clickable link | |
2314 | appendwithlinks $comment |
|
2314 | appendwithlinks $comment | |
2315 |
|
2315 | |||
2316 | $ctext tag delete Comments |
|
2316 | $ctext tag delete Comments | |
2317 | $ctext tag remove found 1.0 end |
|
2317 | $ctext tag remove found 1.0 end | |
2318 | $ctext conf -state disabled |
|
2318 | $ctext conf -state disabled | |
2319 | set commentend [$ctext index "end - 1c"] |
|
2319 | set commentend [$ctext index "end - 1c"] | |
2320 |
|
2320 | |||
2321 | $cflist delete 0 end |
|
2321 | $cflist delete 0 end | |
2322 | $cflist insert end "Comments" |
|
2322 | $cflist insert end "Comments" | |
2323 | if {$nparents($id) == 1} { |
|
2323 | if {$nparents($id) == 1} { | |
2324 | startdiff [concat $id $parents($id)] |
|
2324 | startdiff [concat $id $parents($id)] | |
2325 | } elseif {$nparents($id) > 1} { |
|
2325 | } elseif {$nparents($id) > 1} { | |
2326 | mergediff $id |
|
2326 | mergediff $id | |
2327 | } |
|
2327 | } | |
2328 | } |
|
2328 | } | |
2329 |
|
2329 | |||
2330 | proc selnextline {dir} { |
|
2330 | proc selnextline {dir} { | |
2331 | global selectedline |
|
2331 | global selectedline | |
2332 | if {![info exists selectedline]} return |
|
2332 | if {![info exists selectedline]} return | |
2333 | set l [expr $selectedline + $dir] |
|
2333 | set l [expr $selectedline + $dir] | |
2334 | unmarkmatches |
|
2334 | unmarkmatches | |
2335 | selectline $l 1 |
|
2335 | selectline $l 1 | |
2336 | } |
|
2336 | } | |
2337 |
|
2337 | |||
2338 | proc unselectline {} { |
|
2338 | proc unselectline {} { | |
2339 | global selectedline |
|
2339 | global selectedline | |
2340 |
|
2340 | |||
2341 | catch {unset selectedline} |
|
2341 | catch {unset selectedline} | |
2342 | allcanvs delete secsel |
|
2342 | allcanvs delete secsel | |
2343 | } |
|
2343 | } | |
2344 |
|
2344 | |||
2345 | proc addtohistory {cmd} { |
|
2345 | proc addtohistory {cmd} { | |
2346 | global history historyindex |
|
2346 | global history historyindex | |
2347 |
|
2347 | |||
2348 | if {$historyindex > 0 |
|
2348 | if {$historyindex > 0 | |
2349 | && [lindex $history [expr {$historyindex - 1}]] == $cmd} { |
|
2349 | && [lindex $history [expr {$historyindex - 1}]] == $cmd} { | |
2350 | return |
|
2350 | return | |
2351 | } |
|
2351 | } | |
2352 |
|
2352 | |||
2353 | if {$historyindex < [llength $history]} { |
|
2353 | if {$historyindex < [llength $history]} { | |
2354 | set history [lreplace $history $historyindex end $cmd] |
|
2354 | set history [lreplace $history $historyindex end $cmd] | |
2355 | } else { |
|
2355 | } else { | |
2356 | lappend history $cmd |
|
2356 | lappend history $cmd | |
2357 | } |
|
2357 | } | |
2358 | incr historyindex |
|
2358 | incr historyindex | |
2359 | if {$historyindex > 1} { |
|
2359 | if {$historyindex > 1} { | |
2360 | .ctop.top.bar.leftbut conf -state normal |
|
2360 | .ctop.top.bar.leftbut conf -state normal | |
2361 | } else { |
|
2361 | } else { | |
2362 | .ctop.top.bar.leftbut conf -state disabled |
|
2362 | .ctop.top.bar.leftbut conf -state disabled | |
2363 | } |
|
2363 | } | |
2364 | .ctop.top.bar.rightbut conf -state disabled |
|
2364 | .ctop.top.bar.rightbut conf -state disabled | |
2365 | } |
|
2365 | } | |
2366 |
|
2366 | |||
2367 | proc goback {} { |
|
2367 | proc goback {} { | |
2368 | global history historyindex |
|
2368 | global history historyindex | |
2369 |
|
2369 | |||
2370 | if {$historyindex > 1} { |
|
2370 | if {$historyindex > 1} { | |
2371 | incr historyindex -1 |
|
2371 | incr historyindex -1 | |
2372 | set cmd [lindex $history [expr {$historyindex - 1}]] |
|
2372 | set cmd [lindex $history [expr {$historyindex - 1}]] | |
2373 | eval $cmd |
|
2373 | eval $cmd | |
2374 | .ctop.top.bar.rightbut conf -state normal |
|
2374 | .ctop.top.bar.rightbut conf -state normal | |
2375 | } |
|
2375 | } | |
2376 | if {$historyindex <= 1} { |
|
2376 | if {$historyindex <= 1} { | |
2377 | .ctop.top.bar.leftbut conf -state disabled |
|
2377 | .ctop.top.bar.leftbut conf -state disabled | |
2378 | } |
|
2378 | } | |
2379 | } |
|
2379 | } | |
2380 |
|
2380 | |||
2381 | proc goforw {} { |
|
2381 | proc goforw {} { | |
2382 | global history historyindex |
|
2382 | global history historyindex | |
2383 |
|
2383 | |||
2384 | if {$historyindex < [llength $history]} { |
|
2384 | if {$historyindex < [llength $history]} { | |
2385 | set cmd [lindex $history $historyindex] |
|
2385 | set cmd [lindex $history $historyindex] | |
2386 | incr historyindex |
|
2386 | incr historyindex | |
2387 | eval $cmd |
|
2387 | eval $cmd | |
2388 | .ctop.top.bar.leftbut conf -state normal |
|
2388 | .ctop.top.bar.leftbut conf -state normal | |
2389 | } |
|
2389 | } | |
2390 | if {$historyindex >= [llength $history]} { |
|
2390 | if {$historyindex >= [llength $history]} { | |
2391 | .ctop.top.bar.rightbut conf -state disabled |
|
2391 | .ctop.top.bar.rightbut conf -state disabled | |
2392 | } |
|
2392 | } | |
2393 | } |
|
2393 | } | |
2394 |
|
2394 | |||
2395 | proc mergediff {id} { |
|
2395 | proc mergediff {id} { | |
2396 | global parents diffmergeid diffmergegca mergefilelist diffpindex |
|
2396 | global parents diffmergeid diffmergegca mergefilelist diffpindex | |
2397 |
|
2397 | |||
2398 | set diffmergeid $id |
|
2398 | set diffmergeid $id | |
2399 | set diffpindex -1 |
|
2399 | set diffpindex -1 | |
2400 | set diffmergegca [findgca $parents($id)] |
|
2400 | set diffmergegca [findgca $parents($id)] | |
2401 | if {[info exists mergefilelist($id)]} { |
|
2401 | if {[info exists mergefilelist($id)]} { | |
2402 | if {$mergefilelist($id) ne {}} { |
|
2402 | if {$mergefilelist($id) ne {}} { | |
2403 | showmergediff |
|
2403 | showmergediff | |
2404 | } |
|
2404 | } | |
2405 | } else { |
|
2405 | } else { | |
2406 | contmergediff {} |
|
2406 | contmergediff {} | |
2407 | } |
|
2407 | } | |
2408 | } |
|
2408 | } | |
2409 |
|
2409 | |||
2410 | proc findgca {ids} { |
|
2410 | proc findgca {ids} { | |
2411 | global env |
|
2411 | global env | |
2412 | set gca {} |
|
2412 | set gca {} | |
2413 | foreach id $ids { |
|
2413 | foreach id $ids { | |
2414 | if {$gca eq {}} { |
|
2414 | if {$gca eq {}} { | |
2415 | set gca $id |
|
2415 | set gca $id | |
2416 | } else { |
|
2416 | } else { | |
2417 | if {[catch { |
|
2417 | if {[catch { | |
2418 | set gca [exec $env(HG) --config ui.report_untrusted=false debug-merge-base $gca $id] |
|
2418 | set gca [exec $env(HG) --config ui.report_untrusted=false debug-merge-base $gca $id] | |
2419 | } err]} { |
|
2419 | } err]} { | |
2420 | return {} |
|
2420 | return {} | |
2421 | } |
|
2421 | } | |
2422 | } |
|
2422 | } | |
2423 | } |
|
2423 | } | |
2424 | return $gca |
|
2424 | return $gca | |
2425 | } |
|
2425 | } | |
2426 |
|
2426 | |||
2427 | proc contmergediff {ids} { |
|
2427 | proc contmergediff {ids} { | |
2428 | global diffmergeid diffpindex parents nparents diffmergegca |
|
2428 | global diffmergeid diffpindex parents nparents diffmergegca | |
2429 | global treediffs mergefilelist diffids treepending |
|
2429 | global treediffs mergefilelist diffids treepending | |
2430 |
|
2430 | |||
2431 | # diff the child against each of the parents, and diff |
|
2431 | # diff the child against each of the parents, and diff | |
2432 | # each of the parents against the GCA. |
|
2432 | # each of the parents against the GCA. | |
2433 | while 1 { |
|
2433 | while 1 { | |
2434 | if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} { |
|
2434 | if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} { | |
2435 | set ids [list [lindex $ids 1] $diffmergegca] |
|
2435 | set ids [list [lindex $ids 1] $diffmergegca] | |
2436 | } else { |
|
2436 | } else { | |
2437 | if {[incr diffpindex] >= $nparents($diffmergeid)} break |
|
2437 | if {[incr diffpindex] >= $nparents($diffmergeid)} break | |
2438 | set p [lindex $parents($diffmergeid) $diffpindex] |
|
2438 | set p [lindex $parents($diffmergeid) $diffpindex] | |
2439 | set ids [list $diffmergeid $p] |
|
2439 | set ids [list $diffmergeid $p] | |
2440 | } |
|
2440 | } | |
2441 | if {![info exists treediffs($ids)]} { |
|
2441 | if {![info exists treediffs($ids)]} { | |
2442 | set diffids $ids |
|
2442 | set diffids $ids | |
2443 | if {![info exists treepending]} { |
|
2443 | if {![info exists treepending]} { | |
2444 | gettreediffs $ids |
|
2444 | gettreediffs $ids | |
2445 | } |
|
2445 | } | |
2446 | return |
|
2446 | return | |
2447 | } |
|
2447 | } | |
2448 | } |
|
2448 | } | |
2449 |
|
2449 | |||
2450 | # If a file in some parent is different from the child and also |
|
2450 | # If a file in some parent is different from the child and also | |
2451 | # different from the GCA, then it's interesting. |
|
2451 | # different from the GCA, then it's interesting. | |
2452 | # If we don't have a GCA, then a file is interesting if it is |
|
2452 | # If we don't have a GCA, then a file is interesting if it is | |
2453 | # different from the child in all the parents. |
|
2453 | # different from the child in all the parents. | |
2454 | if {$diffmergegca ne {}} { |
|
2454 | if {$diffmergegca ne {}} { | |
2455 | set files {} |
|
2455 | set files {} | |
2456 | foreach p $parents($diffmergeid) { |
|
2456 | foreach p $parents($diffmergeid) { | |
2457 | set gcadiffs $treediffs([list $p $diffmergegca]) |
|
2457 | set gcadiffs $treediffs([list $p $diffmergegca]) | |
2458 | foreach f $treediffs([list $diffmergeid $p]) { |
|
2458 | foreach f $treediffs([list $diffmergeid $p]) { | |
2459 | if {[lsearch -exact $files $f] < 0 |
|
2459 | if {[lsearch -exact $files $f] < 0 | |
2460 | && [lsearch -exact $gcadiffs $f] >= 0} { |
|
2460 | && [lsearch -exact $gcadiffs $f] >= 0} { | |
2461 | lappend files $f |
|
2461 | lappend files $f | |
2462 | } |
|
2462 | } | |
2463 | } |
|
2463 | } | |
2464 | } |
|
2464 | } | |
2465 | set files [lsort $files] |
|
2465 | set files [lsort $files] | |
2466 | } else { |
|
2466 | } else { | |
2467 | set p [lindex $parents($diffmergeid) 0] |
|
2467 | set p [lindex $parents($diffmergeid) 0] | |
2468 | set files $treediffs([list $diffmergeid $p]) |
|
2468 | set files $treediffs([list $diffmergeid $p]) | |
2469 | for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} { |
|
2469 | for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} { | |
2470 | set p [lindex $parents($diffmergeid) $i] |
|
2470 | set p [lindex $parents($diffmergeid) $i] | |
2471 | set df $treediffs([list $diffmergeid $p]) |
|
2471 | set df $treediffs([list $diffmergeid $p]) | |
2472 | set nf {} |
|
2472 | set nf {} | |
2473 | foreach f $files { |
|
2473 | foreach f $files { | |
2474 | if {[lsearch -exact $df $f] >= 0} { |
|
2474 | if {[lsearch -exact $df $f] >= 0} { | |
2475 | lappend nf $f |
|
2475 | lappend nf $f | |
2476 | } |
|
2476 | } | |
2477 | } |
|
2477 | } | |
2478 | set files $nf |
|
2478 | set files $nf | |
2479 | } |
|
2479 | } | |
2480 | } |
|
2480 | } | |
2481 |
|
2481 | |||
2482 | set mergefilelist($diffmergeid) $files |
|
2482 | set mergefilelist($diffmergeid) $files | |
2483 | if {$files ne {}} { |
|
2483 | if {$files ne {}} { | |
2484 | showmergediff |
|
2484 | showmergediff | |
2485 | } |
|
2485 | } | |
2486 | } |
|
2486 | } | |
2487 |
|
2487 | |||
2488 | proc showmergediff {} { |
|
2488 | proc showmergediff {} { | |
2489 | global cflist diffmergeid mergefilelist parents |
|
2489 | global cflist diffmergeid mergefilelist parents | |
2490 | global diffopts diffinhunk currentfile currenthunk filelines |
|
2490 | global diffopts diffinhunk currentfile currenthunk filelines | |
2491 | global diffblocked groupfilelast mergefds groupfilenum grouphunks |
|
2491 | global diffblocked groupfilelast mergefds groupfilenum grouphunks | |
2492 | global env |
|
2492 | global env | |
2493 |
|
2493 | |||
2494 | set files $mergefilelist($diffmergeid) |
|
2494 | set files $mergefilelist($diffmergeid) | |
2495 | foreach f $files { |
|
2495 | foreach f $files { | |
2496 | $cflist insert end $f |
|
2496 | $cflist insert end $f | |
2497 | } |
|
2497 | } | |
2498 | set env(GIT_DIFF_OPTS) $diffopts |
|
2498 | set env(GIT_DIFF_OPTS) $diffopts | |
2499 | set flist {} |
|
2499 | set flist {} | |
2500 | catch {unset currentfile} |
|
2500 | catch {unset currentfile} | |
2501 | catch {unset currenthunk} |
|
2501 | catch {unset currenthunk} | |
2502 | catch {unset filelines} |
|
2502 | catch {unset filelines} | |
2503 | catch {unset groupfilenum} |
|
2503 | catch {unset groupfilenum} | |
2504 | catch {unset grouphunks} |
|
2504 | catch {unset grouphunks} | |
2505 | set groupfilelast -1 |
|
2505 | set groupfilelast -1 | |
2506 | foreach p $parents($diffmergeid) { |
|
2506 | foreach p $parents($diffmergeid) { | |
2507 | set cmd [list | $env(HG) --config ui.report_untrusted=false debug-diff-tree -p $p $diffmergeid] |
|
2507 | set cmd [list | $env(HG) --config ui.report_untrusted=false debug-diff-tree -p $p $diffmergeid] | |
2508 | set cmd [concat $cmd $mergefilelist($diffmergeid)] |
|
2508 | set cmd [concat $cmd $mergefilelist($diffmergeid)] | |
2509 | if {[catch {set f [open $cmd r]} err]} { |
|
2509 | if {[catch {set f [open $cmd r]} err]} { | |
2510 | error_popup "Error getting diffs: $err" |
|
2510 | error_popup "Error getting diffs: $err" | |
2511 | foreach f $flist { |
|
2511 | foreach f $flist { | |
2512 | catch {close $f} |
|
2512 | catch {close $f} | |
2513 | } |
|
2513 | } | |
2514 | return |
|
2514 | return | |
2515 | } |
|
2515 | } | |
2516 | lappend flist $f |
|
2516 | lappend flist $f | |
2517 | set ids [list $diffmergeid $p] |
|
2517 | set ids [list $diffmergeid $p] | |
2518 | set mergefds($ids) $f |
|
2518 | set mergefds($ids) $f | |
2519 | set diffinhunk($ids) 0 |
|
2519 | set diffinhunk($ids) 0 | |
2520 | set diffblocked($ids) 0 |
|
2520 | set diffblocked($ids) 0 | |
2521 | fconfigure $f -blocking 0 |
|
2521 | fconfigure $f -blocking 0 | |
2522 | fileevent $f readable [list getmergediffline $f $ids $diffmergeid] |
|
2522 | fileevent $f readable [list getmergediffline $f $ids $diffmergeid] | |
2523 | } |
|
2523 | } | |
2524 | } |
|
2524 | } | |
2525 |
|
2525 | |||
2526 | proc getmergediffline {f ids id} { |
|
2526 | proc getmergediffline {f ids id} { | |
2527 | global diffmergeid diffinhunk diffoldlines diffnewlines |
|
2527 | global diffmergeid diffinhunk diffoldlines diffnewlines | |
2528 | global currentfile currenthunk |
|
2528 | global currentfile currenthunk | |
2529 | global diffoldstart diffnewstart diffoldlno diffnewlno |
|
2529 | global diffoldstart diffnewstart diffoldlno diffnewlno | |
2530 | global diffblocked mergefilelist |
|
2530 | global diffblocked mergefilelist | |
2531 | global noldlines nnewlines difflcounts filelines |
|
2531 | global noldlines nnewlines difflcounts filelines | |
2532 |
|
2532 | |||
2533 | set n [gets $f line] |
|
2533 | set n [gets $f line] | |
2534 | if {$n < 0} { |
|
2534 | if {$n < 0} { | |
2535 | if {![eof $f]} return |
|
2535 | if {![eof $f]} return | |
2536 | } |
|
2536 | } | |
2537 |
|
2537 | |||
2538 | if {!([info exists diffmergeid] && $diffmergeid == $id)} { |
|
2538 | if {!([info exists diffmergeid] && $diffmergeid == $id)} { | |
2539 | if {$n < 0} { |
|
2539 | if {$n < 0} { | |
2540 | close $f |
|
2540 | close $f | |
2541 | } |
|
2541 | } | |
2542 | return |
|
2542 | return | |
2543 | } |
|
2543 | } | |
2544 |
|
2544 | |||
2545 | if {$diffinhunk($ids) != 0} { |
|
2545 | if {$diffinhunk($ids) != 0} { | |
2546 | set fi $currentfile($ids) |
|
2546 | set fi $currentfile($ids) | |
2547 | if {$n > 0 && [regexp {^[-+ \\]} $line match]} { |
|
2547 | if {$n > 0 && [regexp {^[-+ \\]} $line match]} { | |
2548 | # continuing an existing hunk |
|
2548 | # continuing an existing hunk | |
2549 | set line [string range $line 1 end] |
|
2549 | set line [string range $line 1 end] | |
2550 | set p [lindex $ids 1] |
|
2550 | set p [lindex $ids 1] | |
2551 | if {$match eq "-" || $match eq " "} { |
|
2551 | if {$match eq "-" || $match eq " "} { | |
2552 | set filelines($p,$fi,$diffoldlno($ids)) $line |
|
2552 | set filelines($p,$fi,$diffoldlno($ids)) $line | |
2553 | incr diffoldlno($ids) |
|
2553 | incr diffoldlno($ids) | |
2554 | } |
|
2554 | } | |
2555 | if {$match eq "+" || $match eq " "} { |
|
2555 | if {$match eq "+" || $match eq " "} { | |
2556 | set filelines($id,$fi,$diffnewlno($ids)) $line |
|
2556 | set filelines($id,$fi,$diffnewlno($ids)) $line | |
2557 | incr diffnewlno($ids) |
|
2557 | incr diffnewlno($ids) | |
2558 | } |
|
2558 | } | |
2559 | if {$match eq " "} { |
|
2559 | if {$match eq " "} { | |
2560 | if {$diffinhunk($ids) == 2} { |
|
2560 | if {$diffinhunk($ids) == 2} { | |
2561 | lappend difflcounts($ids) \ |
|
2561 | lappend difflcounts($ids) \ | |
2562 | [list $noldlines($ids) $nnewlines($ids)] |
|
2562 | [list $noldlines($ids) $nnewlines($ids)] | |
2563 | set noldlines($ids) 0 |
|
2563 | set noldlines($ids) 0 | |
2564 | set diffinhunk($ids) 1 |
|
2564 | set diffinhunk($ids) 1 | |
2565 | } |
|
2565 | } | |
2566 | incr noldlines($ids) |
|
2566 | incr noldlines($ids) | |
2567 | } elseif {$match eq "-" || $match eq "+"} { |
|
2567 | } elseif {$match eq "-" || $match eq "+"} { | |
2568 | if {$diffinhunk($ids) == 1} { |
|
2568 | if {$diffinhunk($ids) == 1} { | |
2569 | lappend difflcounts($ids) [list $noldlines($ids)] |
|
2569 | lappend difflcounts($ids) [list $noldlines($ids)] | |
2570 | set noldlines($ids) 0 |
|
2570 | set noldlines($ids) 0 | |
2571 | set nnewlines($ids) 0 |
|
2571 | set nnewlines($ids) 0 | |
2572 | set diffinhunk($ids) 2 |
|
2572 | set diffinhunk($ids) 2 | |
2573 | } |
|
2573 | } | |
2574 | if {$match eq "-"} { |
|
2574 | if {$match eq "-"} { | |
2575 | incr noldlines($ids) |
|
2575 | incr noldlines($ids) | |
2576 | } else { |
|
2576 | } else { | |
2577 | incr nnewlines($ids) |
|
2577 | incr nnewlines($ids) | |
2578 | } |
|
2578 | } | |
2579 | } |
|
2579 | } | |
2580 | # and if it's \ No newline at end of line, then what? |
|
2580 | # and if it's \ No newline at end of line, then what? | |
2581 | return |
|
2581 | return | |
2582 | } |
|
2582 | } | |
2583 | # end of a hunk |
|
2583 | # end of a hunk | |
2584 | if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} { |
|
2584 | if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} { | |
2585 | lappend difflcounts($ids) [list $noldlines($ids)] |
|
2585 | lappend difflcounts($ids) [list $noldlines($ids)] | |
2586 | } elseif {$diffinhunk($ids) == 2 |
|
2586 | } elseif {$diffinhunk($ids) == 2 | |
2587 | && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} { |
|
2587 | && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} { | |
2588 | lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)] |
|
2588 | lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)] | |
2589 | } |
|
2589 | } | |
2590 | set currenthunk($ids) [list $currentfile($ids) \ |
|
2590 | set currenthunk($ids) [list $currentfile($ids) \ | |
2591 | $diffoldstart($ids) $diffnewstart($ids) \ |
|
2591 | $diffoldstart($ids) $diffnewstart($ids) \ | |
2592 | $diffoldlno($ids) $diffnewlno($ids) \ |
|
2592 | $diffoldlno($ids) $diffnewlno($ids) \ | |
2593 | $difflcounts($ids)] |
|
2593 | $difflcounts($ids)] | |
2594 | set diffinhunk($ids) 0 |
|
2594 | set diffinhunk($ids) 0 | |
2595 | # -1 = need to block, 0 = unblocked, 1 = is blocked |
|
2595 | # -1 = need to block, 0 = unblocked, 1 = is blocked | |
2596 | set diffblocked($ids) -1 |
|
2596 | set diffblocked($ids) -1 | |
2597 | processhunks |
|
2597 | processhunks | |
2598 | if {$diffblocked($ids) == -1} { |
|
2598 | if {$diffblocked($ids) == -1} { | |
2599 | fileevent $f readable {} |
|
2599 | fileevent $f readable {} | |
2600 | set diffblocked($ids) 1 |
|
2600 | set diffblocked($ids) 1 | |
2601 | } |
|
2601 | } | |
2602 | } |
|
2602 | } | |
2603 |
|
2603 | |||
2604 | if {$n < 0} { |
|
2604 | if {$n < 0} { | |
2605 | # eof |
|
2605 | # eof | |
2606 | if {!$diffblocked($ids)} { |
|
2606 | if {!$diffblocked($ids)} { | |
2607 | close $f |
|
2607 | close $f | |
2608 | set currentfile($ids) [llength $mergefilelist($diffmergeid)] |
|
2608 | set currentfile($ids) [llength $mergefilelist($diffmergeid)] | |
2609 | set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}] |
|
2609 | set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}] | |
2610 | processhunks |
|
2610 | processhunks | |
2611 | } |
|
2611 | } | |
2612 | } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} { |
|
2612 | } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} { | |
2613 | # start of a new file |
|
2613 | # start of a new file | |
2614 | set currentfile($ids) \ |
|
2614 | set currentfile($ids) \ | |
2615 | [lsearch -exact $mergefilelist($diffmergeid) $fname] |
|
2615 | [lsearch -exact $mergefilelist($diffmergeid) $fname] | |
2616 | } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \ |
|
2616 | } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \ | |
2617 | $line match f1l f1c f2l f2c rest]} { |
|
2617 | $line match f1l f1c f2l f2c rest]} { | |
2618 | if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} { |
|
2618 | if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} { | |
2619 | # start of a new hunk |
|
2619 | # start of a new hunk | |
2620 | if {$f1l == 0 && $f1c == 0} { |
|
2620 | if {$f1l == 0 && $f1c == 0} { | |
2621 | set f1l 1 |
|
2621 | set f1l 1 | |
2622 | } |
|
2622 | } | |
2623 | if {$f2l == 0 && $f2c == 0} { |
|
2623 | if {$f2l == 0 && $f2c == 0} { | |
2624 | set f2l 1 |
|
2624 | set f2l 1 | |
2625 | } |
|
2625 | } | |
2626 | set diffinhunk($ids) 1 |
|
2626 | set diffinhunk($ids) 1 | |
2627 | set diffoldstart($ids) $f1l |
|
2627 | set diffoldstart($ids) $f1l | |
2628 | set diffnewstart($ids) $f2l |
|
2628 | set diffnewstart($ids) $f2l | |
2629 | set diffoldlno($ids) $f1l |
|
2629 | set diffoldlno($ids) $f1l | |
2630 | set diffnewlno($ids) $f2l |
|
2630 | set diffnewlno($ids) $f2l | |
2631 | set difflcounts($ids) {} |
|
2631 | set difflcounts($ids) {} | |
2632 | set noldlines($ids) 0 |
|
2632 | set noldlines($ids) 0 | |
2633 | set nnewlines($ids) 0 |
|
2633 | set nnewlines($ids) 0 | |
2634 | } |
|
2634 | } | |
2635 | } |
|
2635 | } | |
2636 | } |
|
2636 | } | |
2637 |
|
2637 | |||
2638 | proc processhunks {} { |
|
2638 | proc processhunks {} { | |
2639 | global diffmergeid parents nparents currenthunk |
|
2639 | global diffmergeid parents nparents currenthunk | |
2640 | global mergefilelist diffblocked mergefds |
|
2640 | global mergefilelist diffblocked mergefds | |
2641 | global grouphunks grouplinestart grouplineend groupfilenum |
|
2641 | global grouphunks grouplinestart grouplineend groupfilenum | |
2642 |
|
2642 | |||
2643 | set nfiles [llength $mergefilelist($diffmergeid)] |
|
2643 | set nfiles [llength $mergefilelist($diffmergeid)] | |
2644 | while 1 { |
|
2644 | while 1 { | |
2645 | set fi $nfiles |
|
2645 | set fi $nfiles | |
2646 | set lno 0 |
|
2646 | set lno 0 | |
2647 | # look for the earliest hunk |
|
2647 | # look for the earliest hunk | |
2648 | foreach p $parents($diffmergeid) { |
|
2648 | foreach p $parents($diffmergeid) { | |
2649 | set ids [list $diffmergeid $p] |
|
2649 | set ids [list $diffmergeid $p] | |
2650 | if {![info exists currenthunk($ids)]} return |
|
2650 | if {![info exists currenthunk($ids)]} return | |
2651 | set i [lindex $currenthunk($ids) 0] |
|
2651 | set i [lindex $currenthunk($ids) 0] | |
2652 | set l [lindex $currenthunk($ids) 2] |
|
2652 | set l [lindex $currenthunk($ids) 2] | |
2653 | if {$i < $fi || ($i == $fi && $l < $lno)} { |
|
2653 | if {$i < $fi || ($i == $fi && $l < $lno)} { | |
2654 | set fi $i |
|
2654 | set fi $i | |
2655 | set lno $l |
|
2655 | set lno $l | |
2656 | set pi $p |
|
2656 | set pi $p | |
2657 | } |
|
2657 | } | |
2658 | } |
|
2658 | } | |
2659 |
|
2659 | |||
2660 | if {$fi < $nfiles} { |
|
2660 | if {$fi < $nfiles} { | |
2661 | set ids [list $diffmergeid $pi] |
|
2661 | set ids [list $diffmergeid $pi] | |
2662 | set hunk $currenthunk($ids) |
|
2662 | set hunk $currenthunk($ids) | |
2663 | unset currenthunk($ids) |
|
2663 | unset currenthunk($ids) | |
2664 | if {$diffblocked($ids) > 0} { |
|
2664 | if {$diffblocked($ids) > 0} { | |
2665 | fileevent $mergefds($ids) readable \ |
|
2665 | fileevent $mergefds($ids) readable \ | |
2666 | [list getmergediffline $mergefds($ids) $ids $diffmergeid] |
|
2666 | [list getmergediffline $mergefds($ids) $ids $diffmergeid] | |
2667 | } |
|
2667 | } | |
2668 | set diffblocked($ids) 0 |
|
2668 | set diffblocked($ids) 0 | |
2669 |
|
2669 | |||
2670 | if {[info exists groupfilenum] && $groupfilenum == $fi |
|
2670 | if {[info exists groupfilenum] && $groupfilenum == $fi | |
2671 | && $lno <= $grouplineend} { |
|
2671 | && $lno <= $grouplineend} { | |
2672 | # add this hunk to the pending group |
|
2672 | # add this hunk to the pending group | |
2673 | lappend grouphunks($pi) $hunk |
|
2673 | lappend grouphunks($pi) $hunk | |
2674 | set endln [lindex $hunk 4] |
|
2674 | set endln [lindex $hunk 4] | |
2675 | if {$endln > $grouplineend} { |
|
2675 | if {$endln > $grouplineend} { | |
2676 | set grouplineend $endln |
|
2676 | set grouplineend $endln | |
2677 | } |
|
2677 | } | |
2678 | continue |
|
2678 | continue | |
2679 | } |
|
2679 | } | |
2680 | } |
|
2680 | } | |
2681 |
|
2681 | |||
2682 | # succeeding stuff doesn't belong in this group, so |
|
2682 | # succeeding stuff doesn't belong in this group, so | |
2683 | # process the group now |
|
2683 | # process the group now | |
2684 | if {[info exists groupfilenum]} { |
|
2684 | if {[info exists groupfilenum]} { | |
2685 | processgroup |
|
2685 | processgroup | |
2686 | unset groupfilenum |
|
2686 | unset groupfilenum | |
2687 | unset grouphunks |
|
2687 | unset grouphunks | |
2688 | } |
|
2688 | } | |
2689 |
|
2689 | |||
2690 | if {$fi >= $nfiles} break |
|
2690 | if {$fi >= $nfiles} break | |
2691 |
|
2691 | |||
2692 | # start a new group |
|
2692 | # start a new group | |
2693 | set groupfilenum $fi |
|
2693 | set groupfilenum $fi | |
2694 | set grouphunks($pi) [list $hunk] |
|
2694 | set grouphunks($pi) [list $hunk] | |
2695 | set grouplinestart $lno |
|
2695 | set grouplinestart $lno | |
2696 | set grouplineend [lindex $hunk 4] |
|
2696 | set grouplineend [lindex $hunk 4] | |
2697 | } |
|
2697 | } | |
2698 | } |
|
2698 | } | |
2699 |
|
2699 | |||
2700 | proc processgroup {} { |
|
2700 | proc processgroup {} { | |
2701 | global groupfilelast groupfilenum difffilestart |
|
2701 | global groupfilelast groupfilenum difffilestart | |
2702 | global mergefilelist diffmergeid ctext filelines |
|
2702 | global mergefilelist diffmergeid ctext filelines | |
2703 | global parents diffmergeid diffoffset |
|
2703 | global parents diffmergeid diffoffset | |
2704 | global grouphunks grouplinestart grouplineend nparents |
|
2704 | global grouphunks grouplinestart grouplineend nparents | |
2705 | global mergemax |
|
2705 | global mergemax | |
2706 |
|
2706 | |||
2707 | $ctext conf -state normal |
|
2707 | $ctext conf -state normal | |
2708 | set id $diffmergeid |
|
2708 | set id $diffmergeid | |
2709 | set f $groupfilenum |
|
2709 | set f $groupfilenum | |
2710 | if {$groupfilelast != $f} { |
|
2710 | if {$groupfilelast != $f} { | |
2711 | $ctext insert end "\n" |
|
2711 | $ctext insert end "\n" | |
2712 | set here [$ctext index "end - 1c"] |
|
2712 | set here [$ctext index "end - 1c"] | |
2713 | set difffilestart($f) $here |
|
2713 | set difffilestart($f) $here | |
2714 | set mark fmark.[expr {$f + 1}] |
|
2714 | set mark fmark.[expr {$f + 1}] | |
2715 | $ctext mark set $mark $here |
|
2715 | $ctext mark set $mark $here | |
2716 | $ctext mark gravity $mark left |
|
2716 | $ctext mark gravity $mark left | |
2717 | set header [lindex $mergefilelist($id) $f] |
|
2717 | set header [lindex $mergefilelist($id) $f] | |
2718 | set l [expr {(78 - [string length $header]) / 2}] |
|
2718 | set l [expr {(78 - [string length $header]) / 2}] | |
2719 | set pad [string range "----------------------------------------" 1 $l] |
|
2719 | set pad [string range "----------------------------------------" 1 $l] | |
2720 | $ctext insert end "$pad $header $pad\n" filesep |
|
2720 | $ctext insert end "$pad $header $pad\n" filesep | |
2721 | set groupfilelast $f |
|
2721 | set groupfilelast $f | |
2722 | foreach p $parents($id) { |
|
2722 | foreach p $parents($id) { | |
2723 | set diffoffset($p) 0 |
|
2723 | set diffoffset($p) 0 | |
2724 | } |
|
2724 | } | |
2725 | } |
|
2725 | } | |
2726 |
|
2726 | |||
2727 | $ctext insert end "@@" msep |
|
2727 | $ctext insert end "@@" msep | |
2728 | set nlines [expr {$grouplineend - $grouplinestart}] |
|
2728 | set nlines [expr {$grouplineend - $grouplinestart}] | |
2729 | set events {} |
|
2729 | set events {} | |
2730 | set pnum 0 |
|
2730 | set pnum 0 | |
2731 | foreach p $parents($id) { |
|
2731 | foreach p $parents($id) { | |
2732 | set startline [expr {$grouplinestart + $diffoffset($p)}] |
|
2732 | set startline [expr {$grouplinestart + $diffoffset($p)}] | |
2733 | set ol $startline |
|
2733 | set ol $startline | |
2734 | set nl $grouplinestart |
|
2734 | set nl $grouplinestart | |
2735 | if {[info exists grouphunks($p)]} { |
|
2735 | if {[info exists grouphunks($p)]} { | |
2736 | foreach h $grouphunks($p) { |
|
2736 | foreach h $grouphunks($p) { | |
2737 | set l [lindex $h 2] |
|
2737 | set l [lindex $h 2] | |
2738 | if {$nl < $l} { |
|
2738 | if {$nl < $l} { | |
2739 | for {} {$nl < $l} {incr nl} { |
|
2739 | for {} {$nl < $l} {incr nl} { | |
2740 | set filelines($p,$f,$ol) $filelines($id,$f,$nl) |
|
2740 | set filelines($p,$f,$ol) $filelines($id,$f,$nl) | |
2741 | incr ol |
|
2741 | incr ol | |
2742 | } |
|
2742 | } | |
2743 | } |
|
2743 | } | |
2744 | foreach chunk [lindex $h 5] { |
|
2744 | foreach chunk [lindex $h 5] { | |
2745 | if {[llength $chunk] == 2} { |
|
2745 | if {[llength $chunk] == 2} { | |
2746 | set olc [lindex $chunk 0] |
|
2746 | set olc [lindex $chunk 0] | |
2747 | set nlc [lindex $chunk 1] |
|
2747 | set nlc [lindex $chunk 1] | |
2748 | set nnl [expr {$nl + $nlc}] |
|
2748 | set nnl [expr {$nl + $nlc}] | |
2749 | lappend events [list $nl $nnl $pnum $olc $nlc] |
|
2749 | lappend events [list $nl $nnl $pnum $olc $nlc] | |
2750 | incr ol $olc |
|
2750 | incr ol $olc | |
2751 | set nl $nnl |
|
2751 | set nl $nnl | |
2752 | } else { |
|
2752 | } else { | |
2753 | incr ol [lindex $chunk 0] |
|
2753 | incr ol [lindex $chunk 0] | |
2754 | incr nl [lindex $chunk 0] |
|
2754 | incr nl [lindex $chunk 0] | |
2755 | } |
|
2755 | } | |
2756 | } |
|
2756 | } | |
2757 | } |
|
2757 | } | |
2758 | } |
|
2758 | } | |
2759 | if {$nl < $grouplineend} { |
|
2759 | if {$nl < $grouplineend} { | |
2760 | for {} {$nl < $grouplineend} {incr nl} { |
|
2760 | for {} {$nl < $grouplineend} {incr nl} { | |
2761 | set filelines($p,$f,$ol) $filelines($id,$f,$nl) |
|
2761 | set filelines($p,$f,$ol) $filelines($id,$f,$nl) | |
2762 | incr ol |
|
2762 | incr ol | |
2763 | } |
|
2763 | } | |
2764 | } |
|
2764 | } | |
2765 | set nlines [expr {$ol - $startline}] |
|
2765 | set nlines [expr {$ol - $startline}] | |
2766 | $ctext insert end " -$startline,$nlines" msep |
|
2766 | $ctext insert end " -$startline,$nlines" msep | |
2767 | incr pnum |
|
2767 | incr pnum | |
2768 | } |
|
2768 | } | |
2769 |
|
2769 | |||
2770 | set nlines [expr {$grouplineend - $grouplinestart}] |
|
2770 | set nlines [expr {$grouplineend - $grouplinestart}] | |
2771 | $ctext insert end " +$grouplinestart,$nlines @@\n" msep |
|
2771 | $ctext insert end " +$grouplinestart,$nlines @@\n" msep | |
2772 |
|
2772 | |||
2773 | set events [lsort -integer -index 0 $events] |
|
2773 | set events [lsort -integer -index 0 $events] | |
2774 | set nevents [llength $events] |
|
2774 | set nevents [llength $events] | |
2775 | set nmerge $nparents($diffmergeid) |
|
2775 | set nmerge $nparents($diffmergeid) | |
2776 | set l $grouplinestart |
|
2776 | set l $grouplinestart | |
2777 | for {set i 0} {$i < $nevents} {set i $j} { |
|
2777 | for {set i 0} {$i < $nevents} {set i $j} { | |
2778 | set nl [lindex $events $i 0] |
|
2778 | set nl [lindex $events $i 0] | |
2779 | while {$l < $nl} { |
|
2779 | while {$l < $nl} { | |
2780 | $ctext insert end " $filelines($id,$f,$l)\n" |
|
2780 | $ctext insert end " $filelines($id,$f,$l)\n" | |
2781 | incr l |
|
2781 | incr l | |
2782 | } |
|
2782 | } | |
2783 | set e [lindex $events $i] |
|
2783 | set e [lindex $events $i] | |
2784 | set enl [lindex $e 1] |
|
2784 | set enl [lindex $e 1] | |
2785 | set j $i |
|
2785 | set j $i | |
2786 | set active {} |
|
2786 | set active {} | |
2787 | while 1 { |
|
2787 | while 1 { | |
2788 | set pnum [lindex $e 2] |
|
2788 | set pnum [lindex $e 2] | |
2789 | set olc [lindex $e 3] |
|
2789 | set olc [lindex $e 3] | |
2790 | set nlc [lindex $e 4] |
|
2790 | set nlc [lindex $e 4] | |
2791 | if {![info exists delta($pnum)]} { |
|
2791 | if {![info exists delta($pnum)]} { | |
2792 | set delta($pnum) [expr {$olc - $nlc}] |
|
2792 | set delta($pnum) [expr {$olc - $nlc}] | |
2793 | lappend active $pnum |
|
2793 | lappend active $pnum | |
2794 | } else { |
|
2794 | } else { | |
2795 | incr delta($pnum) [expr {$olc - $nlc}] |
|
2795 | incr delta($pnum) [expr {$olc - $nlc}] | |
2796 | } |
|
2796 | } | |
2797 | if {[incr j] >= $nevents} break |
|
2797 | if {[incr j] >= $nevents} break | |
2798 | set e [lindex $events $j] |
|
2798 | set e [lindex $events $j] | |
2799 | if {[lindex $e 0] >= $enl} break |
|
2799 | if {[lindex $e 0] >= $enl} break | |
2800 | if {[lindex $e 1] > $enl} { |
|
2800 | if {[lindex $e 1] > $enl} { | |
2801 | set enl [lindex $e 1] |
|
2801 | set enl [lindex $e 1] | |
2802 | } |
|
2802 | } | |
2803 | } |
|
2803 | } | |
2804 | set nlc [expr {$enl - $l}] |
|
2804 | set nlc [expr {$enl - $l}] | |
2805 | set ncol mresult |
|
2805 | set ncol mresult | |
2806 | set bestpn -1 |
|
2806 | set bestpn -1 | |
2807 | if {[llength $active] == $nmerge - 1} { |
|
2807 | if {[llength $active] == $nmerge - 1} { | |
2808 | # no diff for one of the parents, i.e. it's identical |
|
2808 | # no diff for one of the parents, i.e. it's identical | |
2809 | for {set pnum 0} {$pnum < $nmerge} {incr pnum} { |
|
2809 | for {set pnum 0} {$pnum < $nmerge} {incr pnum} { | |
2810 | if {![info exists delta($pnum)]} { |
|
2810 | if {![info exists delta($pnum)]} { | |
2811 | if {$pnum < $mergemax} { |
|
2811 | if {$pnum < $mergemax} { | |
2812 | lappend ncol m$pnum |
|
2812 | lappend ncol m$pnum | |
2813 | } else { |
|
2813 | } else { | |
2814 | lappend ncol mmax |
|
2814 | lappend ncol mmax | |
2815 | } |
|
2815 | } | |
2816 | break |
|
2816 | break | |
2817 | } |
|
2817 | } | |
2818 | } |
|
2818 | } | |
2819 | } elseif {[llength $active] == $nmerge} { |
|
2819 | } elseif {[llength $active] == $nmerge} { | |
2820 | # all parents are different, see if one is very similar |
|
2820 | # all parents are different, see if one is very similar | |
2821 | set bestsim 30 |
|
2821 | set bestsim 30 | |
2822 | for {set pnum 0} {$pnum < $nmerge} {incr pnum} { |
|
2822 | for {set pnum 0} {$pnum < $nmerge} {incr pnum} { | |
2823 | set sim [similarity $pnum $l $nlc $f \ |
|
2823 | set sim [similarity $pnum $l $nlc $f \ | |
2824 | [lrange $events $i [expr {$j-1}]]] |
|
2824 | [lrange $events $i [expr {$j-1}]]] | |
2825 | if {$sim > $bestsim} { |
|
2825 | if {$sim > $bestsim} { | |
2826 | set bestsim $sim |
|
2826 | set bestsim $sim | |
2827 | set bestpn $pnum |
|
2827 | set bestpn $pnum | |
2828 | } |
|
2828 | } | |
2829 | } |
|
2829 | } | |
2830 | if {$bestpn >= 0} { |
|
2830 | if {$bestpn >= 0} { | |
2831 | lappend ncol m$bestpn |
|
2831 | lappend ncol m$bestpn | |
2832 | } |
|
2832 | } | |
2833 | } |
|
2833 | } | |
2834 | set pnum -1 |
|
2834 | set pnum -1 | |
2835 | foreach p $parents($id) { |
|
2835 | foreach p $parents($id) { | |
2836 | incr pnum |
|
2836 | incr pnum | |
2837 | if {![info exists delta($pnum)] || $pnum == $bestpn} continue |
|
2837 | if {![info exists delta($pnum)] || $pnum == $bestpn} continue | |
2838 | set olc [expr {$nlc + $delta($pnum)}] |
|
2838 | set olc [expr {$nlc + $delta($pnum)}] | |
2839 | set ol [expr {$l + $diffoffset($p)}] |
|
2839 | set ol [expr {$l + $diffoffset($p)}] | |
2840 | incr diffoffset($p) $delta($pnum) |
|
2840 | incr diffoffset($p) $delta($pnum) | |
2841 | unset delta($pnum) |
|
2841 | unset delta($pnum) | |
2842 | for {} {$olc > 0} {incr olc -1} { |
|
2842 | for {} {$olc > 0} {incr olc -1} { | |
2843 | $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum |
|
2843 | $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum | |
2844 | incr ol |
|
2844 | incr ol | |
2845 | } |
|
2845 | } | |
2846 | } |
|
2846 | } | |
2847 | set endl [expr {$l + $nlc}] |
|
2847 | set endl [expr {$l + $nlc}] | |
2848 | if {$bestpn >= 0} { |
|
2848 | if {$bestpn >= 0} { | |
2849 | # show this pretty much as a normal diff |
|
2849 | # show this pretty much as a normal diff | |
2850 | set p [lindex $parents($id) $bestpn] |
|
2850 | set p [lindex $parents($id) $bestpn] | |
2851 | set ol [expr {$l + $diffoffset($p)}] |
|
2851 | set ol [expr {$l + $diffoffset($p)}] | |
2852 | incr diffoffset($p) $delta($bestpn) |
|
2852 | incr diffoffset($p) $delta($bestpn) | |
2853 | unset delta($bestpn) |
|
2853 | unset delta($bestpn) | |
2854 | for {set k $i} {$k < $j} {incr k} { |
|
2854 | for {set k $i} {$k < $j} {incr k} { | |
2855 | set e [lindex $events $k] |
|
2855 | set e [lindex $events $k] | |
2856 | if {[lindex $e 2] != $bestpn} continue |
|
2856 | if {[lindex $e 2] != $bestpn} continue | |
2857 | set nl [lindex $e 0] |
|
2857 | set nl [lindex $e 0] | |
2858 | set ol [expr {$ol + $nl - $l}] |
|
2858 | set ol [expr {$ol + $nl - $l}] | |
2859 | for {} {$l < $nl} {incr l} { |
|
2859 | for {} {$l < $nl} {incr l} { | |
2860 | $ctext insert end "+$filelines($id,$f,$l)\n" $ncol |
|
2860 | $ctext insert end "+$filelines($id,$f,$l)\n" $ncol | |
2861 | } |
|
2861 | } | |
2862 | set c [lindex $e 3] |
|
2862 | set c [lindex $e 3] | |
2863 | for {} {$c > 0} {incr c -1} { |
|
2863 | for {} {$c > 0} {incr c -1} { | |
2864 | $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn |
|
2864 | $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn | |
2865 | incr ol |
|
2865 | incr ol | |
2866 | } |
|
2866 | } | |
2867 | set nl [lindex $e 1] |
|
2867 | set nl [lindex $e 1] | |
2868 | for {} {$l < $nl} {incr l} { |
|
2868 | for {} {$l < $nl} {incr l} { | |
2869 | $ctext insert end "+$filelines($id,$f,$l)\n" mresult |
|
2869 | $ctext insert end "+$filelines($id,$f,$l)\n" mresult | |
2870 | } |
|
2870 | } | |
2871 | } |
|
2871 | } | |
2872 | } |
|
2872 | } | |
2873 | for {} {$l < $endl} {incr l} { |
|
2873 | for {} {$l < $endl} {incr l} { | |
2874 | $ctext insert end "+$filelines($id,$f,$l)\n" $ncol |
|
2874 | $ctext insert end "+$filelines($id,$f,$l)\n" $ncol | |
2875 | } |
|
2875 | } | |
2876 | } |
|
2876 | } | |
2877 | while {$l < $grouplineend} { |
|
2877 | while {$l < $grouplineend} { | |
2878 | $ctext insert end " $filelines($id,$f,$l)\n" |
|
2878 | $ctext insert end " $filelines($id,$f,$l)\n" | |
2879 | incr l |
|
2879 | incr l | |
2880 | } |
|
2880 | } | |
2881 | $ctext conf -state disabled |
|
2881 | $ctext conf -state disabled | |
2882 | } |
|
2882 | } | |
2883 |
|
2883 | |||
2884 | proc similarity {pnum l nlc f events} { |
|
2884 | proc similarity {pnum l nlc f events} { | |
2885 | global diffmergeid parents diffoffset filelines |
|
2885 | global diffmergeid parents diffoffset filelines | |
2886 |
|
2886 | |||
2887 | set id $diffmergeid |
|
2887 | set id $diffmergeid | |
2888 | set p [lindex $parents($id) $pnum] |
|
2888 | set p [lindex $parents($id) $pnum] | |
2889 | set ol [expr {$l + $diffoffset($p)}] |
|
2889 | set ol [expr {$l + $diffoffset($p)}] | |
2890 | set endl [expr {$l + $nlc}] |
|
2890 | set endl [expr {$l + $nlc}] | |
2891 | set same 0 |
|
2891 | set same 0 | |
2892 | set diff 0 |
|
2892 | set diff 0 | |
2893 | foreach e $events { |
|
2893 | foreach e $events { | |
2894 | if {[lindex $e 2] != $pnum} continue |
|
2894 | if {[lindex $e 2] != $pnum} continue | |
2895 | set nl [lindex $e 0] |
|
2895 | set nl [lindex $e 0] | |
2896 | set ol [expr {$ol + $nl - $l}] |
|
2896 | set ol [expr {$ol + $nl - $l}] | |
2897 | for {} {$l < $nl} {incr l} { |
|
2897 | for {} {$l < $nl} {incr l} { | |
2898 | incr same [string length $filelines($id,$f,$l)] |
|
2898 | incr same [string length $filelines($id,$f,$l)] | |
2899 | incr same |
|
2899 | incr same | |
2900 | } |
|
2900 | } | |
2901 | set oc [lindex $e 3] |
|
2901 | set oc [lindex $e 3] | |
2902 | for {} {$oc > 0} {incr oc -1} { |
|
2902 | for {} {$oc > 0} {incr oc -1} { | |
2903 | incr diff [string length $filelines($p,$f,$ol)] |
|
2903 | incr diff [string length $filelines($p,$f,$ol)] | |
2904 | incr diff |
|
2904 | incr diff | |
2905 | incr ol |
|
2905 | incr ol | |
2906 | } |
|
2906 | } | |
2907 | set nl [lindex $e 1] |
|
2907 | set nl [lindex $e 1] | |
2908 | for {} {$l < $nl} {incr l} { |
|
2908 | for {} {$l < $nl} {incr l} { | |
2909 | incr diff [string length $filelines($id,$f,$l)] |
|
2909 | incr diff [string length $filelines($id,$f,$l)] | |
2910 | incr diff |
|
2910 | incr diff | |
2911 | } |
|
2911 | } | |
2912 | } |
|
2912 | } | |
2913 | for {} {$l < $endl} {incr l} { |
|
2913 | for {} {$l < $endl} {incr l} { | |
2914 | incr same [string length $filelines($id,$f,$l)] |
|
2914 | incr same [string length $filelines($id,$f,$l)] | |
2915 | incr same |
|
2915 | incr same | |
2916 | } |
|
2916 | } | |
2917 | if {$same == 0} { |
|
2917 | if {$same == 0} { | |
2918 | return 0 |
|
2918 | return 0 | |
2919 | } |
|
2919 | } | |
2920 | return [expr {200 * $same / (2 * $same + $diff)}] |
|
2920 | return [expr {200 * $same / (2 * $same + $diff)}] | |
2921 | } |
|
2921 | } | |
2922 |
|
2922 | |||
2923 | proc startdiff {ids} { |
|
2923 | proc startdiff {ids} { | |
2924 | global treediffs diffids treepending diffmergeid |
|
2924 | global treediffs diffids treepending diffmergeid | |
2925 |
|
2925 | |||
2926 | set diffids $ids |
|
2926 | set diffids $ids | |
2927 | catch {unset diffmergeid} |
|
2927 | catch {unset diffmergeid} | |
2928 | if {![info exists treediffs($ids)]} { |
|
2928 | if {![info exists treediffs($ids)]} { | |
2929 | if {![info exists treepending]} { |
|
2929 | if {![info exists treepending]} { | |
2930 | gettreediffs $ids |
|
2930 | gettreediffs $ids | |
2931 | } |
|
2931 | } | |
2932 | } else { |
|
2932 | } else { | |
2933 | addtocflist $ids |
|
2933 | addtocflist $ids | |
2934 | } |
|
2934 | } | |
2935 | } |
|
2935 | } | |
2936 |
|
2936 | |||
2937 | proc addtocflist {ids} { |
|
2937 | proc addtocflist {ids} { | |
2938 | global treediffs cflist |
|
2938 | global treediffs cflist | |
2939 | foreach f $treediffs($ids) { |
|
2939 | foreach f $treediffs($ids) { | |
2940 | $cflist insert end $f |
|
2940 | $cflist insert end $f | |
2941 | } |
|
2941 | } | |
2942 | getblobdiffs $ids |
|
2942 | getblobdiffs $ids | |
2943 | } |
|
2943 | } | |
2944 |
|
2944 | |||
2945 | proc gettreediffs {ids} { |
|
2945 | proc gettreediffs {ids} { | |
2946 | global treediff parents treepending env |
|
2946 | global treediff parents treepending env | |
2947 | set treepending $ids |
|
2947 | set treepending $ids | |
2948 | set treediff {} |
|
2948 | set treediff {} | |
2949 | set id [lindex $ids 0] |
|
2949 | set id [lindex $ids 0] | |
2950 | set p [lindex $ids 1] |
|
2950 | set p [lindex $ids 1] | |
2951 | if [catch {set gdtf [open "|{$env(HG)} --config ui.report_untrusted=false debug-diff-tree -r $p $id" r]}] return |
|
2951 | if [catch {set gdtf [open "|{$env(HG)} --config ui.report_untrusted=false debug-diff-tree -r $p $id" r]}] return | |
2952 | fconfigure $gdtf -blocking 0 |
|
2952 | fconfigure $gdtf -blocking 0 | |
2953 | fileevent $gdtf readable [list gettreediffline $gdtf $ids] |
|
2953 | fileevent $gdtf readable [list gettreediffline $gdtf $ids] | |
2954 | } |
|
2954 | } | |
2955 |
|
2955 | |||
2956 | proc gettreediffline {gdtf ids} { |
|
2956 | proc gettreediffline {gdtf ids} { | |
2957 | global treediff treediffs treepending diffids diffmergeid |
|
2957 | global treediff treediffs treepending diffids diffmergeid | |
2958 |
|
2958 | |||
2959 | set n [gets $gdtf line] |
|
2959 | set n [gets $gdtf line] | |
2960 | if {$n < 0} { |
|
2960 | if {$n < 0} { | |
2961 | if {![eof $gdtf]} return |
|
2961 | if {![eof $gdtf]} return | |
2962 | close $gdtf |
|
2962 | close $gdtf | |
2963 | set treediffs($ids) $treediff |
|
2963 | set treediffs($ids) $treediff | |
2964 | unset treepending |
|
2964 | unset treepending | |
2965 | if {$ids != $diffids} { |
|
2965 | if {$ids != $diffids} { | |
2966 | gettreediffs $diffids |
|
2966 | gettreediffs $diffids | |
2967 | } else { |
|
2967 | } else { | |
2968 | if {[info exists diffmergeid]} { |
|
2968 | if {[info exists diffmergeid]} { | |
2969 | contmergediff $ids |
|
2969 | contmergediff $ids | |
2970 | } else { |
|
2970 | } else { | |
2971 | addtocflist $ids |
|
2971 | addtocflist $ids | |
2972 | } |
|
2972 | } | |
2973 | } |
|
2973 | } | |
2974 | return |
|
2974 | return | |
2975 | } |
|
2975 | } | |
2976 | set tab1 [expr [string first "\t" $line] + 1] |
|
2976 | set tab1 [expr [string first "\t" $line] + 1] | |
2977 | set tab2 [expr [string first "\t" $line $tab1] - 1] |
|
2977 | set tab2 [expr [string first "\t" $line $tab1] - 1] | |
2978 | set file [string range $line $tab1 $tab2] |
|
2978 | set file [string range $line $tab1 $tab2] | |
2979 | lappend treediff $file |
|
2979 | lappend treediff $file | |
2980 | } |
|
2980 | } | |
2981 |
|
2981 | |||
2982 | proc getblobdiffs {ids} { |
|
2982 | proc getblobdiffs {ids} { | |
2983 | global diffopts blobdifffd diffids env curdifftag curtagstart |
|
2983 | global diffopts blobdifffd diffids env curdifftag curtagstart | |
2984 | global difffilestart nextupdate diffinhdr treediffs |
|
2984 | global difffilestart nextupdate diffinhdr treediffs | |
2985 |
|
2985 | |||
2986 | set id [lindex $ids 0] |
|
2986 | set id [lindex $ids 0] | |
2987 | set p [lindex $ids 1] |
|
2987 | set p [lindex $ids 1] | |
2988 | set env(GIT_DIFF_OPTS) $diffopts |
|
2988 | set env(GIT_DIFF_OPTS) $diffopts | |
2989 | set cmd [list | $env(HG) --config ui.report_untrusted=false debug-diff-tree -r -p -C $p $id] |
|
2989 | set cmd [list | $env(HG) --config ui.report_untrusted=false debug-diff-tree -r -p -C $p $id] | |
2990 | if {[catch {set bdf [open $cmd r]} err]} { |
|
2990 | if {[catch {set bdf [open $cmd r]} err]} { | |
2991 | puts "error getting diffs: $err" |
|
2991 | puts "error getting diffs: $err" | |
2992 | return |
|
2992 | return | |
2993 | } |
|
2993 | } | |
2994 | set diffinhdr 0 |
|
2994 | set diffinhdr 0 | |
2995 | fconfigure $bdf -blocking 0 |
|
2995 | fconfigure $bdf -blocking 0 | |
2996 | set blobdifffd($ids) $bdf |
|
2996 | set blobdifffd($ids) $bdf | |
2997 | set curdifftag Comments |
|
2997 | set curdifftag Comments | |
2998 | set curtagstart 0.0 |
|
2998 | set curtagstart 0.0 | |
2999 | catch {unset difffilestart} |
|
2999 | catch {unset difffilestart} | |
3000 | fileevent $bdf readable [list getblobdiffline $bdf $diffids] |
|
3000 | fileevent $bdf readable [list getblobdiffline $bdf $diffids] | |
3001 | set nextupdate [expr {[clock clicks -milliseconds] + 100}] |
|
3001 | set nextupdate [expr {[clock clicks -milliseconds] + 100}] | |
3002 | } |
|
3002 | } | |
3003 |
|
3003 | |||
3004 | proc getblobdiffline {bdf ids} { |
|
3004 | proc getblobdiffline {bdf ids} { | |
3005 | global diffids blobdifffd ctext curdifftag curtagstart |
|
3005 | global diffids blobdifffd ctext curdifftag curtagstart | |
3006 | global diffnexthead diffnextnote difffilestart |
|
3006 | global diffnexthead diffnextnote difffilestart | |
3007 | global nextupdate diffinhdr treediffs |
|
3007 | global nextupdate diffinhdr treediffs | |
3008 | global gaudydiff |
|
3008 | global gaudydiff | |
3009 |
|
3009 | |||
3010 | set n [gets $bdf line] |
|
3010 | set n [gets $bdf line] | |
3011 | if {$n < 0} { |
|
3011 | if {$n < 0} { | |
3012 | if {[eof $bdf]} { |
|
3012 | if {[eof $bdf]} { | |
3013 | close $bdf |
|
3013 | close $bdf | |
3014 | if {$ids == $diffids && $bdf == $blobdifffd($ids)} { |
|
3014 | if {$ids == $diffids && $bdf == $blobdifffd($ids)} { | |
3015 | $ctext tag add $curdifftag $curtagstart end |
|
3015 | $ctext tag add $curdifftag $curtagstart end | |
3016 | } |
|
3016 | } | |
3017 | } |
|
3017 | } | |
3018 | return |
|
3018 | return | |
3019 | } |
|
3019 | } | |
3020 | if {$ids != $diffids || $bdf != $blobdifffd($ids)} { |
|
3020 | if {$ids != $diffids || $bdf != $blobdifffd($ids)} { | |
3021 | return |
|
3021 | return | |
3022 | } |
|
3022 | } | |
3023 | regsub -all "\r" $line "" line |
|
3023 | regsub -all "\r" $line "" line | |
3024 | $ctext conf -state normal |
|
3024 | $ctext conf -state normal | |
3025 | if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} { |
|
3025 | if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} { | |
3026 | # start of a new file |
|
3026 | # start of a new file | |
3027 | $ctext insert end "\n" |
|
3027 | $ctext insert end "\n" | |
3028 | $ctext tag add $curdifftag $curtagstart end |
|
3028 | $ctext tag add $curdifftag $curtagstart end | |
3029 | set curtagstart [$ctext index "end - 1c"] |
|
3029 | set curtagstart [$ctext index "end - 1c"] | |
3030 | set header $newname |
|
3030 | set header $newname | |
3031 | set here [$ctext index "end - 1c"] |
|
3031 | set here [$ctext index "end - 1c"] | |
3032 | set i [lsearch -exact $treediffs($diffids) $fname] |
|
3032 | set i [lsearch -exact $treediffs($diffids) $fname] | |
3033 | if {$i >= 0} { |
|
3033 | if {$i >= 0} { | |
3034 | set difffilestart($i) $here |
|
3034 | set difffilestart($i) $here | |
3035 | incr i |
|
3035 | incr i | |
3036 | $ctext mark set fmark.$i $here |
|
3036 | $ctext mark set fmark.$i $here | |
3037 | $ctext mark gravity fmark.$i left |
|
3037 | $ctext mark gravity fmark.$i left | |
3038 | } |
|
3038 | } | |
3039 | if {$newname != $fname} { |
|
3039 | if {$newname != $fname} { | |
3040 | set i [lsearch -exact $treediffs($diffids) $newname] |
|
3040 | set i [lsearch -exact $treediffs($diffids) $newname] | |
3041 | if {$i >= 0} { |
|
3041 | if {$i >= 0} { | |
3042 | set difffilestart($i) $here |
|
3042 | set difffilestart($i) $here | |
3043 | incr i |
|
3043 | incr i | |
3044 | $ctext mark set fmark.$i $here |
|
3044 | $ctext mark set fmark.$i $here | |
3045 | $ctext mark gravity fmark.$i left |
|
3045 | $ctext mark gravity fmark.$i left | |
3046 | } |
|
3046 | } | |
3047 | } |
|
3047 | } | |
3048 | set curdifftag "f:$fname" |
|
3048 | set curdifftag "f:$fname" | |
3049 | $ctext tag delete $curdifftag |
|
3049 | $ctext tag delete $curdifftag | |
3050 | set l [expr {(78 - [string length $header]) / 2}] |
|
3050 | set l [expr {(78 - [string length $header]) / 2}] | |
3051 | set pad [string range "----------------------------------------" 1 $l] |
|
3051 | set pad [string range "----------------------------------------" 1 $l] | |
3052 | $ctext insert end "$pad $header $pad\n" filesep |
|
3052 | $ctext insert end "$pad $header $pad\n" filesep | |
3053 | set diffinhdr 1 |
|
3053 | set diffinhdr 1 | |
3054 | } elseif {[regexp {^(---|\+\+\+)} $line]} { |
|
3054 | } elseif {[regexp {^(---|\+\+\+)} $line]} { | |
3055 | set diffinhdr 0 |
|
3055 | set diffinhdr 0 | |
3056 | } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \ |
|
3056 | } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \ | |
3057 | $line match f1l f1c f2l f2c rest]} { |
|
3057 | $line match f1l f1c f2l f2c rest]} { | |
3058 | if {$gaudydiff} { |
|
3058 | if {$gaudydiff} { | |
3059 | $ctext insert end "\t" hunksep |
|
3059 | $ctext insert end "\t" hunksep | |
3060 | $ctext insert end " $f1l " d0 " $f2l " d1 |
|
3060 | $ctext insert end " $f1l " d0 " $f2l " d1 | |
3061 | $ctext insert end " $rest \n" hunksep |
|
3061 | $ctext insert end " $rest \n" hunksep | |
3062 | } else { |
|
3062 | } else { | |
3063 | $ctext insert end "$line\n" hunksep |
|
3063 | $ctext insert end "$line\n" hunksep | |
3064 | } |
|
3064 | } | |
3065 | set diffinhdr 0 |
|
3065 | set diffinhdr 0 | |
3066 | } else { |
|
3066 | } else { | |
3067 | set x [string range $line 0 0] |
|
3067 | set x [string range $line 0 0] | |
3068 | if {$x == "-" || $x == "+"} { |
|
3068 | if {$x == "-" || $x == "+"} { | |
3069 | set tag [expr {$x == "+"}] |
|
3069 | set tag [expr {$x == "+"}] | |
3070 | if {$gaudydiff} { |
|
3070 | if {$gaudydiff} { | |
3071 | set line [string range $line 1 end] |
|
3071 | set line [string range $line 1 end] | |
3072 | } |
|
3072 | } | |
3073 | $ctext insert end "$line\n" d$tag |
|
3073 | $ctext insert end "$line\n" d$tag | |
3074 | } elseif {$x == " "} { |
|
3074 | } elseif {$x == " "} { | |
3075 | if {$gaudydiff} { |
|
3075 | if {$gaudydiff} { | |
3076 | set line [string range $line 1 end] |
|
3076 | set line [string range $line 1 end] | |
3077 | } |
|
3077 | } | |
3078 | $ctext insert end "$line\n" |
|
3078 | $ctext insert end "$line\n" | |
3079 | } elseif {$diffinhdr || $x == "\\"} { |
|
3079 | } elseif {$diffinhdr || $x == "\\"} { | |
3080 | # e.g. "\ No newline at end of file" |
|
3080 | # e.g. "\ No newline at end of file" | |
3081 | $ctext insert end "$line\n" filesep |
|
3081 | $ctext insert end "$line\n" filesep | |
3082 | } elseif {$line != ""} { |
|
3082 | } elseif {$line != ""} { | |
3083 | # Something else we don't recognize |
|
3083 | # Something else we don't recognize | |
3084 | if {$curdifftag != "Comments"} { |
|
3084 | if {$curdifftag != "Comments"} { | |
3085 | $ctext insert end "\n" |
|
3085 | $ctext insert end "\n" | |
3086 | $ctext tag add $curdifftag $curtagstart end |
|
3086 | $ctext tag add $curdifftag $curtagstart end | |
3087 | set curtagstart [$ctext index "end - 1c"] |
|
3087 | set curtagstart [$ctext index "end - 1c"] | |
3088 | set curdifftag Comments |
|
3088 | set curdifftag Comments | |
3089 | } |
|
3089 | } | |
3090 | $ctext insert end "$line\n" filesep |
|
3090 | $ctext insert end "$line\n" filesep | |
3091 | } |
|
3091 | } | |
3092 | } |
|
3092 | } | |
3093 | $ctext conf -state disabled |
|
3093 | $ctext conf -state disabled | |
3094 | if {[clock clicks -milliseconds] >= $nextupdate} { |
|
3094 | if {[clock clicks -milliseconds] >= $nextupdate} { | |
3095 | incr nextupdate 100 |
|
3095 | incr nextupdate 100 | |
3096 | fileevent $bdf readable {} |
|
3096 | fileevent $bdf readable {} | |
3097 | update |
|
3097 | update | |
3098 | fileevent $bdf readable "getblobdiffline $bdf {$ids}" |
|
3098 | fileevent $bdf readable "getblobdiffline $bdf {$ids}" | |
3099 | } |
|
3099 | } | |
3100 | } |
|
3100 | } | |
3101 |
|
3101 | |||
3102 | proc nextfile {} { |
|
3102 | proc nextfile {} { | |
3103 | global difffilestart ctext |
|
3103 | global difffilestart ctext | |
3104 | set here [$ctext index @0,0] |
|
3104 | set here [$ctext index @0,0] | |
3105 | for {set i 0} {[info exists difffilestart($i)]} {incr i} { |
|
3105 | for {set i 0} {[info exists difffilestart($i)]} {incr i} { | |
3106 | if {[$ctext compare $difffilestart($i) > $here]} { |
|
3106 | if {[$ctext compare $difffilestart($i) > $here]} { | |
3107 | if {![info exists pos] |
|
3107 | if {![info exists pos] | |
3108 | || [$ctext compare $difffilestart($i) < $pos]} { |
|
3108 | || [$ctext compare $difffilestart($i) < $pos]} { | |
3109 | set pos $difffilestart($i) |
|
3109 | set pos $difffilestart($i) | |
3110 | } |
|
3110 | } | |
3111 | } |
|
3111 | } | |
3112 | } |
|
3112 | } | |
3113 | if {[info exists pos]} { |
|
3113 | if {[info exists pos]} { | |
3114 | $ctext yview $pos |
|
3114 | $ctext yview $pos | |
3115 | } |
|
3115 | } | |
3116 | } |
|
3116 | } | |
3117 |
|
3117 | |||
3118 | proc listboxsel {} { |
|
3118 | proc listboxsel {} { | |
3119 | global ctext cflist currentid |
|
3119 | global ctext cflist currentid | |
3120 | if {![info exists currentid]} return |
|
3120 | if {![info exists currentid]} return | |
3121 | set sel [lsort [$cflist curselection]] |
|
3121 | set sel [lsort [$cflist curselection]] | |
3122 | if {$sel eq {}} return |
|
3122 | if {$sel eq {}} return | |
3123 | set first [lindex $sel 0] |
|
3123 | set first [lindex $sel 0] | |
3124 | catch {$ctext yview fmark.$first} |
|
3124 | catch {$ctext yview fmark.$first} | |
3125 | } |
|
3125 | } | |
3126 |
|
3126 | |||
3127 | proc setcoords {} { |
|
3127 | proc setcoords {} { | |
3128 | global linespc charspc canvx0 canvy0 mainfont |
|
3128 | global linespc charspc canvx0 canvy0 mainfont | |
3129 | global xspc1 xspc2 lthickness |
|
3129 | global xspc1 xspc2 lthickness | |
3130 |
|
3130 | |||
3131 | set linespc [font metrics $mainfont -linespace] |
|
3131 | set linespc [font metrics $mainfont -linespace] | |
3132 | set charspc [font measure $mainfont "m"] |
|
3132 | set charspc [font measure $mainfont "m"] | |
3133 | set canvy0 [expr 3 + 0.5 * $linespc] |
|
3133 | set canvy0 [expr 3 + 0.5 * $linespc] | |
3134 | set canvx0 [expr 3 + 0.5 * $linespc] |
|
3134 | set canvx0 [expr 3 + 0.5 * $linespc] | |
3135 | set lthickness [expr {int($linespc / 9) + 1}] |
|
3135 | set lthickness [expr {int($linespc / 9) + 1}] | |
3136 | set xspc1(0) $linespc |
|
3136 | set xspc1(0) $linespc | |
3137 | set xspc2 $linespc |
|
3137 | set xspc2 $linespc | |
3138 | } |
|
3138 | } | |
3139 |
|
3139 | |||
3140 | proc redisplay {} { |
|
3140 | proc redisplay {} { | |
3141 | global stopped redisplaying phase |
|
3141 | global stopped redisplaying phase | |
3142 | if {$stopped > 1} return |
|
3142 | if {$stopped > 1} return | |
3143 | if {$phase == "getcommits"} return |
|
3143 | if {$phase == "getcommits"} return | |
3144 | set redisplaying 1 |
|
3144 | set redisplaying 1 | |
3145 | if {$phase == "drawgraph" || $phase == "incrdraw"} { |
|
3145 | if {$phase == "drawgraph" || $phase == "incrdraw"} { | |
3146 | set stopped 1 |
|
3146 | set stopped 1 | |
3147 | } else { |
|
3147 | } else { | |
3148 | drawgraph |
|
3148 | drawgraph | |
3149 | } |
|
3149 | } | |
3150 | } |
|
3150 | } | |
3151 |
|
3151 | |||
3152 | proc incrfont {inc} { |
|
3152 | proc incrfont {inc} { | |
3153 | global mainfont namefont textfont ctext canv phase |
|
3153 | global mainfont namefont textfont ctext canv phase | |
3154 | global stopped entries curidfont |
|
3154 | global stopped entries curidfont | |
3155 | unmarkmatches |
|
3155 | unmarkmatches | |
3156 | set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]] |
|
3156 | set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]] | |
3157 | set curidfont [lreplace $curidfont 1 1 [expr {[lindex $curidfont 1] + $inc}]] |
|
3157 | set curidfont [lreplace $curidfont 1 1 [expr {[lindex $curidfont 1] + $inc}]] | |
3158 | set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]] |
|
3158 | set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]] | |
3159 | set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]] |
|
3159 | set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]] | |
3160 | setcoords |
|
3160 | setcoords | |
3161 | $ctext conf -font $textfont |
|
3161 | $ctext conf -font $textfont | |
3162 | $ctext tag conf filesep -font [concat $textfont bold] |
|
3162 | $ctext tag conf filesep -font [concat $textfont bold] | |
3163 | foreach e $entries { |
|
3163 | foreach e $entries { | |
3164 | $e conf -font $mainfont |
|
3164 | $e conf -font $mainfont | |
3165 | } |
|
3165 | } | |
3166 | if {$phase == "getcommits"} { |
|
3166 | if {$phase == "getcommits"} { | |
3167 | $canv itemconf textitems -font $mainfont |
|
3167 | $canv itemconf textitems -font $mainfont | |
3168 | } |
|
3168 | } | |
3169 | redisplay |
|
3169 | redisplay | |
3170 | } |
|
3170 | } | |
3171 |
|
3171 | |||
3172 | proc clearsha1 {} { |
|
3172 | proc clearsha1 {} { | |
3173 | global sha1entry sha1string |
|
3173 | global sha1entry sha1string | |
3174 | if {[string length $sha1string] == 40} { |
|
3174 | if {[string length $sha1string] == 40} { | |
3175 | $sha1entry delete 0 end |
|
3175 | $sha1entry delete 0 end | |
3176 | } |
|
3176 | } | |
3177 | } |
|
3177 | } | |
3178 |
|
3178 | |||
3179 | proc sha1change {n1 n2 op} { |
|
3179 | proc sha1change {n1 n2 op} { | |
3180 | global sha1string currentid sha1but |
|
3180 | global sha1string currentid sha1but | |
3181 | if {$sha1string == {} |
|
3181 | if {$sha1string == {} | |
3182 | || ([info exists currentid] && $sha1string == $currentid)} { |
|
3182 | || ([info exists currentid] && $sha1string == $currentid)} { | |
3183 | set state disabled |
|
3183 | set state disabled | |
3184 | } else { |
|
3184 | } else { | |
3185 | set state normal |
|
3185 | set state normal | |
3186 | } |
|
3186 | } | |
3187 | if {[$sha1but cget -state] == $state} return |
|
3187 | if {[$sha1but cget -state] == $state} return | |
3188 | if {$state == "normal"} { |
|
3188 | if {$state == "normal"} { | |
3189 | $sha1but conf -state normal -relief raised -text "Goto: " |
|
3189 | $sha1but conf -state normal -relief raised -text "Goto: " | |
3190 | } else { |
|
3190 | } else { | |
3191 | $sha1but conf -state disabled -relief flat -text "SHA1 ID: " |
|
3191 | $sha1but conf -state disabled -relief flat -text "SHA1 ID: " | |
3192 | } |
|
3192 | } | |
3193 | } |
|
3193 | } | |
3194 |
|
3194 | |||
3195 | proc gotocommit {} { |
|
3195 | proc gotocommit {} { | |
3196 | global sha1string currentid idline tagids |
|
3196 | global sha1string currentid idline tagids | |
3197 | global lineid numcommits |
|
3197 | global lineid numcommits | |
3198 |
|
3198 | |||
3199 | if {$sha1string == {} |
|
3199 | if {$sha1string == {} | |
3200 | || ([info exists currentid] && $sha1string == $currentid)} return |
|
3200 | || ([info exists currentid] && $sha1string == $currentid)} return | |
3201 | if {[info exists tagids($sha1string)]} { |
|
3201 | if {[info exists tagids($sha1string)]} { | |
3202 | set id $tagids($sha1string) |
|
3202 | set id $tagids($sha1string) | |
3203 | } else { |
|
3203 | } else { | |
3204 | set id [string tolower $sha1string] |
|
3204 | set id [string tolower $sha1string] | |
3205 | if {[regexp {^[0-9a-f]{4,39}$} $id]} { |
|
3205 | if {[regexp {^[0-9a-f]{4,39}$} $id]} { | |
3206 | set matches {} |
|
3206 | set matches {} | |
3207 | for {set l 0} {$l < $numcommits} {incr l} { |
|
3207 | for {set l 0} {$l < $numcommits} {incr l} { | |
3208 | if {[string match $id* $lineid($l)]} { |
|
3208 | if {[string match $id* $lineid($l)]} { | |
3209 | lappend matches $lineid($l) |
|
3209 | lappend matches $lineid($l) | |
3210 | } |
|
3210 | } | |
3211 | } |
|
3211 | } | |
3212 | if {$matches ne {}} { |
|
3212 | if {$matches ne {}} { | |
3213 | if {[llength $matches] > 1} { |
|
3213 | if {[llength $matches] > 1} { | |
3214 | error_popup "Short SHA1 id $id is ambiguous" |
|
3214 | error_popup "Short SHA1 id $id is ambiguous" | |
3215 | return |
|
3215 | return | |
3216 | } |
|
3216 | } | |
3217 | set id [lindex $matches 0] |
|
3217 | set id [lindex $matches 0] | |
3218 | } |
|
3218 | } | |
3219 | } |
|
3219 | } | |
3220 | } |
|
3220 | } | |
3221 | if {[info exists idline($id)]} { |
|
3221 | if {[info exists idline($id)]} { | |
3222 | selectline $idline($id) 1 |
|
3222 | selectline $idline($id) 1 | |
3223 | return |
|
3223 | return | |
3224 | } |
|
3224 | } | |
3225 | if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} { |
|
3225 | if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} { | |
3226 | set type "SHA1 id" |
|
3226 | set type "SHA1 id" | |
3227 | } else { |
|
3227 | } else { | |
3228 | set type "Tag" |
|
3228 | set type "Tag" | |
3229 | } |
|
3229 | } | |
3230 | error_popup "$type $sha1string is not known" |
|
3230 | error_popup "$type $sha1string is not known" | |
3231 | } |
|
3231 | } | |
3232 |
|
3232 | |||
3233 | proc lineenter {x y id} { |
|
3233 | proc lineenter {x y id} { | |
3234 | global hoverx hovery hoverid hovertimer |
|
3234 | global hoverx hovery hoverid hovertimer | |
3235 | global commitinfo canv |
|
3235 | global commitinfo canv | |
3236 |
|
3236 | |||
3237 | if {![info exists commitinfo($id)]} return |
|
3237 | if {![info exists commitinfo($id)]} return | |
3238 | set hoverx $x |
|
3238 | set hoverx $x | |
3239 | set hovery $y |
|
3239 | set hovery $y | |
3240 | set hoverid $id |
|
3240 | set hoverid $id | |
3241 | if {[info exists hovertimer]} { |
|
3241 | if {[info exists hovertimer]} { | |
3242 | after cancel $hovertimer |
|
3242 | after cancel $hovertimer | |
3243 | } |
|
3243 | } | |
3244 | set hovertimer [after 500 linehover] |
|
3244 | set hovertimer [after 500 linehover] | |
3245 | $canv delete hover |
|
3245 | $canv delete hover | |
3246 | } |
|
3246 | } | |
3247 |
|
3247 | |||
3248 | proc linemotion {x y id} { |
|
3248 | proc linemotion {x y id} { | |
3249 | global hoverx hovery hoverid hovertimer |
|
3249 | global hoverx hovery hoverid hovertimer | |
3250 |
|
3250 | |||
3251 | if {[info exists hoverid] && $id == $hoverid} { |
|
3251 | if {[info exists hoverid] && $id == $hoverid} { | |
3252 | set hoverx $x |
|
3252 | set hoverx $x | |
3253 | set hovery $y |
|
3253 | set hovery $y | |
3254 | if {[info exists hovertimer]} { |
|
3254 | if {[info exists hovertimer]} { | |
3255 | after cancel $hovertimer |
|
3255 | after cancel $hovertimer | |
3256 | } |
|
3256 | } | |
3257 | set hovertimer [after 500 linehover] |
|
3257 | set hovertimer [after 500 linehover] | |
3258 | } |
|
3258 | } | |
3259 | } |
|
3259 | } | |
3260 |
|
3260 | |||
3261 | proc lineleave {id} { |
|
3261 | proc lineleave {id} { | |
3262 | global hoverid hovertimer canv |
|
3262 | global hoverid hovertimer canv | |
3263 |
|
3263 | |||
3264 | if {[info exists hoverid] && $id == $hoverid} { |
|
3264 | if {[info exists hoverid] && $id == $hoverid} { | |
3265 | $canv delete hover |
|
3265 | $canv delete hover | |
3266 | if {[info exists hovertimer]} { |
|
3266 | if {[info exists hovertimer]} { | |
3267 | after cancel $hovertimer |
|
3267 | after cancel $hovertimer | |
3268 | unset hovertimer |
|
3268 | unset hovertimer | |
3269 | } |
|
3269 | } | |
3270 | unset hoverid |
|
3270 | unset hoverid | |
3271 | } |
|
3271 | } | |
3272 | } |
|
3272 | } | |
3273 |
|
3273 | |||
3274 | proc linehover {} { |
|
3274 | proc linehover {} { | |
3275 | global hoverx hovery hoverid hovertimer |
|
3275 | global hoverx hovery hoverid hovertimer | |
3276 | global canv linespc lthickness |
|
3276 | global canv linespc lthickness | |
3277 | global commitinfo mainfont |
|
3277 | global commitinfo mainfont | |
3278 |
|
3278 | |||
3279 | set text [lindex $commitinfo($hoverid) 0] |
|
3279 | set text [lindex $commitinfo($hoverid) 0] | |
3280 | set ymax [lindex [$canv cget -scrollregion] 3] |
|
3280 | set ymax [lindex [$canv cget -scrollregion] 3] | |
3281 | if {$ymax == {}} return |
|
3281 | if {$ymax == {}} return | |
3282 | set yfrac [lindex [$canv yview] 0] |
|
3282 | set yfrac [lindex [$canv yview] 0] | |
3283 | set x [expr {$hoverx + 2 * $linespc}] |
|
3283 | set x [expr {$hoverx + 2 * $linespc}] | |
3284 | set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}] |
|
3284 | set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}] | |
3285 | set x0 [expr {$x - 2 * $lthickness}] |
|
3285 | set x0 [expr {$x - 2 * $lthickness}] | |
3286 | set y0 [expr {$y - 2 * $lthickness}] |
|
3286 | set y0 [expr {$y - 2 * $lthickness}] | |
3287 | set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}] |
|
3287 | set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}] | |
3288 | set y1 [expr {$y + $linespc + 2 * $lthickness}] |
|
3288 | set y1 [expr {$y + $linespc + 2 * $lthickness}] | |
3289 | set t [$canv create rectangle $x0 $y0 $x1 $y1 \ |
|
3289 | set t [$canv create rectangle $x0 $y0 $x1 $y1 \ | |
3290 | -fill \#ffff80 -outline black -width 1 -tags hover] |
|
3290 | -fill \#ffff80 -outline black -width 1 -tags hover] | |
3291 | $canv raise $t |
|
3291 | $canv raise $t | |
3292 | set t [$canv create text $x $y -anchor nw -text $text -tags hover] |
|
3292 | set t [$canv create text $x $y -anchor nw -text $text -tags hover] | |
3293 | $canv raise $t |
|
3293 | $canv raise $t | |
3294 | } |
|
3294 | } | |
3295 |
|
3295 | |||
3296 | proc clickisonarrow {id y} { |
|
3296 | proc clickisonarrow {id y} { | |
3297 | global mainline mainlinearrow sidelines lthickness |
|
3297 | global mainline mainlinearrow sidelines lthickness | |
3298 |
|
3298 | |||
3299 | set thresh [expr {2 * $lthickness + 6}] |
|
3299 | set thresh [expr {2 * $lthickness + 6}] | |
3300 | if {[info exists mainline($id)]} { |
|
3300 | if {[info exists mainline($id)]} { | |
3301 | if {$mainlinearrow($id) ne "none"} { |
|
3301 | if {$mainlinearrow($id) ne "none"} { | |
3302 | if {abs([lindex $mainline($id) 1] - $y) < $thresh} { |
|
3302 | if {abs([lindex $mainline($id) 1] - $y) < $thresh} { | |
3303 | return "up" |
|
3303 | return "up" | |
3304 | } |
|
3304 | } | |
3305 | } |
|
3305 | } | |
3306 | } |
|
3306 | } | |
3307 | if {[info exists sidelines($id)]} { |
|
3307 | if {[info exists sidelines($id)]} { | |
3308 | foreach ls $sidelines($id) { |
|
3308 | foreach ls $sidelines($id) { | |
3309 | set coords [lindex $ls 0] |
|
3309 | set coords [lindex $ls 0] | |
3310 | set arrow [lindex $ls 2] |
|
3310 | set arrow [lindex $ls 2] | |
3311 | if {$arrow eq "first" || $arrow eq "both"} { |
|
3311 | if {$arrow eq "first" || $arrow eq "both"} { | |
3312 | if {abs([lindex $coords 1] - $y) < $thresh} { |
|
3312 | if {abs([lindex $coords 1] - $y) < $thresh} { | |
3313 | return "up" |
|
3313 | return "up" | |
3314 | } |
|
3314 | } | |
3315 | } |
|
3315 | } | |
3316 | if {$arrow eq "last" || $arrow eq "both"} { |
|
3316 | if {$arrow eq "last" || $arrow eq "both"} { | |
3317 | if {abs([lindex $coords end] - $y) < $thresh} { |
|
3317 | if {abs([lindex $coords end] - $y) < $thresh} { | |
3318 | return "down" |
|
3318 | return "down" | |
3319 | } |
|
3319 | } | |
3320 | } |
|
3320 | } | |
3321 | } |
|
3321 | } | |
3322 | } |
|
3322 | } | |
3323 | return {} |
|
3323 | return {} | |
3324 | } |
|
3324 | } | |
3325 |
|
3325 | |||
3326 | proc arrowjump {id dirn y} { |
|
3326 | proc arrowjump {id dirn y} { | |
3327 | global mainline sidelines canv |
|
3327 | global mainline sidelines canv | |
3328 |
|
3328 | |||
3329 | set yt {} |
|
3329 | set yt {} | |
3330 | if {$dirn eq "down"} { |
|
3330 | if {$dirn eq "down"} { | |
3331 | if {[info exists mainline($id)]} { |
|
3331 | if {[info exists mainline($id)]} { | |
3332 | set y1 [lindex $mainline($id) 1] |
|
3332 | set y1 [lindex $mainline($id) 1] | |
3333 | if {$y1 > $y} { |
|
3333 | if {$y1 > $y} { | |
3334 | set yt $y1 |
|
3334 | set yt $y1 | |
3335 | } |
|
3335 | } | |
3336 | } |
|
3336 | } | |
3337 | if {[info exists sidelines($id)]} { |
|
3337 | if {[info exists sidelines($id)]} { | |
3338 | foreach ls $sidelines($id) { |
|
3338 | foreach ls $sidelines($id) { | |
3339 | set y1 [lindex $ls 0 1] |
|
3339 | set y1 [lindex $ls 0 1] | |
3340 | if {$y1 > $y && ($yt eq {} || $y1 < $yt)} { |
|
3340 | if {$y1 > $y && ($yt eq {} || $y1 < $yt)} { | |
3341 | set yt $y1 |
|
3341 | set yt $y1 | |
3342 | } |
|
3342 | } | |
3343 | } |
|
3343 | } | |
3344 | } |
|
3344 | } | |
3345 | } else { |
|
3345 | } else { | |
3346 | if {[info exists sidelines($id)]} { |
|
3346 | if {[info exists sidelines($id)]} { | |
3347 | foreach ls $sidelines($id) { |
|
3347 | foreach ls $sidelines($id) { | |
3348 | set y1 [lindex $ls 0 end] |
|
3348 | set y1 [lindex $ls 0 end] | |
3349 | if {$y1 < $y && ($yt eq {} || $y1 > $yt)} { |
|
3349 | if {$y1 < $y && ($yt eq {} || $y1 > $yt)} { | |
3350 | set yt $y1 |
|
3350 | set yt $y1 | |
3351 | } |
|
3351 | } | |
3352 | } |
|
3352 | } | |
3353 | } |
|
3353 | } | |
3354 | } |
|
3354 | } | |
3355 | if {$yt eq {}} return |
|
3355 | if {$yt eq {}} return | |
3356 | set ymax [lindex [$canv cget -scrollregion] 3] |
|
3356 | set ymax [lindex [$canv cget -scrollregion] 3] | |
3357 | if {$ymax eq {} || $ymax <= 0} return |
|
3357 | if {$ymax eq {} || $ymax <= 0} return | |
3358 | set view [$canv yview] |
|
3358 | set view [$canv yview] | |
3359 | set yspan [expr {[lindex $view 1] - [lindex $view 0]}] |
|
3359 | set yspan [expr {[lindex $view 1] - [lindex $view 0]}] | |
3360 | set yfrac [expr {$yt / $ymax - $yspan / 2}] |
|
3360 | set yfrac [expr {$yt / $ymax - $yspan / 2}] | |
3361 | if {$yfrac < 0} { |
|
3361 | if {$yfrac < 0} { | |
3362 | set yfrac 0 |
|
3362 | set yfrac 0 | |
3363 | } |
|
3363 | } | |
3364 | $canv yview moveto $yfrac |
|
3364 | $canv yview moveto $yfrac | |
3365 | } |
|
3365 | } | |
3366 |
|
3366 | |||
3367 | proc lineclick {x y id isnew} { |
|
3367 | proc lineclick {x y id isnew} { | |
3368 | global ctext commitinfo children cflist canv thickerline |
|
3368 | global ctext commitinfo children cflist canv thickerline | |
3369 |
|
3369 | |||
3370 | unmarkmatches |
|
3370 | unmarkmatches | |
3371 | unselectline |
|
3371 | unselectline | |
3372 | normalline |
|
3372 | normalline | |
3373 | $canv delete hover |
|
3373 | $canv delete hover | |
3374 | # draw this line thicker than normal |
|
3374 | # draw this line thicker than normal | |
3375 | drawlines $id 1 |
|
3375 | drawlines $id 1 | |
3376 | set thickerline $id |
|
3376 | set thickerline $id | |
3377 | if {$isnew} { |
|
3377 | if {$isnew} { | |
3378 | set ymax [lindex [$canv cget -scrollregion] 3] |
|
3378 | set ymax [lindex [$canv cget -scrollregion] 3] | |
3379 | if {$ymax eq {}} return |
|
3379 | if {$ymax eq {}} return | |
3380 | set yfrac [lindex [$canv yview] 0] |
|
3380 | set yfrac [lindex [$canv yview] 0] | |
3381 | set y [expr {$y + $yfrac * $ymax}] |
|
3381 | set y [expr {$y + $yfrac * $ymax}] | |
3382 | } |
|
3382 | } | |
3383 | set dirn [clickisonarrow $id $y] |
|
3383 | set dirn [clickisonarrow $id $y] | |
3384 | if {$dirn ne {}} { |
|
3384 | if {$dirn ne {}} { | |
3385 | arrowjump $id $dirn $y |
|
3385 | arrowjump $id $dirn $y | |
3386 | return |
|
3386 | return | |
3387 | } |
|
3387 | } | |
3388 |
|
3388 | |||
3389 | if {$isnew} { |
|
3389 | if {$isnew} { | |
3390 | addtohistory [list lineclick $x $y $id 0] |
|
3390 | addtohistory [list lineclick $x $y $id 0] | |
3391 | } |
|
3391 | } | |
3392 | # fill the details pane with info about this line |
|
3392 | # fill the details pane with info about this line | |
3393 | $ctext conf -state normal |
|
3393 | $ctext conf -state normal | |
3394 | $ctext delete 0.0 end |
|
3394 | $ctext delete 0.0 end | |
3395 | $ctext tag conf link -foreground blue -underline 1 |
|
3395 | $ctext tag conf link -foreground blue -underline 1 | |
3396 | $ctext tag bind link <Enter> { %W configure -cursor hand2 } |
|
3396 | $ctext tag bind link <Enter> { %W configure -cursor hand2 } | |
3397 | $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor } |
|
3397 | $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor } | |
3398 | $ctext insert end "Parent:\t" |
|
3398 | $ctext insert end "Parent:\t" | |
3399 | $ctext insert end $id [list link link0] |
|
3399 | $ctext insert end $id [list link link0] | |
3400 | $ctext tag bind link0 <1> [list selbyid $id] |
|
3400 | $ctext tag bind link0 <1> [list selbyid $id] | |
3401 | set info $commitinfo($id) |
|
3401 | set info $commitinfo($id) | |
3402 | $ctext insert end "\n\t[lindex $info 0]\n" |
|
3402 | $ctext insert end "\n\t[lindex $info 0]\n" | |
3403 | $ctext insert end "\tAuthor:\t[lindex $info 1]\n" |
|
3403 | $ctext insert end "\tAuthor:\t[lindex $info 1]\n" | |
3404 | $ctext insert end "\tDate:\t[lindex $info 2]\n" |
|
3404 | $ctext insert end "\tDate:\t[lindex $info 2]\n" | |
3405 | if {[info exists children($id)]} { |
|
3405 | if {[info exists children($id)]} { | |
3406 | $ctext insert end "\nChildren:" |
|
3406 | $ctext insert end "\nChildren:" | |
3407 | set i 0 |
|
3407 | set i 0 | |
3408 | foreach child $children($id) { |
|
3408 | foreach child $children($id) { | |
3409 | incr i |
|
3409 | incr i | |
3410 | set info $commitinfo($child) |
|
3410 | set info $commitinfo($child) | |
3411 | $ctext insert end "\n\t" |
|
3411 | $ctext insert end "\n\t" | |
3412 | $ctext insert end $child [list link link$i] |
|
3412 | $ctext insert end $child [list link link$i] | |
3413 | $ctext tag bind link$i <1> [list selbyid $child] |
|
3413 | $ctext tag bind link$i <1> [list selbyid $child] | |
3414 | $ctext insert end "\n\t[lindex $info 0]" |
|
3414 | $ctext insert end "\n\t[lindex $info 0]" | |
3415 | $ctext insert end "\n\tAuthor:\t[lindex $info 1]" |
|
3415 | $ctext insert end "\n\tAuthor:\t[lindex $info 1]" | |
3416 | $ctext insert end "\n\tDate:\t[lindex $info 2]\n" |
|
3416 | $ctext insert end "\n\tDate:\t[lindex $info 2]\n" | |
3417 | } |
|
3417 | } | |
3418 | } |
|
3418 | } | |
3419 | $ctext conf -state disabled |
|
3419 | $ctext conf -state disabled | |
3420 |
|
3420 | |||
3421 | $cflist delete 0 end |
|
3421 | $cflist delete 0 end | |
3422 | } |
|
3422 | } | |
3423 |
|
3423 | |||
3424 | proc normalline {} { |
|
3424 | proc normalline {} { | |
3425 | global thickerline |
|
3425 | global thickerline | |
3426 | if {[info exists thickerline]} { |
|
3426 | if {[info exists thickerline]} { | |
3427 | drawlines $thickerline 0 |
|
3427 | drawlines $thickerline 0 | |
3428 | unset thickerline |
|
3428 | unset thickerline | |
3429 | } |
|
3429 | } | |
3430 | } |
|
3430 | } | |
3431 |
|
3431 | |||
3432 | proc selbyid {id} { |
|
3432 | proc selbyid {id} { | |
3433 | global idline |
|
3433 | global idline | |
3434 | if {[info exists idline($id)]} { |
|
3434 | if {[info exists idline($id)]} { | |
3435 | selectline $idline($id) 1 |
|
3435 | selectline $idline($id) 1 | |
3436 | } |
|
3436 | } | |
3437 | } |
|
3437 | } | |
3438 |
|
3438 | |||
3439 | proc mstime {} { |
|
3439 | proc mstime {} { | |
3440 | global startmstime |
|
3440 | global startmstime | |
3441 | if {![info exists startmstime]} { |
|
3441 | if {![info exists startmstime]} { | |
3442 | set startmstime [clock clicks -milliseconds] |
|
3442 | set startmstime [clock clicks -milliseconds] | |
3443 | } |
|
3443 | } | |
3444 | return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]] |
|
3444 | return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]] | |
3445 | } |
|
3445 | } | |
3446 |
|
3446 | |||
3447 | proc rowmenu {x y id} { |
|
3447 | proc rowmenu {x y id} { | |
3448 | global rowctxmenu idline selectedline rowmenuid hgvdiff |
|
3448 | global rowctxmenu idline selectedline rowmenuid hgvdiff | |
3449 |
|
3449 | |||
3450 | if {![info exists selectedline] || $idline($id) eq $selectedline} { |
|
3450 | if {![info exists selectedline] || $idline($id) eq $selectedline} { | |
3451 | set state disabled |
|
3451 | set state disabled | |
3452 | } else { |
|
3452 | } else { | |
3453 | set state normal |
|
3453 | set state normal | |
3454 | } |
|
3454 | } | |
3455 | $rowctxmenu entryconfigure 0 -state $state |
|
3455 | $rowctxmenu entryconfigure 0 -state $state | |
3456 | $rowctxmenu entryconfigure 1 -state $state |
|
3456 | $rowctxmenu entryconfigure 1 -state $state | |
3457 | $rowctxmenu entryconfigure 2 -state $state |
|
3457 | $rowctxmenu entryconfigure 2 -state $state | |
3458 | if { $hgvdiff ne "" } { |
|
3458 | if { $hgvdiff ne "" } { | |
3459 | $rowctxmenu entryconfigure 6 -state $state |
|
3459 | $rowctxmenu entryconfigure 6 -state $state | |
3460 | } |
|
3460 | } | |
3461 | set rowmenuid $id |
|
3461 | set rowmenuid $id | |
3462 | tk_popup $rowctxmenu $x $y |
|
3462 | tk_popup $rowctxmenu $x $y | |
3463 | } |
|
3463 | } | |
3464 |
|
3464 | |||
3465 | proc diffvssel {dirn} { |
|
3465 | proc diffvssel {dirn} { | |
3466 | global rowmenuid selectedline lineid |
|
3466 | global rowmenuid selectedline lineid | |
3467 |
|
3467 | |||
3468 | if {![info exists selectedline]} return |
|
3468 | if {![info exists selectedline]} return | |
3469 | if {$dirn} { |
|
3469 | if {$dirn} { | |
3470 | set oldid $lineid($selectedline) |
|
3470 | set oldid $lineid($selectedline) | |
3471 | set newid $rowmenuid |
|
3471 | set newid $rowmenuid | |
3472 | } else { |
|
3472 | } else { | |
3473 | set oldid $rowmenuid |
|
3473 | set oldid $rowmenuid | |
3474 | set newid $lineid($selectedline) |
|
3474 | set newid $lineid($selectedline) | |
3475 | } |
|
3475 | } | |
3476 | addtohistory [list doseldiff $oldid $newid] |
|
3476 | addtohistory [list doseldiff $oldid $newid] | |
3477 | doseldiff $oldid $newid |
|
3477 | doseldiff $oldid $newid | |
3478 | } |
|
3478 | } | |
3479 |
|
3479 | |||
3480 | proc doseldiff {oldid newid} { |
|
3480 | proc doseldiff {oldid newid} { | |
3481 | global ctext cflist |
|
3481 | global ctext cflist | |
3482 | global commitinfo |
|
3482 | global commitinfo | |
3483 |
|
3483 | |||
3484 | $ctext conf -state normal |
|
3484 | $ctext conf -state normal | |
3485 | $ctext delete 0.0 end |
|
3485 | $ctext delete 0.0 end | |
3486 | $ctext mark set fmark.0 0.0 |
|
3486 | $ctext mark set fmark.0 0.0 | |
3487 | $ctext mark gravity fmark.0 left |
|
3487 | $ctext mark gravity fmark.0 left | |
3488 | $cflist delete 0 end |
|
3488 | $cflist delete 0 end | |
3489 | $cflist insert end "Top" |
|
3489 | $cflist insert end "Top" | |
3490 | $ctext insert end "From " |
|
3490 | $ctext insert end "From " | |
3491 | $ctext tag conf link -foreground blue -underline 1 |
|
3491 | $ctext tag conf link -foreground blue -underline 1 | |
3492 | $ctext tag bind link <Enter> { %W configure -cursor hand2 } |
|
3492 | $ctext tag bind link <Enter> { %W configure -cursor hand2 } | |
3493 | $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor } |
|
3493 | $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor } | |
3494 | $ctext tag bind link0 <1> [list selbyid $oldid] |
|
3494 | $ctext tag bind link0 <1> [list selbyid $oldid] | |
3495 | $ctext insert end $oldid [list link link0] |
|
3495 | $ctext insert end $oldid [list link link0] | |
3496 | $ctext insert end "\n " |
|
3496 | $ctext insert end "\n " | |
3497 | $ctext insert end [lindex $commitinfo($oldid) 0] |
|
3497 | $ctext insert end [lindex $commitinfo($oldid) 0] | |
3498 | $ctext insert end "\n\nTo " |
|
3498 | $ctext insert end "\n\nTo " | |
3499 | $ctext tag bind link1 <1> [list selbyid $newid] |
|
3499 | $ctext tag bind link1 <1> [list selbyid $newid] | |
3500 | $ctext insert end $newid [list link link1] |
|
3500 | $ctext insert end $newid [list link link1] | |
3501 | $ctext insert end "\n " |
|
3501 | $ctext insert end "\n " | |
3502 | $ctext insert end [lindex $commitinfo($newid) 0] |
|
3502 | $ctext insert end [lindex $commitinfo($newid) 0] | |
3503 | $ctext insert end "\n" |
|
3503 | $ctext insert end "\n" | |
3504 | $ctext conf -state disabled |
|
3504 | $ctext conf -state disabled | |
3505 | $ctext tag delete Comments |
|
3505 | $ctext tag delete Comments | |
3506 | $ctext tag remove found 1.0 end |
|
3506 | $ctext tag remove found 1.0 end | |
3507 | startdiff [list $newid $oldid] |
|
3507 | startdiff [list $newid $oldid] | |
3508 | } |
|
3508 | } | |
3509 |
|
3509 | |||
3510 | proc mkpatch {} { |
|
3510 | proc mkpatch {} { | |
3511 | global rowmenuid currentid commitinfo patchtop patchnum |
|
3511 | global rowmenuid currentid commitinfo patchtop patchnum | |
3512 |
|
3512 | |||
3513 | if {![info exists currentid]} return |
|
3513 | if {![info exists currentid]} return | |
3514 | set oldid $currentid |
|
3514 | set oldid $currentid | |
3515 | set oldhead [lindex $commitinfo($oldid) 0] |
|
3515 | set oldhead [lindex $commitinfo($oldid) 0] | |
3516 | set newid $rowmenuid |
|
3516 | set newid $rowmenuid | |
3517 | set newhead [lindex $commitinfo($newid) 0] |
|
3517 | set newhead [lindex $commitinfo($newid) 0] | |
3518 | set top .patch |
|
3518 | set top .patch | |
3519 | set patchtop $top |
|
3519 | set patchtop $top | |
3520 | catch {destroy $top} |
|
3520 | catch {destroy $top} | |
3521 | toplevel $top |
|
3521 | toplevel $top | |
3522 | label $top.title -text "Generate patch" |
|
3522 | label $top.title -text "Generate patch" | |
3523 | grid $top.title - -pady 10 |
|
3523 | grid $top.title - -pady 10 | |
3524 | label $top.from -text "From:" |
|
3524 | label $top.from -text "From:" | |
3525 | entry $top.fromsha1 -width 40 -relief flat |
|
3525 | entry $top.fromsha1 -width 40 -relief flat | |
3526 | $top.fromsha1 insert 0 $oldid |
|
3526 | $top.fromsha1 insert 0 $oldid | |
3527 | $top.fromsha1 conf -state readonly |
|
3527 | $top.fromsha1 conf -state readonly | |
3528 | grid $top.from $top.fromsha1 -sticky w |
|
3528 | grid $top.from $top.fromsha1 -sticky w | |
3529 | entry $top.fromhead -width 60 -relief flat |
|
3529 | entry $top.fromhead -width 60 -relief flat | |
3530 | $top.fromhead insert 0 $oldhead |
|
3530 | $top.fromhead insert 0 $oldhead | |
3531 | $top.fromhead conf -state readonly |
|
3531 | $top.fromhead conf -state readonly | |
3532 | grid x $top.fromhead -sticky w |
|
3532 | grid x $top.fromhead -sticky w | |
3533 | label $top.to -text "To:" |
|
3533 | label $top.to -text "To:" | |
3534 | entry $top.tosha1 -width 40 -relief flat |
|
3534 | entry $top.tosha1 -width 40 -relief flat | |
3535 | $top.tosha1 insert 0 $newid |
|
3535 | $top.tosha1 insert 0 $newid | |
3536 | $top.tosha1 conf -state readonly |
|
3536 | $top.tosha1 conf -state readonly | |
3537 | grid $top.to $top.tosha1 -sticky w |
|
3537 | grid $top.to $top.tosha1 -sticky w | |
3538 | entry $top.tohead -width 60 -relief flat |
|
3538 | entry $top.tohead -width 60 -relief flat | |
3539 | $top.tohead insert 0 $newhead |
|
3539 | $top.tohead insert 0 $newhead | |
3540 | $top.tohead conf -state readonly |
|
3540 | $top.tohead conf -state readonly | |
3541 | grid x $top.tohead -sticky w |
|
3541 | grid x $top.tohead -sticky w | |
3542 | button $top.rev -text "Reverse" -command mkpatchrev -padx 5 |
|
3542 | button $top.rev -text "Reverse" -command mkpatchrev -padx 5 | |
3543 | grid $top.rev x -pady 10 |
|
3543 | grid $top.rev x -pady 10 | |
3544 | label $top.flab -text "Output file:" |
|
3544 | label $top.flab -text "Output file:" | |
3545 | entry $top.fname -width 60 |
|
3545 | entry $top.fname -width 60 | |
3546 | $top.fname insert 0 [file normalize "patch$patchnum.patch"] |
|
3546 | $top.fname insert 0 [file normalize "patch$patchnum.patch"] | |
3547 | incr patchnum |
|
3547 | incr patchnum | |
3548 | grid $top.flab $top.fname -sticky w |
|
3548 | grid $top.flab $top.fname -sticky w | |
3549 | frame $top.buts |
|
3549 | frame $top.buts | |
3550 | button $top.buts.gen -text "Generate" -command mkpatchgo |
|
3550 | button $top.buts.gen -text "Generate" -command mkpatchgo | |
3551 | button $top.buts.can -text "Cancel" -command mkpatchcan |
|
3551 | button $top.buts.can -text "Cancel" -command mkpatchcan | |
3552 | grid $top.buts.gen $top.buts.can |
|
3552 | grid $top.buts.gen $top.buts.can | |
3553 | grid columnconfigure $top.buts 0 -weight 1 -uniform a |
|
3553 | grid columnconfigure $top.buts 0 -weight 1 -uniform a | |
3554 | grid columnconfigure $top.buts 1 -weight 1 -uniform a |
|
3554 | grid columnconfigure $top.buts 1 -weight 1 -uniform a | |
3555 | grid $top.buts - -pady 10 -sticky ew |
|
3555 | grid $top.buts - -pady 10 -sticky ew | |
3556 | focus $top.fname |
|
3556 | focus $top.fname | |
3557 | } |
|
3557 | } | |
3558 |
|
3558 | |||
3559 | proc mkpatchrev {} { |
|
3559 | proc mkpatchrev {} { | |
3560 | global patchtop |
|
3560 | global patchtop | |
3561 |
|
3561 | |||
3562 | set oldid [$patchtop.fromsha1 get] |
|
3562 | set oldid [$patchtop.fromsha1 get] | |
3563 | set oldhead [$patchtop.fromhead get] |
|
3563 | set oldhead [$patchtop.fromhead get] | |
3564 | set newid [$patchtop.tosha1 get] |
|
3564 | set newid [$patchtop.tosha1 get] | |
3565 | set newhead [$patchtop.tohead get] |
|
3565 | set newhead [$patchtop.tohead get] | |
3566 | foreach e [list fromsha1 fromhead tosha1 tohead] \ |
|
3566 | foreach e [list fromsha1 fromhead tosha1 tohead] \ | |
3567 | v [list $newid $newhead $oldid $oldhead] { |
|
3567 | v [list $newid $newhead $oldid $oldhead] { | |
3568 | $patchtop.$e conf -state normal |
|
3568 | $patchtop.$e conf -state normal | |
3569 | $patchtop.$e delete 0 end |
|
3569 | $patchtop.$e delete 0 end | |
3570 | $patchtop.$e insert 0 $v |
|
3570 | $patchtop.$e insert 0 $v | |
3571 | $patchtop.$e conf -state readonly |
|
3571 | $patchtop.$e conf -state readonly | |
3572 | } |
|
3572 | } | |
3573 | } |
|
3573 | } | |
3574 |
|
3574 | |||
3575 | proc mkpatchgo {} { |
|
3575 | proc mkpatchgo {} { | |
3576 | global patchtop env |
|
3576 | global patchtop env | |
3577 |
|
3577 | |||
3578 | set oldid [$patchtop.fromsha1 get] |
|
3578 | set oldid [$patchtop.fromsha1 get] | |
3579 | set newid [$patchtop.tosha1 get] |
|
3579 | set newid [$patchtop.tosha1 get] | |
3580 | set fname [$patchtop.fname get] |
|
3580 | set fname [$patchtop.fname get] | |
3581 | if {[catch {exec $env(HG) --config ui.report_untrusted=false debug-diff-tree -p $oldid $newid >$fname &} err]} { |
|
3581 | if {[catch {exec $env(HG) --config ui.report_untrusted=false debug-diff-tree -p $oldid $newid >$fname &} err]} { | |
3582 | error_popup "Error creating patch: $err" |
|
3582 | error_popup "Error creating patch: $err" | |
3583 | } |
|
3583 | } | |
3584 | catch {destroy $patchtop} |
|
3584 | catch {destroy $patchtop} | |
3585 | unset patchtop |
|
3585 | unset patchtop | |
3586 | } |
|
3586 | } | |
3587 |
|
3587 | |||
3588 | proc mkpatchcan {} { |
|
3588 | proc mkpatchcan {} { | |
3589 | global patchtop |
|
3589 | global patchtop | |
3590 |
|
3590 | |||
3591 | catch {destroy $patchtop} |
|
3591 | catch {destroy $patchtop} | |
3592 | unset patchtop |
|
3592 | unset patchtop | |
3593 | } |
|
3593 | } | |
3594 |
|
3594 | |||
3595 | proc mktag {} { |
|
3595 | proc mktag {} { | |
3596 | global rowmenuid mktagtop commitinfo |
|
3596 | global rowmenuid mktagtop commitinfo | |
3597 |
|
3597 | |||
3598 | set top .maketag |
|
3598 | set top .maketag | |
3599 | set mktagtop $top |
|
3599 | set mktagtop $top | |
3600 | catch {destroy $top} |
|
3600 | catch {destroy $top} | |
3601 | toplevel $top |
|
3601 | toplevel $top | |
3602 | label $top.title -text "Create tag" |
|
3602 | label $top.title -text "Create tag" | |
3603 | grid $top.title - -pady 10 |
|
3603 | grid $top.title - -pady 10 | |
3604 | label $top.id -text "ID:" |
|
3604 | label $top.id -text "ID:" | |
3605 | entry $top.sha1 -width 40 -relief flat |
|
3605 | entry $top.sha1 -width 40 -relief flat | |
3606 | $top.sha1 insert 0 $rowmenuid |
|
3606 | $top.sha1 insert 0 $rowmenuid | |
3607 | $top.sha1 conf -state readonly |
|
3607 | $top.sha1 conf -state readonly | |
3608 | grid $top.id $top.sha1 -sticky w |
|
3608 | grid $top.id $top.sha1 -sticky w | |
3609 | entry $top.head -width 60 -relief flat |
|
3609 | entry $top.head -width 60 -relief flat | |
3610 | $top.head insert 0 [lindex $commitinfo($rowmenuid) 0] |
|
3610 | $top.head insert 0 [lindex $commitinfo($rowmenuid) 0] | |
3611 | $top.head conf -state readonly |
|
3611 | $top.head conf -state readonly | |
3612 | grid x $top.head -sticky w |
|
3612 | grid x $top.head -sticky w | |
3613 | label $top.tlab -text "Tag name:" |
|
3613 | label $top.tlab -text "Tag name:" | |
3614 | entry $top.tag -width 60 |
|
3614 | entry $top.tag -width 60 | |
3615 | grid $top.tlab $top.tag -sticky w |
|
3615 | grid $top.tlab $top.tag -sticky w | |
3616 | frame $top.buts |
|
3616 | frame $top.buts | |
3617 | button $top.buts.gen -text "Create" -command mktaggo |
|
3617 | button $top.buts.gen -text "Create" -command mktaggo | |
3618 | button $top.buts.can -text "Cancel" -command mktagcan |
|
3618 | button $top.buts.can -text "Cancel" -command mktagcan | |
3619 | grid $top.buts.gen $top.buts.can |
|
3619 | grid $top.buts.gen $top.buts.can | |
3620 | grid columnconfigure $top.buts 0 -weight 1 -uniform a |
|
3620 | grid columnconfigure $top.buts 0 -weight 1 -uniform a | |
3621 | grid columnconfigure $top.buts 1 -weight 1 -uniform a |
|
3621 | grid columnconfigure $top.buts 1 -weight 1 -uniform a | |
3622 | grid $top.buts - -pady 10 -sticky ew |
|
3622 | grid $top.buts - -pady 10 -sticky ew | |
3623 | focus $top.tag |
|
3623 | focus $top.tag | |
3624 | } |
|
3624 | } | |
3625 |
|
3625 | |||
3626 | proc domktag {} { |
|
3626 | proc domktag {} { | |
3627 | global mktagtop env tagids idtags |
|
3627 | global mktagtop env tagids idtags | |
3628 |
|
3628 | |||
3629 | set id [$mktagtop.sha1 get] |
|
3629 | set id [$mktagtop.sha1 get] | |
3630 | set tag [$mktagtop.tag get] |
|
3630 | set tag [$mktagtop.tag get] | |
3631 | if {$tag == {}} { |
|
3631 | if {$tag == {}} { | |
3632 | error_popup "No tag name specified" |
|
3632 | error_popup "No tag name specified" | |
3633 | return |
|
3633 | return | |
3634 | } |
|
3634 | } | |
3635 | if {[info exists tagids($tag)]} { |
|
3635 | if {[info exists tagids($tag)]} { | |
3636 | error_popup "Tag \"$tag\" already exists" |
|
3636 | error_popup "Tag \"$tag\" already exists" | |
3637 | return |
|
3637 | return | |
3638 | } |
|
3638 | } | |
3639 | if {[catch { |
|
3639 | if {[catch { | |
3640 | set out [exec $env(HG) --config ui.report_untrusted=false tag -r $id $tag] |
|
3640 | set out [exec $env(HG) --config ui.report_untrusted=false tag -r $id $tag] | |
3641 | } err]} { |
|
3641 | } err]} { | |
3642 | error_popup "Error creating tag: $err" |
|
3642 | error_popup "Error creating tag: $err" | |
3643 | return |
|
3643 | return | |
3644 | } |
|
3644 | } | |
3645 |
|
3645 | |||
3646 | set tagids($tag) $id |
|
3646 | set tagids($tag) $id | |
3647 | lappend idtags($id) $tag |
|
3647 | lappend idtags($id) $tag | |
3648 | redrawtags $id |
|
3648 | redrawtags $id | |
3649 | } |
|
3649 | } | |
3650 |
|
3650 | |||
3651 | proc redrawtags {id} { |
|
3651 | proc redrawtags {id} { | |
3652 | global canv linehtag idline idpos selectedline |
|
3652 | global canv linehtag idline idpos selectedline | |
3653 |
|
3653 | |||
3654 | if {![info exists idline($id)]} return |
|
3654 | if {![info exists idline($id)]} return | |
3655 | $canv delete tag.$id |
|
3655 | $canv delete tag.$id | |
3656 | set xt [eval drawtags $id $idpos($id)] |
|
3656 | set xt [eval drawtags $id $idpos($id)] | |
3657 | $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2] |
|
3657 | $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2] | |
3658 | if {[info exists selectedline] && $selectedline == $idline($id)} { |
|
3658 | if {[info exists selectedline] && $selectedline == $idline($id)} { | |
3659 | selectline $selectedline 0 |
|
3659 | selectline $selectedline 0 | |
3660 | } |
|
3660 | } | |
3661 | } |
|
3661 | } | |
3662 |
|
3662 | |||
3663 | proc mktagcan {} { |
|
3663 | proc mktagcan {} { | |
3664 | global mktagtop |
|
3664 | global mktagtop | |
3665 |
|
3665 | |||
3666 | catch {destroy $mktagtop} |
|
3666 | catch {destroy $mktagtop} | |
3667 | unset mktagtop |
|
3667 | unset mktagtop | |
3668 | } |
|
3668 | } | |
3669 |
|
3669 | |||
3670 | proc mktaggo {} { |
|
3670 | proc mktaggo {} { | |
3671 | domktag |
|
3671 | domktag | |
3672 | mktagcan |
|
3672 | mktagcan | |
3673 | } |
|
3673 | } | |
3674 |
|
3674 | |||
3675 | proc writecommit {} { |
|
3675 | proc writecommit {} { | |
3676 | global rowmenuid wrcomtop commitinfo wrcomcmd |
|
3676 | global rowmenuid wrcomtop commitinfo wrcomcmd | |
3677 |
|
3677 | |||
3678 | set top .writecommit |
|
3678 | set top .writecommit | |
3679 | set wrcomtop $top |
|
3679 | set wrcomtop $top | |
3680 | catch {destroy $top} |
|
3680 | catch {destroy $top} | |
3681 | toplevel $top |
|
3681 | toplevel $top | |
3682 | label $top.title -text "Write commit to file" |
|
3682 | label $top.title -text "Write commit to file" | |
3683 | grid $top.title - -pady 10 |
|
3683 | grid $top.title - -pady 10 | |
3684 | label $top.id -text "ID:" |
|
3684 | label $top.id -text "ID:" | |
3685 | entry $top.sha1 -width 40 -relief flat |
|
3685 | entry $top.sha1 -width 40 -relief flat | |
3686 | $top.sha1 insert 0 $rowmenuid |
|
3686 | $top.sha1 insert 0 $rowmenuid | |
3687 | $top.sha1 conf -state readonly |
|
3687 | $top.sha1 conf -state readonly | |
3688 | grid $top.id $top.sha1 -sticky w |
|
3688 | grid $top.id $top.sha1 -sticky w | |
3689 | entry $top.head -width 60 -relief flat |
|
3689 | entry $top.head -width 60 -relief flat | |
3690 | $top.head insert 0 [lindex $commitinfo($rowmenuid) 0] |
|
3690 | $top.head insert 0 [lindex $commitinfo($rowmenuid) 0] | |
3691 | $top.head conf -state readonly |
|
3691 | $top.head conf -state readonly | |
3692 | grid x $top.head -sticky w |
|
3692 | grid x $top.head -sticky w | |
3693 | label $top.clab -text "Command:" |
|
3693 | label $top.clab -text "Command:" | |
3694 | entry $top.cmd -width 60 -textvariable wrcomcmd |
|
3694 | entry $top.cmd -width 60 -textvariable wrcomcmd | |
3695 | grid $top.clab $top.cmd -sticky w -pady 10 |
|
3695 | grid $top.clab $top.cmd -sticky w -pady 10 | |
3696 | label $top.flab -text "Output file:" |
|
3696 | label $top.flab -text "Output file:" | |
3697 | entry $top.fname -width 60 |
|
3697 | entry $top.fname -width 60 | |
3698 | $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"] |
|
3698 | $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"] | |
3699 | grid $top.flab $top.fname -sticky w |
|
3699 | grid $top.flab $top.fname -sticky w | |
3700 | frame $top.buts |
|
3700 | frame $top.buts | |
3701 | button $top.buts.gen -text "Write" -command wrcomgo |
|
3701 | button $top.buts.gen -text "Write" -command wrcomgo | |
3702 | button $top.buts.can -text "Cancel" -command wrcomcan |
|
3702 | button $top.buts.can -text "Cancel" -command wrcomcan | |
3703 | grid $top.buts.gen $top.buts.can |
|
3703 | grid $top.buts.gen $top.buts.can | |
3704 | grid columnconfigure $top.buts 0 -weight 1 -uniform a |
|
3704 | grid columnconfigure $top.buts 0 -weight 1 -uniform a | |
3705 | grid columnconfigure $top.buts 1 -weight 1 -uniform a |
|
3705 | grid columnconfigure $top.buts 1 -weight 1 -uniform a | |
3706 | grid $top.buts - -pady 10 -sticky ew |
|
3706 | grid $top.buts - -pady 10 -sticky ew | |
3707 | focus $top.fname |
|
3707 | focus $top.fname | |
3708 | } |
|
3708 | } | |
3709 |
|
3709 | |||
3710 | proc wrcomgo {} { |
|
3710 | proc wrcomgo {} { | |
3711 | global wrcomtop |
|
3711 | global wrcomtop | |
3712 |
|
3712 | |||
3713 | set id [$wrcomtop.sha1 get] |
|
3713 | set id [$wrcomtop.sha1 get] | |
3714 | set cmd "echo $id | [$wrcomtop.cmd get]" |
|
3714 | set cmd "echo $id | [$wrcomtop.cmd get]" | |
3715 | set fname [$wrcomtop.fname get] |
|
3715 | set fname [$wrcomtop.fname get] | |
3716 | if {[catch {exec sh -c $cmd > $fname &} err]} { |
|
3716 | if {[catch {exec sh -c $cmd > $fname &} err]} { | |
3717 | error_popup "Error writing commit: $err" |
|
3717 | error_popup "Error writing commit: $err" | |
3718 | } |
|
3718 | } | |
3719 | catch {destroy $wrcomtop} |
|
3719 | catch {destroy $wrcomtop} | |
3720 | unset wrcomtop |
|
3720 | unset wrcomtop | |
3721 | } |
|
3721 | } | |
3722 |
|
3722 | |||
3723 | proc wrcomcan {} { |
|
3723 | proc wrcomcan {} { | |
3724 | global wrcomtop |
|
3724 | global wrcomtop | |
3725 |
|
3725 | |||
3726 | catch {destroy $wrcomtop} |
|
3726 | catch {destroy $wrcomtop} | |
3727 | unset wrcomtop |
|
3727 | unset wrcomtop | |
3728 | } |
|
3728 | } | |
3729 |
|
3729 | |||
3730 | proc listrefs {id} { |
|
3730 | proc listrefs {id} { | |
3731 | global idtags idheads idotherrefs |
|
3731 | global idtags idheads idotherrefs | |
3732 |
|
3732 | |||
3733 | set x {} |
|
3733 | set x {} | |
3734 | if {[info exists idtags($id)]} { |
|
3734 | if {[info exists idtags($id)]} { | |
3735 | set x $idtags($id) |
|
3735 | set x $idtags($id) | |
3736 | } |
|
3736 | } | |
3737 | set y {} |
|
3737 | set y {} | |
3738 | if {[info exists idheads($id)]} { |
|
3738 | if {[info exists idheads($id)]} { | |
3739 | set y $idheads($id) |
|
3739 | set y $idheads($id) | |
3740 | } |
|
3740 | } | |
3741 | set z {} |
|
3741 | set z {} | |
3742 | if {[info exists idotherrefs($id)]} { |
|
3742 | if {[info exists idotherrefs($id)]} { | |
3743 | set z $idotherrefs($id) |
|
3743 | set z $idotherrefs($id) | |
3744 | } |
|
3744 | } | |
3745 | return [list $x $y $z] |
|
3745 | return [list $x $y $z] | |
3746 | } |
|
3746 | } | |
3747 |
|
3747 | |||
3748 | proc rereadrefs {} { |
|
3748 | proc rereadrefs {} { | |
3749 | global idtags idheads idotherrefs |
|
3749 | global idtags idheads idotherrefs | |
3750 | global tagids headids otherrefids |
|
3750 | global tagids headids otherrefids | |
3751 |
|
3751 | |||
3752 | set refids [concat [array names idtags] \ |
|
3752 | set refids [concat [array names idtags] \ | |
3753 | [array names idheads] [array names idotherrefs]] |
|
3753 | [array names idheads] [array names idotherrefs]] | |
3754 | foreach id $refids { |
|
3754 | foreach id $refids { | |
3755 | if {![info exists ref($id)]} { |
|
3755 | if {![info exists ref($id)]} { | |
3756 | set ref($id) [listrefs $id] |
|
3756 | set ref($id) [listrefs $id] | |
3757 | } |
|
3757 | } | |
3758 | } |
|
3758 | } | |
3759 | foreach v {tagids idtags headids idheads otherrefids idotherrefs} { |
|
3759 | foreach v {tagids idtags headids idheads otherrefids idotherrefs} { | |
3760 | catch {unset $v} |
|
3760 | catch {unset $v} | |
3761 | } |
|
3761 | } | |
3762 | readrefs |
|
3762 | readrefs | |
3763 | set refids [lsort -unique [concat $refids [array names idtags] \ |
|
3763 | set refids [lsort -unique [concat $refids [array names idtags] \ | |
3764 | [array names idheads] [array names idotherrefs]]] |
|
3764 | [array names idheads] [array names idotherrefs]]] | |
3765 | foreach id $refids { |
|
3765 | foreach id $refids { | |
3766 | set v [listrefs $id] |
|
3766 | set v [listrefs $id] | |
3767 | if {![info exists ref($id)] || $ref($id) != $v} { |
|
3767 | if {![info exists ref($id)] || $ref($id) != $v} { | |
3768 | redrawtags $id |
|
3768 | redrawtags $id | |
3769 | } |
|
3769 | } | |
3770 | } |
|
3770 | } | |
3771 | } |
|
3771 | } | |
3772 |
|
3772 | |||
3773 | proc vdiff {withparent} { |
|
3773 | proc vdiff {withparent} { | |
3774 | global env rowmenuid selectedline lineid hgvdiff |
|
3774 | global env rowmenuid selectedline lineid hgvdiff | |
3775 |
|
3775 | |||
3776 | if {![info exists rowmenuid]} return |
|
3776 | if {![info exists rowmenuid]} return | |
3777 | set curid $rowmenuid |
|
3777 | set curid $rowmenuid | |
3778 |
|
3778 | |||
3779 | if {$withparent} { |
|
3779 | if {$withparent} { | |
3780 | set parents [exec $env(HG) --config ui.report_untrusted=false parents --rev $curid --template "{node}\n"] |
|
3780 | set parents [exec $env(HG) --config ui.report_untrusted=false parents --rev $curid --template "{node}\n"] | |
3781 | set firstparent [lindex [split $parents "\n"] 0] |
|
3781 | set firstparent [lindex [split $parents "\n"] 0] | |
3782 | set otherid $firstparent |
|
3782 | set otherid $firstparent | |
3783 | } else { |
|
3783 | } else { | |
3784 | if {![info exists selectedline]} return |
|
3784 | if {![info exists selectedline]} return | |
3785 | set otherid $lineid($selectedline) |
|
3785 | set otherid $lineid($selectedline) | |
3786 | } |
|
3786 | } | |
3787 | set range "$otherid:$curid" |
|
3787 | set range "$otherid:$curid" | |
3788 | if {[catch {exec $env(HG) --config ui.report_untrusted=false $hgvdiff -r $range} err]} { |
|
3788 | if {[catch {exec $env(HG) --config ui.report_untrusted=false $hgvdiff -r $range} err]} { | |
3789 | # Ignore errors, this is just visualization |
|
3789 | # Ignore errors, this is just visualization | |
3790 | } |
|
3790 | } | |
3791 | } |
|
3791 | } | |
3792 |
|
3792 | |||
3793 | proc showtag {tag isnew} { |
|
3793 | proc showtag {tag isnew} { | |
3794 | global ctext cflist tagcontents tagids linknum |
|
3794 | global ctext cflist tagcontents tagids linknum | |
3795 |
|
3795 | |||
3796 | if {$isnew} { |
|
3796 | if {$isnew} { | |
3797 | addtohistory [list showtag $tag 0] |
|
3797 | addtohistory [list showtag $tag 0] | |
3798 | } |
|
3798 | } | |
3799 | $ctext conf -state normal |
|
3799 | $ctext conf -state normal | |
3800 | $ctext delete 0.0 end |
|
3800 | $ctext delete 0.0 end | |
3801 | set linknum 0 |
|
3801 | set linknum 0 | |
3802 | if {[info exists tagcontents($tag)]} { |
|
3802 | if {[info exists tagcontents($tag)]} { | |
3803 | set text $tagcontents($tag) |
|
3803 | set text $tagcontents($tag) | |
3804 | } else { |
|
3804 | } else { | |
3805 | set text "Tag: $tag\nId: $tagids($tag)" |
|
3805 | set text "Tag: $tag\nId: $tagids($tag)" | |
3806 | } |
|
3806 | } | |
3807 | appendwithlinks $text |
|
3807 | appendwithlinks $text | |
3808 | $ctext conf -state disabled |
|
3808 | $ctext conf -state disabled | |
3809 | $cflist delete 0 end |
|
3809 | $cflist delete 0 end | |
3810 | } |
|
3810 | } | |
3811 |
|
3811 | |||
3812 | proc doquit {} { |
|
3812 | proc doquit {} { | |
3813 | global stopped |
|
3813 | global stopped | |
3814 | set stopped 100 |
|
3814 | set stopped 100 | |
3815 | destroy . |
|
3815 | destroy . | |
3816 | } |
|
3816 | } | |
3817 |
|
3817 | |||
3818 | proc getconfig {} { |
|
3818 | proc getconfig {} { | |
3819 | global env |
|
3819 | global env | |
3820 |
|
3820 | |||
3821 | set lines [exec $env(HG) debug-config] |
|
3821 | set lines [exec $env(HG) debug-config] | |
3822 | regsub -all "\r\n" $lines "\n" config |
|
3822 | regsub -all "\r\n" $lines "\n" config | |
3823 | set config {} |
|
3823 | set config {} | |
3824 | foreach line [split $lines "\n"] { |
|
3824 | foreach line [split $lines "\n"] { | |
3825 | regsub "^(k|v)=" $line "" line |
|
3825 | regsub "^(k|v)=" $line "" line | |
3826 | lappend config $line |
|
3826 | lappend config $line | |
3827 | } |
|
3827 | } | |
3828 | return $config |
|
3828 | return $config | |
3829 | } |
|
3829 | } | |
3830 |
|
3830 | |||
3831 | # defaults... |
|
3831 | # defaults... | |
3832 | set datemode 0 |
|
3832 | set datemode 0 | |
3833 | set boldnames 0 |
|
3833 | set boldnames 0 | |
3834 | set diffopts "-U 5 -p" |
|
3834 | set diffopts "-U 5 -p" | |
3835 | set wrcomcmd "\"\$HG\" --config ui.report_untrusted=false debug-diff-tree --stdin -p --pretty" |
|
3835 | set wrcomcmd "\"\$HG\" --config ui.report_untrusted=false debug-diff-tree --stdin -p --pretty" | |
3836 |
|
3836 | |||
3837 | set mainfont {Helvetica 9} |
|
3837 | set mainfont {Helvetica 9} | |
3838 | set curidfont {} |
|
3838 | set curidfont {} | |
3839 | set textfont {Courier 9} |
|
3839 | set textfont {Courier 9} | |
3840 | set findmergefiles 0 |
|
3840 | set findmergefiles 0 | |
3841 | set gaudydiff 0 |
|
3841 | set gaudydiff 0 | |
3842 | set maxgraphpct 50 |
|
3842 | set maxgraphpct 50 | |
3843 | set maxwidth 16 |
|
3843 | set maxwidth 16 | |
3844 |
|
3844 | |||
3845 | set colors {green red blue magenta darkgrey brown orange} |
|
3845 | set colors {green red blue magenta darkgrey brown orange} | |
3846 | set authorcolors { |
|
3846 | set authorcolors { | |
3847 | deeppink mediumorchid blue burlywood4 goldenrod slateblue red2 navy dimgrey |
|
3847 | deeppink mediumorchid blue burlywood4 goldenrod slateblue red2 navy dimgrey | |
3848 | } |
|
3848 | } | |
3849 |
|
3849 | |||
3850 |
catch {source ~/.g |
|
3850 | catch {source ~/.hgk} | |
3851 |
|
3851 | |||
3852 | if {$curidfont == ""} { # initialize late based on current mainfont |
|
3852 | if {$curidfont == ""} { # initialize late based on current mainfont | |
3853 | set curidfont "$mainfont bold italic underline" |
|
3853 | set curidfont "$mainfont bold italic underline" | |
3854 | } |
|
3854 | } | |
3855 |
|
3855 | |||
3856 | set namefont $mainfont |
|
3856 | set namefont $mainfont | |
3857 | if {$boldnames} { |
|
3857 | if {$boldnames} { | |
3858 | lappend namefont bold |
|
3858 | lappend namefont bold | |
3859 | } |
|
3859 | } | |
3860 |
|
3860 | |||
3861 | set revtreeargs {} |
|
3861 | set revtreeargs {} | |
3862 | foreach arg $argv { |
|
3862 | foreach arg $argv { | |
3863 | switch -regexp -- $arg { |
|
3863 | switch -regexp -- $arg { | |
3864 | "^$" { } |
|
3864 | "^$" { } | |
3865 | "^-b" { set boldnames 1 } |
|
3865 | "^-b" { set boldnames 1 } | |
3866 | "^-d" { set datemode 1 } |
|
3866 | "^-d" { set datemode 1 } | |
3867 | default { |
|
3867 | default { | |
3868 | lappend revtreeargs $arg |
|
3868 | lappend revtreeargs $arg | |
3869 | } |
|
3869 | } | |
3870 | } |
|
3870 | } | |
3871 | } |
|
3871 | } | |
3872 |
|
3872 | |||
3873 | set history {} |
|
3873 | set history {} | |
3874 | set historyindex 0 |
|
3874 | set historyindex 0 | |
3875 |
|
3875 | |||
3876 | set stopped 0 |
|
3876 | set stopped 0 | |
3877 | set redisplaying 0 |
|
3877 | set redisplaying 0 | |
3878 | set stuffsaved 0 |
|
3878 | set stuffsaved 0 | |
3879 | set patchnum 0 |
|
3879 | set patchnum 0 | |
3880 |
|
3880 | |||
3881 | array set config [getconfig] |
|
3881 | array set config [getconfig] | |
3882 | set hgvdiff $config(vdiff) |
|
3882 | set hgvdiff $config(vdiff) | |
3883 | setcoords |
|
3883 | setcoords | |
3884 | makewindow |
|
3884 | makewindow | |
3885 | readrefs |
|
3885 | readrefs | |
3886 | set hgroot [exec $env(HG) root] |
|
3886 | set hgroot [exec $env(HG) root] | |
3887 | wm title . "hgk $hgroot" |
|
3887 | wm title . "hgk $hgroot" | |
3888 | getcommits $revtreeargs |
|
3888 | getcommits $revtreeargs |
General Comments 0
You need to be logged in to leave comments.
Login now