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