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