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