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