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