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