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