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