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