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