1#!/bin/sh
2# Tcl ignores the next line -*- tcl -*- \
3exec wish "$0" -- "$@"
4
5# Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6# This program is free software; it may be used, copied, modified
7# and distributed under the terms of the GNU General Public Licence,
8# either version 2, or (at your option) any later version.
9
10proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
16 }
17}
18
19# A simple scheduler for compute-intensive stuff.
20# The aim is to make sure that event handlers for GUI actions can
21# run at least every 50-100 ms. Unfortunately fileevent handlers are
22# run before X event handlers, so reading from a fast source can
23# make the GUI completely unresponsive.
24proc run args {
25 global isonrunq runq
26
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
30 after idle dorunq
31 }
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
34}
35
36proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
38}
39
40proc filereadable {fd script} {
41 global runq
42
43 fileevent $fd readable {}
44 if {$runq eq {}} {
45 after idle dorunq
46 }
47 lappend runq [list $fd $script]
48}
49
50proc dorunq {} {
51 global isonrunq runq
52
53 set tstart [clock clicks -milliseconds]
54 set t0 $tstart
55 while {$runq ne {}} {
56 set fd [lindex $runq 0 0]
57 set script [lindex $runq 0 1]
58 set repeat [eval $script]
59 set t1 [clock clicks -milliseconds]
60 set t [expr {$t1 - $t0}]
61 set runq [lrange $runq 1 end]
62 if {$repeat ne {} && $repeat} {
63 if {$fd eq {} || $repeat == 2} {
64 # script returns 1 if it wants to be readded
65 # file readers return 2 if they could do more straight away
66 lappend runq [list $fd $script]
67 } else {
68 fileevent $fd readable [list filereadable $fd $script]
69 }
70 } elseif {$fd eq {}} {
71 unset isonrunq($script)
72 }
73 set t0 $t1
74 if {$t1 - $tstart >= 80} break
75 }
76 if {$runq ne {}} {
77 after idle dorunq
78 }
79}
80
81# Start off a git rev-list process and arrange to read its output
82proc start_rev_list {view} {
83 global startmsecs
84 global commfd leftover tclencoding datemode
85 global viewargs viewargscmd viewfiles commitidx viewcomplete vnextroot
86 global showlocalchanges commitinterest mainheadid
87 global progressdirn progresscoords proglastnc curview
88
89 set startmsecs [clock clicks -milliseconds]
90 set commitidx($view) 0
91 set viewcomplete($view) 0
92 set vnextroot($view) 0
93 set args $viewargs($view)
94 if {$viewargscmd($view) ne {}} {
95 if {[catch {
96 set str [exec sh -c $viewargscmd($view)]
97 } err]} {
98 error_popup "Error executing --argscmd command: $err"
99 exit 1
100 }
101 set args [concat $args [split $str "\n"]]
102 }
103 set order "--topo-order"
104 if {$datemode} {
105 set order "--date-order"
106 }
107 if {[catch {
108 set fd [open [concat | git log --no-color -z --pretty=raw $order --parents \
109 --boundary $args "--" $viewfiles($view)] r]
110 } err]} {
111 error_popup "[mc "Error executing git rev-list:"] $err"
112 exit 1
113 }
114 set commfd($view) $fd
115 set leftover($view) {}
116 if {$showlocalchanges} {
117 lappend commitinterest($mainheadid) {dodiffindex}
118 }
119 fconfigure $fd -blocking 0 -translation lf -eofchar {}
120 if {$tclencoding != {}} {
121 fconfigure $fd -encoding $tclencoding
122 }
123 filerun $fd [list getcommitlines $fd $view]
124 nowbusy $view [mc "Reading"]
125 if {$view == $curview} {
126 set progressdirn 1
127 set progresscoords {0 0}
128 set proglastnc 0
129 }
130}
131
132proc stop_rev_list {} {
133 global commfd curview
134
135 if {![info exists commfd($curview)]} return
136 set fd $commfd($curview)
137 catch {
138 set pid [pid $fd]
139 exec kill $pid
140 }
141 catch {close $fd}
142 unset commfd($curview)
143}
144
145proc getcommits {} {
146 global phase canv curview
147
148 set phase getcommits
149 initlayout
150 start_rev_list $curview
151 show_status [mc "Reading commits..."]
152}
153
154# This makes a string representation of a positive integer which
155# sorts as a string in numerical order
156proc strrep {n} {
157 if {$n < 16} {
158 return [format "%x" $n]
159 } elseif {$n < 256} {
160 return [format "x%.2x" $n]
161 } elseif {$n < 65536} {
162 return [format "y%.4x" $n]
163 }
164 return [format "z%.8x" $n]
165}
166
167proc getcommitlines {fd view} {
168 global commitlisted commitinterest
169 global leftover commfd
170 global displayorder commitidx viewcomplete commitrow commitdata
171 global parentlist children curview hlview
172 global vparentlist vdisporder vcmitlisted
173 global ordertok vnextroot idpending
174
175 set stuff [read $fd 500000]
176 # git log doesn't terminate the last commit with a null...
177 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
178 set stuff "\0"
179 }
180 if {$stuff == {}} {
181 if {![eof $fd]} {
182 return 1
183 }
184 # Check if we have seen any ids listed as parents that haven't
185 # appeared in the list
186 foreach vid [array names idpending "$view,*"] {
187 # should only get here if git log is buggy
188 set id [lindex [split $vid ","] 1]
189 set commitrow($vid) $commitidx($view)
190 incr commitidx($view)
191 if {$view == $curview} {
192 lappend parentlist {}
193 lappend displayorder $id
194 lappend commitlisted 0
195 } else {
196 lappend vparentlist($view) {}
197 lappend vdisporder($view) $id
198 lappend vcmitlisted($view) 0
199 }
200 }
201 set viewcomplete($view) 1
202 global viewname progresscoords
203 unset commfd($view)
204 notbusy $view
205 set progresscoords {0 0}
206 adjustprogress
207 # set it blocking so we wait for the process to terminate
208 fconfigure $fd -blocking 1
209 if {[catch {close $fd} err]} {
210 set fv {}
211 if {$view != $curview} {
212 set fv " for the \"$viewname($view)\" view"
213 }
214 if {[string range $err 0 4] == "usage"} {
215 set err "Gitk: error reading commits$fv:\
216 bad arguments to git rev-list."
217 if {$viewname($view) eq "Command line"} {
218 append err \
219 " (Note: arguments to gitk are passed to git rev-list\
220 to allow selection of commits to be displayed.)"
221 }
222 } else {
223 set err "Error reading commits$fv: $err"
224 }
225 error_popup $err
226 }
227 if {$view == $curview} {
228 run chewcommits $view
229 }
230 return 0
231 }
232 set start 0
233 set gotsome 0
234 while 1 {
235 set i [string first "\0" $stuff $start]
236 if {$i < 0} {
237 append leftover($view) [string range $stuff $start end]
238 break
239 }
240 if {$start == 0} {
241 set cmit $leftover($view)
242 append cmit [string range $stuff 0 [expr {$i - 1}]]
243 set leftover($view) {}
244 } else {
245 set cmit [string range $stuff $start [expr {$i - 1}]]
246 }
247 set start [expr {$i + 1}]
248 set j [string first "\n" $cmit]
249 set ok 0
250 set listed 1
251 if {$j >= 0 && [string match "commit *" $cmit]} {
252 set ids [string range $cmit 7 [expr {$j - 1}]]
253 if {[string match {[-^<>]*} $ids]} {
254 switch -- [string index $ids 0] {
255 "-" {set listed 0}
256 "^" {set listed 2}
257 "<" {set listed 3}
258 ">" {set listed 4}
259 }
260 set ids [string range $ids 1 end]
261 }
262 set ok 1
263 foreach id $ids {
264 if {[string length $id] != 40} {
265 set ok 0
266 break
267 }
268 }
269 }
270 if {!$ok} {
271 set shortcmit $cmit
272 if {[string length $shortcmit] > 80} {
273 set shortcmit "[string range $shortcmit 0 80]..."
274 }
275 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
276 exit 1
277 }
278 set id [lindex $ids 0]
279 if {![info exists ordertok($view,$id)]} {
280 set otok "o[strrep $vnextroot($view)]"
281 incr vnextroot($view)
282 set ordertok($view,$id) $otok
283 } else {
284 set otok $ordertok($view,$id)
285 unset idpending($view,$id)
286 }
287 if {$listed} {
288 set olds [lrange $ids 1 end]
289 if {[llength $olds] == 1} {
290 set p [lindex $olds 0]
291 lappend children($view,$p) $id
292 if {![info exists ordertok($view,$p)]} {
293 set ordertok($view,$p) $ordertok($view,$id)
294 set idpending($view,$p) 1
295 }
296 } else {
297 set i 0
298 foreach p $olds {
299 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
300 lappend children($view,$p) $id
301 }
302 if {![info exists ordertok($view,$p)]} {
303 set ordertok($view,$p) "$otok[strrep $i]]"
304 set idpending($view,$p) 1
305 }
306 incr i
307 }
308 }
309 } else {
310 set olds {}
311 }
312 if {![info exists children($view,$id)]} {
313 set children($view,$id) {}
314 }
315 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
316 set commitrow($view,$id) $commitidx($view)
317 incr commitidx($view)
318 if {$view == $curview} {
319 lappend parentlist $olds
320 lappend displayorder $id
321 lappend commitlisted $listed
322 } else {
323 lappend vparentlist($view) $olds
324 lappend vdisporder($view) $id
325 lappend vcmitlisted($view) $listed
326 }
327 if {[info exists commitinterest($id)]} {
328 foreach script $commitinterest($id) {
329 eval [string map [list "%I" $id] $script]
330 }
331 unset commitinterest($id)
332 }
333 set gotsome 1
334 }
335 if {$gotsome} {
336 run chewcommits $view
337 if {$view == $curview} {
338 # update progress bar
339 global progressdirn progresscoords proglastnc
340 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
341 set proglastnc $commitidx($view)
342 set l [lindex $progresscoords 0]
343 set r [lindex $progresscoords 1]
344 if {$progressdirn} {
345 set r [expr {$r + $inc}]
346 if {$r >= 1.0} {
347 set r 1.0
348 set progressdirn 0
349 }
350 if {$r > 0.2} {
351 set l [expr {$r - 0.2}]
352 }
353 } else {
354 set l [expr {$l - $inc}]
355 if {$l <= 0.0} {
356 set l 0.0
357 set progressdirn 1
358 }
359 set r [expr {$l + 0.2}]
360 }
361 set progresscoords [list $l $r]
362 adjustprogress
363 }
364 }
365 return 2
366}
367
368proc chewcommits {view} {
369 global curview hlview viewcomplete
370 global selectedline pending_select
371
372 if {$view == $curview} {
373 layoutmore
374 if {$viewcomplete($view)} {
375 global displayorder commitidx phase
376 global numcommits startmsecs
377
378 if {[info exists pending_select]} {
379 set row [first_real_row]
380 selectline $row 1
381 }
382 if {$commitidx($curview) > 0} {
383 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
384 #puts "overall $ms ms for $numcommits commits"
385 } else {
386 show_status [mc "No commits selected"]
387 }
388 notbusy layout
389 set phase {}
390 }
391 }
392 if {[info exists hlview] && $view == $hlview} {
393 vhighlightmore
394 }
395 return 0
396}
397
398proc readcommit {id} {
399 if {[catch {set contents [exec git cat-file commit $id]}]} return
400 parsecommit $id $contents 0
401}
402
403proc updatecommits {} {
404 global viewdata curview phase displayorder ordertok idpending
405 global children commitrow selectedline thickerline showneartags
406
407 if {$phase ne {}} {
408 stop_rev_list
409 set phase {}
410 }
411 set n $curview
412 foreach id $displayorder {
413 catch {unset children($n,$id)}
414 catch {unset commitrow($n,$id)}
415 catch {unset ordertok($n,$id)}
416 }
417 foreach vid [array names idpending "$n,*"] {
418 unset idpending($vid)
419 }
420 set curview -1
421 catch {unset selectedline}
422 catch {unset thickerline}
423 catch {unset viewdata($n)}
424 readrefs
425 changedrefs
426 if {$showneartags} {
427 getallcommits
428 }
429 showview $n
430}
431
432proc parsecommit {id contents listed} {
433 global commitinfo cdate
434
435 set inhdr 1
436 set comment {}
437 set headline {}
438 set auname {}
439 set audate {}
440 set comname {}
441 set comdate {}
442 set hdrend [string first "\n\n" $contents]
443 if {$hdrend < 0} {
444 # should never happen...
445 set hdrend [string length $contents]
446 }
447 set header [string range $contents 0 [expr {$hdrend - 1}]]
448 set comment [string range $contents [expr {$hdrend + 2}] end]
449 foreach line [split $header "\n"] {
450 set tag [lindex $line 0]
451 if {$tag == "author"} {
452 set audate [lindex $line end-1]
453 set auname [lrange $line 1 end-2]
454 } elseif {$tag == "committer"} {
455 set comdate [lindex $line end-1]
456 set comname [lrange $line 1 end-2]
457 }
458 }
459 set headline {}
460 # take the first non-blank line of the comment as the headline
461 set headline [string trimleft $comment]
462 set i [string first "\n" $headline]
463 if {$i >= 0} {
464 set headline [string range $headline 0 $i]
465 }
466 set headline [string trimright $headline]
467 set i [string first "\r" $headline]
468 if {$i >= 0} {
469 set headline [string trimright [string range $headline 0 $i]]
470 }
471 if {!$listed} {
472 # git rev-list indents the comment by 4 spaces;
473 # if we got this via git cat-file, add the indentation
474 set newcomment {}
475 foreach line [split $comment "\n"] {
476 append newcomment " "
477 append newcomment $line
478 append newcomment "\n"
479 }
480 set comment $newcomment
481 }
482 if {$comdate != {}} {
483 set cdate($id) $comdate
484 }
485 set commitinfo($id) [list $headline $auname $audate \
486 $comname $comdate $comment]
487}
488
489proc getcommit {id} {
490 global commitdata commitinfo
491
492 if {[info exists commitdata($id)]} {
493 parsecommit $id $commitdata($id) 1
494 } else {
495 readcommit $id
496 if {![info exists commitinfo($id)]} {
497 set commitinfo($id) [list [mc "No commit information available"]]
498 }
499 }
500 return 1
501}
502
503proc readrefs {} {
504 global tagids idtags headids idheads tagobjid
505 global otherrefids idotherrefs mainhead mainheadid
506
507 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
508 catch {unset $v}
509 }
510 set refd [open [list | git show-ref -d] r]
511 while {[gets $refd line] >= 0} {
512 if {[string index $line 40] ne " "} continue
513 set id [string range $line 0 39]
514 set ref [string range $line 41 end]
515 if {![string match "refs/*" $ref]} continue
516 set name [string range $ref 5 end]
517 if {[string match "remotes/*" $name]} {
518 if {![string match "*/HEAD" $name]} {
519 set headids($name) $id
520 lappend idheads($id) $name
521 }
522 } elseif {[string match "heads/*" $name]} {
523 set name [string range $name 6 end]
524 set headids($name) $id
525 lappend idheads($id) $name
526 } elseif {[string match "tags/*" $name]} {
527 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
528 # which is what we want since the former is the commit ID
529 set name [string range $name 5 end]
530 if {[string match "*^{}" $name]} {
531 set name [string range $name 0 end-3]
532 } else {
533 set tagobjid($name) $id
534 }
535 set tagids($name) $id
536 lappend idtags($id) $name
537 } else {
538 set otherrefids($name) $id
539 lappend idotherrefs($id) $name
540 }
541 }
542 catch {close $refd}
543 set mainhead {}
544 set mainheadid {}
545 catch {
546 set thehead [exec git symbolic-ref HEAD]
547 if {[string match "refs/heads/*" $thehead]} {
548 set mainhead [string range $thehead 11 end]
549 if {[info exists headids($mainhead)]} {
550 set mainheadid $headids($mainhead)
551 }
552 }
553 }
554}
555
556# skip over fake commits
557proc first_real_row {} {
558 global nullid nullid2 displayorder numcommits
559
560 for {set row 0} {$row < $numcommits} {incr row} {
561 set id [lindex $displayorder $row]
562 if {$id ne $nullid && $id ne $nullid2} {
563 break
564 }
565 }
566 return $row
567}
568
569# update things for a head moved to a child of its previous location
570proc movehead {id name} {
571 global headids idheads
572
573 removehead $headids($name) $name
574 set headids($name) $id
575 lappend idheads($id) $name
576}
577
578# update things when a head has been removed
579proc removehead {id name} {
580 global headids idheads
581
582 if {$idheads($id) eq $name} {
583 unset idheads($id)
584 } else {
585 set i [lsearch -exact $idheads($id) $name]
586 if {$i >= 0} {
587 set idheads($id) [lreplace $idheads($id) $i $i]
588 }
589 }
590 unset headids($name)
591}
592
593proc show_error {w top msg} {
594 message $w.m -text $msg -justify center -aspect 400
595 pack $w.m -side top -fill x -padx 20 -pady 20
596 button $w.ok -text [mc OK] -command "destroy $top"
597 pack $w.ok -side bottom -fill x
598 bind $top <Visibility> "grab $top; focus $top"
599 bind $top <Key-Return> "destroy $top"
600 tkwait window $top
601}
602
603proc error_popup msg {
604 set w .error
605 toplevel $w
606 wm transient $w .
607 show_error $w $w $msg
608}
609
610proc confirm_popup msg {
611 global confirm_ok
612 set confirm_ok 0
613 set w .confirm
614 toplevel $w
615 wm transient $w .
616 message $w.m -text $msg -justify center -aspect 400
617 pack $w.m -side top -fill x -padx 20 -pady 20
618 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
619 pack $w.ok -side left -fill x
620 button $w.cancel -text [mc Cancel] -command "destroy $w"
621 pack $w.cancel -side right -fill x
622 bind $w <Visibility> "grab $w; focus $w"
623 tkwait window $w
624 return $confirm_ok
625}
626
627proc setoptions {} {
628 option add *Panedwindow.showHandle 1 startupFile
629 option add *Panedwindow.sashRelief raised startupFile
630 option add *Button.font uifont startupFile
631 option add *Checkbutton.font uifont startupFile
632 option add *Radiobutton.font uifont startupFile
633 option add *Menu.font uifont startupFile
634 option add *Menubutton.font uifont startupFile
635 option add *Label.font uifont startupFile
636 option add *Message.font uifont startupFile
637 option add *Entry.font uifont startupFile
638}
639
640proc makewindow {} {
641 global canv canv2 canv3 linespc charspc ctext cflist
642 global tabstop
643 global findtype findtypemenu findloc findstring fstring geometry
644 global entries sha1entry sha1string sha1but
645 global diffcontextstring diffcontext
646 global ignorespace
647 global maincursor textcursor curtextcursor
648 global rowctxmenu fakerowmenu mergemax wrapcomment
649 global highlight_files gdttype
650 global searchstring sstring
651 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
652 global headctxmenu progresscanv progressitem progresscoords statusw
653 global fprogitem fprogcoord lastprogupdate progupdatepending
654 global rprogitem rprogcoord
655 global have_tk85
656
657 menu .bar
658 .bar add cascade -label [mc "File"] -menu .bar.file
659 menu .bar.file
660 .bar.file add command -label [mc "Update"] -command updatecommits
661 .bar.file add command -label [mc "Reread references"] -command rereadrefs
662 .bar.file add command -label [mc "List references"] -command showrefs
663 .bar.file add command -label [mc "Quit"] -command doquit
664 menu .bar.edit
665 .bar add cascade -label [mc "Edit"] -menu .bar.edit
666 .bar.edit add command -label [mc "Preferences"] -command doprefs
667
668 menu .bar.view
669 .bar add cascade -label [mc "View"] -menu .bar.view
670 .bar.view add command -label [mc "New view..."] -command {newview 0}
671 .bar.view add command -label [mc "Edit view..."] -command editview \
672 -state disabled
673 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
674 .bar.view add separator
675 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
676 -variable selectedview -value 0
677
678 menu .bar.help
679 .bar add cascade -label [mc "Help"] -menu .bar.help
680 .bar.help add command -label [mc "About gitk"] -command about
681 .bar.help add command -label [mc "Key bindings"] -command keys
682 .bar.help configure
683 . configure -menu .bar
684
685 # the gui has upper and lower half, parts of a paned window.
686 panedwindow .ctop -orient vertical
687
688 # possibly use assumed geometry
689 if {![info exists geometry(pwsash0)]} {
690 set geometry(topheight) [expr {15 * $linespc}]
691 set geometry(topwidth) [expr {80 * $charspc}]
692 set geometry(botheight) [expr {15 * $linespc}]
693 set geometry(botwidth) [expr {50 * $charspc}]
694 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
695 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
696 }
697
698 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
699 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
700 frame .tf.histframe
701 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
702
703 # create three canvases
704 set cscroll .tf.histframe.csb
705 set canv .tf.histframe.pwclist.canv
706 canvas $canv \
707 -selectbackground $selectbgcolor \
708 -background $bgcolor -bd 0 \
709 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
710 .tf.histframe.pwclist add $canv
711 set canv2 .tf.histframe.pwclist.canv2
712 canvas $canv2 \
713 -selectbackground $selectbgcolor \
714 -background $bgcolor -bd 0 -yscrollincr $linespc
715 .tf.histframe.pwclist add $canv2
716 set canv3 .tf.histframe.pwclist.canv3
717 canvas $canv3 \
718 -selectbackground $selectbgcolor \
719 -background $bgcolor -bd 0 -yscrollincr $linespc
720 .tf.histframe.pwclist add $canv3
721 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
722 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
723
724 # a scroll bar to rule them
725 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
726 pack $cscroll -side right -fill y
727 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
728 lappend bglist $canv $canv2 $canv3
729 pack .tf.histframe.pwclist -fill both -expand 1 -side left
730
731 # we have two button bars at bottom of top frame. Bar 1
732 frame .tf.bar
733 frame .tf.lbar -height 15
734
735 set sha1entry .tf.bar.sha1
736 set entries $sha1entry
737 set sha1but .tf.bar.sha1label
738 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
739 -command gotocommit -width 8
740 $sha1but conf -disabledforeground [$sha1but cget -foreground]
741 pack .tf.bar.sha1label -side left
742 entry $sha1entry -width 40 -font textfont -textvariable sha1string
743 trace add variable sha1string write sha1change
744 pack $sha1entry -side left -pady 2
745
746 image create bitmap bm-left -data {
747 #define left_width 16
748 #define left_height 16
749 static unsigned char left_bits[] = {
750 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
751 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
752 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
753 }
754 image create bitmap bm-right -data {
755 #define right_width 16
756 #define right_height 16
757 static unsigned char right_bits[] = {
758 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
759 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
760 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
761 }
762 button .tf.bar.leftbut -image bm-left -command goback \
763 -state disabled -width 26
764 pack .tf.bar.leftbut -side left -fill y
765 button .tf.bar.rightbut -image bm-right -command goforw \
766 -state disabled -width 26
767 pack .tf.bar.rightbut -side left -fill y
768
769 # Status label and progress bar
770 set statusw .tf.bar.status
771 label $statusw -width 15 -relief sunken
772 pack $statusw -side left -padx 5
773 set h [expr {[font metrics uifont -linespace] + 2}]
774 set progresscanv .tf.bar.progress
775 canvas $progresscanv -relief sunken -height $h -borderwidth 2
776 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
777 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
778 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
779 pack $progresscanv -side right -expand 1 -fill x
780 set progresscoords {0 0}
781 set fprogcoord 0
782 set rprogcoord 0
783 bind $progresscanv <Configure> adjustprogress
784 set lastprogupdate [clock clicks -milliseconds]
785 set progupdatepending 0
786
787 # build up the bottom bar of upper window
788 label .tf.lbar.flabel -text "[mc "Find"] "
789 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
790 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
791 label .tf.lbar.flab2 -text " [mc "commit"] "
792 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
793 -side left -fill y
794 set gdttype [mc "containing:"]
795 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
796 [mc "containing:"] \
797 [mc "touching paths:"] \
798 [mc "adding/removing string:"]]
799 trace add variable gdttype write gdttype_change
800 pack .tf.lbar.gdttype -side left -fill y
801
802 set findstring {}
803 set fstring .tf.lbar.findstring
804 lappend entries $fstring
805 entry $fstring -width 30 -font textfont -textvariable findstring
806 trace add variable findstring write find_change
807 set findtype [mc "Exact"]
808 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
809 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
810 trace add variable findtype write findcom_change
811 set findloc [mc "All fields"]
812 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
813 [mc "Comments"] [mc "Author"] [mc "Committer"]
814 trace add variable findloc write find_change
815 pack .tf.lbar.findloc -side right
816 pack .tf.lbar.findtype -side right
817 pack $fstring -side left -expand 1 -fill x
818
819 # Finish putting the upper half of the viewer together
820 pack .tf.lbar -in .tf -side bottom -fill x
821 pack .tf.bar -in .tf -side bottom -fill x
822 pack .tf.histframe -fill both -side top -expand 1
823 .ctop add .tf
824 .ctop paneconfigure .tf -height $geometry(topheight)
825 .ctop paneconfigure .tf -width $geometry(topwidth)
826
827 # now build up the bottom
828 panedwindow .pwbottom -orient horizontal
829
830 # lower left, a text box over search bar, scroll bar to the right
831 # if we know window height, then that will set the lower text height, otherwise
832 # we set lower text height which will drive window height
833 if {[info exists geometry(main)]} {
834 frame .bleft -width $geometry(botwidth)
835 } else {
836 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
837 }
838 frame .bleft.top
839 frame .bleft.mid
840 frame .bleft.bottom
841
842 button .bleft.top.search -text [mc "Search"] -command dosearch
843 pack .bleft.top.search -side left -padx 5
844 set sstring .bleft.top.sstring
845 entry $sstring -width 20 -font textfont -textvariable searchstring
846 lappend entries $sstring
847 trace add variable searchstring write incrsearch
848 pack $sstring -side left -expand 1 -fill x
849 radiobutton .bleft.mid.diff -text [mc "Diff"] \
850 -command changediffdisp -variable diffelide -value {0 0}
851 radiobutton .bleft.mid.old -text [mc "Old version"] \
852 -command changediffdisp -variable diffelide -value {0 1}
853 radiobutton .bleft.mid.new -text [mc "New version"] \
854 -command changediffdisp -variable diffelide -value {1 0}
855 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
856 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
857 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
858 -from 1 -increment 1 -to 10000000 \
859 -validate all -validatecommand "diffcontextvalidate %P" \
860 -textvariable diffcontextstring
861 .bleft.mid.diffcontext set $diffcontext
862 trace add variable diffcontextstring write diffcontextchange
863 lappend entries .bleft.mid.diffcontext
864 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
865 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
866 -command changeignorespace -variable ignorespace
867 pack .bleft.mid.ignspace -side left -padx 5
868 set ctext .bleft.bottom.ctext
869 text $ctext -background $bgcolor -foreground $fgcolor \
870 -state disabled -font textfont \
871 -yscrollcommand scrolltext -wrap none \
872 -xscrollcommand ".bleft.bottom.sbhorizontal set"
873 if {$have_tk85} {
874 $ctext conf -tabstyle wordprocessor
875 }
876 scrollbar .bleft.bottom.sb -command "$ctext yview"
877 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
878 -width 10
879 pack .bleft.top -side top -fill x
880 pack .bleft.mid -side top -fill x
881 grid $ctext .bleft.bottom.sb -sticky nsew
882 grid .bleft.bottom.sbhorizontal -sticky ew
883 grid columnconfigure .bleft.bottom 0 -weight 1
884 grid rowconfigure .bleft.bottom 0 -weight 1
885 grid rowconfigure .bleft.bottom 1 -weight 0
886 pack .bleft.bottom -side top -fill both -expand 1
887 lappend bglist $ctext
888 lappend fglist $ctext
889
890 $ctext tag conf comment -wrap $wrapcomment
891 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
892 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
893 $ctext tag conf d0 -fore [lindex $diffcolors 0]
894 $ctext tag conf d1 -fore [lindex $diffcolors 1]
895 $ctext tag conf m0 -fore red
896 $ctext tag conf m1 -fore blue
897 $ctext tag conf m2 -fore green
898 $ctext tag conf m3 -fore purple
899 $ctext tag conf m4 -fore brown
900 $ctext tag conf m5 -fore "#009090"
901 $ctext tag conf m6 -fore magenta
902 $ctext tag conf m7 -fore "#808000"
903 $ctext tag conf m8 -fore "#009000"
904 $ctext tag conf m9 -fore "#ff0080"
905 $ctext tag conf m10 -fore cyan
906 $ctext tag conf m11 -fore "#b07070"
907 $ctext tag conf m12 -fore "#70b0f0"
908 $ctext tag conf m13 -fore "#70f0b0"
909 $ctext tag conf m14 -fore "#f0b070"
910 $ctext tag conf m15 -fore "#ff70b0"
911 $ctext tag conf mmax -fore darkgrey
912 set mergemax 16
913 $ctext tag conf mresult -font textfontbold
914 $ctext tag conf msep -font textfontbold
915 $ctext tag conf found -back yellow
916
917 .pwbottom add .bleft
918 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
919
920 # lower right
921 frame .bright
922 frame .bright.mode
923 radiobutton .bright.mode.patch -text [mc "Patch"] \
924 -command reselectline -variable cmitmode -value "patch"
925 radiobutton .bright.mode.tree -text [mc "Tree"] \
926 -command reselectline -variable cmitmode -value "tree"
927 grid .bright.mode.patch .bright.mode.tree -sticky ew
928 pack .bright.mode -side top -fill x
929 set cflist .bright.cfiles
930 set indent [font measure mainfont "nn"]
931 text $cflist \
932 -selectbackground $selectbgcolor \
933 -background $bgcolor -foreground $fgcolor \
934 -font mainfont \
935 -tabs [list $indent [expr {2 * $indent}]] \
936 -yscrollcommand ".bright.sb set" \
937 -cursor [. cget -cursor] \
938 -spacing1 1 -spacing3 1
939 lappend bglist $cflist
940 lappend fglist $cflist
941 scrollbar .bright.sb -command "$cflist yview"
942 pack .bright.sb -side right -fill y
943 pack $cflist -side left -fill both -expand 1
944 $cflist tag configure highlight \
945 -background [$cflist cget -selectbackground]
946 $cflist tag configure bold -font mainfontbold
947
948 .pwbottom add .bright
949 .ctop add .pwbottom
950
951 # restore window width & height if known
952 if {[info exists geometry(main)]} {
953 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
954 if {$w > [winfo screenwidth .]} {
955 set w [winfo screenwidth .]
956 }
957 if {$h > [winfo screenheight .]} {
958 set h [winfo screenheight .]
959 }
960 wm geometry . "${w}x$h"
961 }
962 }
963
964 if {[tk windowingsystem] eq {aqua}} {
965 set M1B M1
966 } else {
967 set M1B Control
968 }
969
970 bind .pwbottom <Configure> {resizecdetpanes %W %w}
971 pack .ctop -fill both -expand 1
972 bindall <1> {selcanvline %W %x %y}
973 #bindall <B1-Motion> {selcanvline %W %x %y}
974 if {[tk windowingsystem] == "win32"} {
975 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
976 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
977 } else {
978 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
979 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
980 if {[tk windowingsystem] eq "aqua"} {
981 bindall <MouseWheel> {
982 set delta [expr {- (%D)}]
983 allcanvs yview scroll $delta units
984 }
985 }
986 }
987 bindall <2> "canvscan mark %W %x %y"
988 bindall <B2-Motion> "canvscan dragto %W %x %y"
989 bindkey <Home> selfirstline
990 bindkey <End> sellastline
991 bind . <Key-Up> "selnextline -1"
992 bind . <Key-Down> "selnextline 1"
993 bind . <Shift-Key-Up> "dofind -1 0"
994 bind . <Shift-Key-Down> "dofind 1 0"
995 bindkey <Key-Right> "goforw"
996 bindkey <Key-Left> "goback"
997 bind . <Key-Prior> "selnextpage -1"
998 bind . <Key-Next> "selnextpage 1"
999 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1000 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1001 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1002 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1003 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1004 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1005 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1006 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1007 bindkey <Key-space> "$ctext yview scroll 1 pages"
1008 bindkey p "selnextline -1"
1009 bindkey n "selnextline 1"
1010 bindkey z "goback"
1011 bindkey x "goforw"
1012 bindkey i "selnextline -1"
1013 bindkey k "selnextline 1"
1014 bindkey j "goback"
1015 bindkey l "goforw"
1016 bindkey b "$ctext yview scroll -1 pages"
1017 bindkey d "$ctext yview scroll 18 units"
1018 bindkey u "$ctext yview scroll -18 units"
1019 bindkey / {dofind 1 1}
1020 bindkey <Key-Return> {dofind 1 1}
1021 bindkey ? {dofind -1 1}
1022 bindkey f nextfile
1023 bindkey <F5> updatecommits
1024 bind . <$M1B-q> doquit
1025 bind . <$M1B-f> {dofind 1 1}
1026 bind . <$M1B-g> {dofind 1 0}
1027 bind . <$M1B-r> dosearchback
1028 bind . <$M1B-s> dosearch
1029 bind . <$M1B-equal> {incrfont 1}
1030 bind . <$M1B-plus> {incrfont 1}
1031 bind . <$M1B-KP_Add> {incrfont 1}
1032 bind . <$M1B-minus> {incrfont -1}
1033 bind . <$M1B-KP_Subtract> {incrfont -1}
1034 wm protocol . WM_DELETE_WINDOW doquit
1035 bind . <Button-1> "click %W"
1036 bind $fstring <Key-Return> {dofind 1 1}
1037 bind $sha1entry <Key-Return> gotocommit
1038 bind $sha1entry <<PasteSelection>> clearsha1
1039 bind $cflist <1> {sel_flist %W %x %y; break}
1040 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1041 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1042 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1043
1044 set maincursor [. cget -cursor]
1045 set textcursor [$ctext cget -cursor]
1046 set curtextcursor $textcursor
1047
1048 set rowctxmenu .rowctxmenu
1049 menu $rowctxmenu -tearoff 0
1050 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1051 -command {diffvssel 0}
1052 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1053 -command {diffvssel 1}
1054 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1055 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1056 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1057 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1058 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1059 -command cherrypick
1060 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1061 -command resethead
1062
1063 set fakerowmenu .fakerowmenu
1064 menu $fakerowmenu -tearoff 0
1065 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1066 -command {diffvssel 0}
1067 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1068 -command {diffvssel 1}
1069 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1070# $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1071# $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1072# $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1073
1074 set headctxmenu .headctxmenu
1075 menu $headctxmenu -tearoff 0
1076 $headctxmenu add command -label [mc "Check out this branch"] \
1077 -command cobranch
1078 $headctxmenu add command -label [mc "Remove this branch"] \
1079 -command rmbranch
1080
1081 global flist_menu
1082 set flist_menu .flistctxmenu
1083 menu $flist_menu -tearoff 0
1084 $flist_menu add command -label [mc "Highlight this too"] \
1085 -command {flist_hl 0}
1086 $flist_menu add command -label [mc "Highlight this only"] \
1087 -command {flist_hl 1}
1088}
1089
1090# Windows sends all mouse wheel events to the current focused window, not
1091# the one where the mouse hovers, so bind those events here and redirect
1092# to the correct window
1093proc windows_mousewheel_redirector {W X Y D} {
1094 global canv canv2 canv3
1095 set w [winfo containing -displayof $W $X $Y]
1096 if {$w ne ""} {
1097 set u [expr {$D < 0 ? 5 : -5}]
1098 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1099 allcanvs yview scroll $u units
1100 } else {
1101 catch {
1102 $w yview scroll $u units
1103 }
1104 }
1105 }
1106}
1107
1108# mouse-2 makes all windows scan vertically, but only the one
1109# the cursor is in scans horizontally
1110proc canvscan {op w x y} {
1111 global canv canv2 canv3
1112 foreach c [list $canv $canv2 $canv3] {
1113 if {$c == $w} {
1114 $c scan $op $x $y
1115 } else {
1116 $c scan $op 0 $y
1117 }
1118 }
1119}
1120
1121proc scrollcanv {cscroll f0 f1} {
1122 $cscroll set $f0 $f1
1123 drawfrac $f0 $f1
1124 flushhighlights
1125}
1126
1127# when we make a key binding for the toplevel, make sure
1128# it doesn't get triggered when that key is pressed in the
1129# find string entry widget.
1130proc bindkey {ev script} {
1131 global entries
1132 bind . $ev $script
1133 set escript [bind Entry $ev]
1134 if {$escript == {}} {
1135 set escript [bind Entry <Key>]
1136 }
1137 foreach e $entries {
1138 bind $e $ev "$escript; break"
1139 }
1140}
1141
1142# set the focus back to the toplevel for any click outside
1143# the entry widgets
1144proc click {w} {
1145 global ctext entries
1146 foreach e [concat $entries $ctext] {
1147 if {$w == $e} return
1148 }
1149 focus .
1150}
1151
1152# Adjust the progress bar for a change in requested extent or canvas size
1153proc adjustprogress {} {
1154 global progresscanv progressitem progresscoords
1155 global fprogitem fprogcoord lastprogupdate progupdatepending
1156 global rprogitem rprogcoord
1157
1158 set w [expr {[winfo width $progresscanv] - 4}]
1159 set x0 [expr {$w * [lindex $progresscoords 0]}]
1160 set x1 [expr {$w * [lindex $progresscoords 1]}]
1161 set h [winfo height $progresscanv]
1162 $progresscanv coords $progressitem $x0 0 $x1 $h
1163 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1164 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1165 set now [clock clicks -milliseconds]
1166 if {$now >= $lastprogupdate + 100} {
1167 set progupdatepending 0
1168 update
1169 } elseif {!$progupdatepending} {
1170 set progupdatepending 1
1171 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1172 }
1173}
1174
1175proc doprogupdate {} {
1176 global lastprogupdate progupdatepending
1177
1178 if {$progupdatepending} {
1179 set progupdatepending 0
1180 set lastprogupdate [clock clicks -milliseconds]
1181 update
1182 }
1183}
1184
1185proc savestuff {w} {
1186 global canv canv2 canv3 mainfont textfont uifont tabstop
1187 global stuffsaved findmergefiles maxgraphpct
1188 global maxwidth showneartags showlocalchanges
1189 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
1190 global cmitmode wrapcomment datetimeformat limitdiffs
1191 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1192 global autoselect
1193
1194 if {$stuffsaved} return
1195 if {![winfo viewable .]} return
1196 catch {
1197 set f [open "~/.gitk-new" w]
1198 puts $f [list set mainfont $mainfont]
1199 puts $f [list set textfont $textfont]
1200 puts $f [list set uifont $uifont]
1201 puts $f [list set tabstop $tabstop]
1202 puts $f [list set findmergefiles $findmergefiles]
1203 puts $f [list set maxgraphpct $maxgraphpct]
1204 puts $f [list set maxwidth $maxwidth]
1205 puts $f [list set cmitmode $cmitmode]
1206 puts $f [list set wrapcomment $wrapcomment]
1207 puts $f [list set autoselect $autoselect]
1208 puts $f [list set showneartags $showneartags]
1209 puts $f [list set showlocalchanges $showlocalchanges]
1210 puts $f [list set datetimeformat $datetimeformat]
1211 puts $f [list set limitdiffs $limitdiffs]
1212 puts $f [list set bgcolor $bgcolor]
1213 puts $f [list set fgcolor $fgcolor]
1214 puts $f [list set colors $colors]
1215 puts $f [list set diffcolors $diffcolors]
1216 puts $f [list set diffcontext $diffcontext]
1217 puts $f [list set selectbgcolor $selectbgcolor]
1218
1219 puts $f "set geometry(main) [wm geometry .]"
1220 puts $f "set geometry(topwidth) [winfo width .tf]"
1221 puts $f "set geometry(topheight) [winfo height .tf]"
1222 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1223 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1224 puts $f "set geometry(botwidth) [winfo width .bleft]"
1225 puts $f "set geometry(botheight) [winfo height .bleft]"
1226
1227 puts -nonewline $f "set permviews {"
1228 for {set v 0} {$v < $nextviewnum} {incr v} {
1229 if {$viewperm($v)} {
1230 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
1231 }
1232 }
1233 puts $f "}"
1234 close $f
1235 file rename -force "~/.gitk-new" "~/.gitk"
1236 }
1237 set stuffsaved 1
1238}
1239
1240proc resizeclistpanes {win w} {
1241 global oldwidth
1242 if {[info exists oldwidth($win)]} {
1243 set s0 [$win sash coord 0]
1244 set s1 [$win sash coord 1]
1245 if {$w < 60} {
1246 set sash0 [expr {int($w/2 - 2)}]
1247 set sash1 [expr {int($w*5/6 - 2)}]
1248 } else {
1249 set factor [expr {1.0 * $w / $oldwidth($win)}]
1250 set sash0 [expr {int($factor * [lindex $s0 0])}]
1251 set sash1 [expr {int($factor * [lindex $s1 0])}]
1252 if {$sash0 < 30} {
1253 set sash0 30
1254 }
1255 if {$sash1 < $sash0 + 20} {
1256 set sash1 [expr {$sash0 + 20}]
1257 }
1258 if {$sash1 > $w - 10} {
1259 set sash1 [expr {$w - 10}]
1260 if {$sash0 > $sash1 - 20} {
1261 set sash0 [expr {$sash1 - 20}]
1262 }
1263 }
1264 }
1265 $win sash place 0 $sash0 [lindex $s0 1]
1266 $win sash place 1 $sash1 [lindex $s1 1]
1267 }
1268 set oldwidth($win) $w
1269}
1270
1271proc resizecdetpanes {win w} {
1272 global oldwidth
1273 if {[info exists oldwidth($win)]} {
1274 set s0 [$win sash coord 0]
1275 if {$w < 60} {
1276 set sash0 [expr {int($w*3/4 - 2)}]
1277 } else {
1278 set factor [expr {1.0 * $w / $oldwidth($win)}]
1279 set sash0 [expr {int($factor * [lindex $s0 0])}]
1280 if {$sash0 < 45} {
1281 set sash0 45
1282 }
1283 if {$sash0 > $w - 15} {
1284 set sash0 [expr {$w - 15}]
1285 }
1286 }
1287 $win sash place 0 $sash0 [lindex $s0 1]
1288 }
1289 set oldwidth($win) $w
1290}
1291
1292proc allcanvs args {
1293 global canv canv2 canv3
1294 eval $canv $args
1295 eval $canv2 $args
1296 eval $canv3 $args
1297}
1298
1299proc bindall {event action} {
1300 global canv canv2 canv3
1301 bind $canv $event $action
1302 bind $canv2 $event $action
1303 bind $canv3 $event $action
1304}
1305
1306proc about {} {
1307 global uifont
1308 set w .about
1309 if {[winfo exists $w]} {
1310 raise $w
1311 return
1312 }
1313 toplevel $w
1314 wm title $w [mc "About gitk"]
1315 message $w.m -text [mc "
1316Gitk - a commit viewer for git
1317
1318Copyright © 2005-2006 Paul Mackerras
1319
1320Use and redistribute under the terms of the GNU General Public License"] \
1321 -justify center -aspect 400 -border 2 -bg white -relief groove
1322 pack $w.m -side top -fill x -padx 2 -pady 2
1323 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
1324 pack $w.ok -side bottom
1325 bind $w <Visibility> "focus $w.ok"
1326 bind $w <Key-Escape> "destroy $w"
1327 bind $w <Key-Return> "destroy $w"
1328}
1329
1330proc keys {} {
1331 set w .keys
1332 if {[winfo exists $w]} {
1333 raise $w
1334 return
1335 }
1336 if {[tk windowingsystem] eq {aqua}} {
1337 set M1T Cmd
1338 } else {
1339 set M1T Ctrl
1340 }
1341 toplevel $w
1342 wm title $w [mc "Gitk key bindings"]
1343 message $w.m -text "
1344[mc "Gitk key bindings:"]
1345
1346[mc "<%s-Q> Quit" $M1T]
1347[mc "<Home> Move to first commit"]
1348[mc "<End> Move to last commit"]
1349[mc "<Up>, p, i Move up one commit"]
1350[mc "<Down>, n, k Move down one commit"]
1351[mc "<Left>, z, j Go back in history list"]
1352[mc "<Right>, x, l Go forward in history list"]
1353[mc "<PageUp> Move up one page in commit list"]
1354[mc "<PageDown> Move down one page in commit list"]
1355[mc "<%s-Home> Scroll to top of commit list" $M1T]
1356[mc "<%s-End> Scroll to bottom of commit list" $M1T]
1357[mc "<%s-Up> Scroll commit list up one line" $M1T]
1358[mc "<%s-Down> Scroll commit list down one line" $M1T]
1359[mc "<%s-PageUp> Scroll commit list up one page" $M1T]
1360[mc "<%s-PageDown> Scroll commit list down one page" $M1T]
1361[mc "<Shift-Up> Find backwards (upwards, later commits)"]
1362[mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
1363[mc "<Delete>, b Scroll diff view up one page"]
1364[mc "<Backspace> Scroll diff view up one page"]
1365[mc "<Space> Scroll diff view down one page"]
1366[mc "u Scroll diff view up 18 lines"]
1367[mc "d Scroll diff view down 18 lines"]
1368[mc "<%s-F> Find" $M1T]
1369[mc "<%s-G> Move to next find hit" $M1T]
1370[mc "<Return> Move to next find hit"]
1371[mc "/ Move to next find hit, or redo find"]
1372[mc "? Move to previous find hit"]
1373[mc "f Scroll diff view to next file"]
1374[mc "<%s-S> Search for next hit in diff view" $M1T]
1375[mc "<%s-R> Search for previous hit in diff view" $M1T]
1376[mc "<%s-KP+> Increase font size" $M1T]
1377[mc "<%s-plus> Increase font size" $M1T]
1378[mc "<%s-KP-> Decrease font size" $M1T]
1379[mc "<%s-minus> Decrease font size" $M1T]
1380[mc "<F5> Update"]
1381" \
1382 -justify left -bg white -border 2 -relief groove
1383 pack $w.m -side top -fill both -padx 2 -pady 2
1384 button $w.ok -text [mc "Close"] -command "destroy $w" -default active
1385 pack $w.ok -side bottom
1386 bind $w <Visibility> "focus $w.ok"
1387 bind $w <Key-Escape> "destroy $w"
1388 bind $w <Key-Return> "destroy $w"
1389}
1390
1391# Procedures for manipulating the file list window at the
1392# bottom right of the overall window.
1393
1394proc treeview {w l openlevs} {
1395 global treecontents treediropen treeheight treeparent treeindex
1396
1397 set ix 0
1398 set treeindex() 0
1399 set lev 0
1400 set prefix {}
1401 set prefixend -1
1402 set prefendstack {}
1403 set htstack {}
1404 set ht 0
1405 set treecontents() {}
1406 $w conf -state normal
1407 foreach f $l {
1408 while {[string range $f 0 $prefixend] ne $prefix} {
1409 if {$lev <= $openlevs} {
1410 $w mark set e:$treeindex($prefix) "end -1c"
1411 $w mark gravity e:$treeindex($prefix) left
1412 }
1413 set treeheight($prefix) $ht
1414 incr ht [lindex $htstack end]
1415 set htstack [lreplace $htstack end end]
1416 set prefixend [lindex $prefendstack end]
1417 set prefendstack [lreplace $prefendstack end end]
1418 set prefix [string range $prefix 0 $prefixend]
1419 incr lev -1
1420 }
1421 set tail [string range $f [expr {$prefixend+1}] end]
1422 while {[set slash [string first "/" $tail]] >= 0} {
1423 lappend htstack $ht
1424 set ht 0
1425 lappend prefendstack $prefixend
1426 incr prefixend [expr {$slash + 1}]
1427 set d [string range $tail 0 $slash]
1428 lappend treecontents($prefix) $d
1429 set oldprefix $prefix
1430 append prefix $d
1431 set treecontents($prefix) {}
1432 set treeindex($prefix) [incr ix]
1433 set treeparent($prefix) $oldprefix
1434 set tail [string range $tail [expr {$slash+1}] end]
1435 if {$lev <= $openlevs} {
1436 set ht 1
1437 set treediropen($prefix) [expr {$lev < $openlevs}]
1438 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1439 $w mark set d:$ix "end -1c"
1440 $w mark gravity d:$ix left
1441 set str "\n"
1442 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1443 $w insert end $str
1444 $w image create end -align center -image $bm -padx 1 \
1445 -name a:$ix
1446 $w insert end $d [highlight_tag $prefix]
1447 $w mark set s:$ix "end -1c"
1448 $w mark gravity s:$ix left
1449 }
1450 incr lev
1451 }
1452 if {$tail ne {}} {
1453 if {$lev <= $openlevs} {
1454 incr ht
1455 set str "\n"
1456 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1457 $w insert end $str
1458 $w insert end $tail [highlight_tag $f]
1459 }
1460 lappend treecontents($prefix) $tail
1461 }
1462 }
1463 while {$htstack ne {}} {
1464 set treeheight($prefix) $ht
1465 incr ht [lindex $htstack end]
1466 set htstack [lreplace $htstack end end]
1467 set prefixend [lindex $prefendstack end]
1468 set prefendstack [lreplace $prefendstack end end]
1469 set prefix [string range $prefix 0 $prefixend]
1470 }
1471 $w conf -state disabled
1472}
1473
1474proc linetoelt {l} {
1475 global treeheight treecontents
1476
1477 set y 2
1478 set prefix {}
1479 while {1} {
1480 foreach e $treecontents($prefix) {
1481 if {$y == $l} {
1482 return "$prefix$e"
1483 }
1484 set n 1
1485 if {[string index $e end] eq "/"} {
1486 set n $treeheight($prefix$e)
1487 if {$y + $n > $l} {
1488 append prefix $e
1489 incr y
1490 break
1491 }
1492 }
1493 incr y $n
1494 }
1495 }
1496}
1497
1498proc highlight_tree {y prefix} {
1499 global treeheight treecontents cflist
1500
1501 foreach e $treecontents($prefix) {
1502 set path $prefix$e
1503 if {[highlight_tag $path] ne {}} {
1504 $cflist tag add bold $y.0 "$y.0 lineend"
1505 }
1506 incr y
1507 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1508 set y [highlight_tree $y $path]
1509 }
1510 }
1511 return $y
1512}
1513
1514proc treeclosedir {w dir} {
1515 global treediropen treeheight treeparent treeindex
1516
1517 set ix $treeindex($dir)
1518 $w conf -state normal
1519 $w delete s:$ix e:$ix
1520 set treediropen($dir) 0
1521 $w image configure a:$ix -image tri-rt
1522 $w conf -state disabled
1523 set n [expr {1 - $treeheight($dir)}]
1524 while {$dir ne {}} {
1525 incr treeheight($dir) $n
1526 set dir $treeparent($dir)
1527 }
1528}
1529
1530proc treeopendir {w dir} {
1531 global treediropen treeheight treeparent treecontents treeindex
1532
1533 set ix $treeindex($dir)
1534 $w conf -state normal
1535 $w image configure a:$ix -image tri-dn
1536 $w mark set e:$ix s:$ix
1537 $w mark gravity e:$ix right
1538 set lev 0
1539 set str "\n"
1540 set n [llength $treecontents($dir)]
1541 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1542 incr lev
1543 append str "\t"
1544 incr treeheight($x) $n
1545 }
1546 foreach e $treecontents($dir) {
1547 set de $dir$e
1548 if {[string index $e end] eq "/"} {
1549 set iy $treeindex($de)
1550 $w mark set d:$iy e:$ix
1551 $w mark gravity d:$iy left
1552 $w insert e:$ix $str
1553 set treediropen($de) 0
1554 $w image create e:$ix -align center -image tri-rt -padx 1 \
1555 -name a:$iy
1556 $w insert e:$ix $e [highlight_tag $de]
1557 $w mark set s:$iy e:$ix
1558 $w mark gravity s:$iy left
1559 set treeheight($de) 1
1560 } else {
1561 $w insert e:$ix $str
1562 $w insert e:$ix $e [highlight_tag $de]
1563 }
1564 }
1565 $w mark gravity e:$ix left
1566 $w conf -state disabled
1567 set treediropen($dir) 1
1568 set top [lindex [split [$w index @0,0] .] 0]
1569 set ht [$w cget -height]
1570 set l [lindex [split [$w index s:$ix] .] 0]
1571 if {$l < $top} {
1572 $w yview $l.0
1573 } elseif {$l + $n + 1 > $top + $ht} {
1574 set top [expr {$l + $n + 2 - $ht}]
1575 if {$l < $top} {
1576 set top $l
1577 }
1578 $w yview $top.0
1579 }
1580}
1581
1582proc treeclick {w x y} {
1583 global treediropen cmitmode ctext cflist cflist_top
1584
1585 if {$cmitmode ne "tree"} return
1586 if {![info exists cflist_top]} return
1587 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1588 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1589 $cflist tag add highlight $l.0 "$l.0 lineend"
1590 set cflist_top $l
1591 if {$l == 1} {
1592 $ctext yview 1.0
1593 return
1594 }
1595 set e [linetoelt $l]
1596 if {[string index $e end] ne "/"} {
1597 showfile $e
1598 } elseif {$treediropen($e)} {
1599 treeclosedir $w $e
1600 } else {
1601 treeopendir $w $e
1602 }
1603}
1604
1605proc setfilelist {id} {
1606 global treefilelist cflist
1607
1608 treeview $cflist $treefilelist($id) 0
1609}
1610
1611image create bitmap tri-rt -background black -foreground blue -data {
1612 #define tri-rt_width 13
1613 #define tri-rt_height 13
1614 static unsigned char tri-rt_bits[] = {
1615 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1616 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1617 0x00, 0x00};
1618} -maskdata {
1619 #define tri-rt-mask_width 13
1620 #define tri-rt-mask_height 13
1621 static unsigned char tri-rt-mask_bits[] = {
1622 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1623 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1624 0x08, 0x00};
1625}
1626image create bitmap tri-dn -background black -foreground blue -data {
1627 #define tri-dn_width 13
1628 #define tri-dn_height 13
1629 static unsigned char tri-dn_bits[] = {
1630 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1631 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1632 0x00, 0x00};
1633} -maskdata {
1634 #define tri-dn-mask_width 13
1635 #define tri-dn-mask_height 13
1636 static unsigned char tri-dn-mask_bits[] = {
1637 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1638 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1639 0x00, 0x00};
1640}
1641
1642image create bitmap reficon-T -background black -foreground yellow -data {
1643 #define tagicon_width 13
1644 #define tagicon_height 9
1645 static unsigned char tagicon_bits[] = {
1646 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1647 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1648} -maskdata {
1649 #define tagicon-mask_width 13
1650 #define tagicon-mask_height 9
1651 static unsigned char tagicon-mask_bits[] = {
1652 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1653 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1654}
1655set rectdata {
1656 #define headicon_width 13
1657 #define headicon_height 9
1658 static unsigned char headicon_bits[] = {
1659 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1660 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1661}
1662set rectmask {
1663 #define headicon-mask_width 13
1664 #define headicon-mask_height 9
1665 static unsigned char headicon-mask_bits[] = {
1666 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1667 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1668}
1669image create bitmap reficon-H -background black -foreground green \
1670 -data $rectdata -maskdata $rectmask
1671image create bitmap reficon-o -background black -foreground "#ddddff" \
1672 -data $rectdata -maskdata $rectmask
1673
1674proc init_flist {first} {
1675 global cflist cflist_top selectedline difffilestart
1676
1677 $cflist conf -state normal
1678 $cflist delete 0.0 end
1679 if {$first ne {}} {
1680 $cflist insert end $first
1681 set cflist_top 1
1682 $cflist tag add highlight 1.0 "1.0 lineend"
1683 } else {
1684 catch {unset cflist_top}
1685 }
1686 $cflist conf -state disabled
1687 set difffilestart {}
1688}
1689
1690proc highlight_tag {f} {
1691 global highlight_paths
1692
1693 foreach p $highlight_paths {
1694 if {[string match $p $f]} {
1695 return "bold"
1696 }
1697 }
1698 return {}
1699}
1700
1701proc highlight_filelist {} {
1702 global cmitmode cflist
1703
1704 $cflist conf -state normal
1705 if {$cmitmode ne "tree"} {
1706 set end [lindex [split [$cflist index end] .] 0]
1707 for {set l 2} {$l < $end} {incr l} {
1708 set line [$cflist get $l.0 "$l.0 lineend"]
1709 if {[highlight_tag $line] ne {}} {
1710 $cflist tag add bold $l.0 "$l.0 lineend"
1711 }
1712 }
1713 } else {
1714 highlight_tree 2 {}
1715 }
1716 $cflist conf -state disabled
1717}
1718
1719proc unhighlight_filelist {} {
1720 global cflist
1721
1722 $cflist conf -state normal
1723 $cflist tag remove bold 1.0 end
1724 $cflist conf -state disabled
1725}
1726
1727proc add_flist {fl} {
1728 global cflist
1729
1730 $cflist conf -state normal
1731 foreach f $fl {
1732 $cflist insert end "\n"
1733 $cflist insert end $f [highlight_tag $f]
1734 }
1735 $cflist conf -state disabled
1736}
1737
1738proc sel_flist {w x y} {
1739 global ctext difffilestart cflist cflist_top cmitmode
1740
1741 if {$cmitmode eq "tree"} return
1742 if {![info exists cflist_top]} return
1743 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1744 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1745 $cflist tag add highlight $l.0 "$l.0 lineend"
1746 set cflist_top $l
1747 if {$l == 1} {
1748 $ctext yview 1.0
1749 } else {
1750 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1751 }
1752}
1753
1754proc pop_flist_menu {w X Y x y} {
1755 global ctext cflist cmitmode flist_menu flist_menu_file
1756 global treediffs diffids
1757
1758 stopfinding
1759 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1760 if {$l <= 1} return
1761 if {$cmitmode eq "tree"} {
1762 set e [linetoelt $l]
1763 if {[string index $e end] eq "/"} return
1764 } else {
1765 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1766 }
1767 set flist_menu_file $e
1768 tk_popup $flist_menu $X $Y
1769}
1770
1771proc flist_hl {only} {
1772 global flist_menu_file findstring gdttype
1773
1774 set x [shellquote $flist_menu_file]
1775 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
1776 set findstring $x
1777 } else {
1778 append findstring " " $x
1779 }
1780 set gdttype [mc "touching paths:"]
1781}
1782
1783# Functions for adding and removing shell-type quoting
1784
1785proc shellquote {str} {
1786 if {![string match "*\['\"\\ \t]*" $str]} {
1787 return $str
1788 }
1789 if {![string match "*\['\"\\]*" $str]} {
1790 return "\"$str\""
1791 }
1792 if {![string match "*'*" $str]} {
1793 return "'$str'"
1794 }
1795 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1796}
1797
1798proc shellarglist {l} {
1799 set str {}
1800 foreach a $l {
1801 if {$str ne {}} {
1802 append str " "
1803 }
1804 append str [shellquote $a]
1805 }
1806 return $str
1807}
1808
1809proc shelldequote {str} {
1810 set ret {}
1811 set used -1
1812 while {1} {
1813 incr used
1814 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1815 append ret [string range $str $used end]
1816 set used [string length $str]
1817 break
1818 }
1819 set first [lindex $first 0]
1820 set ch [string index $str $first]
1821 if {$first > $used} {
1822 append ret [string range $str $used [expr {$first - 1}]]
1823 set used $first
1824 }
1825 if {$ch eq " " || $ch eq "\t"} break
1826 incr used
1827 if {$ch eq "'"} {
1828 set first [string first "'" $str $used]
1829 if {$first < 0} {
1830 error "unmatched single-quote"
1831 }
1832 append ret [string range $str $used [expr {$first - 1}]]
1833 set used $first
1834 continue
1835 }
1836 if {$ch eq "\\"} {
1837 if {$used >= [string length $str]} {
1838 error "trailing backslash"
1839 }
1840 append ret [string index $str $used]
1841 continue
1842 }
1843 # here ch == "\""
1844 while {1} {
1845 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1846 error "unmatched double-quote"
1847 }
1848 set first [lindex $first 0]
1849 set ch [string index $str $first]
1850 if {$first > $used} {
1851 append ret [string range $str $used [expr {$first - 1}]]
1852 set used $first
1853 }
1854 if {$ch eq "\""} break
1855 incr used
1856 append ret [string index $str $used]
1857 incr used
1858 }
1859 }
1860 return [list $used $ret]
1861}
1862
1863proc shellsplit {str} {
1864 set l {}
1865 while {1} {
1866 set str [string trimleft $str]
1867 if {$str eq {}} break
1868 set dq [shelldequote $str]
1869 set n [lindex $dq 0]
1870 set word [lindex $dq 1]
1871 set str [string range $str $n end]
1872 lappend l $word
1873 }
1874 return $l
1875}
1876
1877# Code to implement multiple views
1878
1879proc newview {ishighlight} {
1880 global nextviewnum newviewname newviewperm newishighlight
1881 global newviewargs revtreeargs viewargscmd newviewargscmd curview
1882
1883 set newishighlight $ishighlight
1884 set top .gitkview
1885 if {[winfo exists $top]} {
1886 raise $top
1887 return
1888 }
1889 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
1890 set newviewperm($nextviewnum) 0
1891 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1892 set newviewargscmd($nextviewnum) $viewargscmd($curview)
1893 vieweditor $top $nextviewnum [mc "Gitk view definition"]
1894}
1895
1896proc editview {} {
1897 global curview
1898 global viewname viewperm newviewname newviewperm
1899 global viewargs newviewargs viewargscmd newviewargscmd
1900
1901 set top .gitkvedit-$curview
1902 if {[winfo exists $top]} {
1903 raise $top
1904 return
1905 }
1906 set newviewname($curview) $viewname($curview)
1907 set newviewperm($curview) $viewperm($curview)
1908 set newviewargs($curview) [shellarglist $viewargs($curview)]
1909 set newviewargscmd($curview) $viewargscmd($curview)
1910 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1911}
1912
1913proc vieweditor {top n title} {
1914 global newviewname newviewperm viewfiles bgcolor
1915
1916 toplevel $top
1917 wm title $top $title
1918 label $top.nl -text [mc "Name"]
1919 entry $top.name -width 20 -textvariable newviewname($n)
1920 grid $top.nl $top.name -sticky w -pady 5
1921 checkbutton $top.perm -text [mc "Remember this view"] \
1922 -variable newviewperm($n)
1923 grid $top.perm - -pady 5 -sticky w
1924 message $top.al -aspect 1000 \
1925 -text [mc "Commits to include (arguments to git rev-list):"]
1926 grid $top.al - -sticky w -pady 5
1927 entry $top.args -width 50 -textvariable newviewargs($n) \
1928 -background $bgcolor
1929 grid $top.args - -sticky ew -padx 5
1930
1931 message $top.ac -aspect 1000 \
1932 -text [mc "Command to generate more commits to include:"]
1933 grid $top.ac - -sticky w -pady 5
1934 entry $top.argscmd -width 50 -textvariable newviewargscmd($n) \
1935 -background white
1936 grid $top.argscmd - -sticky ew -padx 5
1937
1938 message $top.l -aspect 1000 \
1939 -text [mc "Enter files and directories to include, one per line:"]
1940 grid $top.l - -sticky w
1941 text $top.t -width 40 -height 10 -background $bgcolor -font uifont
1942 if {[info exists viewfiles($n)]} {
1943 foreach f $viewfiles($n) {
1944 $top.t insert end $f
1945 $top.t insert end "\n"
1946 }
1947 $top.t delete {end - 1c} end
1948 $top.t mark set insert 0.0
1949 }
1950 grid $top.t - -sticky ew -padx 5
1951 frame $top.buts
1952 button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
1953 button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
1954 grid $top.buts.ok $top.buts.can
1955 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1956 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1957 grid $top.buts - -pady 10 -sticky ew
1958 focus $top.t
1959}
1960
1961proc doviewmenu {m first cmd op argv} {
1962 set nmenu [$m index end]
1963 for {set i $first} {$i <= $nmenu} {incr i} {
1964 if {[$m entrycget $i -command] eq $cmd} {
1965 eval $m $op $i $argv
1966 break
1967 }
1968 }
1969}
1970
1971proc allviewmenus {n op args} {
1972 # global viewhlmenu
1973
1974 doviewmenu .bar.view 5 [list showview $n] $op $args
1975 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1976}
1977
1978proc newviewok {top n} {
1979 global nextviewnum newviewperm newviewname newishighlight
1980 global viewname viewfiles viewperm selectedview curview
1981 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
1982
1983 if {[catch {
1984 set newargs [shellsplit $newviewargs($n)]
1985 } err]} {
1986 error_popup "[mc "Error in commit selection arguments:"] $err"
1987 wm raise $top
1988 focus $top
1989 return
1990 }
1991 set files {}
1992 foreach f [split [$top.t get 0.0 end] "\n"] {
1993 set ft [string trim $f]
1994 if {$ft ne {}} {
1995 lappend files $ft
1996 }
1997 }
1998 if {![info exists viewfiles($n)]} {
1999 # creating a new view
2000 incr nextviewnum
2001 set viewname($n) $newviewname($n)
2002 set viewperm($n) $newviewperm($n)
2003 set viewfiles($n) $files
2004 set viewargs($n) $newargs
2005 set viewargscmd($n) $newviewargscmd($n)
2006 addviewmenu $n
2007 if {!$newishighlight} {
2008 run showview $n
2009 } else {
2010 run addvhighlight $n
2011 }
2012 } else {
2013 # editing an existing view
2014 set viewperm($n) $newviewperm($n)
2015 if {$newviewname($n) ne $viewname($n)} {
2016 set viewname($n) $newviewname($n)
2017 doviewmenu .bar.view 5 [list showview $n] \
2018 entryconf [list -label $viewname($n)]
2019 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2020 # entryconf [list -label $viewname($n) -value $viewname($n)]
2021 }
2022 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
2023 $newviewargscmd($n) ne $viewargscmd($n)} {
2024 set viewfiles($n) $files
2025 set viewargs($n) $newargs
2026 set viewargscmd($n) $newviewargscmd($n)
2027 if {$curview == $n} {
2028 run updatecommits
2029 }
2030 }
2031 }
2032 catch {destroy $top}
2033}
2034
2035proc delview {} {
2036 global curview viewdata viewperm hlview selectedhlview
2037
2038 if {$curview == 0} return
2039 if {[info exists hlview] && $hlview == $curview} {
2040 set selectedhlview [mc "None"]
2041 unset hlview
2042 }
2043 allviewmenus $curview delete
2044 set viewdata($curview) {}
2045 set viewperm($curview) 0
2046 showview 0
2047}
2048
2049proc addviewmenu {n} {
2050 global viewname viewhlmenu
2051
2052 .bar.view add radiobutton -label $viewname($n) \
2053 -command [list showview $n] -variable selectedview -value $n
2054 #$viewhlmenu add radiobutton -label $viewname($n) \
2055 # -command [list addvhighlight $n] -variable selectedhlview
2056}
2057
2058proc flatten {var} {
2059 global $var
2060
2061 set ret {}
2062 foreach i [array names $var] {
2063 lappend ret $i [set $var\($i\)]
2064 }
2065 return $ret
2066}
2067
2068proc unflatten {var l} {
2069 global $var
2070
2071 catch {unset $var}
2072 foreach {i v} $l {
2073 set $var\($i\) $v
2074 }
2075}
2076
2077proc showview {n} {
2078 global curview viewdata viewfiles
2079 global displayorder parentlist rowidlist rowisopt rowfinal
2080 global colormap rowtextx commitrow nextcolor canvxmax
2081 global numcommits commitlisted
2082 global selectedline currentid canv canvy0
2083 global treediffs
2084 global pending_select phase
2085 global commitidx
2086 global commfd
2087 global selectedview selectfirst
2088 global vparentlist vdisporder vcmitlisted
2089 global hlview selectedhlview commitinterest
2090
2091 if {$n == $curview} return
2092 set selid {}
2093 if {[info exists selectedline]} {
2094 set selid $currentid
2095 set y [yc $selectedline]
2096 set ymax [lindex [$canv cget -scrollregion] 3]
2097 set span [$canv yview]
2098 set ytop [expr {[lindex $span 0] * $ymax}]
2099 set ybot [expr {[lindex $span 1] * $ymax}]
2100 if {$ytop < $y && $y < $ybot} {
2101 set yscreen [expr {$y - $ytop}]
2102 } else {
2103 set yscreen [expr {($ybot - $ytop) / 2}]
2104 }
2105 } elseif {[info exists pending_select]} {
2106 set selid $pending_select
2107 unset pending_select
2108 }
2109 unselectline
2110 normalline
2111 if {$curview >= 0} {
2112 set vparentlist($curview) $parentlist
2113 set vdisporder($curview) $displayorder
2114 set vcmitlisted($curview) $commitlisted
2115 if {$phase ne {} ||
2116 ![info exists viewdata($curview)] ||
2117 [lindex $viewdata($curview) 0] ne {}} {
2118 set viewdata($curview) \
2119 [list $phase $rowidlist $rowisopt $rowfinal]
2120 }
2121 }
2122 catch {unset treediffs}
2123 clear_display
2124 if {[info exists hlview] && $hlview == $n} {
2125 unset hlview
2126 set selectedhlview [mc "None"]
2127 }
2128 catch {unset commitinterest}
2129
2130 set curview $n
2131 set selectedview $n
2132 .bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
2133 .bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
2134
2135 run refill_reflist
2136 if {![info exists viewdata($n)]} {
2137 if {$selid ne {}} {
2138 set pending_select $selid
2139 }
2140 getcommits
2141 return
2142 }
2143
2144 set v $viewdata($n)
2145 set phase [lindex $v 0]
2146 set displayorder $vdisporder($n)
2147 set parentlist $vparentlist($n)
2148 set commitlisted $vcmitlisted($n)
2149 set rowidlist [lindex $v 1]
2150 set rowisopt [lindex $v 2]
2151 set rowfinal [lindex $v 3]
2152 set numcommits $commitidx($n)
2153
2154 catch {unset colormap}
2155 catch {unset rowtextx}
2156 set nextcolor 0
2157 set canvxmax [$canv cget -width]
2158 set curview $n
2159 set row 0
2160 setcanvscroll
2161 set yf 0
2162 set row {}
2163 set selectfirst 0
2164 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2165 set row $commitrow($n,$selid)
2166 # try to get the selected row in the same position on the screen
2167 set ymax [lindex [$canv cget -scrollregion] 3]
2168 set ytop [expr {[yc $row] - $yscreen}]
2169 if {$ytop < 0} {
2170 set ytop 0
2171 }
2172 set yf [expr {$ytop * 1.0 / $ymax}]
2173 }
2174 allcanvs yview moveto $yf
2175 drawvisible
2176 if {$row ne {}} {
2177 selectline $row 0
2178 } elseif {$selid ne {}} {
2179 set pending_select $selid
2180 } else {
2181 set row [first_real_row]
2182 if {$row < $numcommits} {
2183 selectline $row 0
2184 } else {
2185 set selectfirst 1
2186 }
2187 }
2188 if {$phase ne {}} {
2189 if {$phase eq "getcommits"} {
2190 show_status [mc "Reading commits..."]
2191 }
2192 run chewcommits $n
2193 } elseif {$numcommits == 0} {
2194 show_status [mc "No commits selected"]
2195 }
2196}
2197
2198# Stuff relating to the highlighting facility
2199
2200proc ishighlighted {row} {
2201 global vhighlights fhighlights nhighlights rhighlights
2202
2203 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2204 return $nhighlights($row)
2205 }
2206 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2207 return $vhighlights($row)
2208 }
2209 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2210 return $fhighlights($row)
2211 }
2212 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2213 return $rhighlights($row)
2214 }
2215 return 0
2216}
2217
2218proc bolden {row font} {
2219 global canv linehtag selectedline boldrows
2220
2221 lappend boldrows $row
2222 $canv itemconf $linehtag($row) -font $font
2223 if {[info exists selectedline] && $row == $selectedline} {
2224 $canv delete secsel
2225 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2226 -outline {{}} -tags secsel \
2227 -fill [$canv cget -selectbackground]]
2228 $canv lower $t
2229 }
2230}
2231
2232proc bolden_name {row font} {
2233 global canv2 linentag selectedline boldnamerows
2234
2235 lappend boldnamerows $row
2236 $canv2 itemconf $linentag($row) -font $font
2237 if {[info exists selectedline] && $row == $selectedline} {
2238 $canv2 delete secsel
2239 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2240 -outline {{}} -tags secsel \
2241 -fill [$canv2 cget -selectbackground]]
2242 $canv2 lower $t
2243 }
2244}
2245
2246proc unbolden {} {
2247 global boldrows
2248
2249 set stillbold {}
2250 foreach row $boldrows {
2251 if {![ishighlighted $row]} {
2252 bolden $row mainfont
2253 } else {
2254 lappend stillbold $row
2255 }
2256 }
2257 set boldrows $stillbold
2258}
2259
2260proc addvhighlight {n} {
2261 global hlview curview viewdata vhl_done vhighlights commitidx
2262
2263 if {[info exists hlview]} {
2264 delvhighlight
2265 }
2266 set hlview $n
2267 if {$n != $curview && ![info exists viewdata($n)]} {
2268 set viewdata($n) [list getcommits {{}} 0 0 0]
2269 set vparentlist($n) {}
2270 set vdisporder($n) {}
2271 set vcmitlisted($n) {}
2272 start_rev_list $n
2273 }
2274 set vhl_done $commitidx($hlview)
2275 if {$vhl_done > 0} {
2276 drawvisible
2277 }
2278}
2279
2280proc delvhighlight {} {
2281 global hlview vhighlights
2282
2283 if {![info exists hlview]} return
2284 unset hlview
2285 catch {unset vhighlights}
2286 unbolden
2287}
2288
2289proc vhighlightmore {} {
2290 global hlview vhl_done commitidx vhighlights
2291 global displayorder vdisporder curview
2292
2293 set max $commitidx($hlview)
2294 if {$hlview == $curview} {
2295 set disp $displayorder
2296 } else {
2297 set disp $vdisporder($hlview)
2298 }
2299 set vr [visiblerows]
2300 set r0 [lindex $vr 0]
2301 set r1 [lindex $vr 1]
2302 for {set i $vhl_done} {$i < $max} {incr i} {
2303 set id [lindex $disp $i]
2304 if {[info exists commitrow($curview,$id)]} {
2305 set row $commitrow($curview,$id)
2306 if {$r0 <= $row && $row <= $r1} {
2307 if {![highlighted $row]} {
2308 bolden $row mainfontbold
2309 }
2310 set vhighlights($row) 1
2311 }
2312 }
2313 }
2314 set vhl_done $max
2315}
2316
2317proc askvhighlight {row id} {
2318 global hlview vhighlights commitrow iddrawn
2319
2320 if {[info exists commitrow($hlview,$id)]} {
2321 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2322 bolden $row mainfontbold
2323 }
2324 set vhighlights($row) 1
2325 } else {
2326 set vhighlights($row) 0
2327 }
2328}
2329
2330proc hfiles_change {} {
2331 global highlight_files filehighlight fhighlights fh_serial
2332 global highlight_paths gdttype
2333
2334 if {[info exists filehighlight]} {
2335 # delete previous highlights
2336 catch {close $filehighlight}
2337 unset filehighlight
2338 catch {unset fhighlights}
2339 unbolden
2340 unhighlight_filelist
2341 }
2342 set highlight_paths {}
2343 after cancel do_file_hl $fh_serial
2344 incr fh_serial
2345 if {$highlight_files ne {}} {
2346 after 300 do_file_hl $fh_serial
2347 }
2348}
2349
2350proc gdttype_change {name ix op} {
2351 global gdttype highlight_files findstring findpattern
2352
2353 stopfinding
2354 if {$findstring ne {}} {
2355 if {$gdttype eq [mc "containing:"]} {
2356 if {$highlight_files ne {}} {
2357 set highlight_files {}
2358 hfiles_change
2359 }
2360 findcom_change
2361 } else {
2362 if {$findpattern ne {}} {
2363 set findpattern {}
2364 findcom_change
2365 }
2366 set highlight_files $findstring
2367 hfiles_change
2368 }
2369 drawvisible
2370 }
2371 # enable/disable findtype/findloc menus too
2372}
2373
2374proc find_change {name ix op} {
2375 global gdttype findstring highlight_files
2376
2377 stopfinding
2378 if {$gdttype eq [mc "containing:"]} {
2379 findcom_change
2380 } else {
2381 if {$highlight_files ne $findstring} {
2382 set highlight_files $findstring
2383 hfiles_change
2384 }
2385 }
2386 drawvisible
2387}
2388
2389proc findcom_change args {
2390 global nhighlights boldnamerows
2391 global findpattern findtype findstring gdttype
2392
2393 stopfinding
2394 # delete previous highlights, if any
2395 foreach row $boldnamerows {
2396 bolden_name $row mainfont
2397 }
2398 set boldnamerows {}
2399 catch {unset nhighlights}
2400 unbolden
2401 unmarkmatches
2402 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
2403 set findpattern {}
2404 } elseif {$findtype eq [mc "Regexp"]} {
2405 set findpattern $findstring
2406 } else {
2407 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2408 $findstring]
2409 set findpattern "*$e*"
2410 }
2411}
2412
2413proc makepatterns {l} {
2414 set ret {}
2415 foreach e $l {
2416 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2417 if {[string index $ee end] eq "/"} {
2418 lappend ret "$ee*"
2419 } else {
2420 lappend ret $ee
2421 lappend ret "$ee/*"
2422 }
2423 }
2424 return $ret
2425}
2426
2427proc do_file_hl {serial} {
2428 global highlight_files filehighlight highlight_paths gdttype fhl_list
2429
2430 if {$gdttype eq [mc "touching paths:"]} {
2431 if {[catch {set paths [shellsplit $highlight_files]}]} return
2432 set highlight_paths [makepatterns $paths]
2433 highlight_filelist
2434 set gdtargs [concat -- $paths]
2435 } elseif {$gdttype eq [mc "adding/removing string:"]} {
2436 set gdtargs [list "-S$highlight_files"]
2437 } else {
2438 # must be "containing:", i.e. we're searching commit info
2439 return
2440 }
2441 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2442 set filehighlight [open $cmd r+]
2443 fconfigure $filehighlight -blocking 0
2444 filerun $filehighlight readfhighlight
2445 set fhl_list {}
2446 drawvisible
2447 flushhighlights
2448}
2449
2450proc flushhighlights {} {
2451 global filehighlight fhl_list
2452
2453 if {[info exists filehighlight]} {
2454 lappend fhl_list {}
2455 puts $filehighlight ""
2456 flush $filehighlight
2457 }
2458}
2459
2460proc askfilehighlight {row id} {
2461 global filehighlight fhighlights fhl_list
2462
2463 lappend fhl_list $id
2464 set fhighlights($row) -1
2465 puts $filehighlight $id
2466}
2467
2468proc readfhighlight {} {
2469 global filehighlight fhighlights commitrow curview iddrawn
2470 global fhl_list find_dirn
2471
2472 if {![info exists filehighlight]} {
2473 return 0
2474 }
2475 set nr 0
2476 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2477 set line [string trim $line]
2478 set i [lsearch -exact $fhl_list $line]
2479 if {$i < 0} continue
2480 for {set j 0} {$j < $i} {incr j} {
2481 set id [lindex $fhl_list $j]
2482 if {[info exists commitrow($curview,$id)]} {
2483 set fhighlights($commitrow($curview,$id)) 0
2484 }
2485 }
2486 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2487 if {$line eq {}} continue
2488 if {![info exists commitrow($curview,$line)]} continue
2489 set row $commitrow($curview,$line)
2490 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2491 bolden $row mainfontbold
2492 }
2493 set fhighlights($row) 1
2494 }
2495 if {[eof $filehighlight]} {
2496 # strange...
2497 puts "oops, git diff-tree died"
2498 catch {close $filehighlight}
2499 unset filehighlight
2500 return 0
2501 }
2502 if {[info exists find_dirn]} {
2503 run findmore
2504 }
2505 return 1
2506}
2507
2508proc doesmatch {f} {
2509 global findtype findpattern
2510
2511 if {$findtype eq [mc "Regexp"]} {
2512 return [regexp $findpattern $f]
2513 } elseif {$findtype eq [mc "IgnCase"]} {
2514 return [string match -nocase $findpattern $f]
2515 } else {
2516 return [string match $findpattern $f]
2517 }
2518}
2519
2520proc askfindhighlight {row id} {
2521 global nhighlights commitinfo iddrawn
2522 global findloc
2523 global markingmatches
2524
2525 if {![info exists commitinfo($id)]} {
2526 getcommit $id
2527 }
2528 set info $commitinfo($id)
2529 set isbold 0
2530 set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
2531 foreach f $info ty $fldtypes {
2532 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
2533 [doesmatch $f]} {
2534 if {$ty eq [mc "Author"]} {
2535 set isbold 2
2536 break
2537 }
2538 set isbold 1
2539 }
2540 }
2541 if {$isbold && [info exists iddrawn($id)]} {
2542 if {![ishighlighted $row]} {
2543 bolden $row mainfontbold
2544 if {$isbold > 1} {
2545 bolden_name $row mainfontbold
2546 }
2547 }
2548 if {$markingmatches} {
2549 markrowmatches $row $id
2550 }
2551 }
2552 set nhighlights($row) $isbold
2553}
2554
2555proc markrowmatches {row id} {
2556 global canv canv2 linehtag linentag commitinfo findloc
2557
2558 set headline [lindex $commitinfo($id) 0]
2559 set author [lindex $commitinfo($id) 1]
2560 $canv delete match$row
2561 $canv2 delete match$row
2562 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
2563 set m [findmatches $headline]
2564 if {$m ne {}} {
2565 markmatches $canv $row $headline $linehtag($row) $m \
2566 [$canv itemcget $linehtag($row) -font] $row
2567 }
2568 }
2569 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
2570 set m [findmatches $author]
2571 if {$m ne {}} {
2572 markmatches $canv2 $row $author $linentag($row) $m \
2573 [$canv2 itemcget $linentag($row) -font] $row
2574 }
2575 }
2576}
2577
2578proc vrel_change {name ix op} {
2579 global highlight_related
2580
2581 rhighlight_none
2582 if {$highlight_related ne [mc "None"]} {
2583 run drawvisible
2584 }
2585}
2586
2587# prepare for testing whether commits are descendents or ancestors of a
2588proc rhighlight_sel {a} {
2589 global descendent desc_todo ancestor anc_todo
2590 global highlight_related rhighlights
2591
2592 catch {unset descendent}
2593 set desc_todo [list $a]
2594 catch {unset ancestor}
2595 set anc_todo [list $a]
2596 if {$highlight_related ne [mc "None"]} {
2597 rhighlight_none
2598 run drawvisible
2599 }
2600}
2601
2602proc rhighlight_none {} {
2603 global rhighlights
2604
2605 catch {unset rhighlights}
2606 unbolden
2607}
2608
2609proc is_descendent {a} {
2610 global curview children commitrow descendent desc_todo
2611
2612 set v $curview
2613 set la $commitrow($v,$a)
2614 set todo $desc_todo
2615 set leftover {}
2616 set done 0
2617 for {set i 0} {$i < [llength $todo]} {incr i} {
2618 set do [lindex $todo $i]
2619 if {$commitrow($v,$do) < $la} {
2620 lappend leftover $do
2621 continue
2622 }
2623 foreach nk $children($v,$do) {
2624 if {![info exists descendent($nk)]} {
2625 set descendent($nk) 1
2626 lappend todo $nk
2627 if {$nk eq $a} {
2628 set done 1
2629 }
2630 }
2631 }
2632 if {$done} {
2633 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2634 return
2635 }
2636 }
2637 set descendent($a) 0
2638 set desc_todo $leftover
2639}
2640
2641proc is_ancestor {a} {
2642 global curview parentlist commitrow ancestor anc_todo
2643
2644 set v $curview
2645 set la $commitrow($v,$a)
2646 set todo $anc_todo
2647 set leftover {}
2648 set done 0
2649 for {set i 0} {$i < [llength $todo]} {incr i} {
2650 set do [lindex $todo $i]
2651 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2652 lappend leftover $do
2653 continue
2654 }
2655 foreach np [lindex $parentlist $commitrow($v,$do)] {
2656 if {![info exists ancestor($np)]} {
2657 set ancestor($np) 1
2658 lappend todo $np
2659 if {$np eq $a} {
2660 set done 1
2661 }
2662 }
2663 }
2664 if {$done} {
2665 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2666 return
2667 }
2668 }
2669 set ancestor($a) 0
2670 set anc_todo $leftover
2671}
2672
2673proc askrelhighlight {row id} {
2674 global descendent highlight_related iddrawn rhighlights
2675 global selectedline ancestor
2676
2677 if {![info exists selectedline]} return
2678 set isbold 0
2679 if {$highlight_related eq [mc "Descendant"] ||
2680 $highlight_related eq [mc "Not descendant"]} {
2681 if {![info exists descendent($id)]} {
2682 is_descendent $id
2683 }
2684 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
2685 set isbold 1
2686 }
2687 } elseif {$highlight_related eq [mc "Ancestor"] ||
2688 $highlight_related eq [mc "Not ancestor"]} {
2689 if {![info exists ancestor($id)]} {
2690 is_ancestor $id
2691 }
2692 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
2693 set isbold 1
2694 }
2695 }
2696 if {[info exists iddrawn($id)]} {
2697 if {$isbold && ![ishighlighted $row]} {
2698 bolden $row mainfontbold
2699 }
2700 }
2701 set rhighlights($row) $isbold
2702}
2703
2704# Graph layout functions
2705
2706proc shortids {ids} {
2707 set res {}
2708 foreach id $ids {
2709 if {[llength $id] > 1} {
2710 lappend res [shortids $id]
2711 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2712 lappend res [string range $id 0 7]
2713 } else {
2714 lappend res $id
2715 }
2716 }
2717 return $res
2718}
2719
2720proc ntimes {n o} {
2721 set ret {}
2722 set o [list $o]
2723 for {set mask 1} {$mask <= $n} {incr mask $mask} {
2724 if {($n & $mask) != 0} {
2725 set ret [concat $ret $o]
2726 }
2727 set o [concat $o $o]
2728 }
2729 return $ret
2730}
2731
2732# Work out where id should go in idlist so that order-token
2733# values increase from left to right
2734proc idcol {idlist id {i 0}} {
2735 global ordertok curview
2736
2737 set t $ordertok($curview,$id)
2738 if {$i >= [llength $idlist] ||
2739 $t < $ordertok($curview,[lindex $idlist $i])} {
2740 if {$i > [llength $idlist]} {
2741 set i [llength $idlist]
2742 }
2743 while {[incr i -1] >= 0 &&
2744 $t < $ordertok($curview,[lindex $idlist $i])} {}
2745 incr i
2746 } else {
2747 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2748 while {[incr i] < [llength $idlist] &&
2749 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2750 }
2751 }
2752 return $i
2753}
2754
2755proc initlayout {} {
2756 global rowidlist rowisopt rowfinal displayorder commitlisted
2757 global numcommits canvxmax canv
2758 global nextcolor
2759 global parentlist
2760 global colormap rowtextx
2761 global selectfirst
2762
2763 set numcommits 0
2764 set displayorder {}
2765 set commitlisted {}
2766 set parentlist {}
2767 set nextcolor 0
2768 set rowidlist {}
2769 set rowisopt {}
2770 set rowfinal {}
2771 set canvxmax [$canv cget -width]
2772 catch {unset colormap}
2773 catch {unset rowtextx}
2774 set selectfirst 1
2775}
2776
2777proc setcanvscroll {} {
2778 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2779
2780 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2781 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2782 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2783 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2784}
2785
2786proc visiblerows {} {
2787 global canv numcommits linespc
2788
2789 set ymax [lindex [$canv cget -scrollregion] 3]
2790 if {$ymax eq {} || $ymax == 0} return
2791 set f [$canv yview]
2792 set y0 [expr {int([lindex $f 0] * $ymax)}]
2793 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2794 if {$r0 < 0} {
2795 set r0 0
2796 }
2797 set y1 [expr {int([lindex $f 1] * $ymax)}]
2798 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2799 if {$r1 >= $numcommits} {
2800 set r1 [expr {$numcommits - 1}]
2801 }
2802 return [list $r0 $r1]
2803}
2804
2805proc layoutmore {} {
2806 global commitidx viewcomplete numcommits
2807 global uparrowlen downarrowlen mingaplen curview
2808
2809 set show $commitidx($curview)
2810 if {$show > $numcommits || $viewcomplete($curview)} {
2811 showstuff $show $viewcomplete($curview)
2812 }
2813}
2814
2815proc showstuff {canshow last} {
2816 global numcommits commitrow pending_select selectedline curview
2817 global mainheadid displayorder selectfirst
2818 global lastscrollset commitinterest
2819
2820 if {$numcommits == 0} {
2821 global phase
2822 set phase "incrdraw"
2823 allcanvs delete all
2824 }
2825 set r0 $numcommits
2826 set prev $numcommits
2827 set numcommits $canshow
2828 set t [clock clicks -milliseconds]
2829 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2830 set lastscrollset $t
2831 setcanvscroll
2832 }
2833 set rows [visiblerows]
2834 set r1 [lindex $rows 1]
2835 if {$r1 >= $canshow} {
2836 set r1 [expr {$canshow - 1}]
2837 }
2838 if {$r0 <= $r1} {
2839 drawcommits $r0 $r1
2840 }
2841 if {[info exists pending_select] &&
2842 [info exists commitrow($curview,$pending_select)] &&
2843 $commitrow($curview,$pending_select) < $numcommits} {
2844 selectline $commitrow($curview,$pending_select) 1
2845 }
2846 if {$selectfirst} {
2847 if {[info exists selectedline] || [info exists pending_select]} {
2848 set selectfirst 0
2849 } else {
2850 set l [first_real_row]
2851 selectline $l 1
2852 set selectfirst 0
2853 }
2854 }
2855}
2856
2857proc doshowlocalchanges {} {
2858 global curview mainheadid phase commitrow
2859
2860 if {[info exists commitrow($curview,$mainheadid)] &&
2861 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2862 dodiffindex
2863 } elseif {$phase ne {}} {
2864 lappend commitinterest($mainheadid) {}
2865 }
2866}
2867
2868proc dohidelocalchanges {} {
2869 global localfrow localirow lserial
2870
2871 if {$localfrow >= 0} {
2872 removerow $localfrow
2873 set localfrow -1
2874 if {$localirow > 0} {
2875 incr localirow -1
2876 }
2877 }
2878 if {$localirow >= 0} {
2879 removerow $localirow
2880 set localirow -1
2881 }
2882 incr lserial
2883}
2884
2885# spawn off a process to do git diff-index --cached HEAD
2886proc dodiffindex {} {
2887 global localirow localfrow lserial showlocalchanges
2888
2889 if {!$showlocalchanges} return
2890 incr lserial
2891 set localfrow -1
2892 set localirow -1
2893 set fd [open "|git diff-index --cached HEAD" r]
2894 fconfigure $fd -blocking 0
2895 filerun $fd [list readdiffindex $fd $lserial]
2896}
2897
2898proc readdiffindex {fd serial} {
2899 global localirow commitrow mainheadid nullid2 curview
2900 global commitinfo commitdata lserial
2901
2902 set isdiff 1
2903 if {[gets $fd line] < 0} {
2904 if {![eof $fd]} {
2905 return 1
2906 }
2907 set isdiff 0
2908 }
2909 # we only need to see one line and we don't really care what it says...
2910 close $fd
2911
2912 # now see if there are any local changes not checked in to the index
2913 if {$serial == $lserial} {
2914 set fd [open "|git diff-files" r]
2915 fconfigure $fd -blocking 0
2916 filerun $fd [list readdifffiles $fd $serial]
2917 }
2918
2919 if {$isdiff && $serial == $lserial && $localirow == -1} {
2920 # add the line for the changes in the index to the graph
2921 set localirow $commitrow($curview,$mainheadid)
2922 set hl [mc "Local changes checked in to index but not committed"]
2923 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2924 set commitdata($nullid2) "\n $hl\n"
2925 insertrow $localirow $nullid2
2926 }
2927 return 0
2928}
2929
2930proc readdifffiles {fd serial} {
2931 global localirow localfrow commitrow mainheadid nullid curview
2932 global commitinfo commitdata lserial
2933
2934 set isdiff 1
2935 if {[gets $fd line] < 0} {
2936 if {![eof $fd]} {
2937 return 1
2938 }
2939 set isdiff 0
2940 }
2941 # we only need to see one line and we don't really care what it says...
2942 close $fd
2943
2944 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2945 # add the line for the local diff to the graph
2946 if {$localirow >= 0} {
2947 set localfrow $localirow
2948 incr localirow
2949 } else {
2950 set localfrow $commitrow($curview,$mainheadid)
2951 }
2952 set hl [mc "Local uncommitted changes, not checked in to index"]
2953 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2954 set commitdata($nullid) "\n $hl\n"
2955 insertrow $localfrow $nullid
2956 }
2957 return 0
2958}
2959
2960proc nextuse {id row} {
2961 global commitrow curview children
2962
2963 if {[info exists children($curview,$id)]} {
2964 foreach kid $children($curview,$id) {
2965 if {![info exists commitrow($curview,$kid)]} {
2966 return -1
2967 }
2968 if {$commitrow($curview,$kid) > $row} {
2969 return $commitrow($curview,$kid)
2970 }
2971 }
2972 }
2973 if {[info exists commitrow($curview,$id)]} {
2974 return $commitrow($curview,$id)
2975 }
2976 return -1
2977}
2978
2979proc prevuse {id row} {
2980 global commitrow curview children
2981
2982 set ret -1
2983 if {[info exists children($curview,$id)]} {
2984 foreach kid $children($curview,$id) {
2985 if {![info exists commitrow($curview,$kid)]} break
2986 if {$commitrow($curview,$kid) < $row} {
2987 set ret $commitrow($curview,$kid)
2988 }
2989 }
2990 }
2991 return $ret
2992}
2993
2994proc make_idlist {row} {
2995 global displayorder parentlist uparrowlen downarrowlen mingaplen
2996 global commitidx curview ordertok children commitrow
2997
2998 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
2999 if {$r < 0} {
3000 set r 0
3001 }
3002 set ra [expr {$row - $downarrowlen}]
3003 if {$ra < 0} {
3004 set ra 0
3005 }
3006 set rb [expr {$row + $uparrowlen}]
3007 if {$rb > $commitidx($curview)} {
3008 set rb $commitidx($curview)
3009 }
3010 set ids {}
3011 for {} {$r < $ra} {incr r} {
3012 set nextid [lindex $displayorder [expr {$r + 1}]]
3013 foreach p [lindex $parentlist $r] {
3014 if {$p eq $nextid} continue
3015 set rn [nextuse $p $r]
3016 if {$rn >= $row &&
3017 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3018 lappend ids [list $ordertok($curview,$p) $p]
3019 }
3020 }
3021 }
3022 for {} {$r < $row} {incr r} {
3023 set nextid [lindex $displayorder [expr {$r + 1}]]
3024 foreach p [lindex $parentlist $r] {
3025 if {$p eq $nextid} continue
3026 set rn [nextuse $p $r]
3027 if {$rn < 0 || $rn >= $row} {
3028 lappend ids [list $ordertok($curview,$p) $p]
3029 }
3030 }
3031 }
3032 set id [lindex $displayorder $row]
3033 lappend ids [list $ordertok($curview,$id) $id]
3034 while {$r < $rb} {
3035 foreach p [lindex $parentlist $r] {
3036 set firstkid [lindex $children($curview,$p) 0]
3037 if {$commitrow($curview,$firstkid) < $row} {
3038 lappend ids [list $ordertok($curview,$p) $p]
3039 }
3040 }
3041 incr r
3042 set id [lindex $displayorder $r]
3043 if {$id ne {}} {
3044 set firstkid [lindex $children($curview,$id) 0]
3045 if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
3046 lappend ids [list $ordertok($curview,$id) $id]
3047 }
3048 }
3049 }
3050 set idlist {}
3051 foreach idx [lsort -unique $ids] {
3052 lappend idlist [lindex $idx 1]
3053 }
3054 return $idlist
3055}
3056
3057proc rowsequal {a b} {
3058 while {[set i [lsearch -exact $a {}]] >= 0} {
3059 set a [lreplace $a $i $i]
3060 }
3061 while {[set i [lsearch -exact $b {}]] >= 0} {
3062 set b [lreplace $b $i $i]
3063 }
3064 return [expr {$a eq $b}]
3065}
3066
3067proc makeupline {id row rend col} {
3068 global rowidlist uparrowlen downarrowlen mingaplen
3069
3070 for {set r $rend} {1} {set r $rstart} {
3071 set rstart [prevuse $id $r]
3072 if {$rstart < 0} return
3073 if {$rstart < $row} break
3074 }
3075 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3076 set rstart [expr {$rend - $uparrowlen - 1}]
3077 }
3078 for {set r $rstart} {[incr r] <= $row} {} {
3079 set idlist [lindex $rowidlist $r]
3080 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3081 set col [idcol $idlist $id $col]
3082 lset rowidlist $r [linsert $idlist $col $id]
3083 changedrow $r
3084 }
3085 }
3086}
3087
3088proc layoutrows {row endrow} {
3089 global rowidlist rowisopt rowfinal displayorder
3090 global uparrowlen downarrowlen maxwidth mingaplen
3091 global children parentlist
3092 global commitidx viewcomplete curview commitrow
3093
3094 set idlist {}
3095 if {$row > 0} {
3096 set rm1 [expr {$row - 1}]
3097 foreach id [lindex $rowidlist $rm1] {
3098 if {$id ne {}} {
3099 lappend idlist $id
3100 }
3101 }
3102 set final [lindex $rowfinal $rm1]
3103 }
3104 for {} {$row < $endrow} {incr row} {
3105 set rm1 [expr {$row - 1}]
3106 if {$rm1 < 0 || $idlist eq {}} {
3107 set idlist [make_idlist $row]
3108 set final 1
3109 } else {
3110 set id [lindex $displayorder $rm1]
3111 set col [lsearch -exact $idlist $id]
3112 set idlist [lreplace $idlist $col $col]
3113 foreach p [lindex $parentlist $rm1] {
3114 if {[lsearch -exact $idlist $p] < 0} {
3115 set col [idcol $idlist $p $col]
3116 set idlist [linsert $idlist $col $p]
3117 # if not the first child, we have to insert a line going up
3118 if {$id ne [lindex $children($curview,$p) 0]} {
3119 makeupline $p $rm1 $row $col
3120 }
3121 }
3122 }
3123 set id [lindex $displayorder $row]
3124 if {$row > $downarrowlen} {
3125 set termrow [expr {$row - $downarrowlen - 1}]
3126 foreach p [lindex $parentlist $termrow] {
3127 set i [lsearch -exact $idlist $p]
3128 if {$i < 0} continue
3129 set nr [nextuse $p $termrow]
3130 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3131 set idlist [lreplace $idlist $i $i]
3132 }
3133 }
3134 }
3135 set col [lsearch -exact $idlist $id]
3136 if {$col < 0} {
3137 set col [idcol $idlist $id]
3138 set idlist [linsert $idlist $col $id]
3139 if {$children($curview,$id) ne {}} {
3140 makeupline $id $rm1 $row $col
3141 }
3142 }
3143 set r [expr {$row + $uparrowlen - 1}]
3144 if {$r < $commitidx($curview)} {
3145 set x $col
3146 foreach p [lindex $parentlist $r] {
3147 if {[lsearch -exact $idlist $p] >= 0} continue
3148 set fk [lindex $children($curview,$p) 0]
3149 if {$commitrow($curview,$fk) < $row} {
3150 set x [idcol $idlist $p $x]
3151 set idlist [linsert $idlist $x $p]
3152 }
3153 }
3154 if {[incr r] < $commitidx($curview)} {
3155 set p [lindex $displayorder $r]
3156 if {[lsearch -exact $idlist $p] < 0} {
3157 set fk [lindex $children($curview,$p) 0]
3158 if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3159 set x [idcol $idlist $p $x]
3160 set idlist [linsert $idlist $x $p]
3161 }
3162 }
3163 }
3164 }
3165 }
3166 if {$final && !$viewcomplete($curview) &&
3167 $row + $uparrowlen + $mingaplen + $downarrowlen
3168 >= $commitidx($curview)} {
3169 set final 0
3170 }
3171 set l [llength $rowidlist]
3172 if {$row == $l} {
3173 lappend rowidlist $idlist
3174 lappend rowisopt 0
3175 lappend rowfinal $final
3176 } elseif {$row < $l} {
3177 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3178 lset rowidlist $row $idlist
3179 changedrow $row
3180 }
3181 lset rowfinal $row $final
3182 } else {
3183 set pad [ntimes [expr {$row - $l}] {}]
3184 set rowidlist [concat $rowidlist $pad]
3185 lappend rowidlist $idlist
3186 set rowfinal [concat $rowfinal $pad]
3187 lappend rowfinal $final
3188 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3189 }
3190 }
3191 return $row
3192}
3193
3194proc changedrow {row} {
3195 global displayorder iddrawn rowisopt need_redisplay
3196
3197 set l [llength $rowisopt]
3198 if {$row < $l} {
3199 lset rowisopt $row 0
3200 if {$row + 1 < $l} {
3201 lset rowisopt [expr {$row + 1}] 0
3202 if {$row + 2 < $l} {
3203 lset rowisopt [expr {$row + 2}] 0
3204 }
3205 }
3206 }
3207 set id [lindex $displayorder $row]
3208 if {[info exists iddrawn($id)]} {
3209 set need_redisplay 1
3210 }
3211}
3212
3213proc insert_pad {row col npad} {
3214 global rowidlist
3215
3216 set pad [ntimes $npad {}]
3217 set idlist [lindex $rowidlist $row]
3218 set bef [lrange $idlist 0 [expr {$col - 1}]]
3219 set aft [lrange $idlist $col end]
3220 set i [lsearch -exact $aft {}]
3221 if {$i > 0} {
3222 set aft [lreplace $aft $i $i]
3223 }
3224 lset rowidlist $row [concat $bef $pad $aft]
3225 changedrow $row
3226}
3227
3228proc optimize_rows {row col endrow} {
3229 global rowidlist rowisopt displayorder curview children
3230
3231 if {$row < 1} {
3232 set row 1
3233 }
3234 for {} {$row < $endrow} {incr row; set col 0} {
3235 if {[lindex $rowisopt $row]} continue
3236 set haspad 0
3237 set y0 [expr {$row - 1}]
3238 set ym [expr {$row - 2}]
3239 set idlist [lindex $rowidlist $row]
3240 set previdlist [lindex $rowidlist $y0]
3241 if {$idlist eq {} || $previdlist eq {}} continue
3242 if {$ym >= 0} {
3243 set pprevidlist [lindex $rowidlist $ym]
3244 if {$pprevidlist eq {}} continue
3245 } else {
3246 set pprevidlist {}
3247 }
3248 set x0 -1
3249 set xm -1
3250 for {} {$col < [llength $idlist]} {incr col} {
3251 set id [lindex $idlist $col]
3252 if {[lindex $previdlist $col] eq $id} continue
3253 if {$id eq {}} {
3254 set haspad 1
3255 continue
3256 }
3257 set x0 [lsearch -exact $previdlist $id]
3258 if {$x0 < 0} continue
3259 set z [expr {$x0 - $col}]
3260 set isarrow 0
3261 set z0 {}
3262 if {$ym >= 0} {
3263 set xm [lsearch -exact $pprevidlist $id]
3264 if {$xm >= 0} {
3265 set z0 [expr {$xm - $x0}]
3266 }
3267 }
3268 if {$z0 eq {}} {
3269 # if row y0 is the first child of $id then it's not an arrow
3270 if {[lindex $children($curview,$id) 0] ne
3271 [lindex $displayorder $y0]} {
3272 set isarrow 1
3273 }
3274 }
3275 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3276 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3277 set isarrow 1
3278 }
3279 # Looking at lines from this row to the previous row,
3280 # make them go straight up if they end in an arrow on
3281 # the previous row; otherwise make them go straight up
3282 # or at 45 degrees.
3283 if {$z < -1 || ($z < 0 && $isarrow)} {
3284 # Line currently goes left too much;
3285 # insert pads in the previous row, then optimize it
3286 set npad [expr {-1 - $z + $isarrow}]
3287 insert_pad $y0 $x0 $npad
3288 if {$y0 > 0} {
3289 optimize_rows $y0 $x0 $row
3290 }
3291 set previdlist [lindex $rowidlist $y0]
3292 set x0 [lsearch -exact $previdlist $id]
3293 set z [expr {$x0 - $col}]
3294 if {$z0 ne {}} {
3295 set pprevidlist [lindex $rowidlist $ym]
3296 set xm [lsearch -exact $pprevidlist $id]
3297 set z0 [expr {$xm - $x0}]
3298 }
3299 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3300 # Line currently goes right too much;
3301 # insert pads in this line
3302 set npad [expr {$z - 1 + $isarrow}]
3303 insert_pad $row $col $npad
3304 set idlist [lindex $rowidlist $row]
3305 incr col $npad
3306 set z [expr {$x0 - $col}]
3307 set haspad 1
3308 }
3309 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3310 # this line links to its first child on row $row-2
3311 set id [lindex $displayorder $ym]
3312 set xc [lsearch -exact $pprevidlist $id]
3313 if {$xc >= 0} {
3314 set z0 [expr {$xc - $x0}]
3315 }
3316 }
3317 # avoid lines jigging left then immediately right
3318 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3319 insert_pad $y0 $x0 1
3320 incr x0
3321 optimize_rows $y0 $x0 $row
3322 set previdlist [lindex $rowidlist $y0]
3323 }
3324 }
3325 if {!$haspad} {
3326 # Find the first column that doesn't have a line going right
3327 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3328 set id [lindex $idlist $col]
3329 if {$id eq {}} break
3330 set x0 [lsearch -exact $previdlist $id]
3331 if {$x0 < 0} {
3332 # check if this is the link to the first child
3333 set kid [lindex $displayorder $y0]
3334 if {[lindex $children($curview,$id) 0] eq $kid} {
3335 # it is, work out offset to child
3336 set x0 [lsearch -exact $previdlist $kid]
3337 }
3338 }
3339 if {$x0 <= $col} break
3340 }
3341 # Insert a pad at that column as long as it has a line and
3342 # isn't the last column
3343 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3344 set idlist [linsert $idlist $col {}]
3345 lset rowidlist $row $idlist
3346 changedrow $row
3347 }
3348 }
3349 }
3350}
3351
3352proc xc {row col} {
3353 global canvx0 linespc
3354 return [expr {$canvx0 + $col * $linespc}]
3355}
3356
3357proc yc {row} {
3358 global canvy0 linespc
3359 return [expr {$canvy0 + $row * $linespc}]
3360}
3361
3362proc linewidth {id} {
3363 global thickerline lthickness
3364
3365 set wid $lthickness
3366 if {[info exists thickerline] && $id eq $thickerline} {
3367 set wid [expr {2 * $lthickness}]
3368 }
3369 return $wid
3370}
3371
3372proc rowranges {id} {
3373 global commitrow curview children uparrowlen downarrowlen
3374 global rowidlist
3375
3376 set kids $children($curview,$id)
3377 if {$kids eq {}} {
3378 return {}
3379 }
3380 set ret {}
3381 lappend kids $id
3382 foreach child $kids {
3383 if {![info exists commitrow($curview,$child)]} break
3384 set row $commitrow($curview,$child)
3385 if {![info exists prev]} {
3386 lappend ret [expr {$row + 1}]
3387 } else {
3388 if {$row <= $prevrow} {
3389 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3390 }
3391 # see if the line extends the whole way from prevrow to row
3392 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3393 [lsearch -exact [lindex $rowidlist \
3394 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3395 # it doesn't, see where it ends
3396 set r [expr {$prevrow + $downarrowlen}]
3397 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3398 while {[incr r -1] > $prevrow &&
3399 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3400 } else {
3401 while {[incr r] <= $row &&
3402 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3403 incr r -1
3404 }
3405 lappend ret $r
3406 # see where it starts up again
3407 set r [expr {$row - $uparrowlen}]
3408 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3409 while {[incr r] < $row &&
3410 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3411 } else {
3412 while {[incr r -1] >= $prevrow &&
3413 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3414 incr r
3415 }
3416 lappend ret $r
3417 }
3418 }
3419 if {$child eq $id} {
3420 lappend ret $row
3421 }
3422 set prev $id
3423 set prevrow $row
3424 }
3425 return $ret
3426}
3427
3428proc drawlineseg {id row endrow arrowlow} {
3429 global rowidlist displayorder iddrawn linesegs
3430 global canv colormap linespc curview maxlinelen parentlist
3431
3432 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3433 set le [expr {$row + 1}]
3434 set arrowhigh 1
3435 while {1} {
3436 set c [lsearch -exact [lindex $rowidlist $le] $id]
3437 if {$c < 0} {
3438 incr le -1
3439 break
3440 }
3441 lappend cols $c
3442 set x [lindex $displayorder $le]
3443 if {$x eq $id} {
3444 set arrowhigh 0
3445 break
3446 }
3447 if {[info exists iddrawn($x)] || $le == $endrow} {
3448 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3449 if {$c >= 0} {
3450 lappend cols $c
3451 set arrowhigh 0
3452 }
3453 break
3454 }
3455 incr le
3456 }
3457 if {$le <= $row} {
3458 return $row
3459 }
3460
3461 set lines {}
3462 set i 0
3463 set joinhigh 0
3464 if {[info exists linesegs($id)]} {
3465 set lines $linesegs($id)
3466 foreach li $lines {
3467 set r0 [lindex $li 0]
3468 if {$r0 > $row} {
3469 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3470 set joinhigh 1
3471 }
3472 break
3473 }
3474 incr i
3475 }
3476 }
3477 set joinlow 0
3478 if {$i > 0} {
3479 set li [lindex $lines [expr {$i-1}]]
3480 set r1 [lindex $li 1]
3481 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3482 set joinlow 1
3483 }
3484 }
3485
3486 set x [lindex $cols [expr {$le - $row}]]
3487 set xp [lindex $cols [expr {$le - 1 - $row}]]
3488 set dir [expr {$xp - $x}]
3489 if {$joinhigh} {
3490 set ith [lindex $lines $i 2]
3491 set coords [$canv coords $ith]
3492 set ah [$canv itemcget $ith -arrow]
3493 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3494 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3495 if {$x2 ne {} && $x - $x2 == $dir} {
3496 set coords [lrange $coords 0 end-2]
3497 }
3498 } else {
3499 set coords [list [xc $le $x] [yc $le]]
3500 }
3501 if {$joinlow} {
3502 set itl [lindex $lines [expr {$i-1}] 2]
3503 set al [$canv itemcget $itl -arrow]
3504 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3505 } elseif {$arrowlow} {
3506 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3507 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3508 set arrowlow 0
3509 }
3510 }
3511 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3512 for {set y $le} {[incr y -1] > $row} {} {
3513 set x $xp
3514 set xp [lindex $cols [expr {$y - 1 - $row}]]
3515 set ndir [expr {$xp - $x}]
3516 if {$dir != $ndir || $xp < 0} {
3517 lappend coords [xc $y $x] [yc $y]
3518 }
3519 set dir $ndir
3520 }
3521 if {!$joinlow} {
3522 if {$xp < 0} {
3523 # join parent line to first child
3524 set ch [lindex $displayorder $row]
3525 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3526 if {$xc < 0} {
3527 puts "oops: drawlineseg: child $ch not on row $row"
3528 } elseif {$xc != $x} {
3529 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3530 set d [expr {int(0.5 * $linespc)}]
3531 set x1 [xc $row $x]
3532 if {$xc < $x} {
3533 set x2 [expr {$x1 - $d}]
3534 } else {
3535 set x2 [expr {$x1 + $d}]
3536 }
3537 set y2 [yc $row]
3538 set y1 [expr {$y2 + $d}]
3539 lappend coords $x1 $y1 $x2 $y2
3540 } elseif {$xc < $x - 1} {
3541 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3542 } elseif {$xc > $x + 1} {
3543 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3544 }
3545 set x $xc
3546 }
3547 lappend coords [xc $row $x] [yc $row]
3548 } else {
3549 set xn [xc $row $xp]
3550 set yn [yc $row]
3551 lappend coords $xn $yn
3552 }
3553 if {!$joinhigh} {
3554 assigncolor $id
3555 set t [$canv create line $coords -width [linewidth $id] \
3556 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3557 $canv lower $t
3558 bindline $t $id
3559 set lines [linsert $lines $i [list $row $le $t]]
3560 } else {
3561 $canv coords $ith $coords
3562 if {$arrow ne $ah} {
3563 $canv itemconf $ith -arrow $arrow
3564 }
3565 lset lines $i 0 $row
3566 }
3567 } else {
3568 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3569 set ndir [expr {$xo - $xp}]
3570 set clow [$canv coords $itl]
3571 if {$dir == $ndir} {
3572 set clow [lrange $clow 2 end]
3573 }
3574 set coords [concat $coords $clow]
3575 if {!$joinhigh} {
3576 lset lines [expr {$i-1}] 1 $le
3577 } else {
3578 # coalesce two pieces
3579 $canv delete $ith
3580 set b [lindex $lines [expr {$i-1}] 0]
3581 set e [lindex $lines $i 1]
3582 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3583 }
3584 $canv coords $itl $coords
3585 if {$arrow ne $al} {
3586 $canv itemconf $itl -arrow $arrow
3587 }
3588 }
3589
3590 set linesegs($id) $lines
3591 return $le
3592}
3593
3594proc drawparentlinks {id row} {
3595 global rowidlist canv colormap curview parentlist
3596 global idpos linespc
3597
3598 set rowids [lindex $rowidlist $row]
3599 set col [lsearch -exact $rowids $id]
3600 if {$col < 0} return
3601 set olds [lindex $parentlist $row]
3602 set row2 [expr {$row + 1}]
3603 set x [xc $row $col]
3604 set y [yc $row]
3605 set y2 [yc $row2]
3606 set d [expr {int(0.5 * $linespc)}]
3607 set ymid [expr {$y + $d}]
3608 set ids [lindex $rowidlist $row2]
3609 # rmx = right-most X coord used
3610 set rmx 0
3611 foreach p $olds {
3612 set i [lsearch -exact $ids $p]
3613 if {$i < 0} {
3614 puts "oops, parent $p of $id not in list"
3615 continue
3616 }
3617 set x2 [xc $row2 $i]
3618 if {$x2 > $rmx} {
3619 set rmx $x2
3620 }
3621 set j [lsearch -exact $rowids $p]
3622 if {$j < 0} {
3623 # drawlineseg will do this one for us
3624 continue
3625 }
3626 assigncolor $p
3627 # should handle duplicated parents here...
3628 set coords [list $x $y]
3629 if {$i != $col} {
3630 # if attaching to a vertical segment, draw a smaller
3631 # slant for visual distinctness
3632 if {$i == $j} {
3633 if {$i < $col} {
3634 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3635 } else {
3636 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3637 }
3638 } elseif {$i < $col && $i < $j} {
3639 # segment slants towards us already
3640 lappend coords [xc $row $j] $y
3641 } else {
3642 if {$i < $col - 1} {
3643 lappend coords [expr {$x2 + $linespc}] $y
3644 } elseif {$i > $col + 1} {
3645 lappend coords [expr {$x2 - $linespc}] $y
3646 }
3647 lappend coords $x2 $y2
3648 }
3649 } else {
3650 lappend coords $x2 $y2
3651 }
3652 set t [$canv create line $coords -width [linewidth $p] \
3653 -fill $colormap($p) -tags lines.$p]
3654 $canv lower $t
3655 bindline $t $p
3656 }
3657 if {$rmx > [lindex $idpos($id) 1]} {
3658 lset idpos($id) 1 $rmx
3659 redrawtags $id
3660 }
3661}
3662
3663proc drawlines {id} {
3664 global canv
3665
3666 $canv itemconf lines.$id -width [linewidth $id]
3667}
3668
3669proc drawcmittext {id row col} {
3670 global linespc canv canv2 canv3 canvy0 fgcolor curview
3671 global commitlisted commitinfo rowidlist parentlist
3672 global rowtextx idpos idtags idheads idotherrefs
3673 global linehtag linentag linedtag selectedline
3674 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3675
3676 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
3677 set listed [lindex $commitlisted $row]
3678 if {$id eq $nullid} {
3679 set ofill red
3680 } elseif {$id eq $nullid2} {
3681 set ofill green
3682 } else {
3683 set ofill [expr {$listed != 0 ? $listed == 2 ? "gray" : "blue" : "white"}]
3684 }
3685 set x [xc $row $col]
3686 set y [yc $row]
3687 set orad [expr {$linespc / 3}]
3688 if {$listed <= 2} {
3689 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3690 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3691 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3692 } elseif {$listed == 3} {
3693 # triangle pointing left for left-side commits
3694 set t [$canv create polygon \
3695 [expr {$x - $orad}] $y \
3696 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3697 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3698 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3699 } else {
3700 # triangle pointing right for right-side commits
3701 set t [$canv create polygon \
3702 [expr {$x + $orad - 1}] $y \
3703 [expr {$x - $orad}] [expr {$y - $orad}] \
3704 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3705 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3706 }
3707 $canv raise $t
3708 $canv bind $t <1> {selcanvline {} %x %y}
3709 set rmx [llength [lindex $rowidlist $row]]
3710 set olds [lindex $parentlist $row]
3711 if {$olds ne {}} {
3712 set nextids [lindex $rowidlist [expr {$row + 1}]]
3713 foreach p $olds {
3714 set i [lsearch -exact $nextids $p]
3715 if {$i > $rmx} {
3716 set rmx $i
3717 }
3718 }
3719 }
3720 set xt [xc $row $rmx]
3721 set rowtextx($row) $xt
3722 set idpos($id) [list $x $xt $y]
3723 if {[info exists idtags($id)] || [info exists idheads($id)]
3724 || [info exists idotherrefs($id)]} {
3725 set xt [drawtags $id $x $xt $y]
3726 }
3727 set headline [lindex $commitinfo($id) 0]
3728 set name [lindex $commitinfo($id) 1]
3729 set date [lindex $commitinfo($id) 2]
3730 set date [formatdate $date]
3731 set font mainfont
3732 set nfont mainfont
3733 set isbold [ishighlighted $row]
3734 if {$isbold > 0} {
3735 lappend boldrows $row
3736 set font mainfontbold
3737 if {$isbold > 1} {
3738 lappend boldnamerows $row
3739 set nfont mainfontbold
3740 }
3741 }
3742 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3743 -text $headline -font $font -tags text]
3744 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3745 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3746 -text $name -font $nfont -tags text]
3747 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3748 -text $date -font mainfont -tags text]
3749 if {[info exists selectedline] && $selectedline == $row} {
3750 make_secsel $row
3751 }
3752 set xr [expr {$xt + [font measure $font $headline]}]
3753 if {$xr > $canvxmax} {
3754 set canvxmax $xr
3755 setcanvscroll
3756 }
3757}
3758
3759proc drawcmitrow {row} {
3760 global displayorder rowidlist nrows_drawn
3761 global iddrawn markingmatches
3762 global commitinfo parentlist numcommits
3763 global filehighlight fhighlights findpattern nhighlights
3764 global hlview vhighlights
3765 global highlight_related rhighlights
3766
3767 if {$row >= $numcommits} return
3768
3769 set id [lindex $displayorder $row]
3770 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3771 askvhighlight $row $id
3772 }
3773 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3774 askfilehighlight $row $id
3775 }
3776 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
3777 askfindhighlight $row $id
3778 }
3779 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($row)]} {
3780 askrelhighlight $row $id
3781 }
3782 if {![info exists iddrawn($id)]} {
3783 set col [lsearch -exact [lindex $rowidlist $row] $id]
3784 if {$col < 0} {
3785 puts "oops, row $row id $id not in list"
3786 return
3787 }
3788 if {![info exists commitinfo($id)]} {
3789 getcommit $id
3790 }
3791 assigncolor $id
3792 drawcmittext $id $row $col
3793 set iddrawn($id) 1
3794 incr nrows_drawn
3795 }
3796 if {$markingmatches} {
3797 markrowmatches $row $id
3798 }
3799}
3800
3801proc drawcommits {row {endrow {}}} {
3802 global numcommits iddrawn displayorder curview need_redisplay
3803 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3804
3805 if {$row < 0} {
3806 set row 0
3807 }
3808 if {$endrow eq {}} {
3809 set endrow $row
3810 }
3811 if {$endrow >= $numcommits} {
3812 set endrow [expr {$numcommits - 1}]
3813 }
3814
3815 set rl1 [expr {$row - $downarrowlen - 3}]
3816 if {$rl1 < 0} {
3817 set rl1 0
3818 }
3819 set ro1 [expr {$row - 3}]
3820 if {$ro1 < 0} {
3821 set ro1 0
3822 }
3823 set r2 [expr {$endrow + $uparrowlen + 3}]
3824 if {$r2 > $numcommits} {
3825 set r2 $numcommits
3826 }
3827 for {set r $rl1} {$r < $r2} {incr r} {
3828 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3829 if {$rl1 < $r} {
3830 layoutrows $rl1 $r
3831 }
3832 set rl1 [expr {$r + 1}]
3833 }
3834 }
3835 if {$rl1 < $r} {
3836 layoutrows $rl1 $r
3837 }
3838 optimize_rows $ro1 0 $r2
3839 if {$need_redisplay || $nrows_drawn > 2000} {
3840 clear_display
3841 drawvisible
3842 }
3843
3844 # make the lines join to already-drawn rows either side
3845 set r [expr {$row - 1}]
3846 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3847 set r $row
3848 }
3849 set er [expr {$endrow + 1}]
3850 if {$er >= $numcommits ||
3851 ![info exists iddrawn([lindex $displayorder $er])]} {
3852 set er $endrow
3853 }
3854 for {} {$r <= $er} {incr r} {
3855 set id [lindex $displayorder $r]
3856 set wasdrawn [info exists iddrawn($id)]
3857 drawcmitrow $r
3858 if {$r == $er} break
3859 set nextid [lindex $displayorder [expr {$r + 1}]]
3860 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
3861 drawparentlinks $id $r
3862
3863 set rowids [lindex $rowidlist $r]
3864 foreach lid $rowids {
3865 if {$lid eq {}} continue
3866 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
3867 if {$lid eq $id} {
3868 # see if this is the first child of any of its parents
3869 foreach p [lindex $parentlist $r] {
3870 if {[lsearch -exact $rowids $p] < 0} {
3871 # make this line extend up to the child
3872 set lineend($p) [drawlineseg $p $r $er 0]
3873 }
3874 }
3875 } else {
3876 set lineend($lid) [drawlineseg $lid $r $er 1]
3877 }
3878 }
3879 }
3880}
3881
3882proc drawfrac {f0 f1} {
3883 global canv linespc
3884
3885 set ymax [lindex [$canv cget -scrollregion] 3]
3886 if {$ymax eq {} || $ymax == 0} return
3887 set y0 [expr {int($f0 * $ymax)}]
3888 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3889 set y1 [expr {int($f1 * $ymax)}]
3890 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3891 drawcommits $row $endrow
3892}
3893
3894proc drawvisible {} {
3895 global canv
3896 eval drawfrac [$canv yview]
3897}
3898
3899proc clear_display {} {
3900 global iddrawn linesegs need_redisplay nrows_drawn
3901 global vhighlights fhighlights nhighlights rhighlights
3902
3903 allcanvs delete all
3904 catch {unset iddrawn}
3905 catch {unset linesegs}
3906 catch {unset vhighlights}
3907 catch {unset fhighlights}
3908 catch {unset nhighlights}
3909 catch {unset rhighlights}
3910 set need_redisplay 0
3911 set nrows_drawn 0
3912}
3913
3914proc findcrossings {id} {
3915 global rowidlist parentlist numcommits displayorder
3916
3917 set cross {}
3918 set ccross {}
3919 foreach {s e} [rowranges $id] {
3920 if {$e >= $numcommits} {
3921 set e [expr {$numcommits - 1}]
3922 }
3923 if {$e <= $s} continue
3924 for {set row $e} {[incr row -1] >= $s} {} {
3925 set x [lsearch -exact [lindex $rowidlist $row] $id]
3926 if {$x < 0} break
3927 set olds [lindex $parentlist $row]
3928 set kid [lindex $displayorder $row]
3929 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3930 if {$kidx < 0} continue
3931 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3932 foreach p $olds {
3933 set px [lsearch -exact $nextrow $p]
3934 if {$px < 0} continue
3935 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3936 if {[lsearch -exact $ccross $p] >= 0} continue
3937 if {$x == $px + ($kidx < $px? -1: 1)} {
3938 lappend ccross $p
3939 } elseif {[lsearch -exact $cross $p] < 0} {
3940 lappend cross $p
3941 }
3942 }
3943 }
3944 }
3945 }
3946 return [concat $ccross {{}} $cross]
3947}
3948
3949proc assigncolor {id} {
3950 global colormap colors nextcolor
3951 global commitrow parentlist children children curview
3952
3953 if {[info exists colormap($id)]} return
3954 set ncolors [llength $colors]
3955 if {[info exists children($curview,$id)]} {
3956 set kids $children($curview,$id)
3957 } else {
3958 set kids {}
3959 }
3960 if {[llength $kids] == 1} {
3961 set child [lindex $kids 0]
3962 if {[info exists colormap($child)]
3963 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3964 set colormap($id) $colormap($child)
3965 return
3966 }
3967 }
3968 set badcolors {}
3969 set origbad {}
3970 foreach x [findcrossings $id] {
3971 if {$x eq {}} {
3972 # delimiter between corner crossings and other crossings
3973 if {[llength $badcolors] >= $ncolors - 1} break
3974 set origbad $badcolors
3975 }
3976 if {[info exists colormap($x)]
3977 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3978 lappend badcolors $colormap($x)
3979 }
3980 }
3981 if {[llength $badcolors] >= $ncolors} {
3982 set badcolors $origbad
3983 }
3984 set origbad $badcolors
3985 if {[llength $badcolors] < $ncolors - 1} {
3986 foreach child $kids {
3987 if {[info exists colormap($child)]
3988 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3989 lappend badcolors $colormap($child)
3990 }
3991 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3992 if {[info exists colormap($p)]
3993 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3994 lappend badcolors $colormap($p)
3995 }
3996 }
3997 }
3998 if {[llength $badcolors] >= $ncolors} {
3999 set badcolors $origbad
4000 }
4001 }
4002 for {set i 0} {$i <= $ncolors} {incr i} {
4003 set c [lindex $colors $nextcolor]
4004 if {[incr nextcolor] >= $ncolors} {
4005 set nextcolor 0
4006 }
4007 if {[lsearch -exact $badcolors $c]} break
4008 }
4009 set colormap($id) $c
4010}
4011
4012proc bindline {t id} {
4013 global canv
4014
4015 $canv bind $t <Enter> "lineenter %x %y $id"
4016 $canv bind $t <Motion> "linemotion %x %y $id"
4017 $canv bind $t <Leave> "lineleave $id"
4018 $canv bind $t <Button-1> "lineclick %x %y $id 1"
4019}
4020
4021proc drawtags {id x xt y1} {
4022 global idtags idheads idotherrefs mainhead
4023 global linespc lthickness
4024 global canv commitrow rowtextx curview fgcolor bgcolor
4025
4026 set marks {}
4027 set ntags 0
4028 set nheads 0
4029 if {[info exists idtags($id)]} {
4030 set marks $idtags($id)
4031 set ntags [llength $marks]
4032 }
4033 if {[info exists idheads($id)]} {
4034 set marks [concat $marks $idheads($id)]
4035 set nheads [llength $idheads($id)]
4036 }
4037 if {[info exists idotherrefs($id)]} {
4038 set marks [concat $marks $idotherrefs($id)]
4039 }
4040 if {$marks eq {}} {
4041 return $xt
4042 }
4043
4044 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4045 set yt [expr {$y1 - 0.5 * $linespc}]
4046 set yb [expr {$yt + $linespc - 1}]
4047 set xvals {}
4048 set wvals {}
4049 set i -1
4050 foreach tag $marks {
4051 incr i
4052 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4053 set wid [font measure mainfontbold $tag]
4054 } else {
4055 set wid [font measure mainfont $tag]
4056 }
4057 lappend xvals $xt
4058 lappend wvals $wid
4059 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4060 }
4061 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4062 -width $lthickness -fill black -tags tag.$id]
4063 $canv lower $t
4064 foreach tag $marks x $xvals wid $wvals {
4065 set xl [expr {$x + $delta}]
4066 set xr [expr {$x + $delta + $wid + $lthickness}]
4067 set font mainfont
4068 if {[incr ntags -1] >= 0} {
4069 # draw a tag
4070 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4071 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4072 -width 1 -outline black -fill yellow -tags tag.$id]
4073 $canv bind $t <1> [list showtag $tag 1]
4074 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4075 } else {
4076 # draw a head or other ref
4077 if {[incr nheads -1] >= 0} {
4078 set col green
4079 if {$tag eq $mainhead} {
4080 set font mainfontbold
4081 }
4082 } else {
4083 set col "#ddddff"
4084 }
4085 set xl [expr {$xl - $delta/2}]
4086 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4087 -width 1 -outline black -fill $col -tags tag.$id
4088 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4089 set rwid [font measure mainfont $remoteprefix]
4090 set xi [expr {$x + 1}]
4091 set yti [expr {$yt + 1}]
4092 set xri [expr {$x + $rwid}]
4093 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4094 -width 0 -fill "#ffddaa" -tags tag.$id
4095 }
4096 }
4097 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4098 -font $font -tags [list tag.$id text]]
4099 if {$ntags >= 0} {
4100 $canv bind $t <1> [list showtag $tag 1]
4101 } elseif {$nheads >= 0} {
4102 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4103 }
4104 }
4105 return $xt
4106}
4107
4108proc xcoord {i level ln} {
4109 global canvx0 xspc1 xspc2
4110
4111 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4112 if {$i > 0 && $i == $level} {
4113 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4114 } elseif {$i > $level} {
4115 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4116 }
4117 return $x
4118}
4119
4120proc show_status {msg} {
4121 global canv fgcolor
4122
4123 clear_display
4124 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4125 -tags text -fill $fgcolor
4126}
4127
4128# Insert a new commit as the child of the commit on row $row.
4129# The new commit will be displayed on row $row and the commits
4130# on that row and below will move down one row.
4131proc insertrow {row newcmit} {
4132 global displayorder parentlist commitlisted children
4133 global commitrow curview rowidlist rowisopt rowfinal numcommits
4134 global numcommits
4135 global selectedline commitidx ordertok
4136
4137 if {$row >= $numcommits} {
4138 puts "oops, inserting new row $row but only have $numcommits rows"
4139 return
4140 }
4141 set p [lindex $displayorder $row]
4142 set displayorder [linsert $displayorder $row $newcmit]
4143 set parentlist [linsert $parentlist $row $p]
4144 set kids $children($curview,$p)
4145 lappend kids $newcmit
4146 set children($curview,$p) $kids
4147 set children($curview,$newcmit) {}
4148 set commitlisted [linsert $commitlisted $row 1]
4149 set l [llength $displayorder]
4150 for {set r $row} {$r < $l} {incr r} {
4151 set id [lindex $displayorder $r]
4152 set commitrow($curview,$id) $r
4153 }
4154 incr commitidx($curview)
4155 set ordertok($curview,$newcmit) $ordertok($curview,$p)
4156
4157 if {$row < [llength $rowidlist]} {
4158 set idlist [lindex $rowidlist $row]
4159 if {$idlist ne {}} {
4160 if {[llength $kids] == 1} {
4161 set col [lsearch -exact $idlist $p]
4162 lset idlist $col $newcmit
4163 } else {
4164 set col [llength $idlist]
4165 lappend idlist $newcmit
4166 }
4167 }
4168 set rowidlist [linsert $rowidlist $row $idlist]
4169 set rowisopt [linsert $rowisopt $row 0]
4170 set rowfinal [linsert $rowfinal $row [lindex $rowfinal $row]]
4171 }
4172
4173 incr numcommits
4174
4175 if {[info exists selectedline] && $selectedline >= $row} {
4176 incr selectedline
4177 }
4178 redisplay
4179}
4180
4181# Remove a commit that was inserted with insertrow on row $row.
4182proc removerow {row} {
4183 global displayorder parentlist commitlisted children
4184 global commitrow curview rowidlist rowisopt rowfinal numcommits
4185 global numcommits
4186 global linesegends selectedline commitidx
4187
4188 if {$row >= $numcommits} {
4189 puts "oops, removing row $row but only have $numcommits rows"
4190 return
4191 }
4192 set rp1 [expr {$row + 1}]
4193 set id [lindex $displayorder $row]
4194 set p [lindex $parentlist $row]
4195 set displayorder [lreplace $displayorder $row $row]
4196 set parentlist [lreplace $parentlist $row $row]
4197 set commitlisted [lreplace $commitlisted $row $row]
4198 set kids $children($curview,$p)
4199 set i [lsearch -exact $kids $id]
4200 if {$i >= 0} {
4201 set kids [lreplace $kids $i $i]
4202 set children($curview,$p) $kids
4203 }
4204 set l [llength $displayorder]
4205 for {set r $row} {$r < $l} {incr r} {
4206 set id [lindex $displayorder $r]
4207 set commitrow($curview,$id) $r
4208 }
4209 incr commitidx($curview) -1
4210
4211 if {$row < [llength $rowidlist]} {
4212 set rowidlist [lreplace $rowidlist $row $row]
4213 set rowisopt [lreplace $rowisopt $row $row]
4214 set rowfinal [lreplace $rowfinal $row $row]
4215 }
4216
4217 incr numcommits -1
4218
4219 if {[info exists selectedline] && $selectedline > $row} {
4220 incr selectedline -1
4221 }
4222 redisplay
4223}
4224
4225# Don't change the text pane cursor if it is currently the hand cursor,
4226# showing that we are over a sha1 ID link.
4227proc settextcursor {c} {
4228 global ctext curtextcursor
4229
4230 if {[$ctext cget -cursor] == $curtextcursor} {
4231 $ctext config -cursor $c
4232 }
4233 set curtextcursor $c
4234}
4235
4236proc nowbusy {what {name {}}} {
4237 global isbusy busyname statusw
4238
4239 if {[array names isbusy] eq {}} {
4240 . config -cursor watch
4241 settextcursor watch
4242 }
4243 set isbusy($what) 1
4244 set busyname($what) $name
4245 if {$name ne {}} {
4246 $statusw conf -text $name
4247 }
4248}
4249
4250proc notbusy {what} {
4251 global isbusy maincursor textcursor busyname statusw
4252
4253 catch {
4254 unset isbusy($what)
4255 if {$busyname($what) ne {} &&
4256 [$statusw cget -text] eq $busyname($what)} {
4257 $statusw conf -text {}
4258 }
4259 }
4260 if {[array names isbusy] eq {}} {
4261 . config -cursor $maincursor
4262 settextcursor $textcursor
4263 }
4264}
4265
4266proc findmatches {f} {
4267 global findtype findstring
4268 if {$findtype == [mc "Regexp"]} {
4269 set matches [regexp -indices -all -inline $findstring $f]
4270 } else {
4271 set fs $findstring
4272 if {$findtype == [mc "IgnCase"]} {
4273 set f [string tolower $f]
4274 set fs [string tolower $fs]
4275 }
4276 set matches {}
4277 set i 0
4278 set l [string length $fs]
4279 while {[set j [string first $fs $f $i]] >= 0} {
4280 lappend matches [list $j [expr {$j+$l-1}]]
4281 set i [expr {$j + $l}]
4282 }
4283 }
4284 return $matches
4285}
4286
4287proc dofind {{dirn 1} {wrap 1}} {
4288 global findstring findstartline findcurline selectedline numcommits
4289 global gdttype filehighlight fh_serial find_dirn findallowwrap
4290
4291 if {[info exists find_dirn]} {
4292 if {$find_dirn == $dirn} return
4293 stopfinding
4294 }
4295 focus .
4296 if {$findstring eq {} || $numcommits == 0} return
4297 if {![info exists selectedline]} {
4298 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4299 } else {
4300 set findstartline $selectedline
4301 }
4302 set findcurline $findstartline
4303 nowbusy finding [mc "Searching"]
4304 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
4305 after cancel do_file_hl $fh_serial
4306 do_file_hl $fh_serial
4307 }
4308 set find_dirn $dirn
4309 set findallowwrap $wrap
4310 run findmore
4311}
4312
4313proc stopfinding {} {
4314 global find_dirn findcurline fprogcoord
4315
4316 if {[info exists find_dirn]} {
4317 unset find_dirn
4318 unset findcurline
4319 notbusy finding
4320 set fprogcoord 0
4321 adjustprogress
4322 }
4323}
4324
4325proc findmore {} {
4326 global commitdata commitinfo numcommits findpattern findloc
4327 global findstartline findcurline displayorder
4328 global find_dirn gdttype fhighlights fprogcoord
4329 global findallowwrap
4330
4331 if {![info exists find_dirn]} {
4332 return 0
4333 }
4334 set fldtypes [list [mc "Headline"] [mc "Author"] [mc "Date"] [mc "Committer"] [mc "CDate"] [mc "Comments"]]
4335 set l $findcurline
4336 set moretodo 0
4337 if {$find_dirn > 0} {
4338 incr l
4339 if {$l >= $numcommits} {
4340 set l 0
4341 }
4342 if {$l <= $findstartline} {
4343 set lim [expr {$findstartline + 1}]
4344 } else {
4345 set lim $numcommits
4346 set moretodo $findallowwrap
4347 }
4348 } else {
4349 if {$l == 0} {
4350 set l $numcommits
4351 }
4352 incr l -1
4353 if {$l >= $findstartline} {
4354 set lim [expr {$findstartline - 1}]
4355 } else {
4356 set lim -1
4357 set moretodo $findallowwrap
4358 }
4359 }
4360 set n [expr {($lim - $l) * $find_dirn}]
4361 if {$n > 500} {
4362 set n 500
4363 set moretodo 1
4364 }
4365 set found 0
4366 set domore 1
4367 if {$gdttype eq [mc "containing:"]} {
4368 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4369 set id [lindex $displayorder $l]
4370 # shouldn't happen unless git log doesn't give all the commits...
4371 if {![info exists commitdata($id)]} continue
4372 if {![doesmatch $commitdata($id)]} continue
4373 if {![info exists commitinfo($id)]} {
4374 getcommit $id
4375 }
4376 set info $commitinfo($id)
4377 foreach f $info ty $fldtypes {
4378 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
4379 [doesmatch $f]} {
4380 set found 1
4381 break
4382 }
4383 }
4384 if {$found} break
4385 }
4386 } else {
4387 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4388 set id [lindex $displayorder $l]
4389 if {![info exists fhighlights($l)]} {
4390 askfilehighlight $l $id
4391 if {$domore} {
4392 set domore 0
4393 set findcurline [expr {$l - $find_dirn}]
4394 }
4395 } elseif {$fhighlights($l)} {
4396 set found $domore
4397 break
4398 }
4399 }
4400 }
4401 if {$found || ($domore && !$moretodo)} {
4402 unset findcurline
4403 unset find_dirn
4404 notbusy finding
4405 set fprogcoord 0
4406 adjustprogress
4407 if {$found} {
4408 findselectline $l
4409 } else {
4410 bell
4411 }
4412 return 0
4413 }
4414 if {!$domore} {
4415 flushhighlights
4416 } else {
4417 set findcurline [expr {$l - $find_dirn}]
4418 }
4419 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
4420 if {$n < 0} {
4421 incr n $numcommits
4422 }
4423 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4424 adjustprogress
4425 return $domore
4426}
4427
4428proc findselectline {l} {
4429 global findloc commentend ctext findcurline markingmatches gdttype
4430
4431 set markingmatches 1
4432 set findcurline $l
4433 selectline $l 1
4434 if {$findloc == [mc "All fields"] || $findloc == [mc "Comments"]} {
4435 # highlight the matches in the comments
4436 set f [$ctext get 1.0 $commentend]
4437 set matches [findmatches $f]
4438 foreach match $matches {
4439 set start [lindex $match 0]
4440 set end [expr {[lindex $match 1] + 1}]
4441 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4442 }
4443 }
4444 drawvisible
4445}
4446
4447# mark the bits of a headline or author that match a find string
4448proc markmatches {canv l str tag matches font row} {
4449 global selectedline
4450
4451 set bbox [$canv bbox $tag]
4452 set x0 [lindex $bbox 0]
4453 set y0 [lindex $bbox 1]
4454 set y1 [lindex $bbox 3]
4455 foreach match $matches {
4456 set start [lindex $match 0]
4457 set end [lindex $match 1]
4458 if {$start > $end} continue
4459 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4460 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4461 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4462 [expr {$x0+$xlen+2}] $y1 \
4463 -outline {} -tags [list match$l matches] -fill yellow]
4464 $canv lower $t
4465 if {[info exists selectedline] && $row == $selectedline} {
4466 $canv raise $t secsel
4467 }
4468 }
4469}
4470
4471proc unmarkmatches {} {
4472 global markingmatches
4473
4474 allcanvs delete matches
4475 set markingmatches 0
4476 stopfinding
4477}
4478
4479proc selcanvline {w x y} {
4480 global canv canvy0 ctext linespc
4481 global rowtextx
4482 set ymax [lindex [$canv cget -scrollregion] 3]
4483 if {$ymax == {}} return
4484 set yfrac [lindex [$canv yview] 0]
4485 set y [expr {$y + $yfrac * $ymax}]
4486 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4487 if {$l < 0} {
4488 set l 0
4489 }
4490 if {$w eq $canv} {
4491 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4492 }
4493 unmarkmatches
4494 selectline $l 1
4495}
4496
4497proc commit_descriptor {p} {
4498 global commitinfo
4499 if {![info exists commitinfo($p)]} {
4500 getcommit $p
4501 }
4502 set l "..."
4503 if {[llength $commitinfo($p)] > 1} {
4504 set l [lindex $commitinfo($p) 0]
4505 }
4506 return "$p ($l)\n"
4507}
4508
4509# append some text to the ctext widget, and make any SHA1 ID
4510# that we know about be a clickable link.
4511proc appendwithlinks {text tags} {
4512 global ctext commitrow linknum curview pendinglinks
4513
4514 set start [$ctext index "end - 1c"]
4515 $ctext insert end $text $tags
4516 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4517 foreach l $links {
4518 set s [lindex $l 0]
4519 set e [lindex $l 1]
4520 set linkid [string range $text $s $e]
4521 incr e
4522 $ctext tag delete link$linknum
4523 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4524 setlink $linkid link$linknum
4525 incr linknum
4526 }
4527}
4528
4529proc setlink {id lk} {
4530 global curview commitrow ctext pendinglinks commitinterest
4531
4532 if {[info exists commitrow($curview,$id)]} {
4533 $ctext tag conf $lk -foreground blue -underline 1
4534 $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4535 $ctext tag bind $lk <Enter> {linkcursor %W 1}
4536 $ctext tag bind $lk <Leave> {linkcursor %W -1}
4537 } else {
4538 lappend pendinglinks($id) $lk
4539 lappend commitinterest($id) {makelink %I}
4540 }
4541}
4542
4543proc makelink {id} {
4544 global pendinglinks
4545
4546 if {![info exists pendinglinks($id)]} return
4547 foreach lk $pendinglinks($id) {
4548 setlink $id $lk
4549 }
4550 unset pendinglinks($id)
4551}
4552
4553proc linkcursor {w inc} {
4554 global linkentercount curtextcursor
4555
4556 if {[incr linkentercount $inc] > 0} {
4557 $w configure -cursor hand2
4558 } else {
4559 $w configure -cursor $curtextcursor
4560 if {$linkentercount < 0} {
4561 set linkentercount 0
4562 }
4563 }
4564}
4565
4566proc viewnextline {dir} {
4567 global canv linespc
4568
4569 $canv delete hover
4570 set ymax [lindex [$canv cget -scrollregion] 3]
4571 set wnow [$canv yview]
4572 set wtop [expr {[lindex $wnow 0] * $ymax}]
4573 set newtop [expr {$wtop + $dir * $linespc}]
4574 if {$newtop < 0} {
4575 set newtop 0
4576 } elseif {$newtop > $ymax} {
4577 set newtop $ymax
4578 }
4579 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4580}
4581
4582# add a list of tag or branch names at position pos
4583# returns the number of names inserted
4584proc appendrefs {pos ids var} {
4585 global ctext commitrow linknum curview $var maxrefs
4586
4587 if {[catch {$ctext index $pos}]} {
4588 return 0
4589 }
4590 $ctext conf -state normal
4591 $ctext delete $pos "$pos lineend"
4592 set tags {}
4593 foreach id $ids {
4594 foreach tag [set $var\($id\)] {
4595 lappend tags [list $tag $id]
4596 }
4597 }
4598 if {[llength $tags] > $maxrefs} {
4599 $ctext insert $pos "many ([llength $tags])"
4600 } else {
4601 set tags [lsort -index 0 -decreasing $tags]
4602 set sep {}
4603 foreach ti $tags {
4604 set id [lindex $ti 1]
4605 set lk link$linknum
4606 incr linknum
4607 $ctext tag delete $lk
4608 $ctext insert $pos $sep
4609 $ctext insert $pos [lindex $ti 0] $lk
4610 setlink $id $lk
4611 set sep ", "
4612 }
4613 }
4614 $ctext conf -state disabled
4615 return [llength $tags]
4616}
4617
4618# called when we have finished computing the nearby tags
4619proc dispneartags {delay} {
4620 global selectedline currentid showneartags tagphase
4621
4622 if {![info exists selectedline] || !$showneartags} return
4623 after cancel dispnexttag
4624 if {$delay} {
4625 after 200 dispnexttag
4626 set tagphase -1
4627 } else {
4628 after idle dispnexttag
4629 set tagphase 0
4630 }
4631}
4632
4633proc dispnexttag {} {
4634 global selectedline currentid showneartags tagphase ctext
4635
4636 if {![info exists selectedline] || !$showneartags} return
4637 switch -- $tagphase {
4638 0 {
4639 set dtags [desctags $currentid]
4640 if {$dtags ne {}} {
4641 appendrefs precedes $dtags idtags
4642 }
4643 }
4644 1 {
4645 set atags [anctags $currentid]
4646 if {$atags ne {}} {
4647 appendrefs follows $atags idtags
4648 }
4649 }
4650 2 {
4651 set dheads [descheads $currentid]
4652 if {$dheads ne {}} {
4653 if {[appendrefs branch $dheads idheads] > 1
4654 && [$ctext get "branch -3c"] eq "h"} {
4655 # turn "Branch" into "Branches"
4656 $ctext conf -state normal
4657 $ctext insert "branch -2c" "es"
4658 $ctext conf -state disabled
4659 }
4660 }
4661 }
4662 }
4663 if {[incr tagphase] <= 2} {
4664 after idle dispnexttag
4665 }
4666}
4667
4668proc make_secsel {l} {
4669 global linehtag linentag linedtag canv canv2 canv3
4670
4671 if {![info exists linehtag($l)]} return
4672 $canv delete secsel
4673 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4674 -tags secsel -fill [$canv cget -selectbackground]]
4675 $canv lower $t
4676 $canv2 delete secsel
4677 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4678 -tags secsel -fill [$canv2 cget -selectbackground]]
4679 $canv2 lower $t
4680 $canv3 delete secsel
4681 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4682 -tags secsel -fill [$canv3 cget -selectbackground]]
4683 $canv3 lower $t
4684}
4685
4686proc selectline {l isnew} {
4687 global canv ctext commitinfo selectedline
4688 global displayorder
4689 global canvy0 linespc parentlist children curview
4690 global currentid sha1entry
4691 global commentend idtags linknum
4692 global mergemax numcommits pending_select
4693 global cmitmode showneartags allcommits
4694 global autoselect
4695
4696 catch {unset pending_select}
4697 $canv delete hover
4698 normalline
4699 unsel_reflist
4700 stopfinding
4701 if {$l < 0 || $l >= $numcommits} return
4702 set y [expr {$canvy0 + $l * $linespc}]
4703 set ymax [lindex [$canv cget -scrollregion] 3]
4704 set ytop [expr {$y - $linespc - 1}]
4705 set ybot [expr {$y + $linespc + 1}]
4706 set wnow [$canv yview]
4707 set wtop [expr {[lindex $wnow 0] * $ymax}]
4708 set wbot [expr {[lindex $wnow 1] * $ymax}]
4709 set wh [expr {$wbot - $wtop}]
4710 set newtop $wtop
4711 if {$ytop < $wtop} {
4712 if {$ybot < $wtop} {
4713 set newtop [expr {$y - $wh / 2.0}]
4714 } else {
4715 set newtop $ytop
4716 if {$newtop > $wtop - $linespc} {
4717 set newtop [expr {$wtop - $linespc}]
4718 }
4719 }
4720 } elseif {$ybot > $wbot} {
4721 if {$ytop > $wbot} {
4722 set newtop [expr {$y - $wh / 2.0}]
4723 } else {
4724 set newtop [expr {$ybot - $wh}]
4725 if {$newtop < $wtop + $linespc} {
4726 set newtop [expr {$wtop + $linespc}]
4727 }
4728 }
4729 }
4730 if {$newtop != $wtop} {
4731 if {$newtop < 0} {
4732 set newtop 0
4733 }
4734 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4735 drawvisible
4736 }
4737
4738 make_secsel $l
4739
4740 if {$isnew} {
4741 addtohistory [list selectline $l 0]
4742 }
4743
4744 set selectedline $l
4745
4746 set id [lindex $displayorder $l]
4747 set currentid $id
4748 $sha1entry delete 0 end
4749 $sha1entry insert 0 $id
4750 if {$autoselect} {
4751 $sha1entry selection from 0
4752 $sha1entry selection to end
4753 }
4754 rhighlight_sel $id
4755
4756 $ctext conf -state normal
4757 clear_ctext
4758 set linknum 0
4759 set info $commitinfo($id)
4760 set date [formatdate [lindex $info 2]]
4761 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
4762 set date [formatdate [lindex $info 4]]
4763 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
4764 if {[info exists idtags($id)]} {
4765 $ctext insert end [mc "Tags:"]
4766 foreach tag $idtags($id) {
4767 $ctext insert end " $tag"
4768 }
4769 $ctext insert end "\n"
4770 }
4771
4772 set headers {}
4773 set olds [lindex $parentlist $l]
4774 if {[llength $olds] > 1} {
4775 set np 0
4776 foreach p $olds {
4777 if {$np >= $mergemax} {
4778 set tag mmax
4779 } else {
4780 set tag m$np
4781 }
4782 $ctext insert end "[mc "Parent"]: " $tag
4783 appendwithlinks [commit_descriptor $p] {}
4784 incr np
4785 }
4786 } else {
4787 foreach p $olds {
4788 append headers "[mc "Parent"]: [commit_descriptor $p]"
4789 }
4790 }
4791
4792 foreach c $children($curview,$id) {
4793 append headers "[mc "Child"]: [commit_descriptor $c]"
4794 }
4795
4796 # make anything that looks like a SHA1 ID be a clickable link
4797 appendwithlinks $headers {}
4798 if {$showneartags} {
4799 if {![info exists allcommits]} {
4800 getallcommits
4801 }
4802 $ctext insert end "[mc "Branch"]: "
4803 $ctext mark set branch "end -1c"
4804 $ctext mark gravity branch left
4805 $ctext insert end "\n[mc "Follows"]: "
4806 $ctext mark set follows "end -1c"
4807 $ctext mark gravity follows left
4808 $ctext insert end "\n[mc "Precedes"]: "
4809 $ctext mark set precedes "end -1c"
4810 $ctext mark gravity precedes left
4811 $ctext insert end "\n"
4812 dispneartags 1
4813 }
4814 $ctext insert end "\n"
4815 set comment [lindex $info 5]
4816 if {[string first "\r" $comment] >= 0} {
4817 set comment [string map {"\r" "\n "} $comment]
4818 }
4819 appendwithlinks $comment {comment}
4820
4821 $ctext tag remove found 1.0 end
4822 $ctext conf -state disabled
4823 set commentend [$ctext index "end - 1c"]
4824
4825 init_flist [mc "Comments"]
4826 if {$cmitmode eq "tree"} {
4827 gettree $id
4828 } elseif {[llength $olds] <= 1} {
4829 startdiff $id
4830 } else {
4831 mergediff $id $l
4832 }
4833}
4834
4835proc selfirstline {} {
4836 unmarkmatches
4837 selectline 0 1
4838}
4839
4840proc sellastline {} {
4841 global numcommits
4842 unmarkmatches
4843 set l [expr {$numcommits - 1}]
4844 selectline $l 1
4845}
4846
4847proc selnextline {dir} {
4848 global selectedline
4849 focus .
4850 if {![info exists selectedline]} return
4851 set l [expr {$selectedline + $dir}]
4852 unmarkmatches
4853 selectline $l 1
4854}
4855
4856proc selnextpage {dir} {
4857 global canv linespc selectedline numcommits
4858
4859 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4860 if {$lpp < 1} {
4861 set lpp 1
4862 }
4863 allcanvs yview scroll [expr {$dir * $lpp}] units
4864 drawvisible
4865 if {![info exists selectedline]} return
4866 set l [expr {$selectedline + $dir * $lpp}]
4867 if {$l < 0} {
4868 set l 0
4869 } elseif {$l >= $numcommits} {
4870 set l [expr $numcommits - 1]
4871 }
4872 unmarkmatches
4873 selectline $l 1
4874}
4875
4876proc unselectline {} {
4877 global selectedline currentid
4878
4879 catch {unset selectedline}
4880 catch {unset currentid}
4881 allcanvs delete secsel
4882 rhighlight_none
4883}
4884
4885proc reselectline {} {
4886 global selectedline
4887
4888 if {[info exists selectedline]} {
4889 selectline $selectedline 0
4890 }
4891}
4892
4893proc addtohistory {cmd} {
4894 global history historyindex curview
4895
4896 set elt [list $curview $cmd]
4897 if {$historyindex > 0
4898 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4899 return
4900 }
4901
4902 if {$historyindex < [llength $history]} {
4903 set history [lreplace $history $historyindex end $elt]
4904 } else {
4905 lappend history $elt
4906 }
4907 incr historyindex
4908 if {$historyindex > 1} {
4909 .tf.bar.leftbut conf -state normal
4910 } else {
4911 .tf.bar.leftbut conf -state disabled
4912 }
4913 .tf.bar.rightbut conf -state disabled
4914}
4915
4916proc godo {elt} {
4917 global curview
4918
4919 set view [lindex $elt 0]
4920 set cmd [lindex $elt 1]
4921 if {$curview != $view} {
4922 showview $view
4923 }
4924 eval $cmd
4925}
4926
4927proc goback {} {
4928 global history historyindex
4929 focus .
4930
4931 if {$historyindex > 1} {
4932 incr historyindex -1
4933 godo [lindex $history [expr {$historyindex - 1}]]
4934 .tf.bar.rightbut conf -state normal
4935 }
4936 if {$historyindex <= 1} {
4937 .tf.bar.leftbut conf -state disabled
4938 }
4939}
4940
4941proc goforw {} {
4942 global history historyindex
4943 focus .
4944
4945 if {$historyindex < [llength $history]} {
4946 set cmd [lindex $history $historyindex]
4947 incr historyindex
4948 godo $cmd
4949 .tf.bar.leftbut conf -state normal
4950 }
4951 if {$historyindex >= [llength $history]} {
4952 .tf.bar.rightbut conf -state disabled
4953 }
4954}
4955
4956proc gettree {id} {
4957 global treefilelist treeidlist diffids diffmergeid treepending
4958 global nullid nullid2
4959
4960 set diffids $id
4961 catch {unset diffmergeid}
4962 if {![info exists treefilelist($id)]} {
4963 if {![info exists treepending]} {
4964 if {$id eq $nullid} {
4965 set cmd [list | git ls-files]
4966 } elseif {$id eq $nullid2} {
4967 set cmd [list | git ls-files --stage -t]
4968 } else {
4969 set cmd [list | git ls-tree -r $id]
4970 }
4971 if {[catch {set gtf [open $cmd r]}]} {
4972 return
4973 }
4974 set treepending $id
4975 set treefilelist($id) {}
4976 set treeidlist($id) {}
4977 fconfigure $gtf -blocking 0
4978 filerun $gtf [list gettreeline $gtf $id]
4979 }
4980 } else {
4981 setfilelist $id
4982 }
4983}
4984
4985proc gettreeline {gtf id} {
4986 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4987
4988 set nl 0
4989 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4990 if {$diffids eq $nullid} {
4991 set fname $line
4992 } else {
4993 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4994 set i [string first "\t" $line]
4995 if {$i < 0} continue
4996 set sha1 [lindex $line 2]
4997 set fname [string range $line [expr {$i+1}] end]
4998 if {[string index $fname 0] eq "\""} {
4999 set fname [lindex $fname 0]
5000 }
5001 lappend treeidlist($id) $sha1
5002 }
5003 lappend treefilelist($id) $fname
5004 }
5005 if {![eof $gtf]} {
5006 return [expr {$nl >= 1000? 2: 1}]
5007 }
5008 close $gtf
5009 unset treepending
5010 if {$cmitmode ne "tree"} {
5011 if {![info exists diffmergeid]} {
5012 gettreediffs $diffids
5013 }
5014 } elseif {$id ne $diffids} {
5015 gettree $diffids
5016 } else {
5017 setfilelist $id
5018 }
5019 return 0
5020}
5021
5022proc showfile {f} {
5023 global treefilelist treeidlist diffids nullid nullid2
5024 global ctext commentend
5025
5026 set i [lsearch -exact $treefilelist($diffids) $f]
5027 if {$i < 0} {
5028 puts "oops, $f not in list for id $diffids"
5029 return
5030 }
5031 if {$diffids eq $nullid} {
5032 if {[catch {set bf [open $f r]} err]} {
5033 puts "oops, can't read $f: $err"
5034 return
5035 }
5036 } else {
5037 set blob [lindex $treeidlist($diffids) $i]
5038 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5039 puts "oops, error reading blob $blob: $err"
5040 return
5041 }
5042 }
5043 fconfigure $bf -blocking 0
5044 filerun $bf [list getblobline $bf $diffids]
5045 $ctext config -state normal
5046 clear_ctext $commentend
5047 $ctext insert end "\n"
5048 $ctext insert end "$f\n" filesep
5049 $ctext config -state disabled
5050 $ctext yview $commentend
5051 settabs 0
5052}
5053
5054proc getblobline {bf id} {
5055 global diffids cmitmode ctext
5056
5057 if {$id ne $diffids || $cmitmode ne "tree"} {
5058 catch {close $bf}
5059 return 0
5060 }
5061 $ctext config -state normal
5062 set nl 0
5063 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5064 $ctext insert end "$line\n"
5065 }
5066 if {[eof $bf]} {
5067 # delete last newline
5068 $ctext delete "end - 2c" "end - 1c"
5069 close $bf
5070 return 0
5071 }
5072 $ctext config -state disabled
5073 return [expr {$nl >= 1000? 2: 1}]
5074}
5075
5076proc mergediff {id l} {
5077 global diffmergeid mdifffd
5078 global diffids
5079 global diffcontext
5080 global parentlist
5081 global limitdiffs viewfiles curview
5082
5083 set diffmergeid $id
5084 set diffids $id
5085 # this doesn't seem to actually affect anything...
5086 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
5087 if {$limitdiffs && $viewfiles($curview) ne {}} {
5088 set cmd [concat $cmd -- $viewfiles($curview)]
5089 }
5090 if {[catch {set mdf [open $cmd r]} err]} {
5091 error_popup "[mc "Error getting merge diffs:"] $err"
5092 return
5093 }
5094 fconfigure $mdf -blocking 0
5095 set mdifffd($id) $mdf
5096 set np [llength [lindex $parentlist $l]]
5097 settabs $np
5098 filerun $mdf [list getmergediffline $mdf $id $np]
5099}
5100
5101proc getmergediffline {mdf id np} {
5102 global diffmergeid ctext cflist mergemax
5103 global difffilestart mdifffd
5104
5105 $ctext conf -state normal
5106 set nr 0
5107 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5108 if {![info exists diffmergeid] || $id != $diffmergeid
5109 || $mdf != $mdifffd($id)} {
5110 close $mdf
5111 return 0
5112 }
5113 if {[regexp {^diff --cc (.*)} $line match fname]} {
5114 # start of a new file
5115 $ctext insert end "\n"
5116 set here [$ctext index "end - 1c"]
5117 lappend difffilestart $here
5118 add_flist [list $fname]
5119 set l [expr {(78 - [string length $fname]) / 2}]
5120 set pad [string range "----------------------------------------" 1 $l]
5121 $ctext insert end "$pad $fname $pad\n" filesep
5122 } elseif {[regexp {^@@} $line]} {
5123 $ctext insert end "$line\n" hunksep
5124 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5125 # do nothing
5126 } else {
5127 # parse the prefix - one ' ', '-' or '+' for each parent
5128 set spaces {}
5129 set minuses {}
5130 set pluses {}
5131 set isbad 0
5132 for {set j 0} {$j < $np} {incr j} {
5133 set c [string range $line $j $j]
5134 if {$c == " "} {
5135 lappend spaces $j
5136 } elseif {$c == "-"} {
5137 lappend minuses $j
5138 } elseif {$c == "+"} {
5139 lappend pluses $j
5140 } else {
5141 set isbad 1
5142 break
5143 }
5144 }
5145 set tags {}
5146 set num {}
5147 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5148 # line doesn't appear in result, parents in $minuses have the line
5149 set num [lindex $minuses 0]
5150 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5151 # line appears in result, parents in $pluses don't have the line
5152 lappend tags mresult
5153 set num [lindex $spaces 0]
5154 }
5155 if {$num ne {}} {
5156 if {$num >= $mergemax} {
5157 set num "max"
5158 }
5159 lappend tags m$num
5160 }
5161 $ctext insert end "$line\n" $tags
5162 }
5163 }
5164 $ctext conf -state disabled
5165 if {[eof $mdf]} {
5166 close $mdf
5167 return 0
5168 }
5169 return [expr {$nr >= 1000? 2: 1}]
5170}
5171
5172proc startdiff {ids} {
5173 global treediffs diffids treepending diffmergeid nullid nullid2
5174
5175 settabs 1
5176 set diffids $ids
5177 catch {unset diffmergeid}
5178 if {![info exists treediffs($ids)] ||
5179 [lsearch -exact $ids $nullid] >= 0 ||
5180 [lsearch -exact $ids $nullid2] >= 0} {
5181 if {![info exists treepending]} {
5182 gettreediffs $ids
5183 }
5184 } else {
5185 addtocflist $ids
5186 }
5187}
5188
5189proc path_filter {filter name} {
5190 foreach p $filter {
5191 set l [string length $p]
5192 if {[string index $p end] eq "/"} {
5193 if {[string compare -length $l $p $name] == 0} {
5194 return 1
5195 }
5196 } else {
5197 if {[string compare -length $l $p $name] == 0 &&
5198 ([string length $name] == $l ||
5199 [string index $name $l] eq "/")} {
5200 return 1
5201 }
5202 }
5203 }
5204 return 0
5205}
5206
5207proc addtocflist {ids} {
5208 global treediffs
5209
5210 add_flist $treediffs($ids)
5211 getblobdiffs $ids
5212}
5213
5214proc diffcmd {ids flags} {
5215 global nullid nullid2
5216
5217 set i [lsearch -exact $ids $nullid]
5218 set j [lsearch -exact $ids $nullid2]
5219 if {$i >= 0} {
5220 if {[llength $ids] > 1 && $j < 0} {
5221 # comparing working directory with some specific revision
5222 set cmd [concat | git diff-index $flags]
5223 if {$i == 0} {
5224 lappend cmd -R [lindex $ids 1]
5225 } else {
5226 lappend cmd [lindex $ids 0]
5227 }
5228 } else {
5229 # comparing working directory with index
5230 set cmd [concat | git diff-files $flags]
5231 if {$j == 1} {
5232 lappend cmd -R
5233 }
5234 }
5235 } elseif {$j >= 0} {
5236 set cmd [concat | git diff-index --cached $flags]
5237 if {[llength $ids] > 1} {
5238 # comparing index with specific revision
5239 if {$i == 0} {
5240 lappend cmd -R [lindex $ids 1]
5241 } else {
5242 lappend cmd [lindex $ids 0]
5243 }
5244 } else {
5245 # comparing index with HEAD
5246 lappend cmd HEAD
5247 }
5248 } else {
5249 set cmd [concat | git diff-tree -r $flags $ids]
5250 }
5251 return $cmd
5252}
5253
5254proc gettreediffs {ids} {
5255 global treediff treepending
5256
5257 set treepending $ids
5258 set treediff {}
5259 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5260 fconfigure $gdtf -blocking 0
5261 filerun $gdtf [list gettreediffline $gdtf $ids]
5262}
5263
5264proc gettreediffline {gdtf ids} {
5265 global treediff treediffs treepending diffids diffmergeid
5266 global cmitmode viewfiles curview limitdiffs
5267
5268 set nr 0
5269 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5270 set i [string first "\t" $line]
5271 if {$i >= 0} {
5272 set file [string range $line [expr {$i+1}] end]
5273 if {[string index $file 0] eq "\""} {
5274 set file [lindex $file 0]
5275 }
5276 lappend treediff $file
5277 }
5278 }
5279 if {![eof $gdtf]} {
5280 return [expr {$nr >= 1000? 2: 1}]
5281 }
5282 close $gdtf
5283 if {$limitdiffs && $viewfiles($curview) ne {}} {
5284 set flist {}
5285 foreach f $treediff {
5286 if {[path_filter $viewfiles($curview) $f]} {
5287 lappend flist $f
5288 }
5289 }
5290 set treediffs($ids) $flist
5291 } else {
5292 set treediffs($ids) $treediff
5293 }
5294 unset treepending
5295 if {$cmitmode eq "tree"} {
5296 gettree $diffids
5297 } elseif {$ids != $diffids} {
5298 if {![info exists diffmergeid]} {
5299 gettreediffs $diffids
5300 }
5301 } else {
5302 addtocflist $ids
5303 }
5304 return 0
5305}
5306
5307# empty string or positive integer
5308proc diffcontextvalidate {v} {
5309 return [regexp {^(|[1-9][0-9]*)$} $v]
5310}
5311
5312proc diffcontextchange {n1 n2 op} {
5313 global diffcontextstring diffcontext
5314
5315 if {[string is integer -strict $diffcontextstring]} {
5316 if {$diffcontextstring > 0} {
5317 set diffcontext $diffcontextstring
5318 reselectline
5319 }
5320 }
5321}
5322
5323proc changeignorespace {} {
5324 reselectline
5325}
5326
5327proc getblobdiffs {ids} {
5328 global blobdifffd diffids env
5329 global diffinhdr treediffs
5330 global diffcontext
5331 global ignorespace
5332 global limitdiffs viewfiles curview
5333
5334 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5335 if {$ignorespace} {
5336 append cmd " -w"
5337 }
5338 if {$limitdiffs && $viewfiles($curview) ne {}} {
5339 set cmd [concat $cmd -- $viewfiles($curview)]
5340 }
5341 if {[catch {set bdf [open $cmd r]} err]} {
5342 puts "error getting diffs: $err"
5343 return
5344 }
5345 set diffinhdr 0
5346 fconfigure $bdf -blocking 0
5347 set blobdifffd($ids) $bdf
5348 filerun $bdf [list getblobdiffline $bdf $diffids]
5349}
5350
5351proc setinlist {var i val} {
5352 global $var
5353
5354 while {[llength [set $var]] < $i} {
5355 lappend $var {}
5356 }
5357 if {[llength [set $var]] == $i} {
5358 lappend $var $val
5359 } else {
5360 lset $var $i $val
5361 }
5362}
5363
5364proc makediffhdr {fname ids} {
5365 global ctext curdiffstart treediffs
5366
5367 set i [lsearch -exact $treediffs($ids) $fname]
5368 if {$i >= 0} {
5369 setinlist difffilestart $i $curdiffstart
5370 }
5371 set l [expr {(78 - [string length $fname]) / 2}]
5372 set pad [string range "----------------------------------------" 1 $l]
5373 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5374}
5375
5376proc getblobdiffline {bdf ids} {
5377 global diffids blobdifffd ctext curdiffstart
5378 global diffnexthead diffnextnote difffilestart
5379 global diffinhdr treediffs
5380
5381 set nr 0
5382 $ctext conf -state normal
5383 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5384 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5385 close $bdf
5386 return 0
5387 }
5388 if {![string compare -length 11 "diff --git " $line]} {
5389 # trim off "diff --git "
5390 set line [string range $line 11 end]
5391 set diffinhdr 1
5392 # start of a new file
5393 $ctext insert end "\n"
5394 set curdiffstart [$ctext index "end - 1c"]
5395 $ctext insert end "\n" filesep
5396 # If the name hasn't changed the length will be odd,
5397 # the middle char will be a space, and the two bits either
5398 # side will be a/name and b/name, or "a/name" and "b/name".
5399 # If the name has changed we'll get "rename from" and
5400 # "rename to" or "copy from" and "copy to" lines following this,
5401 # and we'll use them to get the filenames.
5402 # This complexity is necessary because spaces in the filename(s)
5403 # don't get escaped.
5404 set l [string length $line]
5405 set i [expr {$l / 2}]
5406 if {!(($l & 1) && [string index $line $i] eq " " &&
5407 [string range $line 2 [expr {$i - 1}]] eq \
5408 [string range $line [expr {$i + 3}] end])} {
5409 continue
5410 }
5411 # unescape if quoted and chop off the a/ from the front
5412 if {[string index $line 0] eq "\""} {
5413 set fname [string range [lindex $line 0] 2 end]
5414 } else {
5415 set fname [string range $line 2 [expr {$i - 1}]]
5416 }
5417 makediffhdr $fname $ids
5418
5419 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5420 $line match f1l f1c f2l f2c rest]} {
5421 $ctext insert end "$line\n" hunksep
5422 set diffinhdr 0
5423
5424 } elseif {$diffinhdr} {
5425 if {![string compare -length 12 "rename from " $line]} {
5426 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5427 if {[string index $fname 0] eq "\""} {
5428 set fname [lindex $fname 0]
5429 }
5430 set i [lsearch -exact $treediffs($ids) $fname]
5431 if {$i >= 0} {
5432 setinlist difffilestart $i $curdiffstart
5433 }
5434 } elseif {![string compare -length 10 $line "rename to "] ||
5435 ![string compare -length 8 $line "copy to "]} {
5436 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5437 if {[string index $fname 0] eq "\""} {
5438 set fname [lindex $fname 0]
5439 }
5440 makediffhdr $fname $ids
5441 } elseif {[string compare -length 3 $line "---"] == 0} {
5442 # do nothing
5443 continue
5444 } elseif {[string compare -length 3 $line "+++"] == 0} {
5445 set diffinhdr 0
5446 continue
5447 }
5448 $ctext insert end "$line\n" filesep
5449
5450 } else {
5451 set x [string range $line 0 0]
5452 if {$x == "-" || $x == "+"} {
5453 set tag [expr {$x == "+"}]
5454 $ctext insert end "$line\n" d$tag
5455 } elseif {$x == " "} {
5456 $ctext insert end "$line\n"
5457 } else {
5458 # "\ No newline at end of file",
5459 # or something else we don't recognize
5460 $ctext insert end "$line\n" hunksep
5461 }
5462 }
5463 }
5464 $ctext conf -state disabled
5465 if {[eof $bdf]} {
5466 close $bdf
5467 return 0
5468 }
5469 return [expr {$nr >= 1000? 2: 1}]
5470}
5471
5472proc changediffdisp {} {
5473 global ctext diffelide
5474
5475 $ctext tag conf d0 -elide [lindex $diffelide 0]
5476 $ctext tag conf d1 -elide [lindex $diffelide 1]
5477}
5478
5479proc prevfile {} {
5480 global difffilestart ctext
5481 set prev [lindex $difffilestart 0]
5482 set here [$ctext index @0,0]
5483 foreach loc $difffilestart {
5484 if {[$ctext compare $loc >= $here]} {
5485 $ctext yview $prev
5486 return
5487 }
5488 set prev $loc
5489 }
5490 $ctext yview $prev
5491}
5492
5493proc nextfile {} {
5494 global difffilestart ctext
5495 set here [$ctext index @0,0]
5496 foreach loc $difffilestart {
5497 if {[$ctext compare $loc > $here]} {
5498 $ctext yview $loc
5499 return
5500 }
5501 }
5502}
5503
5504proc clear_ctext {{first 1.0}} {
5505 global ctext smarktop smarkbot
5506 global pendinglinks
5507
5508 set l [lindex [split $first .] 0]
5509 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5510 set smarktop $l
5511 }
5512 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5513 set smarkbot $l
5514 }
5515 $ctext delete $first end
5516 if {$first eq "1.0"} {
5517 catch {unset pendinglinks}
5518 }
5519}
5520
5521proc settabs {{firstab {}}} {
5522 global firsttabstop tabstop ctext have_tk85
5523
5524 if {$firstab ne {} && $have_tk85} {
5525 set firsttabstop $firstab
5526 }
5527 set w [font measure textfont "0"]
5528 if {$firsttabstop != 0} {
5529 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5530 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5531 } elseif {$have_tk85 || $tabstop != 8} {
5532 $ctext conf -tabs [expr {$tabstop * $w}]
5533 } else {
5534 $ctext conf -tabs {}
5535 }
5536}
5537
5538proc incrsearch {name ix op} {
5539 global ctext searchstring searchdirn
5540
5541 $ctext tag remove found 1.0 end
5542 if {[catch {$ctext index anchor}]} {
5543 # no anchor set, use start of selection, or of visible area
5544 set sel [$ctext tag ranges sel]
5545 if {$sel ne {}} {
5546 $ctext mark set anchor [lindex $sel 0]
5547 } elseif {$searchdirn eq "-forwards"} {
5548 $ctext mark set anchor @0,0
5549 } else {
5550 $ctext mark set anchor @0,[winfo height $ctext]
5551 }
5552 }
5553 if {$searchstring ne {}} {
5554 set here [$ctext search $searchdirn -- $searchstring anchor]
5555 if {$here ne {}} {
5556 $ctext see $here
5557 }
5558 searchmarkvisible 1
5559 }
5560}
5561
5562proc dosearch {} {
5563 global sstring ctext searchstring searchdirn
5564
5565 focus $sstring
5566 $sstring icursor end
5567 set searchdirn -forwards
5568 if {$searchstring ne {}} {
5569 set sel [$ctext tag ranges sel]
5570 if {$sel ne {}} {
5571 set start "[lindex $sel 0] + 1c"
5572 } elseif {[catch {set start [$ctext index anchor]}]} {
5573 set start "@0,0"
5574 }
5575 set match [$ctext search -count mlen -- $searchstring $start]
5576 $ctext tag remove sel 1.0 end
5577 if {$match eq {}} {
5578 bell
5579 return
5580 }
5581 $ctext see $match
5582 set mend "$match + $mlen c"
5583 $ctext tag add sel $match $mend
5584 $ctext mark unset anchor
5585 }
5586}
5587
5588proc dosearchback {} {
5589 global sstring ctext searchstring searchdirn
5590
5591 focus $sstring
5592 $sstring icursor end
5593 set searchdirn -backwards
5594 if {$searchstring ne {}} {
5595 set sel [$ctext tag ranges sel]
5596 if {$sel ne {}} {
5597 set start [lindex $sel 0]
5598 } elseif {[catch {set start [$ctext index anchor]}]} {
5599 set start @0,[winfo height $ctext]
5600 }
5601 set match [$ctext search -backwards -count ml -- $searchstring $start]
5602 $ctext tag remove sel 1.0 end
5603 if {$match eq {}} {
5604 bell
5605 return
5606 }
5607 $ctext see $match
5608 set mend "$match + $ml c"
5609 $ctext tag add sel $match $mend
5610 $ctext mark unset anchor
5611 }
5612}
5613
5614proc searchmark {first last} {
5615 global ctext searchstring
5616
5617 set mend $first.0
5618 while {1} {
5619 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5620 if {$match eq {}} break
5621 set mend "$match + $mlen c"
5622 $ctext tag add found $match $mend
5623 }
5624}
5625
5626proc searchmarkvisible {doall} {
5627 global ctext smarktop smarkbot
5628
5629 set topline [lindex [split [$ctext index @0,0] .] 0]
5630 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5631 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5632 # no overlap with previous
5633 searchmark $topline $botline
5634 set smarktop $topline
5635 set smarkbot $botline
5636 } else {
5637 if {$topline < $smarktop} {
5638 searchmark $topline [expr {$smarktop-1}]
5639 set smarktop $topline
5640 }
5641 if {$botline > $smarkbot} {
5642 searchmark [expr {$smarkbot+1}] $botline
5643 set smarkbot $botline
5644 }
5645 }
5646}
5647
5648proc scrolltext {f0 f1} {
5649 global searchstring
5650
5651 .bleft.bottom.sb set $f0 $f1
5652 if {$searchstring ne {}} {
5653 searchmarkvisible 0
5654 }
5655}
5656
5657proc setcoords {} {
5658 global linespc charspc canvx0 canvy0
5659 global xspc1 xspc2 lthickness
5660
5661 set linespc [font metrics mainfont -linespace]
5662 set charspc [font measure mainfont "m"]
5663 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5664 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5665 set lthickness [expr {int($linespc / 9) + 1}]
5666 set xspc1(0) $linespc
5667 set xspc2 $linespc
5668}
5669
5670proc redisplay {} {
5671 global canv
5672 global selectedline
5673
5674 set ymax [lindex [$canv cget -scrollregion] 3]
5675 if {$ymax eq {} || $ymax == 0} return
5676 set span [$canv yview]
5677 clear_display
5678 setcanvscroll
5679 allcanvs yview moveto [lindex $span 0]
5680 drawvisible
5681 if {[info exists selectedline]} {
5682 selectline $selectedline 0
5683 allcanvs yview moveto [lindex $span 0]
5684 }
5685}
5686
5687proc parsefont {f n} {
5688 global fontattr
5689
5690 set fontattr($f,family) [lindex $n 0]
5691 set s [lindex $n 1]
5692 if {$s eq {} || $s == 0} {
5693 set s 10
5694 } elseif {$s < 0} {
5695 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5696 }
5697 set fontattr($f,size) $s
5698 set fontattr($f,weight) normal
5699 set fontattr($f,slant) roman
5700 foreach style [lrange $n 2 end] {
5701 switch -- $style {
5702 "normal" -
5703 "bold" {set fontattr($f,weight) $style}
5704 "roman" -
5705 "italic" {set fontattr($f,slant) $style}
5706 }
5707 }
5708}
5709
5710proc fontflags {f {isbold 0}} {
5711 global fontattr
5712
5713 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5714 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5715 -slant $fontattr($f,slant)]
5716}
5717
5718proc fontname {f} {
5719 global fontattr
5720
5721 set n [list $fontattr($f,family) $fontattr($f,size)]
5722 if {$fontattr($f,weight) eq "bold"} {
5723 lappend n "bold"
5724 }
5725 if {$fontattr($f,slant) eq "italic"} {
5726 lappend n "italic"
5727 }
5728 return $n
5729}
5730
5731proc incrfont {inc} {
5732 global mainfont textfont ctext canv phase cflist showrefstop
5733 global stopped entries fontattr
5734
5735 unmarkmatches
5736 set s $fontattr(mainfont,size)
5737 incr s $inc
5738 if {$s < 1} {
5739 set s 1
5740 }
5741 set fontattr(mainfont,size) $s
5742 font config mainfont -size $s
5743 font config mainfontbold -size $s
5744 set mainfont [fontname mainfont]
5745 set s $fontattr(textfont,size)
5746 incr s $inc
5747 if {$s < 1} {
5748 set s 1
5749 }
5750 set fontattr(textfont,size) $s
5751 font config textfont -size $s
5752 font config textfontbold -size $s
5753 set textfont [fontname textfont]
5754 setcoords
5755 settabs
5756 redisplay
5757}
5758
5759proc clearsha1 {} {
5760 global sha1entry sha1string
5761 if {[string length $sha1string] == 40} {
5762 $sha1entry delete 0 end
5763 }
5764}
5765
5766proc sha1change {n1 n2 op} {
5767 global sha1string currentid sha1but
5768 if {$sha1string == {}
5769 || ([info exists currentid] && $sha1string == $currentid)} {
5770 set state disabled
5771 } else {
5772 set state normal
5773 }
5774 if {[$sha1but cget -state] == $state} return
5775 if {$state == "normal"} {
5776 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
5777 } else {
5778 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
5779 }
5780}
5781
5782proc gotocommit {} {
5783 global sha1string currentid commitrow tagids headids
5784 global displayorder numcommits curview
5785
5786 if {$sha1string == {}
5787 || ([info exists currentid] && $sha1string == $currentid)} return
5788 if {[info exists tagids($sha1string)]} {
5789 set id $tagids($sha1string)
5790 } elseif {[info exists headids($sha1string)]} {
5791 set id $headids($sha1string)
5792 } else {
5793 set id [string tolower $sha1string]
5794 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5795 set matches {}
5796 foreach i $displayorder {
5797 if {[string match $id* $i]} {
5798 lappend matches $i
5799 }
5800 }
5801 if {$matches ne {}} {
5802 if {[llength $matches] > 1} {
5803 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
5804 return
5805 }
5806 set id [lindex $matches 0]
5807 }
5808 }
5809 }
5810 if {[info exists commitrow($curview,$id)]} {
5811 selectline $commitrow($curview,$id) 1
5812 return
5813 }
5814 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5815 set msg [mc "SHA1 id %s is not known" $sha1string]
5816 } else {
5817 set msg [mc "Tag/Head %s is not known" $sha1string]
5818 }
5819 error_popup $msg
5820}
5821
5822proc lineenter {x y id} {
5823 global hoverx hovery hoverid hovertimer
5824 global commitinfo canv
5825
5826 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5827 set hoverx $x
5828 set hovery $y
5829 set hoverid $id
5830 if {[info exists hovertimer]} {
5831 after cancel $hovertimer
5832 }
5833 set hovertimer [after 500 linehover]
5834 $canv delete hover
5835}
5836
5837proc linemotion {x y id} {
5838 global hoverx hovery hoverid hovertimer
5839
5840 if {[info exists hoverid] && $id == $hoverid} {
5841 set hoverx $x
5842 set hovery $y
5843 if {[info exists hovertimer]} {
5844 after cancel $hovertimer
5845 }
5846 set hovertimer [after 500 linehover]
5847 }
5848}
5849
5850proc lineleave {id} {
5851 global hoverid hovertimer canv
5852
5853 if {[info exists hoverid] && $id == $hoverid} {
5854 $canv delete hover
5855 if {[info exists hovertimer]} {
5856 after cancel $hovertimer
5857 unset hovertimer
5858 }
5859 unset hoverid
5860 }
5861}
5862
5863proc linehover {} {
5864 global hoverx hovery hoverid hovertimer
5865 global canv linespc lthickness
5866 global commitinfo
5867
5868 set text [lindex $commitinfo($hoverid) 0]
5869 set ymax [lindex [$canv cget -scrollregion] 3]
5870 if {$ymax == {}} return
5871 set yfrac [lindex [$canv yview] 0]
5872 set x [expr {$hoverx + 2 * $linespc}]
5873 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5874 set x0 [expr {$x - 2 * $lthickness}]
5875 set y0 [expr {$y - 2 * $lthickness}]
5876 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5877 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5878 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5879 -fill \#ffff80 -outline black -width 1 -tags hover]
5880 $canv raise $t
5881 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5882 -font mainfont]
5883 $canv raise $t
5884}
5885
5886proc clickisonarrow {id y} {
5887 global lthickness
5888
5889 set ranges [rowranges $id]
5890 set thresh [expr {2 * $lthickness + 6}]
5891 set n [expr {[llength $ranges] - 1}]
5892 for {set i 1} {$i < $n} {incr i} {
5893 set row [lindex $ranges $i]
5894 if {abs([yc $row] - $y) < $thresh} {
5895 return $i
5896 }
5897 }
5898 return {}
5899}
5900
5901proc arrowjump {id n y} {
5902 global canv
5903
5904 # 1 <-> 2, 3 <-> 4, etc...
5905 set n [expr {(($n - 1) ^ 1) + 1}]
5906 set row [lindex [rowranges $id] $n]
5907 set yt [yc $row]
5908 set ymax [lindex [$canv cget -scrollregion] 3]
5909 if {$ymax eq {} || $ymax <= 0} return
5910 set view [$canv yview]
5911 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5912 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5913 if {$yfrac < 0} {
5914 set yfrac 0
5915 }
5916 allcanvs yview moveto $yfrac
5917}
5918
5919proc lineclick {x y id isnew} {
5920 global ctext commitinfo children canv thickerline curview commitrow
5921
5922 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5923 unmarkmatches
5924 unselectline
5925 normalline
5926 $canv delete hover
5927 # draw this line thicker than normal
5928 set thickerline $id
5929 drawlines $id
5930 if {$isnew} {
5931 set ymax [lindex [$canv cget -scrollregion] 3]
5932 if {$ymax eq {}} return
5933 set yfrac [lindex [$canv yview] 0]
5934 set y [expr {$y + $yfrac * $ymax}]
5935 }
5936 set dirn [clickisonarrow $id $y]
5937 if {$dirn ne {}} {
5938 arrowjump $id $dirn $y
5939 return
5940 }
5941
5942 if {$isnew} {
5943 addtohistory [list lineclick $x $y $id 0]
5944 }
5945 # fill the details pane with info about this line
5946 $ctext conf -state normal
5947 clear_ctext
5948 settabs 0
5949 $ctext insert end "[mc "Parent"]:\t"
5950 $ctext insert end $id link0
5951 setlink $id link0
5952 set info $commitinfo($id)
5953 $ctext insert end "\n\t[lindex $info 0]\n"
5954 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
5955 set date [formatdate [lindex $info 2]]
5956 $ctext insert end "\t[mc "Date"]:\t$date\n"
5957 set kids $children($curview,$id)
5958 if {$kids ne {}} {
5959 $ctext insert end "\n[mc "Children"]:"
5960 set i 0
5961 foreach child $kids {
5962 incr i
5963 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5964 set info $commitinfo($child)
5965 $ctext insert end "\n\t"
5966 $ctext insert end $child link$i
5967 setlink $child link$i
5968 $ctext insert end "\n\t[lindex $info 0]"
5969 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
5970 set date [formatdate [lindex $info 2]]
5971 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
5972 }
5973 }
5974 $ctext conf -state disabled
5975 init_flist {}
5976}
5977
5978proc normalline {} {
5979 global thickerline
5980 if {[info exists thickerline]} {
5981 set id $thickerline
5982 unset thickerline
5983 drawlines $id
5984 }
5985}
5986
5987proc selbyid {id} {
5988 global commitrow curview
5989 if {[info exists commitrow($curview,$id)]} {
5990 selectline $commitrow($curview,$id) 1
5991 }
5992}
5993
5994proc mstime {} {
5995 global startmstime
5996 if {![info exists startmstime]} {
5997 set startmstime [clock clicks -milliseconds]
5998 }
5999 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6000}
6001
6002proc rowmenu {x y id} {
6003 global rowctxmenu commitrow selectedline rowmenuid curview
6004 global nullid nullid2 fakerowmenu mainhead
6005
6006 stopfinding
6007 set rowmenuid $id
6008 if {![info exists selectedline]
6009 || $commitrow($curview,$id) eq $selectedline} {
6010 set state disabled
6011 } else {
6012 set state normal
6013 }
6014 if {$id ne $nullid && $id ne $nullid2} {
6015 set menu $rowctxmenu
6016 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6017 } else {
6018 set menu $fakerowmenu
6019 }
6020 $menu entryconfigure [mc "Diff this -> selected"] -state $state
6021 $menu entryconfigure [mc "Diff selected -> this"] -state $state
6022 $menu entryconfigure [mc "Make patch"] -state $state
6023 tk_popup $menu $x $y
6024}
6025
6026proc diffvssel {dirn} {
6027 global rowmenuid selectedline displayorder
6028
6029 if {![info exists selectedline]} return
6030 if {$dirn} {
6031 set oldid [lindex $displayorder $selectedline]
6032 set newid $rowmenuid
6033 } else {
6034 set oldid $rowmenuid
6035 set newid [lindex $displayorder $selectedline]
6036 }
6037 addtohistory [list doseldiff $oldid $newid]
6038 doseldiff $oldid $newid
6039}
6040
6041proc doseldiff {oldid newid} {
6042 global ctext
6043 global commitinfo
6044
6045 $ctext conf -state normal
6046 clear_ctext
6047 init_flist [mc "Top"]
6048 $ctext insert end "[mc "From"] "
6049 $ctext insert end $oldid link0
6050 setlink $oldid link0
6051 $ctext insert end "\n "
6052 $ctext insert end [lindex $commitinfo($oldid) 0]
6053 $ctext insert end "\n\n[mc "To"] "
6054 $ctext insert end $newid link1
6055 setlink $newid link1
6056 $ctext insert end "\n "
6057 $ctext insert end [lindex $commitinfo($newid) 0]
6058 $ctext insert end "\n"
6059 $ctext conf -state disabled
6060 $ctext tag remove found 1.0 end
6061 startdiff [list $oldid $newid]
6062}
6063
6064proc mkpatch {} {
6065 global rowmenuid currentid commitinfo patchtop patchnum
6066
6067 if {![info exists currentid]} return
6068 set oldid $currentid
6069 set oldhead [lindex $commitinfo($oldid) 0]
6070 set newid $rowmenuid
6071 set newhead [lindex $commitinfo($newid) 0]
6072 set top .patch
6073 set patchtop $top
6074 catch {destroy $top}
6075 toplevel $top
6076 label $top.title -text [mc "Generate patch"]
6077 grid $top.title - -pady 10
6078 label $top.from -text [mc "From:"]
6079 entry $top.fromsha1 -width 40 -relief flat
6080 $top.fromsha1 insert 0 $oldid
6081 $top.fromsha1 conf -state readonly
6082 grid $top.from $top.fromsha1 -sticky w
6083 entry $top.fromhead -width 60 -relief flat
6084 $top.fromhead insert 0 $oldhead
6085 $top.fromhead conf -state readonly
6086 grid x $top.fromhead -sticky w
6087 label $top.to -text [mc "To:"]
6088 entry $top.tosha1 -width 40 -relief flat
6089 $top.tosha1 insert 0 $newid
6090 $top.tosha1 conf -state readonly
6091 grid $top.to $top.tosha1 -sticky w
6092 entry $top.tohead -width 60 -relief flat
6093 $top.tohead insert 0 $newhead
6094 $top.tohead conf -state readonly
6095 grid x $top.tohead -sticky w
6096 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6097 grid $top.rev x -pady 10
6098 label $top.flab -text [mc "Output file:"]
6099 entry $top.fname -width 60
6100 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6101 incr patchnum
6102 grid $top.flab $top.fname -sticky w
6103 frame $top.buts
6104 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6105 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6106 grid $top.buts.gen $top.buts.can
6107 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6108 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6109 grid $top.buts - -pady 10 -sticky ew
6110 focus $top.fname
6111}
6112
6113proc mkpatchrev {} {
6114 global patchtop
6115
6116 set oldid [$patchtop.fromsha1 get]
6117 set oldhead [$patchtop.fromhead get]
6118 set newid [$patchtop.tosha1 get]
6119 set newhead [$patchtop.tohead get]
6120 foreach e [list fromsha1 fromhead tosha1 tohead] \
6121 v [list $newid $newhead $oldid $oldhead] {
6122 $patchtop.$e conf -state normal
6123 $patchtop.$e delete 0 end
6124 $patchtop.$e insert 0 $v
6125 $patchtop.$e conf -state readonly
6126 }
6127}
6128
6129proc mkpatchgo {} {
6130 global patchtop nullid nullid2
6131
6132 set oldid [$patchtop.fromsha1 get]
6133 set newid [$patchtop.tosha1 get]
6134 set fname [$patchtop.fname get]
6135 set cmd [diffcmd [list $oldid $newid] -p]
6136 # trim off the initial "|"
6137 set cmd [lrange $cmd 1 end]
6138 lappend cmd >$fname &
6139 if {[catch {eval exec $cmd} err]} {
6140 error_popup "[mc "Error creating patch:"] $err"
6141 }
6142 catch {destroy $patchtop}
6143 unset patchtop
6144}
6145
6146proc mkpatchcan {} {
6147 global patchtop
6148
6149 catch {destroy $patchtop}
6150 unset patchtop
6151}
6152
6153proc mktag {} {
6154 global rowmenuid mktagtop commitinfo
6155
6156 set top .maketag
6157 set mktagtop $top
6158 catch {destroy $top}
6159 toplevel $top
6160 label $top.title -text [mc "Create tag"]
6161 grid $top.title - -pady 10
6162 label $top.id -text [mc "ID:"]
6163 entry $top.sha1 -width 40 -relief flat
6164 $top.sha1 insert 0 $rowmenuid
6165 $top.sha1 conf -state readonly
6166 grid $top.id $top.sha1 -sticky w
6167 entry $top.head -width 60 -relief flat
6168 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6169 $top.head conf -state readonly
6170 grid x $top.head -sticky w
6171 label $top.tlab -text [mc "Tag name:"]
6172 entry $top.tag -width 60
6173 grid $top.tlab $top.tag -sticky w
6174 frame $top.buts
6175 button $top.buts.gen -text [mc "Create"] -command mktaggo
6176 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6177 grid $top.buts.gen $top.buts.can
6178 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6179 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6180 grid $top.buts - -pady 10 -sticky ew
6181 focus $top.tag
6182}
6183
6184proc domktag {} {
6185 global mktagtop env tagids idtags
6186
6187 set id [$mktagtop.sha1 get]
6188 set tag [$mktagtop.tag get]
6189 if {$tag == {}} {
6190 error_popup [mc "No tag name specified"]
6191 return
6192 }
6193 if {[info exists tagids($tag)]} {
6194 error_popup [mc "Tag \"%s\" already exists" $tag]
6195 return
6196 }
6197 if {[catch {
6198 exec git tag $tag $id
6199 } err]} {
6200 error_popup "[mc "Error creating tag:"] $err"
6201 return
6202 }
6203
6204 set tagids($tag) $id
6205 lappend idtags($id) $tag
6206 redrawtags $id
6207 addedtag $id
6208 dispneartags 0
6209 run refill_reflist
6210}
6211
6212proc redrawtags {id} {
6213 global canv linehtag commitrow idpos selectedline curview
6214 global canvxmax iddrawn
6215
6216 if {![info exists commitrow($curview,$id)]} return
6217 if {![info exists iddrawn($id)]} return
6218 drawcommits $commitrow($curview,$id)
6219 $canv delete tag.$id
6220 set xt [eval drawtags $id $idpos($id)]
6221 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6222 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6223 set xr [expr {$xt + [font measure mainfont $text]}]
6224 if {$xr > $canvxmax} {
6225 set canvxmax $xr
6226 setcanvscroll
6227 }
6228 if {[info exists selectedline]
6229 && $selectedline == $commitrow($curview,$id)} {
6230 selectline $selectedline 0
6231 }
6232}
6233
6234proc mktagcan {} {
6235 global mktagtop
6236
6237 catch {destroy $mktagtop}
6238 unset mktagtop
6239}
6240
6241proc mktaggo {} {
6242 domktag
6243 mktagcan
6244}
6245
6246proc writecommit {} {
6247 global rowmenuid wrcomtop commitinfo wrcomcmd
6248
6249 set top .writecommit
6250 set wrcomtop $top
6251 catch {destroy $top}
6252 toplevel $top
6253 label $top.title -text [mc "Write commit to file"]
6254 grid $top.title - -pady 10
6255 label $top.id -text [mc "ID:"]
6256 entry $top.sha1 -width 40 -relief flat
6257 $top.sha1 insert 0 $rowmenuid
6258 $top.sha1 conf -state readonly
6259 grid $top.id $top.sha1 -sticky w
6260 entry $top.head -width 60 -relief flat
6261 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6262 $top.head conf -state readonly
6263 grid x $top.head -sticky w
6264 label $top.clab -text [mc "Command:"]
6265 entry $top.cmd -width 60 -textvariable wrcomcmd
6266 grid $top.clab $top.cmd -sticky w -pady 10
6267 label $top.flab -text [mc "Output file:"]
6268 entry $top.fname -width 60
6269 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6270 grid $top.flab $top.fname -sticky w
6271 frame $top.buts
6272 button $top.buts.gen -text [mc "Write"] -command wrcomgo
6273 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
6274 grid $top.buts.gen $top.buts.can
6275 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6276 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6277 grid $top.buts - -pady 10 -sticky ew
6278 focus $top.fname
6279}
6280
6281proc wrcomgo {} {
6282 global wrcomtop
6283
6284 set id [$wrcomtop.sha1 get]
6285 set cmd "echo $id | [$wrcomtop.cmd get]"
6286 set fname [$wrcomtop.fname get]
6287 if {[catch {exec sh -c $cmd >$fname &} err]} {
6288 error_popup "[mc "Error writing commit:"] $err"
6289 }
6290 catch {destroy $wrcomtop}
6291 unset wrcomtop
6292}
6293
6294proc wrcomcan {} {
6295 global wrcomtop
6296
6297 catch {destroy $wrcomtop}
6298 unset wrcomtop
6299}
6300
6301proc mkbranch {} {
6302 global rowmenuid mkbrtop
6303
6304 set top .makebranch
6305 catch {destroy $top}
6306 toplevel $top
6307 label $top.title -text [mc "Create new branch"]
6308 grid $top.title - -pady 10
6309 label $top.id -text [mc "ID:"]
6310 entry $top.sha1 -width 40 -relief flat
6311 $top.sha1 insert 0 $rowmenuid
6312 $top.sha1 conf -state readonly
6313 grid $top.id $top.sha1 -sticky w
6314 label $top.nlab -text [mc "Name:"]
6315 entry $top.name -width 40
6316 grid $top.nlab $top.name -sticky w
6317 frame $top.buts
6318 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
6319 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
6320 grid $top.buts.go $top.buts.can
6321 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6322 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6323 grid $top.buts - -pady 10 -sticky ew
6324 focus $top.name
6325}
6326
6327proc mkbrgo {top} {
6328 global headids idheads
6329
6330 set name [$top.name get]
6331 set id [$top.sha1 get]
6332 if {$name eq {}} {
6333 error_popup [mc "Please specify a name for the new branch"]
6334 return
6335 }
6336 catch {destroy $top}
6337 nowbusy newbranch
6338 update
6339 if {[catch {
6340 exec git branch $name $id
6341 } err]} {
6342 notbusy newbranch
6343 error_popup $err
6344 } else {
6345 set headids($name) $id
6346 lappend idheads($id) $name
6347 addedhead $id $name
6348 notbusy newbranch
6349 redrawtags $id
6350 dispneartags 0
6351 run refill_reflist
6352 }
6353}
6354
6355proc cherrypick {} {
6356 global rowmenuid curview commitrow
6357 global mainhead
6358
6359 set oldhead [exec git rev-parse HEAD]
6360 set dheads [descheads $rowmenuid]
6361 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6362 set ok [confirm_popup [mc "Commit %s is already\
6363 included in branch %s -- really re-apply it?" \
6364 [string range $rowmenuid 0 7] $mainhead]]
6365 if {!$ok} return
6366 }
6367 nowbusy cherrypick [mc "Cherry-picking"]
6368 update
6369 # Unfortunately git-cherry-pick writes stuff to stderr even when
6370 # no error occurs, and exec takes that as an indication of error...
6371 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6372 notbusy cherrypick
6373 error_popup $err
6374 return
6375 }
6376 set newhead [exec git rev-parse HEAD]
6377 if {$newhead eq $oldhead} {
6378 notbusy cherrypick
6379 error_popup [mc "No changes committed"]
6380 return
6381 }
6382 addnewchild $newhead $oldhead
6383 if {[info exists commitrow($curview,$oldhead)]} {
6384 insertrow $commitrow($curview,$oldhead) $newhead
6385 if {$mainhead ne {}} {
6386 movehead $newhead $mainhead
6387 movedhead $newhead $mainhead
6388 }
6389 redrawtags $oldhead
6390 redrawtags $newhead
6391 }
6392 notbusy cherrypick
6393}
6394
6395proc resethead {} {
6396 global mainheadid mainhead rowmenuid confirm_ok resettype
6397
6398 set confirm_ok 0
6399 set w ".confirmreset"
6400 toplevel $w
6401 wm transient $w .
6402 wm title $w [mc "Confirm reset"]
6403 message $w.m -text \
6404 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
6405 -justify center -aspect 1000
6406 pack $w.m -side top -fill x -padx 20 -pady 20
6407 frame $w.f -relief sunken -border 2
6408 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
6409 grid $w.f.rt -sticky w
6410 set resettype mixed
6411 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6412 -text [mc "Soft: Leave working tree and index untouched"]
6413 grid $w.f.soft -sticky w
6414 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6415 -text [mc "Mixed: Leave working tree untouched, reset index"]
6416 grid $w.f.mixed -sticky w
6417 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6418 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
6419 grid $w.f.hard -sticky w
6420 pack $w.f -side top -fill x
6421 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
6422 pack $w.ok -side left -fill x -padx 20 -pady 20
6423 button $w.cancel -text [mc Cancel] -command "destroy $w"
6424 pack $w.cancel -side right -fill x -padx 20 -pady 20
6425 bind $w <Visibility> "grab $w; focus $w"
6426 tkwait window $w
6427 if {!$confirm_ok} return
6428 if {[catch {set fd [open \
6429 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6430 error_popup $err
6431 } else {
6432 dohidelocalchanges
6433 filerun $fd [list readresetstat $fd]
6434 nowbusy reset [mc "Resetting"]
6435 }
6436}
6437
6438proc readresetstat {fd} {
6439 global mainhead mainheadid showlocalchanges rprogcoord
6440
6441 if {[gets $fd line] >= 0} {
6442 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6443 set rprogcoord [expr {1.0 * $m / $n}]
6444 adjustprogress
6445 }
6446 return 1
6447 }
6448 set rprogcoord 0
6449 adjustprogress
6450 notbusy reset
6451 if {[catch {close $fd} err]} {
6452 error_popup $err
6453 }
6454 set oldhead $mainheadid
6455 set newhead [exec git rev-parse HEAD]
6456 if {$newhead ne $oldhead} {
6457 movehead $newhead $mainhead
6458 movedhead $newhead $mainhead
6459 set mainheadid $newhead
6460 redrawtags $oldhead
6461 redrawtags $newhead
6462 }
6463 if {$showlocalchanges} {
6464 doshowlocalchanges
6465 }
6466 return 0
6467}
6468
6469# context menu for a head
6470proc headmenu {x y id head} {
6471 global headmenuid headmenuhead headctxmenu mainhead
6472
6473 stopfinding
6474 set headmenuid $id
6475 set headmenuhead $head
6476 set state normal
6477 if {$head eq $mainhead} {
6478 set state disabled
6479 }
6480 $headctxmenu entryconfigure 0 -state $state
6481 $headctxmenu entryconfigure 1 -state $state
6482 tk_popup $headctxmenu $x $y
6483}
6484
6485proc cobranch {} {
6486 global headmenuid headmenuhead mainhead headids
6487 global showlocalchanges mainheadid
6488
6489 # check the tree is clean first??
6490 set oldmainhead $mainhead
6491 nowbusy checkout [mc "Checking out"]
6492 update
6493 dohidelocalchanges
6494 if {[catch {
6495 exec git checkout -q $headmenuhead
6496 } err]} {
6497 notbusy checkout
6498 error_popup $err
6499 } else {
6500 notbusy checkout
6501 set mainhead $headmenuhead
6502 set mainheadid $headmenuid
6503 if {[info exists headids($oldmainhead)]} {
6504 redrawtags $headids($oldmainhead)
6505 }
6506 redrawtags $headmenuid
6507 }
6508 if {$showlocalchanges} {
6509 dodiffindex
6510 }
6511}
6512
6513proc rmbranch {} {
6514 global headmenuid headmenuhead mainhead
6515 global idheads
6516
6517 set head $headmenuhead
6518 set id $headmenuid
6519 # this check shouldn't be needed any more...
6520 if {$head eq $mainhead} {
6521 error_popup [mc "Cannot delete the currently checked-out branch"]
6522 return
6523 }
6524 set dheads [descheads $id]
6525 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6526 # the stuff on this branch isn't on any other branch
6527 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
6528 branch.\nReally delete branch %s?" $head $head]]} return
6529 }
6530 nowbusy rmbranch
6531 update
6532 if {[catch {exec git branch -D $head} err]} {
6533 notbusy rmbranch
6534 error_popup $err
6535 return
6536 }
6537 removehead $id $head
6538 removedhead $id $head
6539 redrawtags $id
6540 notbusy rmbranch
6541 dispneartags 0
6542 run refill_reflist
6543}
6544
6545# Display a list of tags and heads
6546proc showrefs {} {
6547 global showrefstop bgcolor fgcolor selectbgcolor
6548 global bglist fglist reflistfilter reflist maincursor
6549
6550 set top .showrefs
6551 set showrefstop $top
6552 if {[winfo exists $top]} {
6553 raise $top
6554 refill_reflist
6555 return
6556 }
6557 toplevel $top
6558 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
6559 text $top.list -background $bgcolor -foreground $fgcolor \
6560 -selectbackground $selectbgcolor -font mainfont \
6561 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6562 -width 30 -height 20 -cursor $maincursor \
6563 -spacing1 1 -spacing3 1 -state disabled
6564 $top.list tag configure highlight -background $selectbgcolor
6565 lappend bglist $top.list
6566 lappend fglist $top.list
6567 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6568 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6569 grid $top.list $top.ysb -sticky nsew
6570 grid $top.xsb x -sticky ew
6571 frame $top.f
6572 label $top.f.l -text "[mc "Filter"]: "
6573 entry $top.f.e -width 20 -textvariable reflistfilter
6574 set reflistfilter "*"
6575 trace add variable reflistfilter write reflistfilter_change
6576 pack $top.f.e -side right -fill x -expand 1
6577 pack $top.f.l -side left
6578 grid $top.f - -sticky ew -pady 2
6579 button $top.close -command [list destroy $top] -text [mc "Close"]
6580 grid $top.close -
6581 grid columnconfigure $top 0 -weight 1
6582 grid rowconfigure $top 0 -weight 1
6583 bind $top.list <1> {break}
6584 bind $top.list <B1-Motion> {break}
6585 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6586 set reflist {}
6587 refill_reflist
6588}
6589
6590proc sel_reflist {w x y} {
6591 global showrefstop reflist headids tagids otherrefids
6592
6593 if {![winfo exists $showrefstop]} return
6594 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6595 set ref [lindex $reflist [expr {$l-1}]]
6596 set n [lindex $ref 0]
6597 switch -- [lindex $ref 1] {
6598 "H" {selbyid $headids($n)}
6599 "T" {selbyid $tagids($n)}
6600 "o" {selbyid $otherrefids($n)}
6601 }
6602 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6603}
6604
6605proc unsel_reflist {} {
6606 global showrefstop
6607
6608 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6609 $showrefstop.list tag remove highlight 0.0 end
6610}
6611
6612proc reflistfilter_change {n1 n2 op} {
6613 global reflistfilter
6614
6615 after cancel refill_reflist
6616 after 200 refill_reflist
6617}
6618
6619proc refill_reflist {} {
6620 global reflist reflistfilter showrefstop headids tagids otherrefids
6621 global commitrow curview commitinterest
6622
6623 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6624 set refs {}
6625 foreach n [array names headids] {
6626 if {[string match $reflistfilter $n]} {
6627 if {[info exists commitrow($curview,$headids($n))]} {
6628 lappend refs [list $n H]
6629 } else {
6630 set commitinterest($headids($n)) {run refill_reflist}
6631 }
6632 }
6633 }
6634 foreach n [array names tagids] {
6635 if {[string match $reflistfilter $n]} {
6636 if {[info exists commitrow($curview,$tagids($n))]} {
6637 lappend refs [list $n T]
6638 } else {
6639 set commitinterest($tagids($n)) {run refill_reflist}
6640 }
6641 }
6642 }
6643 foreach n [array names otherrefids] {
6644 if {[string match $reflistfilter $n]} {
6645 if {[info exists commitrow($curview,$otherrefids($n))]} {
6646 lappend refs [list $n o]
6647 } else {
6648 set commitinterest($otherrefids($n)) {run refill_reflist}
6649 }
6650 }
6651 }
6652 set refs [lsort -index 0 $refs]
6653 if {$refs eq $reflist} return
6654
6655 # Update the contents of $showrefstop.list according to the
6656 # differences between $reflist (old) and $refs (new)
6657 $showrefstop.list conf -state normal
6658 $showrefstop.list insert end "\n"
6659 set i 0
6660 set j 0
6661 while {$i < [llength $reflist] || $j < [llength $refs]} {
6662 if {$i < [llength $reflist]} {
6663 if {$j < [llength $refs]} {
6664 set cmp [string compare [lindex $reflist $i 0] \
6665 [lindex $refs $j 0]]
6666 if {$cmp == 0} {
6667 set cmp [string compare [lindex $reflist $i 1] \
6668 [lindex $refs $j 1]]
6669 }
6670 } else {
6671 set cmp -1
6672 }
6673 } else {
6674 set cmp 1
6675 }
6676 switch -- $cmp {
6677 -1 {
6678 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6679 incr i
6680 }
6681 0 {
6682 incr i
6683 incr j
6684 }
6685 1 {
6686 set l [expr {$j + 1}]
6687 $showrefstop.list image create $l.0 -align baseline \
6688 -image reficon-[lindex $refs $j 1] -padx 2
6689 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6690 incr j
6691 }
6692 }
6693 }
6694 set reflist $refs
6695 # delete last newline
6696 $showrefstop.list delete end-2c end-1c
6697 $showrefstop.list conf -state disabled
6698}
6699
6700# Stuff for finding nearby tags
6701proc getallcommits {} {
6702 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6703 global idheads idtags idotherrefs allparents tagobjid
6704
6705 if {![info exists allcommits]} {
6706 set nextarc 0
6707 set allcommits 0
6708 set seeds {}
6709 set allcwait 0
6710 set cachedarcs 0
6711 set allccache [file join [gitdir] "gitk.cache"]
6712 if {![catch {
6713 set f [open $allccache r]
6714 set allcwait 1
6715 getcache $f
6716 }]} return
6717 }
6718
6719 if {$allcwait} {
6720 return
6721 }
6722 set cmd [list | git rev-list --parents]
6723 set allcupdate [expr {$seeds ne {}}]
6724 if {!$allcupdate} {
6725 set ids "--all"
6726 } else {
6727 set refs [concat [array names idheads] [array names idtags] \
6728 [array names idotherrefs]]
6729 set ids {}
6730 set tagobjs {}
6731 foreach name [array names tagobjid] {
6732 lappend tagobjs $tagobjid($name)
6733 }
6734 foreach id [lsort -unique $refs] {
6735 if {![info exists allparents($id)] &&
6736 [lsearch -exact $tagobjs $id] < 0} {
6737 lappend ids $id
6738 }
6739 }
6740 if {$ids ne {}} {
6741 foreach id $seeds {
6742 lappend ids "^$id"
6743 }
6744 }
6745 }
6746 if {$ids ne {}} {
6747 set fd [open [concat $cmd $ids] r]
6748 fconfigure $fd -blocking 0
6749 incr allcommits
6750 nowbusy allcommits
6751 filerun $fd [list getallclines $fd]
6752 } else {
6753 dispneartags 0
6754 }
6755}
6756
6757# Since most commits have 1 parent and 1 child, we group strings of
6758# such commits into "arcs" joining branch/merge points (BMPs), which
6759# are commits that either don't have 1 parent or don't have 1 child.
6760#
6761# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6762# arcout(id) - outgoing arcs for BMP
6763# arcids(a) - list of IDs on arc including end but not start
6764# arcstart(a) - BMP ID at start of arc
6765# arcend(a) - BMP ID at end of arc
6766# growing(a) - arc a is still growing
6767# arctags(a) - IDs out of arcids (excluding end) that have tags
6768# archeads(a) - IDs out of arcids (excluding end) that have heads
6769# The start of an arc is at the descendent end, so "incoming" means
6770# coming from descendents, and "outgoing" means going towards ancestors.
6771
6772proc getallclines {fd} {
6773 global allparents allchildren idtags idheads nextarc
6774 global arcnos arcids arctags arcout arcend arcstart archeads growing
6775 global seeds allcommits cachedarcs allcupdate
6776
6777 set nid 0
6778 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6779 set id [lindex $line 0]
6780 if {[info exists allparents($id)]} {
6781 # seen it already
6782 continue
6783 }
6784 set cachedarcs 0
6785 set olds [lrange $line 1 end]
6786 set allparents($id) $olds
6787 if {![info exists allchildren($id)]} {
6788 set allchildren($id) {}
6789 set arcnos($id) {}
6790 lappend seeds $id
6791 } else {
6792 set a $arcnos($id)
6793 if {[llength $olds] == 1 && [llength $a] == 1} {
6794 lappend arcids($a) $id
6795 if {[info exists idtags($id)]} {
6796 lappend arctags($a) $id
6797 }
6798 if {[info exists idheads($id)]} {
6799 lappend archeads($a) $id
6800 }
6801 if {[info exists allparents($olds)]} {
6802 # seen parent already
6803 if {![info exists arcout($olds)]} {
6804 splitarc $olds
6805 }
6806 lappend arcids($a) $olds
6807 set arcend($a) $olds
6808 unset growing($a)
6809 }
6810 lappend allchildren($olds) $id
6811 lappend arcnos($olds) $a
6812 continue
6813 }
6814 }
6815 foreach a $arcnos($id) {
6816 lappend arcids($a) $id
6817 set arcend($a) $id
6818 unset growing($a)
6819 }
6820
6821 set ao {}
6822 foreach p $olds {
6823 lappend allchildren($p) $id
6824 set a [incr nextarc]
6825 set arcstart($a) $id
6826 set archeads($a) {}
6827 set arctags($a) {}
6828 set archeads($a) {}
6829 set arcids($a) {}
6830 lappend ao $a
6831 set growing($a) 1
6832 if {[info exists allparents($p)]} {
6833 # seen it already, may need to make a new branch
6834 if {![info exists arcout($p)]} {
6835 splitarc $p
6836 }
6837 lappend arcids($a) $p
6838 set arcend($a) $p
6839 unset growing($a)
6840 }
6841 lappend arcnos($p) $a
6842 }
6843 set arcout($id) $ao
6844 }
6845 if {$nid > 0} {
6846 global cached_dheads cached_dtags cached_atags
6847 catch {unset cached_dheads}
6848 catch {unset cached_dtags}
6849 catch {unset cached_atags}
6850 }
6851 if {![eof $fd]} {
6852 return [expr {$nid >= 1000? 2: 1}]
6853 }
6854 set cacheok 1
6855 if {[catch {
6856 fconfigure $fd -blocking 1
6857 close $fd
6858 } err]} {
6859 # got an error reading the list of commits
6860 # if we were updating, try rereading the whole thing again
6861 if {$allcupdate} {
6862 incr allcommits -1
6863 dropcache $err
6864 return
6865 }
6866 error_popup "[mc "Error reading commit topology information;\
6867 branch and preceding/following tag information\
6868 will be incomplete."]\n($err)"
6869 set cacheok 0
6870 }
6871 if {[incr allcommits -1] == 0} {
6872 notbusy allcommits
6873 if {$cacheok} {
6874 run savecache
6875 }
6876 }
6877 dispneartags 0
6878 return 0
6879}
6880
6881proc recalcarc {a} {
6882 global arctags archeads arcids idtags idheads
6883
6884 set at {}
6885 set ah {}
6886 foreach id [lrange $arcids($a) 0 end-1] {
6887 if {[info exists idtags($id)]} {
6888 lappend at $id
6889 }
6890 if {[info exists idheads($id)]} {
6891 lappend ah $id
6892 }
6893 }
6894 set arctags($a) $at
6895 set archeads($a) $ah
6896}
6897
6898proc splitarc {p} {
6899 global arcnos arcids nextarc arctags archeads idtags idheads
6900 global arcstart arcend arcout allparents growing
6901
6902 set a $arcnos($p)
6903 if {[llength $a] != 1} {
6904 puts "oops splitarc called but [llength $a] arcs already"
6905 return
6906 }
6907 set a [lindex $a 0]
6908 set i [lsearch -exact $arcids($a) $p]
6909 if {$i < 0} {
6910 puts "oops splitarc $p not in arc $a"
6911 return
6912 }
6913 set na [incr nextarc]
6914 if {[info exists arcend($a)]} {
6915 set arcend($na) $arcend($a)
6916 } else {
6917 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6918 set j [lsearch -exact $arcnos($l) $a]
6919 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6920 }
6921 set tail [lrange $arcids($a) [expr {$i+1}] end]
6922 set arcids($a) [lrange $arcids($a) 0 $i]
6923 set arcend($a) $p
6924 set arcstart($na) $p
6925 set arcout($p) $na
6926 set arcids($na) $tail
6927 if {[info exists growing($a)]} {
6928 set growing($na) 1
6929 unset growing($a)
6930 }
6931
6932 foreach id $tail {
6933 if {[llength $arcnos($id)] == 1} {
6934 set arcnos($id) $na
6935 } else {
6936 set j [lsearch -exact $arcnos($id) $a]
6937 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6938 }
6939 }
6940
6941 # reconstruct tags and heads lists
6942 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6943 recalcarc $a
6944 recalcarc $na
6945 } else {
6946 set arctags($na) {}
6947 set archeads($na) {}
6948 }
6949}
6950
6951# Update things for a new commit added that is a child of one
6952# existing commit. Used when cherry-picking.
6953proc addnewchild {id p} {
6954 global allparents allchildren idtags nextarc
6955 global arcnos arcids arctags arcout arcend arcstart archeads growing
6956 global seeds allcommits
6957
6958 if {![info exists allcommits] || ![info exists arcnos($p)]} return
6959 set allparents($id) [list $p]
6960 set allchildren($id) {}
6961 set arcnos($id) {}
6962 lappend seeds $id
6963 lappend allchildren($p) $id
6964 set a [incr nextarc]
6965 set arcstart($a) $id
6966 set archeads($a) {}
6967 set arctags($a) {}
6968 set arcids($a) [list $p]
6969 set arcend($a) $p
6970 if {![info exists arcout($p)]} {
6971 splitarc $p
6972 }
6973 lappend arcnos($p) $a
6974 set arcout($id) [list $a]
6975}
6976
6977# This implements a cache for the topology information.
6978# The cache saves, for each arc, the start and end of the arc,
6979# the ids on the arc, and the outgoing arcs from the end.
6980proc readcache {f} {
6981 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6982 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6983 global allcwait
6984
6985 set a $nextarc
6986 set lim $cachedarcs
6987 if {$lim - $a > 500} {
6988 set lim [expr {$a + 500}]
6989 }
6990 if {[catch {
6991 if {$a == $lim} {
6992 # finish reading the cache and setting up arctags, etc.
6993 set line [gets $f]
6994 if {$line ne "1"} {error "bad final version"}
6995 close $f
6996 foreach id [array names idtags] {
6997 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6998 [llength $allparents($id)] == 1} {
6999 set a [lindex $arcnos($id) 0]
7000 if {$arctags($a) eq {}} {
7001 recalcarc $a
7002 }
7003 }
7004 }
7005 foreach id [array names idheads] {
7006 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7007 [llength $allparents($id)] == 1} {
7008 set a [lindex $arcnos($id) 0]
7009 if {$archeads($a) eq {}} {
7010 recalcarc $a
7011 }
7012 }
7013 }
7014 foreach id [lsort -unique $possible_seeds] {
7015 if {$arcnos($id) eq {}} {
7016 lappend seeds $id
7017 }
7018 }
7019 set allcwait 0
7020 } else {
7021 while {[incr a] <= $lim} {
7022 set line [gets $f]
7023 if {[llength $line] != 3} {error "bad line"}
7024 set s [lindex $line 0]
7025 set arcstart($a) $s
7026 lappend arcout($s) $a
7027 if {![info exists arcnos($s)]} {
7028 lappend possible_seeds $s
7029 set arcnos($s) {}
7030 }
7031 set e [lindex $line 1]
7032 if {$e eq {}} {
7033 set growing($a) 1
7034 } else {
7035 set arcend($a) $e
7036 if {![info exists arcout($e)]} {
7037 set arcout($e) {}
7038 }
7039 }
7040 set arcids($a) [lindex $line 2]
7041 foreach id $arcids($a) {
7042 lappend allparents($s) $id
7043 set s $id
7044 lappend arcnos($id) $a
7045 }
7046 if {![info exists allparents($s)]} {
7047 set allparents($s) {}
7048 }
7049 set arctags($a) {}
7050 set archeads($a) {}
7051 }
7052 set nextarc [expr {$a - 1}]
7053 }
7054 } err]} {
7055 dropcache $err
7056 return 0
7057 }
7058 if {!$allcwait} {
7059 getallcommits
7060 }
7061 return $allcwait
7062}
7063
7064proc getcache {f} {
7065 global nextarc cachedarcs possible_seeds
7066
7067 if {[catch {
7068 set line [gets $f]
7069 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7070 # make sure it's an integer
7071 set cachedarcs [expr {int([lindex $line 1])}]
7072 if {$cachedarcs < 0} {error "bad number of arcs"}
7073 set nextarc 0
7074 set possible_seeds {}
7075 run readcache $f
7076 } err]} {
7077 dropcache $err
7078 }
7079 return 0
7080}
7081
7082proc dropcache {err} {
7083 global allcwait nextarc cachedarcs seeds
7084
7085 #puts "dropping cache ($err)"
7086 foreach v {arcnos arcout arcids arcstart arcend growing \
7087 arctags archeads allparents allchildren} {
7088 global $v
7089 catch {unset $v}
7090 }
7091 set allcwait 0
7092 set nextarc 0
7093 set cachedarcs 0
7094 set seeds {}
7095 getallcommits
7096}
7097
7098proc writecache {f} {
7099 global cachearc cachedarcs allccache
7100 global arcstart arcend arcnos arcids arcout
7101
7102 set a $cachearc
7103 set lim $cachedarcs
7104 if {$lim - $a > 1000} {
7105 set lim [expr {$a + 1000}]
7106 }
7107 if {[catch {
7108 while {[incr a] <= $lim} {
7109 if {[info exists arcend($a)]} {
7110 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7111 } else {
7112 puts $f [list $arcstart($a) {} $arcids($a)]
7113 }
7114 }
7115 } err]} {
7116 catch {close $f}
7117 catch {file delete $allccache}
7118 #puts "writing cache failed ($err)"
7119 return 0
7120 }
7121 set cachearc [expr {$a - 1}]
7122 if {$a > $cachedarcs} {
7123 puts $f "1"
7124 close $f
7125 return 0
7126 }
7127 return 1
7128}
7129
7130proc savecache {} {
7131 global nextarc cachedarcs cachearc allccache
7132
7133 if {$nextarc == $cachedarcs} return
7134 set cachearc 0
7135 set cachedarcs $nextarc
7136 catch {
7137 set f [open $allccache w]
7138 puts $f [list 1 $cachedarcs]
7139 run writecache $f
7140 }
7141}
7142
7143# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7144# or 0 if neither is true.
7145proc anc_or_desc {a b} {
7146 global arcout arcstart arcend arcnos cached_isanc
7147
7148 if {$arcnos($a) eq $arcnos($b)} {
7149 # Both are on the same arc(s); either both are the same BMP,
7150 # or if one is not a BMP, the other is also not a BMP or is
7151 # the BMP at end of the arc (and it only has 1 incoming arc).
7152 # Or both can be BMPs with no incoming arcs.
7153 if {$a eq $b || $arcnos($a) eq {}} {
7154 return 0
7155 }
7156 # assert {[llength $arcnos($a)] == 1}
7157 set arc [lindex $arcnos($a) 0]
7158 set i [lsearch -exact $arcids($arc) $a]
7159 set j [lsearch -exact $arcids($arc) $b]
7160 if {$i < 0 || $i > $j} {
7161 return 1
7162 } else {
7163 return -1
7164 }
7165 }
7166
7167 if {![info exists arcout($a)]} {
7168 set arc [lindex $arcnos($a) 0]
7169 if {[info exists arcend($arc)]} {
7170 set aend $arcend($arc)
7171 } else {
7172 set aend {}
7173 }
7174 set a $arcstart($arc)
7175 } else {
7176 set aend $a
7177 }
7178 if {![info exists arcout($b)]} {
7179 set arc [lindex $arcnos($b) 0]
7180 if {[info exists arcend($arc)]} {
7181 set bend $arcend($arc)
7182 } else {
7183 set bend {}
7184 }
7185 set b $arcstart($arc)
7186 } else {
7187 set bend $b
7188 }
7189 if {$a eq $bend} {
7190 return 1
7191 }
7192 if {$b eq $aend} {
7193 return -1
7194 }
7195 if {[info exists cached_isanc($a,$bend)]} {
7196 if {$cached_isanc($a,$bend)} {
7197 return 1
7198 }
7199 }
7200 if {[info exists cached_isanc($b,$aend)]} {
7201 if {$cached_isanc($b,$aend)} {
7202 return -1
7203 }
7204 if {[info exists cached_isanc($a,$bend)]} {
7205 return 0
7206 }
7207 }
7208
7209 set todo [list $a $b]
7210 set anc($a) a
7211 set anc($b) b
7212 for {set i 0} {$i < [llength $todo]} {incr i} {
7213 set x [lindex $todo $i]
7214 if {$anc($x) eq {}} {
7215 continue
7216 }
7217 foreach arc $arcnos($x) {
7218 set xd $arcstart($arc)
7219 if {$xd eq $bend} {
7220 set cached_isanc($a,$bend) 1
7221 set cached_isanc($b,$aend) 0
7222 return 1
7223 } elseif {$xd eq $aend} {
7224 set cached_isanc($b,$aend) 1
7225 set cached_isanc($a,$bend) 0
7226 return -1
7227 }
7228 if {![info exists anc($xd)]} {
7229 set anc($xd) $anc($x)
7230 lappend todo $xd
7231 } elseif {$anc($xd) ne $anc($x)} {
7232 set anc($xd) {}
7233 }
7234 }
7235 }
7236 set cached_isanc($a,$bend) 0
7237 set cached_isanc($b,$aend) 0
7238 return 0
7239}
7240
7241# This identifies whether $desc has an ancestor that is
7242# a growing tip of the graph and which is not an ancestor of $anc
7243# and returns 0 if so and 1 if not.
7244# If we subsequently discover a tag on such a growing tip, and that
7245# turns out to be a descendent of $anc (which it could, since we
7246# don't necessarily see children before parents), then $desc
7247# isn't a good choice to display as a descendent tag of
7248# $anc (since it is the descendent of another tag which is
7249# a descendent of $anc). Similarly, $anc isn't a good choice to
7250# display as a ancestor tag of $desc.
7251#
7252proc is_certain {desc anc} {
7253 global arcnos arcout arcstart arcend growing problems
7254
7255 set certain {}
7256 if {[llength $arcnos($anc)] == 1} {
7257 # tags on the same arc are certain
7258 if {$arcnos($desc) eq $arcnos($anc)} {
7259 return 1
7260 }
7261 if {![info exists arcout($anc)]} {
7262 # if $anc is partway along an arc, use the start of the arc instead
7263 set a [lindex $arcnos($anc) 0]
7264 set anc $arcstart($a)
7265 }
7266 }
7267 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7268 set x $desc
7269 } else {
7270 set a [lindex $arcnos($desc) 0]
7271 set x $arcend($a)
7272 }
7273 if {$x == $anc} {
7274 return 1
7275 }
7276 set anclist [list $x]
7277 set dl($x) 1
7278 set nnh 1
7279 set ngrowanc 0
7280 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7281 set x [lindex $anclist $i]
7282 if {$dl($x)} {
7283 incr nnh -1
7284 }
7285 set done($x) 1
7286 foreach a $arcout($x) {
7287 if {[info exists growing($a)]} {
7288 if {![info exists growanc($x)] && $dl($x)} {
7289 set growanc($x) 1
7290 incr ngrowanc
7291 }
7292 } else {
7293 set y $arcend($a)
7294 if {[info exists dl($y)]} {
7295 if {$dl($y)} {
7296 if {!$dl($x)} {
7297 set dl($y) 0
7298 if {![info exists done($y)]} {
7299 incr nnh -1
7300 }
7301 if {[info exists growanc($x)]} {
7302 incr ngrowanc -1
7303 }
7304 set xl [list $y]
7305 for {set k 0} {$k < [llength $xl]} {incr k} {
7306 set z [lindex $xl $k]
7307 foreach c $arcout($z) {
7308 if {[info exists arcend($c)]} {
7309 set v $arcend($c)
7310 if {[info exists dl($v)] && $dl($v)} {
7311 set dl($v) 0
7312 if {![info exists done($v)]} {
7313 incr nnh -1
7314 }
7315 if {[info exists growanc($v)]} {
7316 incr ngrowanc -1
7317 }
7318 lappend xl $v
7319 }
7320 }
7321 }
7322 }
7323 }
7324 }
7325 } elseif {$y eq $anc || !$dl($x)} {
7326 set dl($y) 0
7327 lappend anclist $y
7328 } else {
7329 set dl($y) 1
7330 lappend anclist $y
7331 incr nnh
7332 }
7333 }
7334 }
7335 }
7336 foreach x [array names growanc] {
7337 if {$dl($x)} {
7338 return 0
7339 }
7340 return 0
7341 }
7342 return 1
7343}
7344
7345proc validate_arctags {a} {
7346 global arctags idtags
7347
7348 set i -1
7349 set na $arctags($a)
7350 foreach id $arctags($a) {
7351 incr i
7352 if {![info exists idtags($id)]} {
7353 set na [lreplace $na $i $i]
7354 incr i -1
7355 }
7356 }
7357 set arctags($a) $na
7358}
7359
7360proc validate_archeads {a} {
7361 global archeads idheads
7362
7363 set i -1
7364 set na $archeads($a)
7365 foreach id $archeads($a) {
7366 incr i
7367 if {![info exists idheads($id)]} {
7368 set na [lreplace $na $i $i]
7369 incr i -1
7370 }
7371 }
7372 set archeads($a) $na
7373}
7374
7375# Return the list of IDs that have tags that are descendents of id,
7376# ignoring IDs that are descendents of IDs already reported.
7377proc desctags {id} {
7378 global arcnos arcstart arcids arctags idtags allparents
7379 global growing cached_dtags
7380
7381 if {![info exists allparents($id)]} {
7382 return {}
7383 }
7384 set t1 [clock clicks -milliseconds]
7385 set argid $id
7386 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7387 # part-way along an arc; check that arc first
7388 set a [lindex $arcnos($id) 0]
7389 if {$arctags($a) ne {}} {
7390 validate_arctags $a
7391 set i [lsearch -exact $arcids($a) $id]
7392 set tid {}
7393 foreach t $arctags($a) {
7394 set j [lsearch -exact $arcids($a) $t]
7395 if {$j >= $i} break
7396 set tid $t
7397 }
7398 if {$tid ne {}} {
7399 return $tid
7400 }
7401 }
7402 set id $arcstart($a)
7403 if {[info exists idtags($id)]} {
7404 return $id
7405 }
7406 }
7407 if {[info exists cached_dtags($id)]} {
7408 return $cached_dtags($id)
7409 }
7410
7411 set origid $id
7412 set todo [list $id]
7413 set queued($id) 1
7414 set nc 1
7415 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7416 set id [lindex $todo $i]
7417 set done($id) 1
7418 set ta [info exists hastaggedancestor($id)]
7419 if {!$ta} {
7420 incr nc -1
7421 }
7422 # ignore tags on starting node
7423 if {!$ta && $i > 0} {
7424 if {[info exists idtags($id)]} {
7425 set tagloc($id) $id
7426 set ta 1
7427 } elseif {[info exists cached_dtags($id)]} {
7428 set tagloc($id) $cached_dtags($id)
7429 set ta 1
7430 }
7431 }
7432 foreach a $arcnos($id) {
7433 set d $arcstart($a)
7434 if {!$ta && $arctags($a) ne {}} {
7435 validate_arctags $a
7436 if {$arctags($a) ne {}} {
7437 lappend tagloc($id) [lindex $arctags($a) end]
7438 }
7439 }
7440 if {$ta || $arctags($a) ne {}} {
7441 set tomark [list $d]
7442 for {set j 0} {$j < [llength $tomark]} {incr j} {
7443 set dd [lindex $tomark $j]
7444 if {![info exists hastaggedancestor($dd)]} {
7445 if {[info exists done($dd)]} {
7446 foreach b $arcnos($dd) {
7447 lappend tomark $arcstart($b)
7448 }
7449 if {[info exists tagloc($dd)]} {
7450 unset tagloc($dd)
7451 }
7452 } elseif {[info exists queued($dd)]} {
7453 incr nc -1
7454 }
7455 set hastaggedancestor($dd) 1
7456 }
7457 }
7458 }
7459 if {![info exists queued($d)]} {
7460 lappend todo $d
7461 set queued($d) 1
7462 if {![info exists hastaggedancestor($d)]} {
7463 incr nc
7464 }
7465 }
7466 }
7467 }
7468 set tags {}
7469 foreach id [array names tagloc] {
7470 if {![info exists hastaggedancestor($id)]} {
7471 foreach t $tagloc($id) {
7472 if {[lsearch -exact $tags $t] < 0} {
7473 lappend tags $t
7474 }
7475 }
7476 }
7477 }
7478 set t2 [clock clicks -milliseconds]
7479 set loopix $i
7480
7481 # remove tags that are descendents of other tags
7482 for {set i 0} {$i < [llength $tags]} {incr i} {
7483 set a [lindex $tags $i]
7484 for {set j 0} {$j < $i} {incr j} {
7485 set b [lindex $tags $j]
7486 set r [anc_or_desc $a $b]
7487 if {$r == 1} {
7488 set tags [lreplace $tags $j $j]
7489 incr j -1
7490 incr i -1
7491 } elseif {$r == -1} {
7492 set tags [lreplace $tags $i $i]
7493 incr i -1
7494 break
7495 }
7496 }
7497 }
7498
7499 if {[array names growing] ne {}} {
7500 # graph isn't finished, need to check if any tag could get
7501 # eclipsed by another tag coming later. Simply ignore any
7502 # tags that could later get eclipsed.
7503 set ctags {}
7504 foreach t $tags {
7505 if {[is_certain $t $origid]} {
7506 lappend ctags $t
7507 }
7508 }
7509 if {$tags eq $ctags} {
7510 set cached_dtags($origid) $tags
7511 } else {
7512 set tags $ctags
7513 }
7514 } else {
7515 set cached_dtags($origid) $tags
7516 }
7517 set t3 [clock clicks -milliseconds]
7518 if {0 && $t3 - $t1 >= 100} {
7519 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7520 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7521 }
7522 return $tags
7523}
7524
7525proc anctags {id} {
7526 global arcnos arcids arcout arcend arctags idtags allparents
7527 global growing cached_atags
7528
7529 if {![info exists allparents($id)]} {
7530 return {}
7531 }
7532 set t1 [clock clicks -milliseconds]
7533 set argid $id
7534 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7535 # part-way along an arc; check that arc first
7536 set a [lindex $arcnos($id) 0]
7537 if {$arctags($a) ne {}} {
7538 validate_arctags $a
7539 set i [lsearch -exact $arcids($a) $id]
7540 foreach t $arctags($a) {
7541 set j [lsearch -exact $arcids($a) $t]
7542 if {$j > $i} {
7543 return $t
7544 }
7545 }
7546 }
7547 if {![info exists arcend($a)]} {
7548 return {}
7549 }
7550 set id $arcend($a)
7551 if {[info exists idtags($id)]} {
7552 return $id
7553 }
7554 }
7555 if {[info exists cached_atags($id)]} {
7556 return $cached_atags($id)
7557 }
7558
7559 set origid $id
7560 set todo [list $id]
7561 set queued($id) 1
7562 set taglist {}
7563 set nc 1
7564 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7565 set id [lindex $todo $i]
7566 set done($id) 1
7567 set td [info exists hastaggeddescendent($id)]
7568 if {!$td} {
7569 incr nc -1
7570 }
7571 # ignore tags on starting node
7572 if {!$td && $i > 0} {
7573 if {[info exists idtags($id)]} {
7574 set tagloc($id) $id
7575 set td 1
7576 } elseif {[info exists cached_atags($id)]} {
7577 set tagloc($id) $cached_atags($id)
7578 set td 1
7579 }
7580 }
7581 foreach a $arcout($id) {
7582 if {!$td && $arctags($a) ne {}} {
7583 validate_arctags $a
7584 if {$arctags($a) ne {}} {
7585 lappend tagloc($id) [lindex $arctags($a) 0]
7586 }
7587 }
7588 if {![info exists arcend($a)]} continue
7589 set d $arcend($a)
7590 if {$td || $arctags($a) ne {}} {
7591 set tomark [list $d]
7592 for {set j 0} {$j < [llength $tomark]} {incr j} {
7593 set dd [lindex $tomark $j]
7594 if {![info exists hastaggeddescendent($dd)]} {
7595 if {[info exists done($dd)]} {
7596 foreach b $arcout($dd) {
7597 if {[info exists arcend($b)]} {
7598 lappend tomark $arcend($b)
7599 }
7600 }
7601 if {[info exists tagloc($dd)]} {
7602 unset tagloc($dd)
7603 }
7604 } elseif {[info exists queued($dd)]} {
7605 incr nc -1
7606 }
7607 set hastaggeddescendent($dd) 1
7608 }
7609 }
7610 }
7611 if {![info exists queued($d)]} {
7612 lappend todo $d
7613 set queued($d) 1
7614 if {![info exists hastaggeddescendent($d)]} {
7615 incr nc
7616 }
7617 }
7618 }
7619 }
7620 set t2 [clock clicks -milliseconds]
7621 set loopix $i
7622 set tags {}
7623 foreach id [array names tagloc] {
7624 if {![info exists hastaggeddescendent($id)]} {
7625 foreach t $tagloc($id) {
7626 if {[lsearch -exact $tags $t] < 0} {
7627 lappend tags $t
7628 }
7629 }
7630 }
7631 }
7632
7633 # remove tags that are ancestors of other tags
7634 for {set i 0} {$i < [llength $tags]} {incr i} {
7635 set a [lindex $tags $i]
7636 for {set j 0} {$j < $i} {incr j} {
7637 set b [lindex $tags $j]
7638 set r [anc_or_desc $a $b]
7639 if {$r == -1} {
7640 set tags [lreplace $tags $j $j]
7641 incr j -1
7642 incr i -1
7643 } elseif {$r == 1} {
7644 set tags [lreplace $tags $i $i]
7645 incr i -1
7646 break
7647 }
7648 }
7649 }
7650
7651 if {[array names growing] ne {}} {
7652 # graph isn't finished, need to check if any tag could get
7653 # eclipsed by another tag coming later. Simply ignore any
7654 # tags that could later get eclipsed.
7655 set ctags {}
7656 foreach t $tags {
7657 if {[is_certain $origid $t]} {
7658 lappend ctags $t
7659 }
7660 }
7661 if {$tags eq $ctags} {
7662 set cached_atags($origid) $tags
7663 } else {
7664 set tags $ctags
7665 }
7666 } else {
7667 set cached_atags($origid) $tags
7668 }
7669 set t3 [clock clicks -milliseconds]
7670 if {0 && $t3 - $t1 >= 100} {
7671 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7672 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7673 }
7674 return $tags
7675}
7676
7677# Return the list of IDs that have heads that are descendents of id,
7678# including id itself if it has a head.
7679proc descheads {id} {
7680 global arcnos arcstart arcids archeads idheads cached_dheads
7681 global allparents
7682
7683 if {![info exists allparents($id)]} {
7684 return {}
7685 }
7686 set aret {}
7687 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7688 # part-way along an arc; check it first
7689 set a [lindex $arcnos($id) 0]
7690 if {$archeads($a) ne {}} {
7691 validate_archeads $a
7692 set i [lsearch -exact $arcids($a) $id]
7693 foreach t $archeads($a) {
7694 set j [lsearch -exact $arcids($a) $t]
7695 if {$j > $i} break
7696 lappend aret $t
7697 }
7698 }
7699 set id $arcstart($a)
7700 }
7701 set origid $id
7702 set todo [list $id]
7703 set seen($id) 1
7704 set ret {}
7705 for {set i 0} {$i < [llength $todo]} {incr i} {
7706 set id [lindex $todo $i]
7707 if {[info exists cached_dheads($id)]} {
7708 set ret [concat $ret $cached_dheads($id)]
7709 } else {
7710 if {[info exists idheads($id)]} {
7711 lappend ret $id
7712 }
7713 foreach a $arcnos($id) {
7714 if {$archeads($a) ne {}} {
7715 validate_archeads $a
7716 if {$archeads($a) ne {}} {
7717 set ret [concat $ret $archeads($a)]
7718 }
7719 }
7720 set d $arcstart($a)
7721 if {![info exists seen($d)]} {
7722 lappend todo $d
7723 set seen($d) 1
7724 }
7725 }
7726 }
7727 }
7728 set ret [lsort -unique $ret]
7729 set cached_dheads($origid) $ret
7730 return [concat $ret $aret]
7731}
7732
7733proc addedtag {id} {
7734 global arcnos arcout cached_dtags cached_atags
7735
7736 if {![info exists arcnos($id)]} return
7737 if {![info exists arcout($id)]} {
7738 recalcarc [lindex $arcnos($id) 0]
7739 }
7740 catch {unset cached_dtags}
7741 catch {unset cached_atags}
7742}
7743
7744proc addedhead {hid head} {
7745 global arcnos arcout cached_dheads
7746
7747 if {![info exists arcnos($hid)]} return
7748 if {![info exists arcout($hid)]} {
7749 recalcarc [lindex $arcnos($hid) 0]
7750 }
7751 catch {unset cached_dheads}
7752}
7753
7754proc removedhead {hid head} {
7755 global cached_dheads
7756
7757 catch {unset cached_dheads}
7758}
7759
7760proc movedhead {hid head} {
7761 global arcnos arcout cached_dheads
7762
7763 if {![info exists arcnos($hid)]} return
7764 if {![info exists arcout($hid)]} {
7765 recalcarc [lindex $arcnos($hid) 0]
7766 }
7767 catch {unset cached_dheads}
7768}
7769
7770proc changedrefs {} {
7771 global cached_dheads cached_dtags cached_atags
7772 global arctags archeads arcnos arcout idheads idtags
7773
7774 foreach id [concat [array names idheads] [array names idtags]] {
7775 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7776 set a [lindex $arcnos($id) 0]
7777 if {![info exists donearc($a)]} {
7778 recalcarc $a
7779 set donearc($a) 1
7780 }
7781 }
7782 }
7783 catch {unset cached_dtags}
7784 catch {unset cached_atags}
7785 catch {unset cached_dheads}
7786}
7787
7788proc rereadrefs {} {
7789 global idtags idheads idotherrefs mainhead
7790
7791 set refids [concat [array names idtags] \
7792 [array names idheads] [array names idotherrefs]]
7793 foreach id $refids {
7794 if {![info exists ref($id)]} {
7795 set ref($id) [listrefs $id]
7796 }
7797 }
7798 set oldmainhead $mainhead
7799 readrefs
7800 changedrefs
7801 set refids [lsort -unique [concat $refids [array names idtags] \
7802 [array names idheads] [array names idotherrefs]]]
7803 foreach id $refids {
7804 set v [listrefs $id]
7805 if {![info exists ref($id)] || $ref($id) != $v ||
7806 ($id eq $oldmainhead && $id ne $mainhead) ||
7807 ($id eq $mainhead && $id ne $oldmainhead)} {
7808 redrawtags $id
7809 }
7810 }
7811 run refill_reflist
7812}
7813
7814proc listrefs {id} {
7815 global idtags idheads idotherrefs
7816
7817 set x {}
7818 if {[info exists idtags($id)]} {
7819 set x $idtags($id)
7820 }
7821 set y {}
7822 if {[info exists idheads($id)]} {
7823 set y $idheads($id)
7824 }
7825 set z {}
7826 if {[info exists idotherrefs($id)]} {
7827 set z $idotherrefs($id)
7828 }
7829 return [list $x $y $z]
7830}
7831
7832proc showtag {tag isnew} {
7833 global ctext tagcontents tagids linknum tagobjid
7834
7835 if {$isnew} {
7836 addtohistory [list showtag $tag 0]
7837 }
7838 $ctext conf -state normal
7839 clear_ctext
7840 settabs 0
7841 set linknum 0
7842 if {![info exists tagcontents($tag)]} {
7843 catch {
7844 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7845 }
7846 }
7847 if {[info exists tagcontents($tag)]} {
7848 set text $tagcontents($tag)
7849 } else {
7850 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
7851 }
7852 appendwithlinks $text {}
7853 $ctext conf -state disabled
7854 init_flist {}
7855}
7856
7857proc doquit {} {
7858 global stopped
7859 set stopped 100
7860 savestuff .
7861 destroy .
7862}
7863
7864proc mkfontdisp {font top which} {
7865 global fontattr fontpref $font
7866
7867 set fontpref($font) [set $font]
7868 button $top.${font}but -text $which -font optionfont \
7869 -command [list choosefont $font $which]
7870 label $top.$font -relief flat -font $font \
7871 -text $fontattr($font,family) -justify left
7872 grid x $top.${font}but $top.$font -sticky w
7873}
7874
7875proc choosefont {font which} {
7876 global fontparam fontlist fonttop fontattr
7877
7878 set fontparam(which) $which
7879 set fontparam(font) $font
7880 set fontparam(family) [font actual $font -family]
7881 set fontparam(size) $fontattr($font,size)
7882 set fontparam(weight) $fontattr($font,weight)
7883 set fontparam(slant) $fontattr($font,slant)
7884 set top .gitkfont
7885 set fonttop $top
7886 if {![winfo exists $top]} {
7887 font create sample
7888 eval font config sample [font actual $font]
7889 toplevel $top
7890 wm title $top [mc "Gitk font chooser"]
7891 label $top.l -textvariable fontparam(which)
7892 pack $top.l -side top
7893 set fontlist [lsort [font families]]
7894 frame $top.f
7895 listbox $top.f.fam -listvariable fontlist \
7896 -yscrollcommand [list $top.f.sb set]
7897 bind $top.f.fam <<ListboxSelect>> selfontfam
7898 scrollbar $top.f.sb -command [list $top.f.fam yview]
7899 pack $top.f.sb -side right -fill y
7900 pack $top.f.fam -side left -fill both -expand 1
7901 pack $top.f -side top -fill both -expand 1
7902 frame $top.g
7903 spinbox $top.g.size -from 4 -to 40 -width 4 \
7904 -textvariable fontparam(size) \
7905 -validatecommand {string is integer -strict %s}
7906 checkbutton $top.g.bold -padx 5 \
7907 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
7908 -variable fontparam(weight) -onvalue bold -offvalue normal
7909 checkbutton $top.g.ital -padx 5 \
7910 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
7911 -variable fontparam(slant) -onvalue italic -offvalue roman
7912 pack $top.g.size $top.g.bold $top.g.ital -side left
7913 pack $top.g -side top
7914 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7915 -background white
7916 $top.c create text 100 25 -anchor center -text $which -font sample \
7917 -fill black -tags text
7918 bind $top.c <Configure> [list centertext $top.c]
7919 pack $top.c -side top -fill x
7920 frame $top.buts
7921 button $top.buts.ok -text [mc "OK"] -command fontok -default active
7922 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
7923 grid $top.buts.ok $top.buts.can
7924 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7925 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7926 pack $top.buts -side bottom -fill x
7927 trace add variable fontparam write chg_fontparam
7928 } else {
7929 raise $top
7930 $top.c itemconf text -text $which
7931 }
7932 set i [lsearch -exact $fontlist $fontparam(family)]
7933 if {$i >= 0} {
7934 $top.f.fam selection set $i
7935 $top.f.fam see $i
7936 }
7937}
7938
7939proc centertext {w} {
7940 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7941}
7942
7943proc fontok {} {
7944 global fontparam fontpref prefstop
7945
7946 set f $fontparam(font)
7947 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7948 if {$fontparam(weight) eq "bold"} {
7949 lappend fontpref($f) "bold"
7950 }
7951 if {$fontparam(slant) eq "italic"} {
7952 lappend fontpref($f) "italic"
7953 }
7954 set w $prefstop.$f
7955 $w conf -text $fontparam(family) -font $fontpref($f)
7956
7957 fontcan
7958}
7959
7960proc fontcan {} {
7961 global fonttop fontparam
7962
7963 if {[info exists fonttop]} {
7964 catch {destroy $fonttop}
7965 catch {font delete sample}
7966 unset fonttop
7967 unset fontparam
7968 }
7969}
7970
7971proc selfontfam {} {
7972 global fonttop fontparam
7973
7974 set i [$fonttop.f.fam curselection]
7975 if {$i ne {}} {
7976 set fontparam(family) [$fonttop.f.fam get $i]
7977 }
7978}
7979
7980proc chg_fontparam {v sub op} {
7981 global fontparam
7982
7983 font config sample -$sub $fontparam($sub)
7984}
7985
7986proc doprefs {} {
7987 global maxwidth maxgraphpct
7988 global oldprefs prefstop showneartags showlocalchanges
7989 global bgcolor fgcolor ctext diffcolors selectbgcolor
7990 global tabstop limitdiffs autoselect
7991
7992 set top .gitkprefs
7993 set prefstop $top
7994 if {[winfo exists $top]} {
7995 raise $top
7996 return
7997 }
7998 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
7999 limitdiffs tabstop} {
8000 set oldprefs($v) [set $v]
8001 }
8002 toplevel $top
8003 wm title $top [mc "Gitk preferences"]
8004 label $top.ldisp -text [mc "Commit list display options"]
8005 grid $top.ldisp - -sticky w -pady 10
8006 label $top.spacer -text " "
8007 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8008 -font optionfont
8009 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8010 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8011 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8012 -font optionfont
8013 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8014 grid x $top.maxpctl $top.maxpct -sticky w
8015 frame $top.showlocal
8016 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8017 checkbutton $top.showlocal.b -variable showlocalchanges
8018 pack $top.showlocal.b $top.showlocal.l -side left
8019 grid x $top.showlocal -sticky w
8020 frame $top.autoselect
8021 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
8022 checkbutton $top.autoselect.b -variable autoselect
8023 pack $top.autoselect.b $top.autoselect.l -side left
8024 grid x $top.autoselect -sticky w
8025
8026 label $top.ddisp -text [mc "Diff display options"]
8027 grid $top.ddisp - -sticky w -pady 10
8028 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8029 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8030 grid x $top.tabstopl $top.tabstop -sticky w
8031 frame $top.ntag
8032 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8033 checkbutton $top.ntag.b -variable showneartags
8034 pack $top.ntag.b $top.ntag.l -side left
8035 grid x $top.ntag -sticky w
8036 frame $top.ldiff
8037 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8038 checkbutton $top.ldiff.b -variable limitdiffs
8039 pack $top.ldiff.b $top.ldiff.l -side left
8040 grid x $top.ldiff -sticky w
8041
8042 label $top.cdisp -text [mc "Colors: press to choose"]
8043 grid $top.cdisp - -sticky w -pady 10
8044 label $top.bg -padx 40 -relief sunk -background $bgcolor
8045 button $top.bgbut -text [mc "Background"] -font optionfont \
8046 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8047 grid x $top.bgbut $top.bg -sticky w
8048 label $top.fg -padx 40 -relief sunk -background $fgcolor
8049 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8050 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8051 grid x $top.fgbut $top.fg -sticky w
8052 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8053 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8054 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8055 [list $ctext tag conf d0 -foreground]]
8056 grid x $top.diffoldbut $top.diffold -sticky w
8057 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8058 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8059 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8060 [list $ctext tag conf d1 -foreground]]
8061 grid x $top.diffnewbut $top.diffnew -sticky w
8062 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8063 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8064 -command [list choosecolor diffcolors 2 $top.hunksep \
8065 "diff hunk header" \
8066 [list $ctext tag conf hunksep -foreground]]
8067 grid x $top.hunksepbut $top.hunksep -sticky w
8068 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8069 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8070 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8071 grid x $top.selbgbut $top.selbgsep -sticky w
8072
8073 label $top.cfont -text [mc "Fonts: press to choose"]
8074 grid $top.cfont - -sticky w -pady 10
8075 mkfontdisp mainfont $top [mc "Main font"]
8076 mkfontdisp textfont $top [mc "Diff display font"]
8077 mkfontdisp uifont $top [mc "User interface font"]
8078
8079 frame $top.buts
8080 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8081 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8082 grid $top.buts.ok $top.buts.can
8083 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8084 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8085 grid $top.buts - - -pady 10 -sticky ew
8086 bind $top <Visibility> "focus $top.buts.ok"
8087}
8088
8089proc choosecolor {v vi w x cmd} {
8090 global $v
8091
8092 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8093 -title [mc "Gitk: choose color for %s" $x]]
8094 if {$c eq {}} return
8095 $w conf -background $c
8096 lset $v $vi $c
8097 eval $cmd $c
8098}
8099
8100proc setselbg {c} {
8101 global bglist cflist
8102 foreach w $bglist {
8103 $w configure -selectbackground $c
8104 }
8105 $cflist tag configure highlight \
8106 -background [$cflist cget -selectbackground]
8107 allcanvs itemconf secsel -fill $c
8108}
8109
8110proc setbg {c} {
8111 global bglist
8112
8113 foreach w $bglist {
8114 $w conf -background $c
8115 }
8116}
8117
8118proc setfg {c} {
8119 global fglist canv
8120
8121 foreach w $fglist {
8122 $w conf -foreground $c
8123 }
8124 allcanvs itemconf text -fill $c
8125 $canv itemconf circle -outline $c
8126}
8127
8128proc prefscan {} {
8129 global oldprefs prefstop
8130
8131 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8132 limitdiffs tabstop} {
8133 global $v
8134 set $v $oldprefs($v)
8135 }
8136 catch {destroy $prefstop}
8137 unset prefstop
8138 fontcan
8139}
8140
8141proc prefsok {} {
8142 global maxwidth maxgraphpct
8143 global oldprefs prefstop showneartags showlocalchanges
8144 global fontpref mainfont textfont uifont
8145 global limitdiffs treediffs
8146
8147 catch {destroy $prefstop}
8148 unset prefstop
8149 fontcan
8150 set fontchanged 0
8151 if {$mainfont ne $fontpref(mainfont)} {
8152 set mainfont $fontpref(mainfont)
8153 parsefont mainfont $mainfont
8154 eval font configure mainfont [fontflags mainfont]
8155 eval font configure mainfontbold [fontflags mainfont 1]
8156 setcoords
8157 set fontchanged 1
8158 }
8159 if {$textfont ne $fontpref(textfont)} {
8160 set textfont $fontpref(textfont)
8161 parsefont textfont $textfont
8162 eval font configure textfont [fontflags textfont]
8163 eval font configure textfontbold [fontflags textfont 1]
8164 }
8165 if {$uifont ne $fontpref(uifont)} {
8166 set uifont $fontpref(uifont)
8167 parsefont uifont $uifont
8168 eval font configure uifont [fontflags uifont]
8169 }
8170 settabs
8171 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8172 if {$showlocalchanges} {
8173 doshowlocalchanges
8174 } else {
8175 dohidelocalchanges
8176 }
8177 }
8178 if {$limitdiffs != $oldprefs(limitdiffs)} {
8179 # treediffs elements are limited by path
8180 catch {unset treediffs}
8181 }
8182 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8183 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8184 redisplay
8185 } elseif {$showneartags != $oldprefs(showneartags) ||
8186 $limitdiffs != $oldprefs(limitdiffs)} {
8187 reselectline
8188 }
8189}
8190
8191proc formatdate {d} {
8192 global datetimeformat
8193 if {$d ne {}} {
8194 set d [clock format $d -format $datetimeformat]
8195 }
8196 return $d
8197}
8198
8199# This list of encoding names and aliases is distilled from
8200# http://www.iana.org/assignments/character-sets.
8201# Not all of them are supported by Tcl.
8202set encoding_aliases {
8203 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8204 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8205 { ISO-10646-UTF-1 csISO10646UTF1 }
8206 { ISO_646.basic:1983 ref csISO646basic1983 }
8207 { INVARIANT csINVARIANT }
8208 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8209 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8210 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8211 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8212 { NATS-DANO iso-ir-9-1 csNATSDANO }
8213 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8214 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8215 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8216 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8217 { ISO-2022-KR csISO2022KR }
8218 { EUC-KR csEUCKR }
8219 { ISO-2022-JP csISO2022JP }
8220 { ISO-2022-JP-2 csISO2022JP2 }
8221 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8222 csISO13JISC6220jp }
8223 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8224 { IT iso-ir-15 ISO646-IT csISO15Italian }
8225 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8226 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8227 { greek7-old iso-ir-18 csISO18Greek7Old }
8228 { latin-greek iso-ir-19 csISO19LatinGreek }
8229 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8230 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8231 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8232 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8233 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8234 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8235 { INIS iso-ir-49 csISO49INIS }
8236 { INIS-8 iso-ir-50 csISO50INIS8 }
8237 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8238 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8239 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8240 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8241 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8242 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8243 csISO60Norwegian1 }
8244 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8245 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8246 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8247 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8248 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8249 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8250 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8251 { greek7 iso-ir-88 csISO88Greek7 }
8252 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8253 { iso-ir-90 csISO90 }
8254 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8255 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8256 csISO92JISC62991984b }
8257 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8258 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8259 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8260 csISO95JIS62291984handadd }
8261 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8262 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8263 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8264 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8265 CP819 csISOLatin1 }
8266 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8267 { T.61-7bit iso-ir-102 csISO102T617bit }
8268 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8269 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8270 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8271 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8272 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8273 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8274 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8275 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8276 arabic csISOLatinArabic }
8277 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8278 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8279 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8280 greek greek8 csISOLatinGreek }
8281 { T.101-G2 iso-ir-128 csISO128T101G2 }
8282 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8283 csISOLatinHebrew }
8284 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8285 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8286 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8287 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8288 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8289 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8290 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8291 csISOLatinCyrillic }
8292 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8293 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8294 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8295 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8296 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8297 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8298 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8299 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8300 { ISO_10367-box iso-ir-155 csISO10367Box }
8301 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8302 { latin-lap lap iso-ir-158 csISO158Lap }
8303 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8304 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8305 { us-dk csUSDK }
8306 { dk-us csDKUS }
8307 { JIS_X0201 X0201 csHalfWidthKatakana }
8308 { KSC5636 ISO646-KR csKSC5636 }
8309 { ISO-10646-UCS-2 csUnicode }
8310 { ISO-10646-UCS-4 csUCS4 }
8311 { DEC-MCS dec csDECMCS }
8312 { hp-roman8 roman8 r8 csHPRoman8 }
8313 { macintosh mac csMacintosh }
8314 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8315 csIBM037 }
8316 { IBM038 EBCDIC-INT cp038 csIBM038 }
8317 { IBM273 CP273 csIBM273 }
8318 { IBM274 EBCDIC-BE CP274 csIBM274 }
8319 { IBM275 EBCDIC-BR cp275 csIBM275 }
8320 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8321 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8322 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8323 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8324 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8325 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8326 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8327 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8328 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8329 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8330 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8331 { IBM437 cp437 437 csPC8CodePage437 }
8332 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8333 { IBM775 cp775 csPC775Baltic }
8334 { IBM850 cp850 850 csPC850Multilingual }
8335 { IBM851 cp851 851 csIBM851 }
8336 { IBM852 cp852 852 csPCp852 }
8337 { IBM855 cp855 855 csIBM855 }
8338 { IBM857 cp857 857 csIBM857 }
8339 { IBM860 cp860 860 csIBM860 }
8340 { IBM861 cp861 861 cp-is csIBM861 }
8341 { IBM862 cp862 862 csPC862LatinHebrew }
8342 { IBM863 cp863 863 csIBM863 }
8343 { IBM864 cp864 csIBM864 }
8344 { IBM865 cp865 865 csIBM865 }
8345 { IBM866 cp866 866 csIBM866 }
8346 { IBM868 CP868 cp-ar csIBM868 }
8347 { IBM869 cp869 869 cp-gr csIBM869 }
8348 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8349 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8350 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8351 { IBM891 cp891 csIBM891 }
8352 { IBM903 cp903 csIBM903 }
8353 { IBM904 cp904 904 csIBBM904 }
8354 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8355 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8356 { IBM1026 CP1026 csIBM1026 }
8357 { EBCDIC-AT-DE csIBMEBCDICATDE }
8358 { EBCDIC-AT-DE-A csEBCDICATDEA }
8359 { EBCDIC-CA-FR csEBCDICCAFR }
8360 { EBCDIC-DK-NO csEBCDICDKNO }
8361 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8362 { EBCDIC-FI-SE csEBCDICFISE }
8363 { EBCDIC-FI-SE-A csEBCDICFISEA }
8364 { EBCDIC-FR csEBCDICFR }
8365 { EBCDIC-IT csEBCDICIT }
8366 { EBCDIC-PT csEBCDICPT }
8367 { EBCDIC-ES csEBCDICES }
8368 { EBCDIC-ES-A csEBCDICESA }
8369 { EBCDIC-ES-S csEBCDICESS }
8370 { EBCDIC-UK csEBCDICUK }
8371 { EBCDIC-US csEBCDICUS }
8372 { UNKNOWN-8BIT csUnknown8BiT }
8373 { MNEMONIC csMnemonic }
8374 { MNEM csMnem }
8375 { VISCII csVISCII }
8376 { VIQR csVIQR }
8377 { KOI8-R csKOI8R }
8378 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8379 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8380 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8381 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8382 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8383 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8384 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8385 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8386 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8387 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8388 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8389 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8390 { IBM1047 IBM-1047 }
8391 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8392 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8393 { UNICODE-1-1 csUnicode11 }
8394 { CESU-8 csCESU-8 }
8395 { BOCU-1 csBOCU-1 }
8396 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8397 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8398 l8 }
8399 { ISO-8859-15 ISO_8859-15 Latin-9 }
8400 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8401 { GBK CP936 MS936 windows-936 }
8402 { JIS_Encoding csJISEncoding }
8403 { Shift_JIS MS_Kanji csShiftJIS }
8404 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8405 EUC-JP }
8406 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8407 { ISO-10646-UCS-Basic csUnicodeASCII }
8408 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8409 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8410 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8411 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8412 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8413 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8414 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8415 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8416 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8417 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8418 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8419 { Ventura-US csVenturaUS }
8420 { Ventura-International csVenturaInternational }
8421 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8422 { PC8-Turkish csPC8Turkish }
8423 { IBM-Symbols csIBMSymbols }
8424 { IBM-Thai csIBMThai }
8425 { HP-Legal csHPLegal }
8426 { HP-Pi-font csHPPiFont }
8427 { HP-Math8 csHPMath8 }
8428 { Adobe-Symbol-Encoding csHPPSMath }
8429 { HP-DeskTop csHPDesktop }
8430 { Ventura-Math csVenturaMath }
8431 { Microsoft-Publishing csMicrosoftPublishing }
8432 { Windows-31J csWindows31J }
8433 { GB2312 csGB2312 }
8434 { Big5 csBig5 }
8435}
8436
8437proc tcl_encoding {enc} {
8438 global encoding_aliases
8439 set names [encoding names]
8440 set lcnames [string tolower $names]
8441 set enc [string tolower $enc]
8442 set i [lsearch -exact $lcnames $enc]
8443 if {$i < 0} {
8444 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8445 if {[regsub {^iso[-_]} $enc iso encx]} {
8446 set i [lsearch -exact $lcnames $encx]
8447 }
8448 }
8449 if {$i < 0} {
8450 foreach l $encoding_aliases {
8451 set ll [string tolower $l]
8452 if {[lsearch -exact $ll $enc] < 0} continue
8453 # look through the aliases for one that tcl knows about
8454 foreach e $ll {
8455 set i [lsearch -exact $lcnames $e]
8456 if {$i < 0} {
8457 if {[regsub {^iso[-_]} $e iso ex]} {
8458 set i [lsearch -exact $lcnames $ex]
8459 }
8460 }
8461 if {$i >= 0} break
8462 }
8463 break
8464 }
8465 }
8466 if {$i >= 0} {
8467 return [lindex $names $i]
8468 }
8469 return {}
8470}
8471
8472# First check that Tcl/Tk is recent enough
8473if {[catch {package require Tk 8.4} err]} {
8474 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8475 Gitk requires at least Tcl/Tk 8.4."]
8476 exit 1
8477}
8478
8479# defaults...
8480set datemode 0
8481set wrcomcmd "git diff-tree --stdin -p --pretty"
8482
8483set gitencoding {}
8484catch {
8485 set gitencoding [exec git config --get i18n.commitencoding]
8486}
8487if {$gitencoding == ""} {
8488 set gitencoding "utf-8"
8489}
8490set tclencoding [tcl_encoding $gitencoding]
8491if {$tclencoding == {}} {
8492 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8493}
8494
8495set mainfont {Helvetica 9}
8496set textfont {Courier 9}
8497set uifont {Helvetica 9 bold}
8498set tabstop 8
8499set findmergefiles 0
8500set maxgraphpct 50
8501set maxwidth 16
8502set revlistorder 0
8503set fastdate 0
8504set uparrowlen 5
8505set downarrowlen 5
8506set mingaplen 100
8507set cmitmode "patch"
8508set wrapcomment "none"
8509set showneartags 1
8510set maxrefs 20
8511set maxlinelen 200
8512set showlocalchanges 1
8513set limitdiffs 1
8514set datetimeformat "%Y-%m-%d %H:%M:%S"
8515set autoselect 1
8516
8517set colors {green red blue magenta darkgrey brown orange}
8518set bgcolor white
8519set fgcolor black
8520set diffcolors {red "#00a000" blue}
8521set diffcontext 3
8522set ignorespace 0
8523set selectbgcolor gray85
8524
8525## For msgcat loading, first locate the installation location.
8526if { [info exists ::env(GITK_MSGSDIR)] } {
8527 ## Msgsdir was manually set in the environment.
8528 set gitk_msgsdir $::env(GITK_MSGSDIR)
8529} else {
8530 ## Let's guess the prefix from argv0.
8531 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
8532 set gitk_libdir [file join $gitk_prefix share gitk lib]
8533 set gitk_msgsdir [file join $gitk_libdir msgs]
8534 unset gitk_prefix
8535}
8536
8537## Internationalization (i18n) through msgcat and gettext. See
8538## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
8539package require msgcat
8540namespace import ::msgcat::mc
8541## And eventually load the actual message catalog
8542::msgcat::mcload $gitk_msgsdir
8543
8544catch {source ~/.gitk}
8545
8546font create optionfont -family sans-serif -size -12
8547
8548parsefont mainfont $mainfont
8549eval font create mainfont [fontflags mainfont]
8550eval font create mainfontbold [fontflags mainfont 1]
8551
8552parsefont textfont $textfont
8553eval font create textfont [fontflags textfont]
8554eval font create textfontbold [fontflags textfont 1]
8555
8556parsefont uifont $uifont
8557eval font create uifont [fontflags uifont]
8558
8559setoptions
8560
8561# check that we can find a .git directory somewhere...
8562if {[catch {set gitdir [gitdir]}]} {
8563 show_error {} . [mc "Cannot find a git repository here."]
8564 exit 1
8565}
8566if {![file isdirectory $gitdir]} {
8567 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
8568 exit 1
8569}
8570
8571set mergeonly 0
8572set revtreeargs {}
8573set cmdline_files {}
8574set i 0
8575set revtreeargscmd {}
8576foreach arg $argv {
8577 switch -glob -- $arg {
8578 "" { }
8579 "-d" { set datemode 1 }
8580 "--merge" {
8581 set mergeonly 1
8582 lappend revtreeargs $arg
8583 }
8584 "--" {
8585 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8586 break
8587 }
8588 "--argscmd=*" {
8589 set revtreeargscmd [string range $arg 10 end]
8590 }
8591 default {
8592 lappend revtreeargs $arg
8593 }
8594 }
8595 incr i
8596}
8597
8598if {$i >= [llength $argv] && $revtreeargs ne {}} {
8599 # no -- on command line, but some arguments (other than -d)
8600 if {[catch {
8601 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8602 set cmdline_files [split $f "\n"]
8603 set n [llength $cmdline_files]
8604 set revtreeargs [lrange $revtreeargs 0 end-$n]
8605 # Unfortunately git rev-parse doesn't produce an error when
8606 # something is both a revision and a filename. To be consistent
8607 # with git log and git rev-list, check revtreeargs for filenames.
8608 foreach arg $revtreeargs {
8609 if {[file exists $arg]} {
8610 show_error {} . [mc "Ambiguous argument '%s': both revision\
8611 and filename" $arg]
8612 exit 1
8613 }
8614 }
8615 } err]} {
8616 # unfortunately we get both stdout and stderr in $err,
8617 # so look for "fatal:".
8618 set i [string first "fatal:" $err]
8619 if {$i > 0} {
8620 set err [string range $err [expr {$i + 6}] end]
8621 }
8622 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
8623 exit 1
8624 }
8625}
8626
8627if {$mergeonly} {
8628 # find the list of unmerged files
8629 set mlist {}
8630 set nr_unmerged 0
8631 if {[catch {
8632 set fd [open "| git ls-files -u" r]
8633 } err]} {
8634 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
8635 exit 1
8636 }
8637 while {[gets $fd line] >= 0} {
8638 set i [string first "\t" $line]
8639 if {$i < 0} continue
8640 set fname [string range $line [expr {$i+1}] end]
8641 if {[lsearch -exact $mlist $fname] >= 0} continue
8642 incr nr_unmerged
8643 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8644 lappend mlist $fname
8645 }
8646 }
8647 catch {close $fd}
8648 if {$mlist eq {}} {
8649 if {$nr_unmerged == 0} {
8650 show_error {} . [mc "No files selected: --merge specified but\
8651 no files are unmerged."]
8652 } else {
8653 show_error {} . [mc "No files selected: --merge specified but\
8654 no unmerged files are within file limit."]
8655 }
8656 exit 1
8657 }
8658 set cmdline_files $mlist
8659}
8660
8661set nullid "0000000000000000000000000000000000000000"
8662set nullid2 "0000000000000000000000000000000000000001"
8663
8664set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8665
8666set runq {}
8667set history {}
8668set historyindex 0
8669set fh_serial 0
8670set nhl_names {}
8671set highlight_paths {}
8672set findpattern {}
8673set searchdirn -forwards
8674set boldrows {}
8675set boldnamerows {}
8676set diffelide {0 0}
8677set markingmatches 0
8678set linkentercount 0
8679set need_redisplay 0
8680set nrows_drawn 0
8681set firsttabstop 0
8682
8683set nextviewnum 1
8684set curview 0
8685set selectedview 0
8686set selectedhlview [mc "None"]
8687set highlight_related [mc "None"]
8688set highlight_files {}
8689set viewfiles(0) {}
8690set viewperm(0) 0
8691set viewargs(0) {}
8692set viewargscmd(0) {}
8693
8694set cmdlineok 0
8695set stopped 0
8696set stuffsaved 0
8697set patchnum 0
8698set localirow -1
8699set localfrow -1
8700set lserial 0
8701setcoords
8702makewindow
8703# wait for the window to become visible
8704tkwait visibility .
8705wm title . "[file tail $argv0]: [file tail [pwd]]"
8706readrefs
8707
8708if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
8709 # create a view for the files/dirs specified on the command line
8710 set curview 1
8711 set selectedview 1
8712 set nextviewnum 2
8713 set viewname(1) [mc "Command line"]
8714 set viewfiles(1) $cmdline_files
8715 set viewargs(1) $revtreeargs
8716 set viewargscmd(1) $revtreeargscmd
8717 set viewperm(1) 0
8718 addviewmenu 1
8719 .bar.view entryconf [mc "Edit view..."] -state normal
8720 .bar.view entryconf [mc "Delete view"] -state normal
8721}
8722
8723if {[info exists permviews]} {
8724 foreach v $permviews {
8725 set n $nextviewnum
8726 incr nextviewnum
8727 set viewname($n) [lindex $v 0]
8728 set viewfiles($n) [lindex $v 1]
8729 set viewargs($n) [lindex $v 2]
8730 set viewargscmd($n) [lindex $v 3]
8731 set viewperm($n) 1
8732 addviewmenu $n
8733 }
8734}
8735getcommits