skip t5512 because remote does not yet work
[git/platforms/storm.git] / gitk
blob943a76b3d22672a978fda3935124b16df4356bc5
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 catch {file delete "~/.gitk"}
1202 file rename -force "~/.gitk-new" "~/.gitk"
1204 set stuffsaved 1
1207 proc resizeclistpanes {win w} {
1208 global oldwidth
1209 if {[info exists oldwidth($win)]} {
1210 set s0 [$win sash coord 0]
1211 set s1 [$win sash coord 1]
1212 if {$w < 60} {
1213 set sash0 [expr {int($w/2 - 2)}]
1214 set sash1 [expr {int($w*5/6 - 2)}]
1215 } else {
1216 set factor [expr {1.0 * $w / $oldwidth($win)}]
1217 set sash0 [expr {int($factor * [lindex $s0 0])}]
1218 set sash1 [expr {int($factor * [lindex $s1 0])}]
1219 if {$sash0 < 30} {
1220 set sash0 30
1222 if {$sash1 < $sash0 + 20} {
1223 set sash1 [expr {$sash0 + 20}]
1225 if {$sash1 > $w - 10} {
1226 set sash1 [expr {$w - 10}]
1227 if {$sash0 > $sash1 - 20} {
1228 set sash0 [expr {$sash1 - 20}]
1232 $win sash place 0 $sash0 [lindex $s0 1]
1233 $win sash place 1 $sash1 [lindex $s1 1]
1235 set oldwidth($win) $w
1238 proc resizecdetpanes {win w} {
1239 global oldwidth
1240 if {[info exists oldwidth($win)]} {
1241 set s0 [$win sash coord 0]
1242 if {$w < 60} {
1243 set sash0 [expr {int($w*3/4 - 2)}]
1244 } else {
1245 set factor [expr {1.0 * $w / $oldwidth($win)}]
1246 set sash0 [expr {int($factor * [lindex $s0 0])}]
1247 if {$sash0 < 45} {
1248 set sash0 45
1250 if {$sash0 > $w - 15} {
1251 set sash0 [expr {$w - 15}]
1254 $win sash place 0 $sash0 [lindex $s0 1]
1256 set oldwidth($win) $w
1259 proc allcanvs args {
1260 global canv canv2 canv3
1261 eval $canv $args
1262 eval $canv2 $args
1263 eval $canv3 $args
1266 proc bindall {event action} {
1267 global canv canv2 canv3
1268 bind $canv $event $action
1269 bind $canv2 $event $action
1270 bind $canv3 $event $action
1273 proc about {} {
1274 global uifont
1275 set w .about
1276 if {[winfo exists $w]} {
1277 raise $w
1278 return
1280 toplevel $w
1281 wm title $w "About gitk"
1282 message $w.m -text {
1283 Gitk - a commit viewer for git
1285 Copyright © 2005-2006 Paul Mackerras
1287 Use and redistribute under the terms of the GNU General Public License} \
1288 -justify center -aspect 400 -border 2 -bg white -relief groove
1289 pack $w.m -side top -fill x -padx 2 -pady 2
1290 $w.m configure -font uifont
1291 button $w.ok -text Close -command "destroy $w" -default active
1292 pack $w.ok -side bottom
1293 $w.ok configure -font uifont
1294 bind $w <Visibility> "focus $w.ok"
1295 bind $w <Key-Escape> "destroy $w"
1296 bind $w <Key-Return> "destroy $w"
1299 proc keys {} {
1300 global uifont
1301 set w .keys
1302 if {[winfo exists $w]} {
1303 raise $w
1304 return
1306 if {[tk windowingsystem] eq {aqua}} {
1307 set M1T Cmd
1308 } else {
1309 set M1T Ctrl
1311 toplevel $w
1312 wm title $w "Gitk key bindings"
1313 message $w.m -text "
1314 Gitk key bindings:
1316 <$M1T-Q> Quit
1317 <Home> Move to first commit
1318 <End> Move to last commit
1319 <Up>, p, i Move up one commit
1320 <Down>, n, k Move down one commit
1321 <Left>, z, j Go back in history list
1322 <Right>, x, l Go forward in history list
1323 <PageUp> Move up one page in commit list
1324 <PageDown> Move down one page in commit list
1325 <$M1T-Home> Scroll to top of commit list
1326 <$M1T-End> Scroll to bottom of commit list
1327 <$M1T-Up> Scroll commit list up one line
1328 <$M1T-Down> Scroll commit list down one line
1329 <$M1T-PageUp> Scroll commit list up one page
1330 <$M1T-PageDown> Scroll commit list down one page
1331 <Shift-Up> Find backwards (upwards, later commits)
1332 <Shift-Down> Find forwards (downwards, earlier commits)
1333 <Delete>, b Scroll diff view up one page
1334 <Backspace> Scroll diff view up one page
1335 <Space> Scroll diff view down one page
1336 u Scroll diff view up 18 lines
1337 d Scroll diff view down 18 lines
1338 <$M1T-F> Find
1339 <$M1T-G> Move to next find hit
1340 <Return> Move to next find hit
1341 / Move to next find hit, or redo find
1342 ? Move to previous find hit
1343 f Scroll diff view to next file
1344 <$M1T-S> Search for next hit in diff view
1345 <$M1T-R> Search for previous hit in diff view
1346 <$M1T-KP+> Increase font size
1347 <$M1T-plus> Increase font size
1348 <$M1T-KP-> Decrease font size
1349 <$M1T-minus> Decrease font size
1350 <F5> Update
1352 -justify left -bg white -border 2 -relief groove
1353 pack $w.m -side top -fill both -padx 2 -pady 2
1354 $w.m configure -font uifont
1355 button $w.ok -text Close -command "destroy $w" -default active
1356 pack $w.ok -side bottom
1357 $w.ok configure -font uifont
1358 bind $w <Visibility> "focus $w.ok"
1359 bind $w <Key-Escape> "destroy $w"
1360 bind $w <Key-Return> "destroy $w"
1363 # Procedures for manipulating the file list window at the
1364 # bottom right of the overall window.
1366 proc treeview {w l openlevs} {
1367 global treecontents treediropen treeheight treeparent treeindex
1369 set ix 0
1370 set treeindex() 0
1371 set lev 0
1372 set prefix {}
1373 set prefixend -1
1374 set prefendstack {}
1375 set htstack {}
1376 set ht 0
1377 set treecontents() {}
1378 $w conf -state normal
1379 foreach f $l {
1380 while {[string range $f 0 $prefixend] ne $prefix} {
1381 if {$lev <= $openlevs} {
1382 $w mark set e:$treeindex($prefix) "end -1c"
1383 $w mark gravity e:$treeindex($prefix) left
1385 set treeheight($prefix) $ht
1386 incr ht [lindex $htstack end]
1387 set htstack [lreplace $htstack end end]
1388 set prefixend [lindex $prefendstack end]
1389 set prefendstack [lreplace $prefendstack end end]
1390 set prefix [string range $prefix 0 $prefixend]
1391 incr lev -1
1393 set tail [string range $f [expr {$prefixend+1}] end]
1394 while {[set slash [string first "/" $tail]] >= 0} {
1395 lappend htstack $ht
1396 set ht 0
1397 lappend prefendstack $prefixend
1398 incr prefixend [expr {$slash + 1}]
1399 set d [string range $tail 0 $slash]
1400 lappend treecontents($prefix) $d
1401 set oldprefix $prefix
1402 append prefix $d
1403 set treecontents($prefix) {}
1404 set treeindex($prefix) [incr ix]
1405 set treeparent($prefix) $oldprefix
1406 set tail [string range $tail [expr {$slash+1}] end]
1407 if {$lev <= $openlevs} {
1408 set ht 1
1409 set treediropen($prefix) [expr {$lev < $openlevs}]
1410 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1411 $w mark set d:$ix "end -1c"
1412 $w mark gravity d:$ix left
1413 set str "\n"
1414 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1415 $w insert end $str
1416 $w image create end -align center -image $bm -padx 1 \
1417 -name a:$ix
1418 $w insert end $d [highlight_tag $prefix]
1419 $w mark set s:$ix "end -1c"
1420 $w mark gravity s:$ix left
1422 incr lev
1424 if {$tail ne {}} {
1425 if {$lev <= $openlevs} {
1426 incr ht
1427 set str "\n"
1428 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1429 $w insert end $str
1430 $w insert end $tail [highlight_tag $f]
1432 lappend treecontents($prefix) $tail
1435 while {$htstack ne {}} {
1436 set treeheight($prefix) $ht
1437 incr ht [lindex $htstack end]
1438 set htstack [lreplace $htstack end end]
1439 set prefixend [lindex $prefendstack end]
1440 set prefendstack [lreplace $prefendstack end end]
1441 set prefix [string range $prefix 0 $prefixend]
1443 $w conf -state disabled
1446 proc linetoelt {l} {
1447 global treeheight treecontents
1449 set y 2
1450 set prefix {}
1451 while {1} {
1452 foreach e $treecontents($prefix) {
1453 if {$y == $l} {
1454 return "$prefix$e"
1456 set n 1
1457 if {[string index $e end] eq "/"} {
1458 set n $treeheight($prefix$e)
1459 if {$y + $n > $l} {
1460 append prefix $e
1461 incr y
1462 break
1465 incr y $n
1470 proc highlight_tree {y prefix} {
1471 global treeheight treecontents cflist
1473 foreach e $treecontents($prefix) {
1474 set path $prefix$e
1475 if {[highlight_tag $path] ne {}} {
1476 $cflist tag add bold $y.0 "$y.0 lineend"
1478 incr y
1479 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1480 set y [highlight_tree $y $path]
1483 return $y
1486 proc treeclosedir {w dir} {
1487 global treediropen treeheight treeparent treeindex
1489 set ix $treeindex($dir)
1490 $w conf -state normal
1491 $w delete s:$ix e:$ix
1492 set treediropen($dir) 0
1493 $w image configure a:$ix -image tri-rt
1494 $w conf -state disabled
1495 set n [expr {1 - $treeheight($dir)}]
1496 while {$dir ne {}} {
1497 incr treeheight($dir) $n
1498 set dir $treeparent($dir)
1502 proc treeopendir {w dir} {
1503 global treediropen treeheight treeparent treecontents treeindex
1505 set ix $treeindex($dir)
1506 $w conf -state normal
1507 $w image configure a:$ix -image tri-dn
1508 $w mark set e:$ix s:$ix
1509 $w mark gravity e:$ix right
1510 set lev 0
1511 set str "\n"
1512 set n [llength $treecontents($dir)]
1513 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1514 incr lev
1515 append str "\t"
1516 incr treeheight($x) $n
1518 foreach e $treecontents($dir) {
1519 set de $dir$e
1520 if {[string index $e end] eq "/"} {
1521 set iy $treeindex($de)
1522 $w mark set d:$iy e:$ix
1523 $w mark gravity d:$iy left
1524 $w insert e:$ix $str
1525 set treediropen($de) 0
1526 $w image create e:$ix -align center -image tri-rt -padx 1 \
1527 -name a:$iy
1528 $w insert e:$ix $e [highlight_tag $de]
1529 $w mark set s:$iy e:$ix
1530 $w mark gravity s:$iy left
1531 set treeheight($de) 1
1532 } else {
1533 $w insert e:$ix $str
1534 $w insert e:$ix $e [highlight_tag $de]
1537 $w mark gravity e:$ix left
1538 $w conf -state disabled
1539 set treediropen($dir) 1
1540 set top [lindex [split [$w index @0,0] .] 0]
1541 set ht [$w cget -height]
1542 set l [lindex [split [$w index s:$ix] .] 0]
1543 if {$l < $top} {
1544 $w yview $l.0
1545 } elseif {$l + $n + 1 > $top + $ht} {
1546 set top [expr {$l + $n + 2 - $ht}]
1547 if {$l < $top} {
1548 set top $l
1550 $w yview $top.0
1554 proc treeclick {w x y} {
1555 global treediropen cmitmode ctext cflist cflist_top
1557 if {$cmitmode ne "tree"} return
1558 if {![info exists cflist_top]} return
1559 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1560 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1561 $cflist tag add highlight $l.0 "$l.0 lineend"
1562 set cflist_top $l
1563 if {$l == 1} {
1564 $ctext yview 1.0
1565 return
1567 set e [linetoelt $l]
1568 if {[string index $e end] ne "/"} {
1569 showfile $e
1570 } elseif {$treediropen($e)} {
1571 treeclosedir $w $e
1572 } else {
1573 treeopendir $w $e
1577 proc setfilelist {id} {
1578 global treefilelist cflist
1580 treeview $cflist $treefilelist($id) 0
1583 image create bitmap tri-rt -background black -foreground blue -data {
1584 #define tri-rt_width 13
1585 #define tri-rt_height 13
1586 static unsigned char tri-rt_bits[] = {
1587 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1588 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1589 0x00, 0x00};
1590 } -maskdata {
1591 #define tri-rt-mask_width 13
1592 #define tri-rt-mask_height 13
1593 static unsigned char tri-rt-mask_bits[] = {
1594 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1595 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1596 0x08, 0x00};
1598 image create bitmap tri-dn -background black -foreground blue -data {
1599 #define tri-dn_width 13
1600 #define tri-dn_height 13
1601 static unsigned char tri-dn_bits[] = {
1602 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1603 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1604 0x00, 0x00};
1605 } -maskdata {
1606 #define tri-dn-mask_width 13
1607 #define tri-dn-mask_height 13
1608 static unsigned char tri-dn-mask_bits[] = {
1609 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1610 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1611 0x00, 0x00};
1614 image create bitmap reficon-T -background black -foreground yellow -data {
1615 #define tagicon_width 13
1616 #define tagicon_height 9
1617 static unsigned char tagicon_bits[] = {
1618 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1619 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1620 } -maskdata {
1621 #define tagicon-mask_width 13
1622 #define tagicon-mask_height 9
1623 static unsigned char tagicon-mask_bits[] = {
1624 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1625 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1627 set rectdata {
1628 #define headicon_width 13
1629 #define headicon_height 9
1630 static unsigned char headicon_bits[] = {
1631 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1632 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1634 set rectmask {
1635 #define headicon-mask_width 13
1636 #define headicon-mask_height 9
1637 static unsigned char headicon-mask_bits[] = {
1638 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1639 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1641 image create bitmap reficon-H -background black -foreground green \
1642 -data $rectdata -maskdata $rectmask
1643 image create bitmap reficon-o -background black -foreground "#ddddff" \
1644 -data $rectdata -maskdata $rectmask
1646 proc init_flist {first} {
1647 global cflist cflist_top selectedline difffilestart
1649 $cflist conf -state normal
1650 $cflist delete 0.0 end
1651 if {$first ne {}} {
1652 $cflist insert end $first
1653 set cflist_top 1
1654 $cflist tag add highlight 1.0 "1.0 lineend"
1655 } else {
1656 catch {unset cflist_top}
1658 $cflist conf -state disabled
1659 set difffilestart {}
1662 proc highlight_tag {f} {
1663 global highlight_paths
1665 foreach p $highlight_paths {
1666 if {[string match $p $f]} {
1667 return "bold"
1670 return {}
1673 proc highlight_filelist {} {
1674 global cmitmode cflist
1676 $cflist conf -state normal
1677 if {$cmitmode ne "tree"} {
1678 set end [lindex [split [$cflist index end] .] 0]
1679 for {set l 2} {$l < $end} {incr l} {
1680 set line [$cflist get $l.0 "$l.0 lineend"]
1681 if {[highlight_tag $line] ne {}} {
1682 $cflist tag add bold $l.0 "$l.0 lineend"
1685 } else {
1686 highlight_tree 2 {}
1688 $cflist conf -state disabled
1691 proc unhighlight_filelist {} {
1692 global cflist
1694 $cflist conf -state normal
1695 $cflist tag remove bold 1.0 end
1696 $cflist conf -state disabled
1699 proc add_flist {fl} {
1700 global cflist
1702 $cflist conf -state normal
1703 foreach f $fl {
1704 $cflist insert end "\n"
1705 $cflist insert end $f [highlight_tag $f]
1707 $cflist conf -state disabled
1710 proc sel_flist {w x y} {
1711 global ctext difffilestart cflist cflist_top cmitmode
1713 if {$cmitmode eq "tree"} return
1714 if {![info exists cflist_top]} return
1715 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1716 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1717 $cflist tag add highlight $l.0 "$l.0 lineend"
1718 set cflist_top $l
1719 if {$l == 1} {
1720 $ctext yview 1.0
1721 } else {
1722 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1726 proc pop_flist_menu {w X Y x y} {
1727 global ctext cflist cmitmode flist_menu flist_menu_file
1728 global treediffs diffids
1730 stopfinding
1731 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1732 if {$l <= 1} return
1733 if {$cmitmode eq "tree"} {
1734 set e [linetoelt $l]
1735 if {[string index $e end] eq "/"} return
1736 } else {
1737 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1739 set flist_menu_file $e
1740 tk_popup $flist_menu $X $Y
1743 proc flist_hl {only} {
1744 global flist_menu_file findstring gdttype
1746 set x [shellquote $flist_menu_file]
1747 if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
1748 set findstring $x
1749 } else {
1750 append findstring " " $x
1752 set gdttype "touching paths:"
1755 # Functions for adding and removing shell-type quoting
1757 proc shellquote {str} {
1758 if {![string match "*\['\"\\ \t]*" $str]} {
1759 return $str
1761 if {![string match "*\['\"\\]*" $str]} {
1762 return "\"$str\""
1764 if {![string match "*'*" $str]} {
1765 return "'$str'"
1767 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1770 proc shellarglist {l} {
1771 set str {}
1772 foreach a $l {
1773 if {$str ne {}} {
1774 append str " "
1776 append str [shellquote $a]
1778 return $str
1781 proc shelldequote {str} {
1782 set ret {}
1783 set used -1
1784 while {1} {
1785 incr used
1786 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1787 append ret [string range $str $used end]
1788 set used [string length $str]
1789 break
1791 set first [lindex $first 0]
1792 set ch [string index $str $first]
1793 if {$first > $used} {
1794 append ret [string range $str $used [expr {$first - 1}]]
1795 set used $first
1797 if {$ch eq " " || $ch eq "\t"} break
1798 incr used
1799 if {$ch eq "'"} {
1800 set first [string first "'" $str $used]
1801 if {$first < 0} {
1802 error "unmatched single-quote"
1804 append ret [string range $str $used [expr {$first - 1}]]
1805 set used $first
1806 continue
1808 if {$ch eq "\\"} {
1809 if {$used >= [string length $str]} {
1810 error "trailing backslash"
1812 append ret [string index $str $used]
1813 continue
1815 # here ch == "\""
1816 while {1} {
1817 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1818 error "unmatched double-quote"
1820 set first [lindex $first 0]
1821 set ch [string index $str $first]
1822 if {$first > $used} {
1823 append ret [string range $str $used [expr {$first - 1}]]
1824 set used $first
1826 if {$ch eq "\""} break
1827 incr used
1828 append ret [string index $str $used]
1829 incr used
1832 return [list $used $ret]
1835 proc shellsplit {str} {
1836 set l {}
1837 while {1} {
1838 set str [string trimleft $str]
1839 if {$str eq {}} break
1840 set dq [shelldequote $str]
1841 set n [lindex $dq 0]
1842 set word [lindex $dq 1]
1843 set str [string range $str $n end]
1844 lappend l $word
1846 return $l
1849 # Code to implement multiple views
1851 proc newview {ishighlight} {
1852 global nextviewnum newviewname newviewperm uifont newishighlight
1853 global newviewargs revtreeargs
1855 set newishighlight $ishighlight
1856 set top .gitkview
1857 if {[winfo exists $top]} {
1858 raise $top
1859 return
1861 set newviewname($nextviewnum) "View $nextviewnum"
1862 set newviewperm($nextviewnum) 0
1863 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1864 vieweditor $top $nextviewnum "Gitk view definition"
1867 proc editview {} {
1868 global curview
1869 global viewname viewperm newviewname newviewperm
1870 global viewargs newviewargs
1872 set top .gitkvedit-$curview
1873 if {[winfo exists $top]} {
1874 raise $top
1875 return
1877 set newviewname($curview) $viewname($curview)
1878 set newviewperm($curview) $viewperm($curview)
1879 set newviewargs($curview) [shellarglist $viewargs($curview)]
1880 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1883 proc vieweditor {top n title} {
1884 global newviewname newviewperm viewfiles
1885 global uifont
1887 toplevel $top
1888 wm title $top $title
1889 label $top.nl -text "Name" -font uifont
1890 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
1891 grid $top.nl $top.name -sticky w -pady 5
1892 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1893 -font uifont
1894 grid $top.perm - -pady 5 -sticky w
1895 message $top.al -aspect 1000 -font uifont \
1896 -text "Commits to include (arguments to git rev-list):"
1897 grid $top.al - -sticky w -pady 5
1898 entry $top.args -width 50 -textvariable newviewargs($n) \
1899 -background white -font uifont
1900 grid $top.args - -sticky ew -padx 5
1901 message $top.l -aspect 1000 -font uifont \
1902 -text "Enter files and directories to include, one per line:"
1903 grid $top.l - -sticky w
1904 text $top.t -width 40 -height 10 -background white -font uifont
1905 if {[info exists viewfiles($n)]} {
1906 foreach f $viewfiles($n) {
1907 $top.t insert end $f
1908 $top.t insert end "\n"
1910 $top.t delete {end - 1c} end
1911 $top.t mark set insert 0.0
1913 grid $top.t - -sticky ew -padx 5
1914 frame $top.buts
1915 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1916 -font uifont
1917 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1918 -font uifont
1919 grid $top.buts.ok $top.buts.can
1920 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1921 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1922 grid $top.buts - -pady 10 -sticky ew
1923 focus $top.t
1926 proc doviewmenu {m first cmd op argv} {
1927 set nmenu [$m index end]
1928 for {set i $first} {$i <= $nmenu} {incr i} {
1929 if {[$m entrycget $i -command] eq $cmd} {
1930 eval $m $op $i $argv
1931 break
1936 proc allviewmenus {n op args} {
1937 # global viewhlmenu
1939 doviewmenu .bar.view 5 [list showview $n] $op $args
1940 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1943 proc newviewok {top n} {
1944 global nextviewnum newviewperm newviewname newishighlight
1945 global viewname viewfiles viewperm selectedview curview
1946 global viewargs newviewargs viewhlmenu
1948 if {[catch {
1949 set newargs [shellsplit $newviewargs($n)]
1950 } err]} {
1951 error_popup "Error in commit selection arguments: $err"
1952 wm raise $top
1953 focus $top
1954 return
1956 set files {}
1957 foreach f [split [$top.t get 0.0 end] "\n"] {
1958 set ft [string trim $f]
1959 if {$ft ne {}} {
1960 lappend files $ft
1963 if {![info exists viewfiles($n)]} {
1964 # creating a new view
1965 incr nextviewnum
1966 set viewname($n) $newviewname($n)
1967 set viewperm($n) $newviewperm($n)
1968 set viewfiles($n) $files
1969 set viewargs($n) $newargs
1970 addviewmenu $n
1971 if {!$newishighlight} {
1972 run showview $n
1973 } else {
1974 run addvhighlight $n
1976 } else {
1977 # editing an existing view
1978 set viewperm($n) $newviewperm($n)
1979 if {$newviewname($n) ne $viewname($n)} {
1980 set viewname($n) $newviewname($n)
1981 doviewmenu .bar.view 5 [list showview $n] \
1982 entryconf [list -label $viewname($n)]
1983 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1984 # entryconf [list -label $viewname($n) -value $viewname($n)]
1986 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1987 set viewfiles($n) $files
1988 set viewargs($n) $newargs
1989 if {$curview == $n} {
1990 run updatecommits
1994 catch {destroy $top}
1997 proc delview {} {
1998 global curview viewdata viewperm hlview selectedhlview
2000 if {$curview == 0} return
2001 if {[info exists hlview] && $hlview == $curview} {
2002 set selectedhlview None
2003 unset hlview
2005 allviewmenus $curview delete
2006 set viewdata($curview) {}
2007 set viewperm($curview) 0
2008 showview 0
2011 proc addviewmenu {n} {
2012 global viewname viewhlmenu
2014 .bar.view add radiobutton -label $viewname($n) \
2015 -command [list showview $n] -variable selectedview -value $n
2016 #$viewhlmenu add radiobutton -label $viewname($n) \
2017 # -command [list addvhighlight $n] -variable selectedhlview
2020 proc flatten {var} {
2021 global $var
2023 set ret {}
2024 foreach i [array names $var] {
2025 lappend ret $i [set $var\($i\)]
2027 return $ret
2030 proc unflatten {var l} {
2031 global $var
2033 catch {unset $var}
2034 foreach {i v} $l {
2035 set $var\($i\) $v
2039 proc showview {n} {
2040 global curview viewdata viewfiles
2041 global displayorder parentlist rowidlist rowisopt rowfinal
2042 global colormap rowtextx commitrow nextcolor canvxmax
2043 global numcommits commitlisted
2044 global selectedline currentid canv canvy0
2045 global treediffs
2046 global pending_select phase
2047 global commitidx
2048 global commfd
2049 global selectedview selectfirst
2050 global vparentlist vdisporder vcmitlisted
2051 global hlview selectedhlview commitinterest
2053 if {$n == $curview} return
2054 set selid {}
2055 if {[info exists selectedline]} {
2056 set selid $currentid
2057 set y [yc $selectedline]
2058 set ymax [lindex [$canv cget -scrollregion] 3]
2059 set span [$canv yview]
2060 set ytop [expr {[lindex $span 0] * $ymax}]
2061 set ybot [expr {[lindex $span 1] * $ymax}]
2062 if {$ytop < $y && $y < $ybot} {
2063 set yscreen [expr {$y - $ytop}]
2064 } else {
2065 set yscreen [expr {($ybot - $ytop) / 2}]
2067 } elseif {[info exists pending_select]} {
2068 set selid $pending_select
2069 unset pending_select
2071 unselectline
2072 normalline
2073 if {$curview >= 0} {
2074 set vparentlist($curview) $parentlist
2075 set vdisporder($curview) $displayorder
2076 set vcmitlisted($curview) $commitlisted
2077 if {$phase ne {} ||
2078 ![info exists viewdata($curview)] ||
2079 [lindex $viewdata($curview) 0] ne {}} {
2080 set viewdata($curview) \
2081 [list $phase $rowidlist $rowisopt $rowfinal]
2084 catch {unset treediffs}
2085 clear_display
2086 if {[info exists hlview] && $hlview == $n} {
2087 unset hlview
2088 set selectedhlview None
2090 catch {unset commitinterest}
2092 set curview $n
2093 set selectedview $n
2094 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2095 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2097 run refill_reflist
2098 if {![info exists viewdata($n)]} {
2099 if {$selid ne {}} {
2100 set pending_select $selid
2102 getcommits
2103 return
2106 set v $viewdata($n)
2107 set phase [lindex $v 0]
2108 set displayorder $vdisporder($n)
2109 set parentlist $vparentlist($n)
2110 set commitlisted $vcmitlisted($n)
2111 set rowidlist [lindex $v 1]
2112 set rowisopt [lindex $v 2]
2113 set rowfinal [lindex $v 3]
2114 set numcommits $commitidx($n)
2116 catch {unset colormap}
2117 catch {unset rowtextx}
2118 set nextcolor 0
2119 set canvxmax [$canv cget -width]
2120 set curview $n
2121 set row 0
2122 setcanvscroll
2123 set yf 0
2124 set row {}
2125 set selectfirst 0
2126 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2127 set row $commitrow($n,$selid)
2128 # try to get the selected row in the same position on the screen
2129 set ymax [lindex [$canv cget -scrollregion] 3]
2130 set ytop [expr {[yc $row] - $yscreen}]
2131 if {$ytop < 0} {
2132 set ytop 0
2134 set yf [expr {$ytop * 1.0 / $ymax}]
2136 allcanvs yview moveto $yf
2137 drawvisible
2138 if {$row ne {}} {
2139 selectline $row 0
2140 } elseif {$selid ne {}} {
2141 set pending_select $selid
2142 } else {
2143 set row [first_real_row]
2144 if {$row < $numcommits} {
2145 selectline $row 0
2146 } else {
2147 set selectfirst 1
2150 if {$phase ne {}} {
2151 if {$phase eq "getcommits"} {
2152 show_status "Reading commits..."
2154 run chewcommits $n
2155 } elseif {$numcommits == 0} {
2156 show_status "No commits selected"
2160 # Stuff relating to the highlighting facility
2162 proc ishighlighted {row} {
2163 global vhighlights fhighlights nhighlights rhighlights
2165 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2166 return $nhighlights($row)
2168 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2169 return $vhighlights($row)
2171 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2172 return $fhighlights($row)
2174 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2175 return $rhighlights($row)
2177 return 0
2180 proc bolden {row font} {
2181 global canv linehtag selectedline boldrows
2183 lappend boldrows $row
2184 $canv itemconf $linehtag($row) -font $font
2185 if {[info exists selectedline] && $row == $selectedline} {
2186 $canv delete secsel
2187 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2188 -outline {{}} -tags secsel \
2189 -fill [$canv cget -selectbackground]]
2190 $canv lower $t
2194 proc bolden_name {row font} {
2195 global canv2 linentag selectedline boldnamerows
2197 lappend boldnamerows $row
2198 $canv2 itemconf $linentag($row) -font $font
2199 if {[info exists selectedline] && $row == $selectedline} {
2200 $canv2 delete secsel
2201 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2202 -outline {{}} -tags secsel \
2203 -fill [$canv2 cget -selectbackground]]
2204 $canv2 lower $t
2208 proc unbolden {} {
2209 global boldrows
2211 set stillbold {}
2212 foreach row $boldrows {
2213 if {![ishighlighted $row]} {
2214 bolden $row mainfont
2215 } else {
2216 lappend stillbold $row
2219 set boldrows $stillbold
2222 proc addvhighlight {n} {
2223 global hlview curview viewdata vhl_done vhighlights commitidx
2225 if {[info exists hlview]} {
2226 delvhighlight
2228 set hlview $n
2229 if {$n != $curview && ![info exists viewdata($n)]} {
2230 set viewdata($n) [list getcommits {{}} 0 0 0]
2231 set vparentlist($n) {}
2232 set vdisporder($n) {}
2233 set vcmitlisted($n) {}
2234 start_rev_list $n
2236 set vhl_done $commitidx($hlview)
2237 if {$vhl_done > 0} {
2238 drawvisible
2242 proc delvhighlight {} {
2243 global hlview vhighlights
2245 if {![info exists hlview]} return
2246 unset hlview
2247 catch {unset vhighlights}
2248 unbolden
2251 proc vhighlightmore {} {
2252 global hlview vhl_done commitidx vhighlights
2253 global displayorder vdisporder curview
2255 set max $commitidx($hlview)
2256 if {$hlview == $curview} {
2257 set disp $displayorder
2258 } else {
2259 set disp $vdisporder($hlview)
2261 set vr [visiblerows]
2262 set r0 [lindex $vr 0]
2263 set r1 [lindex $vr 1]
2264 for {set i $vhl_done} {$i < $max} {incr i} {
2265 set id [lindex $disp $i]
2266 if {[info exists commitrow($curview,$id)]} {
2267 set row $commitrow($curview,$id)
2268 if {$r0 <= $row && $row <= $r1} {
2269 if {![highlighted $row]} {
2270 bolden $row mainfontbold
2272 set vhighlights($row) 1
2276 set vhl_done $max
2279 proc askvhighlight {row id} {
2280 global hlview vhighlights commitrow iddrawn
2282 if {[info exists commitrow($hlview,$id)]} {
2283 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2284 bolden $row mainfontbold
2286 set vhighlights($row) 1
2287 } else {
2288 set vhighlights($row) 0
2292 proc hfiles_change {} {
2293 global highlight_files filehighlight fhighlights fh_serial
2294 global highlight_paths gdttype
2296 if {[info exists filehighlight]} {
2297 # delete previous highlights
2298 catch {close $filehighlight}
2299 unset filehighlight
2300 catch {unset fhighlights}
2301 unbolden
2302 unhighlight_filelist
2304 set highlight_paths {}
2305 after cancel do_file_hl $fh_serial
2306 incr fh_serial
2307 if {$highlight_files ne {}} {
2308 after 300 do_file_hl $fh_serial
2312 proc gdttype_change {name ix op} {
2313 global gdttype highlight_files findstring findpattern
2315 stopfinding
2316 if {$findstring ne {}} {
2317 if {$gdttype eq "containing:"} {
2318 if {$highlight_files ne {}} {
2319 set highlight_files {}
2320 hfiles_change
2322 findcom_change
2323 } else {
2324 if {$findpattern ne {}} {
2325 set findpattern {}
2326 findcom_change
2328 set highlight_files $findstring
2329 hfiles_change
2331 drawvisible
2333 # enable/disable findtype/findloc menus too
2336 proc find_change {name ix op} {
2337 global gdttype findstring highlight_files
2339 stopfinding
2340 if {$gdttype eq "containing:"} {
2341 findcom_change
2342 } else {
2343 if {$highlight_files ne $findstring} {
2344 set highlight_files $findstring
2345 hfiles_change
2348 drawvisible
2351 proc findcom_change args {
2352 global nhighlights boldnamerows
2353 global findpattern findtype findstring gdttype
2355 stopfinding
2356 # delete previous highlights, if any
2357 foreach row $boldnamerows {
2358 bolden_name $row mainfont
2360 set boldnamerows {}
2361 catch {unset nhighlights}
2362 unbolden
2363 unmarkmatches
2364 if {$gdttype ne "containing:" || $findstring eq {}} {
2365 set findpattern {}
2366 } elseif {$findtype eq "Regexp"} {
2367 set findpattern $findstring
2368 } else {
2369 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2370 $findstring]
2371 set findpattern "*$e*"
2375 proc makepatterns {l} {
2376 set ret {}
2377 foreach e $l {
2378 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2379 if {[string index $ee end] eq "/"} {
2380 lappend ret "$ee*"
2381 } else {
2382 lappend ret $ee
2383 lappend ret "$ee/*"
2386 return $ret
2389 proc do_file_hl {serial} {
2390 global highlight_files filehighlight highlight_paths gdttype fhl_list
2392 if {$gdttype eq "touching paths:"} {
2393 if {[catch {set paths [shellsplit $highlight_files]}]} return
2394 set highlight_paths [makepatterns $paths]
2395 highlight_filelist
2396 set gdtargs [concat -- $paths]
2397 } elseif {$gdttype eq "adding/removing string:"} {
2398 set gdtargs [list "-S$highlight_files"]
2399 } else {
2400 # must be "containing:", i.e. we're searching commit info
2401 return
2403 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2404 set filehighlight [open $cmd r+]
2405 fconfigure $filehighlight -blocking 0
2406 filerun $filehighlight readfhighlight
2407 set fhl_list {}
2408 drawvisible
2409 flushhighlights
2412 proc flushhighlights {} {
2413 global filehighlight fhl_list
2415 if {[info exists filehighlight]} {
2416 lappend fhl_list {}
2417 puts $filehighlight ""
2418 flush $filehighlight
2422 proc askfilehighlight {row id} {
2423 global filehighlight fhighlights fhl_list
2425 lappend fhl_list $id
2426 set fhighlights($row) -1
2427 puts $filehighlight $id
2430 proc readfhighlight {} {
2431 global filehighlight fhighlights commitrow curview iddrawn
2432 global fhl_list find_dirn
2434 if {![info exists filehighlight]} {
2435 return 0
2437 set nr 0
2438 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2439 set line [string trim $line]
2440 set i [lsearch -exact $fhl_list $line]
2441 if {$i < 0} continue
2442 for {set j 0} {$j < $i} {incr j} {
2443 set id [lindex $fhl_list $j]
2444 if {[info exists commitrow($curview,$id)]} {
2445 set fhighlights($commitrow($curview,$id)) 0
2448 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2449 if {$line eq {}} continue
2450 if {![info exists commitrow($curview,$line)]} continue
2451 set row $commitrow($curview,$line)
2452 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2453 bolden $row mainfontbold
2455 set fhighlights($row) 1
2457 if {[eof $filehighlight]} {
2458 # strange...
2459 puts "oops, git diff-tree died"
2460 catch {close $filehighlight}
2461 unset filehighlight
2462 return 0
2464 if {[info exists find_dirn]} {
2465 run findmore
2467 return 1
2470 proc doesmatch {f} {
2471 global findtype findpattern
2473 if {$findtype eq "Regexp"} {
2474 return [regexp $findpattern $f]
2475 } elseif {$findtype eq "IgnCase"} {
2476 return [string match -nocase $findpattern $f]
2477 } else {
2478 return [string match $findpattern $f]
2482 proc askfindhighlight {row id} {
2483 global nhighlights commitinfo iddrawn
2484 global findloc
2485 global markingmatches
2487 if {![info exists commitinfo($id)]} {
2488 getcommit $id
2490 set info $commitinfo($id)
2491 set isbold 0
2492 set fldtypes {Headline Author Date Committer CDate Comments}
2493 foreach f $info ty $fldtypes {
2494 if {($findloc eq "All fields" || $findloc eq $ty) &&
2495 [doesmatch $f]} {
2496 if {$ty eq "Author"} {
2497 set isbold 2
2498 break
2500 set isbold 1
2503 if {$isbold && [info exists iddrawn($id)]} {
2504 if {![ishighlighted $row]} {
2505 bolden $row mainfontbold
2506 if {$isbold > 1} {
2507 bolden_name $row mainfontbold
2510 if {$markingmatches} {
2511 markrowmatches $row $id
2514 set nhighlights($row) $isbold
2517 proc markrowmatches {row id} {
2518 global canv canv2 linehtag linentag commitinfo findloc
2520 set headline [lindex $commitinfo($id) 0]
2521 set author [lindex $commitinfo($id) 1]
2522 $canv delete match$row
2523 $canv2 delete match$row
2524 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2525 set m [findmatches $headline]
2526 if {$m ne {}} {
2527 markmatches $canv $row $headline $linehtag($row) $m \
2528 [$canv itemcget $linehtag($row) -font] $row
2531 if {$findloc eq "All fields" || $findloc eq "Author"} {
2532 set m [findmatches $author]
2533 if {$m ne {}} {
2534 markmatches $canv2 $row $author $linentag($row) $m \
2535 [$canv2 itemcget $linentag($row) -font] $row
2540 proc vrel_change {name ix op} {
2541 global highlight_related
2543 rhighlight_none
2544 if {$highlight_related ne "None"} {
2545 run drawvisible
2549 # prepare for testing whether commits are descendents or ancestors of a
2550 proc rhighlight_sel {a} {
2551 global descendent desc_todo ancestor anc_todo
2552 global highlight_related rhighlights
2554 catch {unset descendent}
2555 set desc_todo [list $a]
2556 catch {unset ancestor}
2557 set anc_todo [list $a]
2558 if {$highlight_related ne "None"} {
2559 rhighlight_none
2560 run drawvisible
2564 proc rhighlight_none {} {
2565 global rhighlights
2567 catch {unset rhighlights}
2568 unbolden
2571 proc is_descendent {a} {
2572 global curview children commitrow descendent desc_todo
2574 set v $curview
2575 set la $commitrow($v,$a)
2576 set todo $desc_todo
2577 set leftover {}
2578 set done 0
2579 for {set i 0} {$i < [llength $todo]} {incr i} {
2580 set do [lindex $todo $i]
2581 if {$commitrow($v,$do) < $la} {
2582 lappend leftover $do
2583 continue
2585 foreach nk $children($v,$do) {
2586 if {![info exists descendent($nk)]} {
2587 set descendent($nk) 1
2588 lappend todo $nk
2589 if {$nk eq $a} {
2590 set done 1
2594 if {$done} {
2595 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2596 return
2599 set descendent($a) 0
2600 set desc_todo $leftover
2603 proc is_ancestor {a} {
2604 global curview parentlist commitrow ancestor anc_todo
2606 set v $curview
2607 set la $commitrow($v,$a)
2608 set todo $anc_todo
2609 set leftover {}
2610 set done 0
2611 for {set i 0} {$i < [llength $todo]} {incr i} {
2612 set do [lindex $todo $i]
2613 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2614 lappend leftover $do
2615 continue
2617 foreach np [lindex $parentlist $commitrow($v,$do)] {
2618 if {![info exists ancestor($np)]} {
2619 set ancestor($np) 1
2620 lappend todo $np
2621 if {$np eq $a} {
2622 set done 1
2626 if {$done} {
2627 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2628 return
2631 set ancestor($a) 0
2632 set anc_todo $leftover
2635 proc askrelhighlight {row id} {
2636 global descendent highlight_related iddrawn rhighlights
2637 global selectedline ancestor
2639 if {![info exists selectedline]} return
2640 set isbold 0
2641 if {$highlight_related eq "Descendent" ||
2642 $highlight_related eq "Not descendent"} {
2643 if {![info exists descendent($id)]} {
2644 is_descendent $id
2646 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2647 set isbold 1
2649 } elseif {$highlight_related eq "Ancestor" ||
2650 $highlight_related eq "Not ancestor"} {
2651 if {![info exists ancestor($id)]} {
2652 is_ancestor $id
2654 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2655 set isbold 1
2658 if {[info exists iddrawn($id)]} {
2659 if {$isbold && ![ishighlighted $row]} {
2660 bolden $row mainfontbold
2663 set rhighlights($row) $isbold
2666 # Graph layout functions
2668 proc shortids {ids} {
2669 set res {}
2670 foreach id $ids {
2671 if {[llength $id] > 1} {
2672 lappend res [shortids $id]
2673 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2674 lappend res [string range $id 0 7]
2675 } else {
2676 lappend res $id
2679 return $res
2682 proc ntimes {n o} {
2683 set ret {}
2684 set o [list $o]
2685 for {set mask 1} {$mask <= $n} {incr mask $mask} {
2686 if {($n & $mask) != 0} {
2687 set ret [concat $ret $o]
2689 set o [concat $o $o]
2691 return $ret
2694 # Work out where id should go in idlist so that order-token
2695 # values increase from left to right
2696 proc idcol {idlist id {i 0}} {
2697 global ordertok curview
2699 set t $ordertok($curview,$id)
2700 if {$i >= [llength $idlist] ||
2701 $t < $ordertok($curview,[lindex $idlist $i])} {
2702 if {$i > [llength $idlist]} {
2703 set i [llength $idlist]
2705 while {[incr i -1] >= 0 &&
2706 $t < $ordertok($curview,[lindex $idlist $i])} {}
2707 incr i
2708 } else {
2709 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2710 while {[incr i] < [llength $idlist] &&
2711 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2714 return $i
2717 proc initlayout {} {
2718 global rowidlist rowisopt rowfinal displayorder commitlisted
2719 global numcommits canvxmax canv
2720 global nextcolor
2721 global parentlist
2722 global colormap rowtextx
2723 global selectfirst
2725 set numcommits 0
2726 set displayorder {}
2727 set commitlisted {}
2728 set parentlist {}
2729 set nextcolor 0
2730 set rowidlist {}
2731 set rowisopt {}
2732 set rowfinal {}
2733 set canvxmax [$canv cget -width]
2734 catch {unset colormap}
2735 catch {unset rowtextx}
2736 set selectfirst 1
2739 proc setcanvscroll {} {
2740 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2742 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2743 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2744 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2745 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2748 proc visiblerows {} {
2749 global canv numcommits linespc
2751 set ymax [lindex [$canv cget -scrollregion] 3]
2752 if {$ymax eq {} || $ymax == 0} return
2753 set f [$canv yview]
2754 set y0 [expr {int([lindex $f 0] * $ymax)}]
2755 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2756 if {$r0 < 0} {
2757 set r0 0
2759 set y1 [expr {int([lindex $f 1] * $ymax)}]
2760 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2761 if {$r1 >= $numcommits} {
2762 set r1 [expr {$numcommits - 1}]
2764 return [list $r0 $r1]
2767 proc layoutmore {} {
2768 global commitidx viewcomplete numcommits
2769 global uparrowlen downarrowlen mingaplen curview
2771 set show $commitidx($curview)
2772 if {$show > $numcommits || $viewcomplete($curview)} {
2773 showstuff $show $viewcomplete($curview)
2777 proc showstuff {canshow last} {
2778 global numcommits commitrow pending_select selectedline curview
2779 global mainheadid displayorder selectfirst
2780 global lastscrollset commitinterest
2782 if {$numcommits == 0} {
2783 global phase
2784 set phase "incrdraw"
2785 allcanvs delete all
2787 set r0 $numcommits
2788 set prev $numcommits
2789 set numcommits $canshow
2790 set t [clock clicks -milliseconds]
2791 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2792 set lastscrollset $t
2793 setcanvscroll
2795 set rows [visiblerows]
2796 set r1 [lindex $rows 1]
2797 if {$r1 >= $canshow} {
2798 set r1 [expr {$canshow - 1}]
2800 if {$r0 <= $r1} {
2801 drawcommits $r0 $r1
2803 if {[info exists pending_select] &&
2804 [info exists commitrow($curview,$pending_select)] &&
2805 $commitrow($curview,$pending_select) < $numcommits} {
2806 selectline $commitrow($curview,$pending_select) 1
2808 if {$selectfirst} {
2809 if {[info exists selectedline] || [info exists pending_select]} {
2810 set selectfirst 0
2811 } else {
2812 set l [first_real_row]
2813 selectline $l 1
2814 set selectfirst 0
2819 proc doshowlocalchanges {} {
2820 global curview mainheadid phase commitrow
2822 if {[info exists commitrow($curview,$mainheadid)] &&
2823 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2824 dodiffindex
2825 } elseif {$phase ne {}} {
2826 lappend commitinterest($mainheadid) {}
2830 proc dohidelocalchanges {} {
2831 global localfrow localirow lserial
2833 if {$localfrow >= 0} {
2834 removerow $localfrow
2835 set localfrow -1
2836 if {$localirow > 0} {
2837 incr localirow -1
2840 if {$localirow >= 0} {
2841 removerow $localirow
2842 set localirow -1
2844 incr lserial
2847 # spawn off a process to do git diff-index --cached HEAD
2848 proc dodiffindex {} {
2849 global localirow localfrow lserial showlocalchanges
2851 if {!$showlocalchanges} return
2852 incr lserial
2853 set localfrow -1
2854 set localirow -1
2855 set fd [open "|git diff-index --cached HEAD" r]
2856 fconfigure $fd -blocking 0
2857 filerun $fd [list readdiffindex $fd $lserial]
2860 proc readdiffindex {fd serial} {
2861 global localirow commitrow mainheadid nullid2 curview
2862 global commitinfo commitdata lserial
2864 set isdiff 1
2865 if {[gets $fd line] < 0} {
2866 if {![eof $fd]} {
2867 return 1
2869 set isdiff 0
2871 # we only need to see one line and we don't really care what it says...
2872 close $fd
2874 # now see if there are any local changes not checked in to the index
2875 if {$serial == $lserial} {
2876 set fd [open "|git diff-files" r]
2877 fconfigure $fd -blocking 0
2878 filerun $fd [list readdifffiles $fd $serial]
2881 if {$isdiff && $serial == $lserial && $localirow == -1} {
2882 # add the line for the changes in the index to the graph
2883 set localirow $commitrow($curview,$mainheadid)
2884 set hl "Local changes checked in to index but not committed"
2885 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2886 set commitdata($nullid2) "\n $hl\n"
2887 insertrow $localirow $nullid2
2889 return 0
2892 proc readdifffiles {fd serial} {
2893 global localirow localfrow commitrow mainheadid nullid curview
2894 global commitinfo commitdata lserial
2896 set isdiff 1
2897 if {[gets $fd line] < 0} {
2898 if {![eof $fd]} {
2899 return 1
2901 set isdiff 0
2903 # we only need to see one line and we don't really care what it says...
2904 close $fd
2906 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2907 # add the line for the local diff to the graph
2908 if {$localirow >= 0} {
2909 set localfrow $localirow
2910 incr localirow
2911 } else {
2912 set localfrow $commitrow($curview,$mainheadid)
2914 set hl "Local uncommitted changes, not checked in to index"
2915 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2916 set commitdata($nullid) "\n $hl\n"
2917 insertrow $localfrow $nullid
2919 return 0
2922 proc nextuse {id row} {
2923 global commitrow curview children
2925 if {[info exists children($curview,$id)]} {
2926 foreach kid $children($curview,$id) {
2927 if {![info exists commitrow($curview,$kid)]} {
2928 return -1
2930 if {$commitrow($curview,$kid) > $row} {
2931 return $commitrow($curview,$kid)
2935 if {[info exists commitrow($curview,$id)]} {
2936 return $commitrow($curview,$id)
2938 return -1
2941 proc prevuse {id row} {
2942 global commitrow curview children
2944 set ret -1
2945 if {[info exists children($curview,$id)]} {
2946 foreach kid $children($curview,$id) {
2947 if {![info exists commitrow($curview,$kid)]} break
2948 if {$commitrow($curview,$kid) < $row} {
2949 set ret $commitrow($curview,$kid)
2953 return $ret
2956 proc make_idlist {row} {
2957 global displayorder parentlist uparrowlen downarrowlen mingaplen
2958 global commitidx curview ordertok children commitrow
2960 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
2961 if {$r < 0} {
2962 set r 0
2964 set ra [expr {$row - $downarrowlen}]
2965 if {$ra < 0} {
2966 set ra 0
2968 set rb [expr {$row + $uparrowlen}]
2969 if {$rb > $commitidx($curview)} {
2970 set rb $commitidx($curview)
2972 set ids {}
2973 for {} {$r < $ra} {incr r} {
2974 set nextid [lindex $displayorder [expr {$r + 1}]]
2975 foreach p [lindex $parentlist $r] {
2976 if {$p eq $nextid} continue
2977 set rn [nextuse $p $r]
2978 if {$rn >= $row &&
2979 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
2980 lappend ids [list $ordertok($curview,$p) $p]
2984 for {} {$r < $row} {incr r} {
2985 set nextid [lindex $displayorder [expr {$r + 1}]]
2986 foreach p [lindex $parentlist $r] {
2987 if {$p eq $nextid} continue
2988 set rn [nextuse $p $r]
2989 if {$rn < 0 || $rn >= $row} {
2990 lappend ids [list $ordertok($curview,$p) $p]
2994 set id [lindex $displayorder $row]
2995 lappend ids [list $ordertok($curview,$id) $id]
2996 while {$r < $rb} {
2997 foreach p [lindex $parentlist $r] {
2998 set firstkid [lindex $children($curview,$p) 0]
2999 if {$commitrow($curview,$firstkid) < $row} {
3000 lappend ids [list $ordertok($curview,$p) $p]
3003 incr r
3004 set id [lindex $displayorder $r]
3005 if {$id ne {}} {
3006 set firstkid [lindex $children($curview,$id) 0]
3007 if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
3008 lappend ids [list $ordertok($curview,$id) $id]
3012 set idlist {}
3013 foreach idx [lsort -unique $ids] {
3014 lappend idlist [lindex $idx 1]
3016 return $idlist
3019 proc rowsequal {a b} {
3020 while {[set i [lsearch -exact $a {}]] >= 0} {
3021 set a [lreplace $a $i $i]
3023 while {[set i [lsearch -exact $b {}]] >= 0} {
3024 set b [lreplace $b $i $i]
3026 return [expr {$a eq $b}]
3029 proc makeupline {id row rend col} {
3030 global rowidlist uparrowlen downarrowlen mingaplen
3032 for {set r $rend} {1} {set r $rstart} {
3033 set rstart [prevuse $id $r]
3034 if {$rstart < 0} return
3035 if {$rstart < $row} break
3037 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3038 set rstart [expr {$rend - $uparrowlen - 1}]
3040 for {set r $rstart} {[incr r] <= $row} {} {
3041 set idlist [lindex $rowidlist $r]
3042 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3043 set col [idcol $idlist $id $col]
3044 lset rowidlist $r [linsert $idlist $col $id]
3045 changedrow $r
3050 proc layoutrows {row endrow} {
3051 global rowidlist rowisopt rowfinal displayorder
3052 global uparrowlen downarrowlen maxwidth mingaplen
3053 global children parentlist
3054 global commitidx viewcomplete curview commitrow
3056 set idlist {}
3057 if {$row > 0} {
3058 set rm1 [expr {$row - 1}]
3059 foreach id [lindex $rowidlist $rm1] {
3060 if {$id ne {}} {
3061 lappend idlist $id
3064 set final [lindex $rowfinal $rm1]
3066 for {} {$row < $endrow} {incr row} {
3067 set rm1 [expr {$row - 1}]
3068 if {$rm1 < 0 || $idlist eq {}} {
3069 set idlist [make_idlist $row]
3070 set final 1
3071 } else {
3072 set id [lindex $displayorder $rm1]
3073 set col [lsearch -exact $idlist $id]
3074 set idlist [lreplace $idlist $col $col]
3075 foreach p [lindex $parentlist $rm1] {
3076 if {[lsearch -exact $idlist $p] < 0} {
3077 set col [idcol $idlist $p $col]
3078 set idlist [linsert $idlist $col $p]
3079 # if not the first child, we have to insert a line going up
3080 if {$id ne [lindex $children($curview,$p) 0]} {
3081 makeupline $p $rm1 $row $col
3085 set id [lindex $displayorder $row]
3086 if {$row > $downarrowlen} {
3087 set termrow [expr {$row - $downarrowlen - 1}]
3088 foreach p [lindex $parentlist $termrow] {
3089 set i [lsearch -exact $idlist $p]
3090 if {$i < 0} continue
3091 set nr [nextuse $p $termrow]
3092 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3093 set idlist [lreplace $idlist $i $i]
3097 set col [lsearch -exact $idlist $id]
3098 if {$col < 0} {
3099 set col [idcol $idlist $id]
3100 set idlist [linsert $idlist $col $id]
3101 if {$children($curview,$id) ne {}} {
3102 makeupline $id $rm1 $row $col
3105 set r [expr {$row + $uparrowlen - 1}]
3106 if {$r < $commitidx($curview)} {
3107 set x $col
3108 foreach p [lindex $parentlist $r] {
3109 if {[lsearch -exact $idlist $p] >= 0} continue
3110 set fk [lindex $children($curview,$p) 0]
3111 if {$commitrow($curview,$fk) < $row} {
3112 set x [idcol $idlist $p $x]
3113 set idlist [linsert $idlist $x $p]
3116 if {[incr r] < $commitidx($curview)} {
3117 set p [lindex $displayorder $r]
3118 if {[lsearch -exact $idlist $p] < 0} {
3119 set fk [lindex $children($curview,$p) 0]
3120 if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3121 set x [idcol $idlist $p $x]
3122 set idlist [linsert $idlist $x $p]
3128 if {$final && !$viewcomplete($curview) &&
3129 $row + $uparrowlen + $mingaplen + $downarrowlen
3130 >= $commitidx($curview)} {
3131 set final 0
3133 set l [llength $rowidlist]
3134 if {$row == $l} {
3135 lappend rowidlist $idlist
3136 lappend rowisopt 0
3137 lappend rowfinal $final
3138 } elseif {$row < $l} {
3139 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3140 lset rowidlist $row $idlist
3141 changedrow $row
3143 lset rowfinal $row $final
3144 } else {
3145 set pad [ntimes [expr {$row - $l}] {}]
3146 set rowidlist [concat $rowidlist $pad]
3147 lappend rowidlist $idlist
3148 set rowfinal [concat $rowfinal $pad]
3149 lappend rowfinal $final
3150 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3153 return $row
3156 proc changedrow {row} {
3157 global displayorder iddrawn rowisopt need_redisplay
3159 set l [llength $rowisopt]
3160 if {$row < $l} {
3161 lset rowisopt $row 0
3162 if {$row + 1 < $l} {
3163 lset rowisopt [expr {$row + 1}] 0
3164 if {$row + 2 < $l} {
3165 lset rowisopt [expr {$row + 2}] 0
3169 set id [lindex $displayorder $row]
3170 if {[info exists iddrawn($id)]} {
3171 set need_redisplay 1
3175 proc insert_pad {row col npad} {
3176 global rowidlist
3178 set pad [ntimes $npad {}]
3179 set idlist [lindex $rowidlist $row]
3180 set bef [lrange $idlist 0 [expr {$col - 1}]]
3181 set aft [lrange $idlist $col end]
3182 set i [lsearch -exact $aft {}]
3183 if {$i > 0} {
3184 set aft [lreplace $aft $i $i]
3186 lset rowidlist $row [concat $bef $pad $aft]
3187 changedrow $row
3190 proc optimize_rows {row col endrow} {
3191 global rowidlist rowisopt displayorder curview children
3193 if {$row < 1} {
3194 set row 1
3196 for {} {$row < $endrow} {incr row; set col 0} {
3197 if {[lindex $rowisopt $row]} continue
3198 set haspad 0
3199 set y0 [expr {$row - 1}]
3200 set ym [expr {$row - 2}]
3201 set idlist [lindex $rowidlist $row]
3202 set previdlist [lindex $rowidlist $y0]
3203 if {$idlist eq {} || $previdlist eq {}} continue
3204 if {$ym >= 0} {
3205 set pprevidlist [lindex $rowidlist $ym]
3206 if {$pprevidlist eq {}} continue
3207 } else {
3208 set pprevidlist {}
3210 set x0 -1
3211 set xm -1
3212 for {} {$col < [llength $idlist]} {incr col} {
3213 set id [lindex $idlist $col]
3214 if {[lindex $previdlist $col] eq $id} continue
3215 if {$id eq {}} {
3216 set haspad 1
3217 continue
3219 set x0 [lsearch -exact $previdlist $id]
3220 if {$x0 < 0} continue
3221 set z [expr {$x0 - $col}]
3222 set isarrow 0
3223 set z0 {}
3224 if {$ym >= 0} {
3225 set xm [lsearch -exact $pprevidlist $id]
3226 if {$xm >= 0} {
3227 set z0 [expr {$xm - $x0}]
3230 if {$z0 eq {}} {
3231 # if row y0 is the first child of $id then it's not an arrow
3232 if {[lindex $children($curview,$id) 0] ne
3233 [lindex $displayorder $y0]} {
3234 set isarrow 1
3237 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3238 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3239 set isarrow 1
3241 # Looking at lines from this row to the previous row,
3242 # make them go straight up if they end in an arrow on
3243 # the previous row; otherwise make them go straight up
3244 # or at 45 degrees.
3245 if {$z < -1 || ($z < 0 && $isarrow)} {
3246 # Line currently goes left too much;
3247 # insert pads in the previous row, then optimize it
3248 set npad [expr {-1 - $z + $isarrow}]
3249 insert_pad $y0 $x0 $npad
3250 if {$y0 > 0} {
3251 optimize_rows $y0 $x0 $row
3253 set previdlist [lindex $rowidlist $y0]
3254 set x0 [lsearch -exact $previdlist $id]
3255 set z [expr {$x0 - $col}]
3256 if {$z0 ne {}} {
3257 set pprevidlist [lindex $rowidlist $ym]
3258 set xm [lsearch -exact $pprevidlist $id]
3259 set z0 [expr {$xm - $x0}]
3261 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3262 # Line currently goes right too much;
3263 # insert pads in this line
3264 set npad [expr {$z - 1 + $isarrow}]
3265 insert_pad $row $col $npad
3266 set idlist [lindex $rowidlist $row]
3267 incr col $npad
3268 set z [expr {$x0 - $col}]
3269 set haspad 1
3271 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3272 # this line links to its first child on row $row-2
3273 set id [lindex $displayorder $ym]
3274 set xc [lsearch -exact $pprevidlist $id]
3275 if {$xc >= 0} {
3276 set z0 [expr {$xc - $x0}]
3279 # avoid lines jigging left then immediately right
3280 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3281 insert_pad $y0 $x0 1
3282 incr x0
3283 optimize_rows $y0 $x0 $row
3284 set previdlist [lindex $rowidlist $y0]
3287 if {!$haspad} {
3288 # Find the first column that doesn't have a line going right
3289 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3290 set id [lindex $idlist $col]
3291 if {$id eq {}} break
3292 set x0 [lsearch -exact $previdlist $id]
3293 if {$x0 < 0} {
3294 # check if this is the link to the first child
3295 set kid [lindex $displayorder $y0]
3296 if {[lindex $children($curview,$id) 0] eq $kid} {
3297 # it is, work out offset to child
3298 set x0 [lsearch -exact $previdlist $kid]
3301 if {$x0 <= $col} break
3303 # Insert a pad at that column as long as it has a line and
3304 # isn't the last column
3305 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3306 set idlist [linsert $idlist $col {}]
3307 lset rowidlist $row $idlist
3308 changedrow $row
3314 proc xc {row col} {
3315 global canvx0 linespc
3316 return [expr {$canvx0 + $col * $linespc}]
3319 proc yc {row} {
3320 global canvy0 linespc
3321 return [expr {$canvy0 + $row * $linespc}]
3324 proc linewidth {id} {
3325 global thickerline lthickness
3327 set wid $lthickness
3328 if {[info exists thickerline] && $id eq $thickerline} {
3329 set wid [expr {2 * $lthickness}]
3331 return $wid
3334 proc rowranges {id} {
3335 global commitrow curview children uparrowlen downarrowlen
3336 global rowidlist
3338 set kids $children($curview,$id)
3339 if {$kids eq {}} {
3340 return {}
3342 set ret {}
3343 lappend kids $id
3344 foreach child $kids {
3345 if {![info exists commitrow($curview,$child)]} break
3346 set row $commitrow($curview,$child)
3347 if {![info exists prev]} {
3348 lappend ret [expr {$row + 1}]
3349 } else {
3350 if {$row <= $prevrow} {
3351 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3353 # see if the line extends the whole way from prevrow to row
3354 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3355 [lsearch -exact [lindex $rowidlist \
3356 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3357 # it doesn't, see where it ends
3358 set r [expr {$prevrow + $downarrowlen}]
3359 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3360 while {[incr r -1] > $prevrow &&
3361 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3362 } else {
3363 while {[incr r] <= $row &&
3364 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3365 incr r -1
3367 lappend ret $r
3368 # see where it starts up again
3369 set r [expr {$row - $uparrowlen}]
3370 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3371 while {[incr r] < $row &&
3372 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3373 } else {
3374 while {[incr r -1] >= $prevrow &&
3375 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3376 incr r
3378 lappend ret $r
3381 if {$child eq $id} {
3382 lappend ret $row
3384 set prev $id
3385 set prevrow $row
3387 return $ret
3390 proc drawlineseg {id row endrow arrowlow} {
3391 global rowidlist displayorder iddrawn linesegs
3392 global canv colormap linespc curview maxlinelen parentlist
3394 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3395 set le [expr {$row + 1}]
3396 set arrowhigh 1
3397 while {1} {
3398 set c [lsearch -exact [lindex $rowidlist $le] $id]
3399 if {$c < 0} {
3400 incr le -1
3401 break
3403 lappend cols $c
3404 set x [lindex $displayorder $le]
3405 if {$x eq $id} {
3406 set arrowhigh 0
3407 break
3409 if {[info exists iddrawn($x)] || $le == $endrow} {
3410 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3411 if {$c >= 0} {
3412 lappend cols $c
3413 set arrowhigh 0
3415 break
3417 incr le
3419 if {$le <= $row} {
3420 return $row
3423 set lines {}
3424 set i 0
3425 set joinhigh 0
3426 if {[info exists linesegs($id)]} {
3427 set lines $linesegs($id)
3428 foreach li $lines {
3429 set r0 [lindex $li 0]
3430 if {$r0 > $row} {
3431 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3432 set joinhigh 1
3434 break
3436 incr i
3439 set joinlow 0
3440 if {$i > 0} {
3441 set li [lindex $lines [expr {$i-1}]]
3442 set r1 [lindex $li 1]
3443 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3444 set joinlow 1
3448 set x [lindex $cols [expr {$le - $row}]]
3449 set xp [lindex $cols [expr {$le - 1 - $row}]]
3450 set dir [expr {$xp - $x}]
3451 if {$joinhigh} {
3452 set ith [lindex $lines $i 2]
3453 set coords [$canv coords $ith]
3454 set ah [$canv itemcget $ith -arrow]
3455 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3456 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3457 if {$x2 ne {} && $x - $x2 == $dir} {
3458 set coords [lrange $coords 0 end-2]
3460 } else {
3461 set coords [list [xc $le $x] [yc $le]]
3463 if {$joinlow} {
3464 set itl [lindex $lines [expr {$i-1}] 2]
3465 set al [$canv itemcget $itl -arrow]
3466 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3467 } elseif {$arrowlow} {
3468 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3469 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3470 set arrowlow 0
3473 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3474 for {set y $le} {[incr y -1] > $row} {} {
3475 set x $xp
3476 set xp [lindex $cols [expr {$y - 1 - $row}]]
3477 set ndir [expr {$xp - $x}]
3478 if {$dir != $ndir || $xp < 0} {
3479 lappend coords [xc $y $x] [yc $y]
3481 set dir $ndir
3483 if {!$joinlow} {
3484 if {$xp < 0} {
3485 # join parent line to first child
3486 set ch [lindex $displayorder $row]
3487 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3488 if {$xc < 0} {
3489 puts "oops: drawlineseg: child $ch not on row $row"
3490 } elseif {$xc != $x} {
3491 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3492 set d [expr {int(0.5 * $linespc)}]
3493 set x1 [xc $row $x]
3494 if {$xc < $x} {
3495 set x2 [expr {$x1 - $d}]
3496 } else {
3497 set x2 [expr {$x1 + $d}]
3499 set y2 [yc $row]
3500 set y1 [expr {$y2 + $d}]
3501 lappend coords $x1 $y1 $x2 $y2
3502 } elseif {$xc < $x - 1} {
3503 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3504 } elseif {$xc > $x + 1} {
3505 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3507 set x $xc
3509 lappend coords [xc $row $x] [yc $row]
3510 } else {
3511 set xn [xc $row $xp]
3512 set yn [yc $row]
3513 lappend coords $xn $yn
3515 if {!$joinhigh} {
3516 assigncolor $id
3517 set t [$canv create line $coords -width [linewidth $id] \
3518 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3519 $canv lower $t
3520 bindline $t $id
3521 set lines [linsert $lines $i [list $row $le $t]]
3522 } else {
3523 $canv coords $ith $coords
3524 if {$arrow ne $ah} {
3525 $canv itemconf $ith -arrow $arrow
3527 lset lines $i 0 $row
3529 } else {
3530 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3531 set ndir [expr {$xo - $xp}]
3532 set clow [$canv coords $itl]
3533 if {$dir == $ndir} {
3534 set clow [lrange $clow 2 end]
3536 set coords [concat $coords $clow]
3537 if {!$joinhigh} {
3538 lset lines [expr {$i-1}] 1 $le
3539 } else {
3540 # coalesce two pieces
3541 $canv delete $ith
3542 set b [lindex $lines [expr {$i-1}] 0]
3543 set e [lindex $lines $i 1]
3544 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3546 $canv coords $itl $coords
3547 if {$arrow ne $al} {
3548 $canv itemconf $itl -arrow $arrow
3552 set linesegs($id) $lines
3553 return $le
3556 proc drawparentlinks {id row} {
3557 global rowidlist canv colormap curview parentlist
3558 global idpos linespc
3560 set rowids [lindex $rowidlist $row]
3561 set col [lsearch -exact $rowids $id]
3562 if {$col < 0} return
3563 set olds [lindex $parentlist $row]
3564 set row2 [expr {$row + 1}]
3565 set x [xc $row $col]
3566 set y [yc $row]
3567 set y2 [yc $row2]
3568 set d [expr {int(0.5 * $linespc)}]
3569 set ymid [expr {$y + $d}]
3570 set ids [lindex $rowidlist $row2]
3571 # rmx = right-most X coord used
3572 set rmx 0
3573 foreach p $olds {
3574 set i [lsearch -exact $ids $p]
3575 if {$i < 0} {
3576 puts "oops, parent $p of $id not in list"
3577 continue
3579 set x2 [xc $row2 $i]
3580 if {$x2 > $rmx} {
3581 set rmx $x2
3583 set j [lsearch -exact $rowids $p]
3584 if {$j < 0} {
3585 # drawlineseg will do this one for us
3586 continue
3588 assigncolor $p
3589 # should handle duplicated parents here...
3590 set coords [list $x $y]
3591 if {$i != $col} {
3592 # if attaching to a vertical segment, draw a smaller
3593 # slant for visual distinctness
3594 if {$i == $j} {
3595 if {$i < $col} {
3596 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3597 } else {
3598 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3600 } elseif {$i < $col && $i < $j} {
3601 # segment slants towards us already
3602 lappend coords [xc $row $j] $y
3603 } else {
3604 if {$i < $col - 1} {
3605 lappend coords [expr {$x2 + $linespc}] $y
3606 } elseif {$i > $col + 1} {
3607 lappend coords [expr {$x2 - $linespc}] $y
3609 lappend coords $x2 $y2
3611 } else {
3612 lappend coords $x2 $y2
3614 set t [$canv create line $coords -width [linewidth $p] \
3615 -fill $colormap($p) -tags lines.$p]
3616 $canv lower $t
3617 bindline $t $p
3619 if {$rmx > [lindex $idpos($id) 1]} {
3620 lset idpos($id) 1 $rmx
3621 redrawtags $id
3625 proc drawlines {id} {
3626 global canv
3628 $canv itemconf lines.$id -width [linewidth $id]
3631 proc drawcmittext {id row col} {
3632 global linespc canv canv2 canv3 canvy0 fgcolor curview
3633 global commitlisted commitinfo rowidlist parentlist
3634 global rowtextx idpos idtags idheads idotherrefs
3635 global linehtag linentag linedtag selectedline
3636 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3638 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3639 set listed [lindex $commitlisted $row]
3640 if {$id eq $nullid} {
3641 set ofill red
3642 } elseif {$id eq $nullid2} {
3643 set ofill green
3644 } else {
3645 set ofill [expr {$listed != 0? "blue": "white"}]
3647 set x [xc $row $col]
3648 set y [yc $row]
3649 set orad [expr {$linespc / 3}]
3650 if {$listed <= 1} {
3651 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3652 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3653 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3654 } elseif {$listed == 2} {
3655 # triangle pointing left for left-side commits
3656 set t [$canv create polygon \
3657 [expr {$x - $orad}] $y \
3658 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3659 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3660 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3661 } else {
3662 # triangle pointing right for right-side commits
3663 set t [$canv create polygon \
3664 [expr {$x + $orad - 1}] $y \
3665 [expr {$x - $orad}] [expr {$y - $orad}] \
3666 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3667 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3669 $canv raise $t
3670 $canv bind $t <1> {selcanvline {} %x %y}
3671 set rmx [llength [lindex $rowidlist $row]]
3672 set olds [lindex $parentlist $row]
3673 if {$olds ne {}} {
3674 set nextids [lindex $rowidlist [expr {$row + 1}]]
3675 foreach p $olds {
3676 set i [lsearch -exact $nextids $p]
3677 if {$i > $rmx} {
3678 set rmx $i
3682 set xt [xc $row $rmx]
3683 set rowtextx($row) $xt
3684 set idpos($id) [list $x $xt $y]
3685 if {[info exists idtags($id)] || [info exists idheads($id)]
3686 || [info exists idotherrefs($id)]} {
3687 set xt [drawtags $id $x $xt $y]
3689 set headline [lindex $commitinfo($id) 0]
3690 set name [lindex $commitinfo($id) 1]
3691 set date [lindex $commitinfo($id) 2]
3692 set date [formatdate $date]
3693 set font mainfont
3694 set nfont mainfont
3695 set isbold [ishighlighted $row]
3696 if {$isbold > 0} {
3697 lappend boldrows $row
3698 set font mainfontbold
3699 if {$isbold > 1} {
3700 lappend boldnamerows $row
3701 set nfont mainfontbold
3704 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3705 -text $headline -font $font -tags text]
3706 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3707 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3708 -text $name -font $nfont -tags text]
3709 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3710 -text $date -font mainfont -tags text]
3711 if {[info exists selectedline] && $selectedline == $row} {
3712 make_secsel $row
3714 set xr [expr {$xt + [font measure $font $headline]}]
3715 if {$xr > $canvxmax} {
3716 set canvxmax $xr
3717 setcanvscroll
3721 proc drawcmitrow {row} {
3722 global displayorder rowidlist nrows_drawn
3723 global iddrawn markingmatches
3724 global commitinfo parentlist numcommits
3725 global filehighlight fhighlights findpattern nhighlights
3726 global hlview vhighlights
3727 global highlight_related rhighlights
3729 if {$row >= $numcommits} return
3731 set id [lindex $displayorder $row]
3732 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3733 askvhighlight $row $id
3735 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3736 askfilehighlight $row $id
3738 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
3739 askfindhighlight $row $id
3741 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3742 askrelhighlight $row $id
3744 if {![info exists iddrawn($id)]} {
3745 set col [lsearch -exact [lindex $rowidlist $row] $id]
3746 if {$col < 0} {
3747 puts "oops, row $row id $id not in list"
3748 return
3750 if {![info exists commitinfo($id)]} {
3751 getcommit $id
3753 assigncolor $id
3754 drawcmittext $id $row $col
3755 set iddrawn($id) 1
3756 incr nrows_drawn
3758 if {$markingmatches} {
3759 markrowmatches $row $id
3763 proc drawcommits {row {endrow {}}} {
3764 global numcommits iddrawn displayorder curview need_redisplay
3765 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3767 if {$row < 0} {
3768 set row 0
3770 if {$endrow eq {}} {
3771 set endrow $row
3773 if {$endrow >= $numcommits} {
3774 set endrow [expr {$numcommits - 1}]
3777 set rl1 [expr {$row - $downarrowlen - 3}]
3778 if {$rl1 < 0} {
3779 set rl1 0
3781 set ro1 [expr {$row - 3}]
3782 if {$ro1 < 0} {
3783 set ro1 0
3785 set r2 [expr {$endrow + $uparrowlen + 3}]
3786 if {$r2 > $numcommits} {
3787 set r2 $numcommits
3789 for {set r $rl1} {$r < $r2} {incr r} {
3790 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3791 if {$rl1 < $r} {
3792 layoutrows $rl1 $r
3794 set rl1 [expr {$r + 1}]
3797 if {$rl1 < $r} {
3798 layoutrows $rl1 $r
3800 optimize_rows $ro1 0 $r2
3801 if {$need_redisplay || $nrows_drawn > 2000} {
3802 clear_display
3803 drawvisible
3806 # make the lines join to already-drawn rows either side
3807 set r [expr {$row - 1}]
3808 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3809 set r $row
3811 set er [expr {$endrow + 1}]
3812 if {$er >= $numcommits ||
3813 ![info exists iddrawn([lindex $displayorder $er])]} {
3814 set er $endrow
3816 for {} {$r <= $er} {incr r} {
3817 set id [lindex $displayorder $r]
3818 set wasdrawn [info exists iddrawn($id)]
3819 drawcmitrow $r
3820 if {$r == $er} break
3821 set nextid [lindex $displayorder [expr {$r + 1}]]
3822 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
3823 drawparentlinks $id $r
3825 set rowids [lindex $rowidlist $r]
3826 foreach lid $rowids {
3827 if {$lid eq {}} continue
3828 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
3829 if {$lid eq $id} {
3830 # see if this is the first child of any of its parents
3831 foreach p [lindex $parentlist $r] {
3832 if {[lsearch -exact $rowids $p] < 0} {
3833 # make this line extend up to the child
3834 set lineend($p) [drawlineseg $p $r $er 0]
3837 } else {
3838 set lineend($lid) [drawlineseg $lid $r $er 1]
3844 proc drawfrac {f0 f1} {
3845 global canv linespc
3847 set ymax [lindex [$canv cget -scrollregion] 3]
3848 if {$ymax eq {} || $ymax == 0} return
3849 set y0 [expr {int($f0 * $ymax)}]
3850 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3851 set y1 [expr {int($f1 * $ymax)}]
3852 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3853 drawcommits $row $endrow
3856 proc drawvisible {} {
3857 global canv
3858 eval drawfrac [$canv yview]
3861 proc clear_display {} {
3862 global iddrawn linesegs need_redisplay nrows_drawn
3863 global vhighlights fhighlights nhighlights rhighlights
3865 allcanvs delete all
3866 catch {unset iddrawn}
3867 catch {unset linesegs}
3868 catch {unset vhighlights}
3869 catch {unset fhighlights}
3870 catch {unset nhighlights}
3871 catch {unset rhighlights}
3872 set need_redisplay 0
3873 set nrows_drawn 0
3876 proc findcrossings {id} {
3877 global rowidlist parentlist numcommits displayorder
3879 set cross {}
3880 set ccross {}
3881 foreach {s e} [rowranges $id] {
3882 if {$e >= $numcommits} {
3883 set e [expr {$numcommits - 1}]
3885 if {$e <= $s} continue
3886 for {set row $e} {[incr row -1] >= $s} {} {
3887 set x [lsearch -exact [lindex $rowidlist $row] $id]
3888 if {$x < 0} break
3889 set olds [lindex $parentlist $row]
3890 set kid [lindex $displayorder $row]
3891 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3892 if {$kidx < 0} continue
3893 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3894 foreach p $olds {
3895 set px [lsearch -exact $nextrow $p]
3896 if {$px < 0} continue
3897 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3898 if {[lsearch -exact $ccross $p] >= 0} continue
3899 if {$x == $px + ($kidx < $px? -1: 1)} {
3900 lappend ccross $p
3901 } elseif {[lsearch -exact $cross $p] < 0} {
3902 lappend cross $p
3908 return [concat $ccross {{}} $cross]
3911 proc assigncolor {id} {
3912 global colormap colors nextcolor
3913 global commitrow parentlist children children curview
3915 if {[info exists colormap($id)]} return
3916 set ncolors [llength $colors]
3917 if {[info exists children($curview,$id)]} {
3918 set kids $children($curview,$id)
3919 } else {
3920 set kids {}
3922 if {[llength $kids] == 1} {
3923 set child [lindex $kids 0]
3924 if {[info exists colormap($child)]
3925 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3926 set colormap($id) $colormap($child)
3927 return
3930 set badcolors {}
3931 set origbad {}
3932 foreach x [findcrossings $id] {
3933 if {$x eq {}} {
3934 # delimiter between corner crossings and other crossings
3935 if {[llength $badcolors] >= $ncolors - 1} break
3936 set origbad $badcolors
3938 if {[info exists colormap($x)]
3939 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3940 lappend badcolors $colormap($x)
3943 if {[llength $badcolors] >= $ncolors} {
3944 set badcolors $origbad
3946 set origbad $badcolors
3947 if {[llength $badcolors] < $ncolors - 1} {
3948 foreach child $kids {
3949 if {[info exists colormap($child)]
3950 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3951 lappend badcolors $colormap($child)
3953 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3954 if {[info exists colormap($p)]
3955 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3956 lappend badcolors $colormap($p)
3960 if {[llength $badcolors] >= $ncolors} {
3961 set badcolors $origbad
3964 for {set i 0} {$i <= $ncolors} {incr i} {
3965 set c [lindex $colors $nextcolor]
3966 if {[incr nextcolor] >= $ncolors} {
3967 set nextcolor 0
3969 if {[lsearch -exact $badcolors $c]} break
3971 set colormap($id) $c
3974 proc bindline {t id} {
3975 global canv
3977 $canv bind $t <Enter> "lineenter %x %y $id"
3978 $canv bind $t <Motion> "linemotion %x %y $id"
3979 $canv bind $t <Leave> "lineleave $id"
3980 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3983 proc drawtags {id x xt y1} {
3984 global idtags idheads idotherrefs mainhead
3985 global linespc lthickness
3986 global canv commitrow rowtextx curview fgcolor bgcolor
3988 set marks {}
3989 set ntags 0
3990 set nheads 0
3991 if {[info exists idtags($id)]} {
3992 set marks $idtags($id)
3993 set ntags [llength $marks]
3995 if {[info exists idheads($id)]} {
3996 set marks [concat $marks $idheads($id)]
3997 set nheads [llength $idheads($id)]
3999 if {[info exists idotherrefs($id)]} {
4000 set marks [concat $marks $idotherrefs($id)]
4002 if {$marks eq {}} {
4003 return $xt
4006 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4007 set yt [expr {$y1 - 0.5 * $linespc}]
4008 set yb [expr {$yt + $linespc - 1}]
4009 set xvals {}
4010 set wvals {}
4011 set i -1
4012 foreach tag $marks {
4013 incr i
4014 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4015 set wid [font measure mainfontbold $tag]
4016 } else {
4017 set wid [font measure mainfont $tag]
4019 lappend xvals $xt
4020 lappend wvals $wid
4021 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4023 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4024 -width $lthickness -fill black -tags tag.$id]
4025 $canv lower $t
4026 foreach tag $marks x $xvals wid $wvals {
4027 set xl [expr {$x + $delta}]
4028 set xr [expr {$x + $delta + $wid + $lthickness}]
4029 set font mainfont
4030 if {[incr ntags -1] >= 0} {
4031 # draw a tag
4032 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4033 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4034 -width 1 -outline black -fill yellow -tags tag.$id]
4035 $canv bind $t <1> [list showtag $tag 1]
4036 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4037 } else {
4038 # draw a head or other ref
4039 if {[incr nheads -1] >= 0} {
4040 set col green
4041 if {$tag eq $mainhead} {
4042 set font mainfontbold
4044 } else {
4045 set col "#ddddff"
4047 set xl [expr {$xl - $delta/2}]
4048 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4049 -width 1 -outline black -fill $col -tags tag.$id
4050 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4051 set rwid [font measure mainfont $remoteprefix]
4052 set xi [expr {$x + 1}]
4053 set yti [expr {$yt + 1}]
4054 set xri [expr {$x + $rwid}]
4055 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4056 -width 0 -fill "#ffddaa" -tags tag.$id
4059 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4060 -font $font -tags [list tag.$id text]]
4061 if {$ntags >= 0} {
4062 $canv bind $t <1> [list showtag $tag 1]
4063 } elseif {$nheads >= 0} {
4064 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4067 return $xt
4070 proc xcoord {i level ln} {
4071 global canvx0 xspc1 xspc2
4073 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4074 if {$i > 0 && $i == $level} {
4075 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4076 } elseif {$i > $level} {
4077 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4079 return $x
4082 proc show_status {msg} {
4083 global canv fgcolor
4085 clear_display
4086 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4087 -tags text -fill $fgcolor
4090 # Insert a new commit as the child of the commit on row $row.
4091 # The new commit will be displayed on row $row and the commits
4092 # on that row and below will move down one row.
4093 proc insertrow {row newcmit} {
4094 global displayorder parentlist commitlisted children
4095 global commitrow curview rowidlist rowisopt rowfinal numcommits
4096 global numcommits
4097 global selectedline commitidx ordertok
4099 if {$row >= $numcommits} {
4100 puts "oops, inserting new row $row but only have $numcommits rows"
4101 return
4103 set p [lindex $displayorder $row]
4104 set displayorder [linsert $displayorder $row $newcmit]
4105 set parentlist [linsert $parentlist $row $p]
4106 set kids $children($curview,$p)
4107 lappend kids $newcmit
4108 set children($curview,$p) $kids
4109 set children($curview,$newcmit) {}
4110 set commitlisted [linsert $commitlisted $row 1]
4111 set l [llength $displayorder]
4112 for {set r $row} {$r < $l} {incr r} {
4113 set id [lindex $displayorder $r]
4114 set commitrow($curview,$id) $r
4116 incr commitidx($curview)
4117 set ordertok($curview,$newcmit) $ordertok($curview,$p)
4119 if {$row < [llength $rowidlist]} {
4120 set idlist [lindex $rowidlist $row]
4121 if {$idlist ne {}} {
4122 if {[llength $kids] == 1} {
4123 set col [lsearch -exact $idlist $p]
4124 lset idlist $col $newcmit
4125 } else {
4126 set col [llength $idlist]
4127 lappend idlist $newcmit
4130 set rowidlist [linsert $rowidlist $row $idlist]
4131 set rowisopt [linsert $rowisopt $row 0]
4132 set rowfinal [linsert $rowfinal $row [lindex $rowfinal $row]]
4135 incr numcommits
4137 if {[info exists selectedline] && $selectedline >= $row} {
4138 incr selectedline
4140 redisplay
4143 # Remove a commit that was inserted with insertrow on row $row.
4144 proc removerow {row} {
4145 global displayorder parentlist commitlisted children
4146 global commitrow curview rowidlist rowisopt rowfinal numcommits
4147 global numcommits
4148 global linesegends selectedline commitidx
4150 if {$row >= $numcommits} {
4151 puts "oops, removing row $row but only have $numcommits rows"
4152 return
4154 set rp1 [expr {$row + 1}]
4155 set id [lindex $displayorder $row]
4156 set p [lindex $parentlist $row]
4157 set displayorder [lreplace $displayorder $row $row]
4158 set parentlist [lreplace $parentlist $row $row]
4159 set commitlisted [lreplace $commitlisted $row $row]
4160 set kids $children($curview,$p)
4161 set i [lsearch -exact $kids $id]
4162 if {$i >= 0} {
4163 set kids [lreplace $kids $i $i]
4164 set children($curview,$p) $kids
4166 set l [llength $displayorder]
4167 for {set r $row} {$r < $l} {incr r} {
4168 set id [lindex $displayorder $r]
4169 set commitrow($curview,$id) $r
4171 incr commitidx($curview) -1
4173 if {$row < [llength $rowidlist]} {
4174 set rowidlist [lreplace $rowidlist $row $row]
4175 set rowisopt [lreplace $rowisopt $row $row]
4176 set rowfinal [lreplace $rowfinal $row $row]
4179 incr numcommits -1
4181 if {[info exists selectedline] && $selectedline > $row} {
4182 incr selectedline -1
4184 redisplay
4187 # Don't change the text pane cursor if it is currently the hand cursor,
4188 # showing that we are over a sha1 ID link.
4189 proc settextcursor {c} {
4190 global ctext curtextcursor
4192 if {[$ctext cget -cursor] == $curtextcursor} {
4193 $ctext config -cursor $c
4195 set curtextcursor $c
4198 proc nowbusy {what {name {}}} {
4199 global isbusy busyname statusw
4201 if {[array names isbusy] eq {}} {
4202 . config -cursor watch
4203 settextcursor watch
4205 set isbusy($what) 1
4206 set busyname($what) $name
4207 if {$name ne {}} {
4208 $statusw conf -text $name
4212 proc notbusy {what} {
4213 global isbusy maincursor textcursor busyname statusw
4215 catch {
4216 unset isbusy($what)
4217 if {$busyname($what) ne {} &&
4218 [$statusw cget -text] eq $busyname($what)} {
4219 $statusw conf -text {}
4222 if {[array names isbusy] eq {}} {
4223 . config -cursor $maincursor
4224 settextcursor $textcursor
4228 proc findmatches {f} {
4229 global findtype findstring
4230 if {$findtype == "Regexp"} {
4231 set matches [regexp -indices -all -inline $findstring $f]
4232 } else {
4233 set fs $findstring
4234 if {$findtype == "IgnCase"} {
4235 set f [string tolower $f]
4236 set fs [string tolower $fs]
4238 set matches {}
4239 set i 0
4240 set l [string length $fs]
4241 while {[set j [string first $fs $f $i]] >= 0} {
4242 lappend matches [list $j [expr {$j+$l-1}]]
4243 set i [expr {$j + $l}]
4246 return $matches
4249 proc dofind {{dirn 1} {wrap 1}} {
4250 global findstring findstartline findcurline selectedline numcommits
4251 global gdttype filehighlight fh_serial find_dirn findallowwrap
4253 if {[info exists find_dirn]} {
4254 if {$find_dirn == $dirn} return
4255 stopfinding
4257 focus .
4258 if {$findstring eq {} || $numcommits == 0} return
4259 if {![info exists selectedline]} {
4260 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4261 } else {
4262 set findstartline $selectedline
4264 set findcurline $findstartline
4265 nowbusy finding "Searching"
4266 if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4267 after cancel do_file_hl $fh_serial
4268 do_file_hl $fh_serial
4270 set find_dirn $dirn
4271 set findallowwrap $wrap
4272 run findmore
4275 proc stopfinding {} {
4276 global find_dirn findcurline fprogcoord
4278 if {[info exists find_dirn]} {
4279 unset find_dirn
4280 unset findcurline
4281 notbusy finding
4282 set fprogcoord 0
4283 adjustprogress
4287 proc findmore {} {
4288 global commitdata commitinfo numcommits findpattern findloc
4289 global findstartline findcurline displayorder
4290 global find_dirn gdttype fhighlights fprogcoord
4291 global findallowwrap
4293 if {![info exists find_dirn]} {
4294 return 0
4296 set fldtypes {Headline Author Date Committer CDate Comments}
4297 set l $findcurline
4298 set moretodo 0
4299 if {$find_dirn > 0} {
4300 incr l
4301 if {$l >= $numcommits} {
4302 set l 0
4304 if {$l <= $findstartline} {
4305 set lim [expr {$findstartline + 1}]
4306 } else {
4307 set lim $numcommits
4308 set moretodo $findallowwrap
4310 } else {
4311 if {$l == 0} {
4312 set l $numcommits
4314 incr l -1
4315 if {$l >= $findstartline} {
4316 set lim [expr {$findstartline - 1}]
4317 } else {
4318 set lim -1
4319 set moretodo $findallowwrap
4322 set n [expr {($lim - $l) * $find_dirn}]
4323 if {$n > 500} {
4324 set n 500
4325 set moretodo 1
4327 set found 0
4328 set domore 1
4329 if {$gdttype eq "containing:"} {
4330 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4331 set id [lindex $displayorder $l]
4332 # shouldn't happen unless git log doesn't give all the commits...
4333 if {![info exists commitdata($id)]} continue
4334 if {![doesmatch $commitdata($id)]} continue
4335 if {![info exists commitinfo($id)]} {
4336 getcommit $id
4338 set info $commitinfo($id)
4339 foreach f $info ty $fldtypes {
4340 if {($findloc eq "All fields" || $findloc eq $ty) &&
4341 [doesmatch $f]} {
4342 set found 1
4343 break
4346 if {$found} break
4348 } else {
4349 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4350 set id [lindex $displayorder $l]
4351 if {![info exists fhighlights($l)]} {
4352 askfilehighlight $l $id
4353 if {$domore} {
4354 set domore 0
4355 set findcurline [expr {$l - $find_dirn}]
4357 } elseif {$fhighlights($l)} {
4358 set found $domore
4359 break
4363 if {$found || ($domore && !$moretodo)} {
4364 unset findcurline
4365 unset find_dirn
4366 notbusy finding
4367 set fprogcoord 0
4368 adjustprogress
4369 if {$found} {
4370 findselectline $l
4371 } else {
4372 bell
4374 return 0
4376 if {!$domore} {
4377 flushhighlights
4378 } else {
4379 set findcurline [expr {$l - $find_dirn}]
4381 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
4382 if {$n < 0} {
4383 incr n $numcommits
4385 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4386 adjustprogress
4387 return $domore
4390 proc findselectline {l} {
4391 global findloc commentend ctext findcurline markingmatches gdttype
4393 set markingmatches 1
4394 set findcurline $l
4395 selectline $l 1
4396 if {$findloc == "All fields" || $findloc == "Comments"} {
4397 # highlight the matches in the comments
4398 set f [$ctext get 1.0 $commentend]
4399 set matches [findmatches $f]
4400 foreach match $matches {
4401 set start [lindex $match 0]
4402 set end [expr {[lindex $match 1] + 1}]
4403 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4406 drawvisible
4409 # mark the bits of a headline or author that match a find string
4410 proc markmatches {canv l str tag matches font row} {
4411 global selectedline
4413 set bbox [$canv bbox $tag]
4414 set x0 [lindex $bbox 0]
4415 set y0 [lindex $bbox 1]
4416 set y1 [lindex $bbox 3]
4417 foreach match $matches {
4418 set start [lindex $match 0]
4419 set end [lindex $match 1]
4420 if {$start > $end} continue
4421 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4422 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4423 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4424 [expr {$x0+$xlen+2}] $y1 \
4425 -outline {} -tags [list match$l matches] -fill yellow]
4426 $canv lower $t
4427 if {[info exists selectedline] && $row == $selectedline} {
4428 $canv raise $t secsel
4433 proc unmarkmatches {} {
4434 global markingmatches
4436 allcanvs delete matches
4437 set markingmatches 0
4438 stopfinding
4441 proc selcanvline {w x y} {
4442 global canv canvy0 ctext linespc
4443 global rowtextx
4444 set ymax [lindex [$canv cget -scrollregion] 3]
4445 if {$ymax == {}} return
4446 set yfrac [lindex [$canv yview] 0]
4447 set y [expr {$y + $yfrac * $ymax}]
4448 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4449 if {$l < 0} {
4450 set l 0
4452 if {$w eq $canv} {
4453 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4455 unmarkmatches
4456 selectline $l 1
4459 proc commit_descriptor {p} {
4460 global commitinfo
4461 if {![info exists commitinfo($p)]} {
4462 getcommit $p
4464 set l "..."
4465 if {[llength $commitinfo($p)] > 1} {
4466 set l [lindex $commitinfo($p) 0]
4468 return "$p ($l)\n"
4471 # append some text to the ctext widget, and make any SHA1 ID
4472 # that we know about be a clickable link.
4473 proc appendwithlinks {text tags} {
4474 global ctext commitrow linknum curview pendinglinks
4476 set start [$ctext index "end - 1c"]
4477 $ctext insert end $text $tags
4478 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4479 foreach l $links {
4480 set s [lindex $l 0]
4481 set e [lindex $l 1]
4482 set linkid [string range $text $s $e]
4483 incr e
4484 $ctext tag delete link$linknum
4485 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4486 setlink $linkid link$linknum
4487 incr linknum
4491 proc setlink {id lk} {
4492 global curview commitrow ctext pendinglinks commitinterest
4494 if {[info exists commitrow($curview,$id)]} {
4495 $ctext tag conf $lk -foreground blue -underline 1
4496 $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4497 $ctext tag bind $lk <Enter> {linkcursor %W 1}
4498 $ctext tag bind $lk <Leave> {linkcursor %W -1}
4499 } else {
4500 lappend pendinglinks($id) $lk
4501 lappend commitinterest($id) {makelink %I}
4505 proc makelink {id} {
4506 global pendinglinks
4508 if {![info exists pendinglinks($id)]} return
4509 foreach lk $pendinglinks($id) {
4510 setlink $id $lk
4512 unset pendinglinks($id)
4515 proc linkcursor {w inc} {
4516 global linkentercount curtextcursor
4518 if {[incr linkentercount $inc] > 0} {
4519 $w configure -cursor hand2
4520 } else {
4521 $w configure -cursor $curtextcursor
4522 if {$linkentercount < 0} {
4523 set linkentercount 0
4528 proc viewnextline {dir} {
4529 global canv linespc
4531 $canv delete hover
4532 set ymax [lindex [$canv cget -scrollregion] 3]
4533 set wnow [$canv yview]
4534 set wtop [expr {[lindex $wnow 0] * $ymax}]
4535 set newtop [expr {$wtop + $dir * $linespc}]
4536 if {$newtop < 0} {
4537 set newtop 0
4538 } elseif {$newtop > $ymax} {
4539 set newtop $ymax
4541 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4544 # add a list of tag or branch names at position pos
4545 # returns the number of names inserted
4546 proc appendrefs {pos ids var} {
4547 global ctext commitrow linknum curview $var maxrefs
4549 if {[catch {$ctext index $pos}]} {
4550 return 0
4552 $ctext conf -state normal
4553 $ctext delete $pos "$pos lineend"
4554 set tags {}
4555 foreach id $ids {
4556 foreach tag [set $var\($id\)] {
4557 lappend tags [list $tag $id]
4560 if {[llength $tags] > $maxrefs} {
4561 $ctext insert $pos "many ([llength $tags])"
4562 } else {
4563 set tags [lsort -index 0 -decreasing $tags]
4564 set sep {}
4565 foreach ti $tags {
4566 set id [lindex $ti 1]
4567 set lk link$linknum
4568 incr linknum
4569 $ctext tag delete $lk
4570 $ctext insert $pos $sep
4571 $ctext insert $pos [lindex $ti 0] $lk
4572 setlink $id $lk
4573 set sep ", "
4576 $ctext conf -state disabled
4577 return [llength $tags]
4580 # called when we have finished computing the nearby tags
4581 proc dispneartags {delay} {
4582 global selectedline currentid showneartags tagphase
4584 if {![info exists selectedline] || !$showneartags} return
4585 after cancel dispnexttag
4586 if {$delay} {
4587 after 200 dispnexttag
4588 set tagphase -1
4589 } else {
4590 after idle dispnexttag
4591 set tagphase 0
4595 proc dispnexttag {} {
4596 global selectedline currentid showneartags tagphase ctext
4598 if {![info exists selectedline] || !$showneartags} return
4599 switch -- $tagphase {
4601 set dtags [desctags $currentid]
4602 if {$dtags ne {}} {
4603 appendrefs precedes $dtags idtags
4607 set atags [anctags $currentid]
4608 if {$atags ne {}} {
4609 appendrefs follows $atags idtags
4613 set dheads [descheads $currentid]
4614 if {$dheads ne {}} {
4615 if {[appendrefs branch $dheads idheads] > 1
4616 && [$ctext get "branch -3c"] eq "h"} {
4617 # turn "Branch" into "Branches"
4618 $ctext conf -state normal
4619 $ctext insert "branch -2c" "es"
4620 $ctext conf -state disabled
4625 if {[incr tagphase] <= 2} {
4626 after idle dispnexttag
4630 proc make_secsel {l} {
4631 global linehtag linentag linedtag canv canv2 canv3
4633 if {![info exists linehtag($l)]} return
4634 $canv delete secsel
4635 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4636 -tags secsel -fill [$canv cget -selectbackground]]
4637 $canv lower $t
4638 $canv2 delete secsel
4639 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4640 -tags secsel -fill [$canv2 cget -selectbackground]]
4641 $canv2 lower $t
4642 $canv3 delete secsel
4643 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4644 -tags secsel -fill [$canv3 cget -selectbackground]]
4645 $canv3 lower $t
4648 proc selectline {l isnew} {
4649 global canv ctext commitinfo selectedline
4650 global displayorder
4651 global canvy0 linespc parentlist children curview
4652 global currentid sha1entry
4653 global commentend idtags linknum
4654 global mergemax numcommits pending_select
4655 global cmitmode showneartags allcommits
4657 catch {unset pending_select}
4658 $canv delete hover
4659 normalline
4660 unsel_reflist
4661 stopfinding
4662 if {$l < 0 || $l >= $numcommits} return
4663 set y [expr {$canvy0 + $l * $linespc}]
4664 set ymax [lindex [$canv cget -scrollregion] 3]
4665 set ytop [expr {$y - $linespc - 1}]
4666 set ybot [expr {$y + $linespc + 1}]
4667 set wnow [$canv yview]
4668 set wtop [expr {[lindex $wnow 0] * $ymax}]
4669 set wbot [expr {[lindex $wnow 1] * $ymax}]
4670 set wh [expr {$wbot - $wtop}]
4671 set newtop $wtop
4672 if {$ytop < $wtop} {
4673 if {$ybot < $wtop} {
4674 set newtop [expr {$y - $wh / 2.0}]
4675 } else {
4676 set newtop $ytop
4677 if {$newtop > $wtop - $linespc} {
4678 set newtop [expr {$wtop - $linespc}]
4681 } elseif {$ybot > $wbot} {
4682 if {$ytop > $wbot} {
4683 set newtop [expr {$y - $wh / 2.0}]
4684 } else {
4685 set newtop [expr {$ybot - $wh}]
4686 if {$newtop < $wtop + $linespc} {
4687 set newtop [expr {$wtop + $linespc}]
4691 if {$newtop != $wtop} {
4692 if {$newtop < 0} {
4693 set newtop 0
4695 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4696 drawvisible
4699 make_secsel $l
4701 if {$isnew} {
4702 addtohistory [list selectline $l 0]
4705 set selectedline $l
4707 set id [lindex $displayorder $l]
4708 set currentid $id
4709 $sha1entry delete 0 end
4710 $sha1entry insert 0 $id
4711 $sha1entry selection from 0
4712 $sha1entry selection to end
4713 rhighlight_sel $id
4715 $ctext conf -state normal
4716 clear_ctext
4717 set linknum 0
4718 set info $commitinfo($id)
4719 set date [formatdate [lindex $info 2]]
4720 $ctext insert end "Author: [lindex $info 1] $date\n"
4721 set date [formatdate [lindex $info 4]]
4722 $ctext insert end "Committer: [lindex $info 3] $date\n"
4723 if {[info exists idtags($id)]} {
4724 $ctext insert end "Tags:"
4725 foreach tag $idtags($id) {
4726 $ctext insert end " $tag"
4728 $ctext insert end "\n"
4731 set headers {}
4732 set olds [lindex $parentlist $l]
4733 if {[llength $olds] > 1} {
4734 set np 0
4735 foreach p $olds {
4736 if {$np >= $mergemax} {
4737 set tag mmax
4738 } else {
4739 set tag m$np
4741 $ctext insert end "Parent: " $tag
4742 appendwithlinks [commit_descriptor $p] {}
4743 incr np
4745 } else {
4746 foreach p $olds {
4747 append headers "Parent: [commit_descriptor $p]"
4751 foreach c $children($curview,$id) {
4752 append headers "Child: [commit_descriptor $c]"
4755 # make anything that looks like a SHA1 ID be a clickable link
4756 appendwithlinks $headers {}
4757 if {$showneartags} {
4758 if {![info exists allcommits]} {
4759 getallcommits
4761 $ctext insert end "Branch: "
4762 $ctext mark set branch "end -1c"
4763 $ctext mark gravity branch left
4764 $ctext insert end "\nFollows: "
4765 $ctext mark set follows "end -1c"
4766 $ctext mark gravity follows left
4767 $ctext insert end "\nPrecedes: "
4768 $ctext mark set precedes "end -1c"
4769 $ctext mark gravity precedes left
4770 $ctext insert end "\n"
4771 dispneartags 1
4773 $ctext insert end "\n"
4774 set comment [lindex $info 5]
4775 if {[string first "\r" $comment] >= 0} {
4776 set comment [string map {"\r" "\n "} $comment]
4778 appendwithlinks $comment {comment}
4780 $ctext tag remove found 1.0 end
4781 $ctext conf -state disabled
4782 set commentend [$ctext index "end - 1c"]
4784 init_flist "Comments"
4785 if {$cmitmode eq "tree"} {
4786 gettree $id
4787 } elseif {[llength $olds] <= 1} {
4788 startdiff $id
4789 } else {
4790 mergediff $id $l
4794 proc selfirstline {} {
4795 unmarkmatches
4796 selectline 0 1
4799 proc sellastline {} {
4800 global numcommits
4801 unmarkmatches
4802 set l [expr {$numcommits - 1}]
4803 selectline $l 1
4806 proc selnextline {dir} {
4807 global selectedline
4808 focus .
4809 if {![info exists selectedline]} return
4810 set l [expr {$selectedline + $dir}]
4811 unmarkmatches
4812 selectline $l 1
4815 proc selnextpage {dir} {
4816 global canv linespc selectedline numcommits
4818 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4819 if {$lpp < 1} {
4820 set lpp 1
4822 allcanvs yview scroll [expr {$dir * $lpp}] units
4823 drawvisible
4824 if {![info exists selectedline]} return
4825 set l [expr {$selectedline + $dir * $lpp}]
4826 if {$l < 0} {
4827 set l 0
4828 } elseif {$l >= $numcommits} {
4829 set l [expr $numcommits - 1]
4831 unmarkmatches
4832 selectline $l 1
4835 proc unselectline {} {
4836 global selectedline currentid
4838 catch {unset selectedline}
4839 catch {unset currentid}
4840 allcanvs delete secsel
4841 rhighlight_none
4844 proc reselectline {} {
4845 global selectedline
4847 if {[info exists selectedline]} {
4848 selectline $selectedline 0
4852 proc addtohistory {cmd} {
4853 global history historyindex curview
4855 set elt [list $curview $cmd]
4856 if {$historyindex > 0
4857 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4858 return
4861 if {$historyindex < [llength $history]} {
4862 set history [lreplace $history $historyindex end $elt]
4863 } else {
4864 lappend history $elt
4866 incr historyindex
4867 if {$historyindex > 1} {
4868 .tf.bar.leftbut conf -state normal
4869 } else {
4870 .tf.bar.leftbut conf -state disabled
4872 .tf.bar.rightbut conf -state disabled
4875 proc godo {elt} {
4876 global curview
4878 set view [lindex $elt 0]
4879 set cmd [lindex $elt 1]
4880 if {$curview != $view} {
4881 showview $view
4883 eval $cmd
4886 proc goback {} {
4887 global history historyindex
4888 focus .
4890 if {$historyindex > 1} {
4891 incr historyindex -1
4892 godo [lindex $history [expr {$historyindex - 1}]]
4893 .tf.bar.rightbut conf -state normal
4895 if {$historyindex <= 1} {
4896 .tf.bar.leftbut conf -state disabled
4900 proc goforw {} {
4901 global history historyindex
4902 focus .
4904 if {$historyindex < [llength $history]} {
4905 set cmd [lindex $history $historyindex]
4906 incr historyindex
4907 godo $cmd
4908 .tf.bar.leftbut conf -state normal
4910 if {$historyindex >= [llength $history]} {
4911 .tf.bar.rightbut conf -state disabled
4915 proc gettree {id} {
4916 global treefilelist treeidlist diffids diffmergeid treepending
4917 global nullid nullid2
4919 set diffids $id
4920 catch {unset diffmergeid}
4921 if {![info exists treefilelist($id)]} {
4922 if {![info exists treepending]} {
4923 if {$id eq $nullid} {
4924 set cmd [list | git ls-files]
4925 } elseif {$id eq $nullid2} {
4926 set cmd [list | git ls-files --stage -t]
4927 } else {
4928 set cmd [list | git ls-tree -r $id]
4930 if {[catch {set gtf [open $cmd r]}]} {
4931 return
4933 set treepending $id
4934 set treefilelist($id) {}
4935 set treeidlist($id) {}
4936 fconfigure $gtf -blocking 0
4937 filerun $gtf [list gettreeline $gtf $id]
4939 } else {
4940 setfilelist $id
4944 proc gettreeline {gtf id} {
4945 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4947 set nl 0
4948 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4949 if {$diffids eq $nullid} {
4950 set fname $line
4951 } else {
4952 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4953 set i [string first "\t" $line]
4954 if {$i < 0} continue
4955 set sha1 [lindex $line 2]
4956 set fname [string range $line [expr {$i+1}] end]
4957 if {[string index $fname 0] eq "\""} {
4958 set fname [lindex $fname 0]
4960 lappend treeidlist($id) $sha1
4962 lappend treefilelist($id) $fname
4964 if {![eof $gtf]} {
4965 return [expr {$nl >= 1000? 2: 1}]
4967 close $gtf
4968 unset treepending
4969 if {$cmitmode ne "tree"} {
4970 if {![info exists diffmergeid]} {
4971 gettreediffs $diffids
4973 } elseif {$id ne $diffids} {
4974 gettree $diffids
4975 } else {
4976 setfilelist $id
4978 return 0
4981 proc showfile {f} {
4982 global treefilelist treeidlist diffids nullid nullid2
4983 global ctext commentend
4985 set i [lsearch -exact $treefilelist($diffids) $f]
4986 if {$i < 0} {
4987 puts "oops, $f not in list for id $diffids"
4988 return
4990 if {$diffids eq $nullid} {
4991 if {[catch {set bf [open $f r]} err]} {
4992 puts "oops, can't read $f: $err"
4993 return
4995 } else {
4996 set blob [lindex $treeidlist($diffids) $i]
4997 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4998 puts "oops, error reading blob $blob: $err"
4999 return
5002 fconfigure $bf -blocking 0
5003 filerun $bf [list getblobline $bf $diffids]
5004 $ctext config -state normal
5005 clear_ctext $commentend
5006 $ctext insert end "\n"
5007 $ctext insert end "$f\n" filesep
5008 $ctext config -state disabled
5009 $ctext yview $commentend
5010 settabs 0
5013 proc getblobline {bf id} {
5014 global diffids cmitmode ctext
5016 if {$id ne $diffids || $cmitmode ne "tree"} {
5017 catch {close $bf}
5018 return 0
5020 $ctext config -state normal
5021 set nl 0
5022 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5023 $ctext insert end "$line\n"
5025 if {[eof $bf]} {
5026 # delete last newline
5027 $ctext delete "end - 2c" "end - 1c"
5028 close $bf
5029 return 0
5031 $ctext config -state disabled
5032 return [expr {$nl >= 1000? 2: 1}]
5035 proc mergediff {id l} {
5036 global diffmergeid mdifffd
5037 global diffids
5038 global parentlist
5039 global limitdiffs viewfiles curview
5041 set diffmergeid $id
5042 set diffids $id
5043 # this doesn't seem to actually affect anything...
5044 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5045 if {$limitdiffs && $viewfiles($curview) ne {}} {
5046 set cmd [concat $cmd -- $viewfiles($curview)]
5048 if {[catch {set mdf [open $cmd r]} err]} {
5049 error_popup "Error getting merge diffs: $err"
5050 return
5052 fconfigure $mdf -blocking 0
5053 set mdifffd($id) $mdf
5054 set np [llength [lindex $parentlist $l]]
5055 settabs $np
5056 filerun $mdf [list getmergediffline $mdf $id $np]
5059 proc getmergediffline {mdf id np} {
5060 global diffmergeid ctext cflist mergemax
5061 global difffilestart mdifffd
5063 $ctext conf -state normal
5064 set nr 0
5065 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5066 if {![info exists diffmergeid] || $id != $diffmergeid
5067 || $mdf != $mdifffd($id)} {
5068 close $mdf
5069 return 0
5071 if {[regexp {^diff --cc (.*)} $line match fname]} {
5072 # start of a new file
5073 $ctext insert end "\n"
5074 set here [$ctext index "end - 1c"]
5075 lappend difffilestart $here
5076 add_flist [list $fname]
5077 set l [expr {(78 - [string length $fname]) / 2}]
5078 set pad [string range "----------------------------------------" 1 $l]
5079 $ctext insert end "$pad $fname $pad\n" filesep
5080 } elseif {[regexp {^@@} $line]} {
5081 $ctext insert end "$line\n" hunksep
5082 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5083 # do nothing
5084 } else {
5085 # parse the prefix - one ' ', '-' or '+' for each parent
5086 set spaces {}
5087 set minuses {}
5088 set pluses {}
5089 set isbad 0
5090 for {set j 0} {$j < $np} {incr j} {
5091 set c [string range $line $j $j]
5092 if {$c == " "} {
5093 lappend spaces $j
5094 } elseif {$c == "-"} {
5095 lappend minuses $j
5096 } elseif {$c == "+"} {
5097 lappend pluses $j
5098 } else {
5099 set isbad 1
5100 break
5103 set tags {}
5104 set num {}
5105 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5106 # line doesn't appear in result, parents in $minuses have the line
5107 set num [lindex $minuses 0]
5108 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5109 # line appears in result, parents in $pluses don't have the line
5110 lappend tags mresult
5111 set num [lindex $spaces 0]
5113 if {$num ne {}} {
5114 if {$num >= $mergemax} {
5115 set num "max"
5117 lappend tags m$num
5119 $ctext insert end "$line\n" $tags
5122 $ctext conf -state disabled
5123 if {[eof $mdf]} {
5124 close $mdf
5125 return 0
5127 return [expr {$nr >= 1000? 2: 1}]
5130 proc startdiff {ids} {
5131 global treediffs diffids treepending diffmergeid nullid nullid2
5133 settabs 1
5134 set diffids $ids
5135 catch {unset diffmergeid}
5136 if {![info exists treediffs($ids)] ||
5137 [lsearch -exact $ids $nullid] >= 0 ||
5138 [lsearch -exact $ids $nullid2] >= 0} {
5139 if {![info exists treepending]} {
5140 gettreediffs $ids
5142 } else {
5143 addtocflist $ids
5147 proc path_filter {filter name} {
5148 foreach p $filter {
5149 set l [string length $p]
5150 if {[string index $p end] eq "/"} {
5151 if {[string compare -length $l $p $name] == 0} {
5152 return 1
5154 } else {
5155 if {[string compare -length $l $p $name] == 0 &&
5156 ([string length $name] == $l ||
5157 [string index $name $l] eq "/")} {
5158 return 1
5162 return 0
5165 proc addtocflist {ids} {
5166 global treediffs
5168 add_flist $treediffs($ids)
5169 getblobdiffs $ids
5172 proc diffcmd {ids flags} {
5173 global nullid nullid2
5175 set i [lsearch -exact $ids $nullid]
5176 set j [lsearch -exact $ids $nullid2]
5177 if {$i >= 0} {
5178 if {[llength $ids] > 1 && $j < 0} {
5179 # comparing working directory with some specific revision
5180 set cmd [concat | git diff-index $flags]
5181 if {$i == 0} {
5182 lappend cmd -R [lindex $ids 1]
5183 } else {
5184 lappend cmd [lindex $ids 0]
5186 } else {
5187 # comparing working directory with index
5188 set cmd [concat | git diff-files $flags]
5189 if {$j == 1} {
5190 lappend cmd -R
5193 } elseif {$j >= 0} {
5194 set cmd [concat | git diff-index --cached $flags]
5195 if {[llength $ids] > 1} {
5196 # comparing index with specific revision
5197 if {$i == 0} {
5198 lappend cmd -R [lindex $ids 1]
5199 } else {
5200 lappend cmd [lindex $ids 0]
5202 } else {
5203 # comparing index with HEAD
5204 lappend cmd HEAD
5206 } else {
5207 set cmd [concat | git diff-tree -r $flags $ids]
5209 return $cmd
5212 proc gettreediffs {ids} {
5213 global treediff treepending
5215 set treepending $ids
5216 set treediff {}
5217 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5218 fconfigure $gdtf -blocking 0
5219 filerun $gdtf [list gettreediffline $gdtf $ids]
5222 proc gettreediffline {gdtf ids} {
5223 global treediff treediffs treepending diffids diffmergeid
5224 global cmitmode viewfiles curview limitdiffs
5226 set nr 0
5227 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5228 set i [string first "\t" $line]
5229 if {$i >= 0} {
5230 set file [string range $line [expr {$i+1}] end]
5231 if {[string index $file 0] eq "\""} {
5232 set file [lindex $file 0]
5234 lappend treediff $file
5237 if {![eof $gdtf]} {
5238 return [expr {$nr >= 1000? 2: 1}]
5240 close $gdtf
5241 if {$limitdiffs && $viewfiles($curview) ne {}} {
5242 set flist {}
5243 foreach f $treediff {
5244 if {[path_filter $viewfiles($curview) $f]} {
5245 lappend flist $f
5248 set treediffs($ids) $flist
5249 } else {
5250 set treediffs($ids) $treediff
5252 unset treepending
5253 if {$cmitmode eq "tree"} {
5254 gettree $diffids
5255 } elseif {$ids != $diffids} {
5256 if {![info exists diffmergeid]} {
5257 gettreediffs $diffids
5259 } else {
5260 addtocflist $ids
5262 return 0
5265 # empty string or positive integer
5266 proc diffcontextvalidate {v} {
5267 return [regexp {^(|[1-9][0-9]*)$} $v]
5270 proc diffcontextchange {n1 n2 op} {
5271 global diffcontextstring diffcontext
5273 if {[string is integer -strict $diffcontextstring]} {
5274 if {$diffcontextstring > 0} {
5275 set diffcontext $diffcontextstring
5276 reselectline
5281 proc getblobdiffs {ids} {
5282 global blobdifffd diffids env
5283 global diffinhdr treediffs
5284 global diffcontext
5285 global limitdiffs viewfiles curview
5287 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5288 if {$limitdiffs && $viewfiles($curview) ne {}} {
5289 set cmd [concat $cmd -- $viewfiles($curview)]
5291 if {[catch {set bdf [open $cmd r]} err]} {
5292 puts "error getting diffs: $err"
5293 return
5295 set diffinhdr 0
5296 fconfigure $bdf -blocking 0
5297 set blobdifffd($ids) $bdf
5298 filerun $bdf [list getblobdiffline $bdf $diffids]
5301 proc setinlist {var i val} {
5302 global $var
5304 while {[llength [set $var]] < $i} {
5305 lappend $var {}
5307 if {[llength [set $var]] == $i} {
5308 lappend $var $val
5309 } else {
5310 lset $var $i $val
5314 proc makediffhdr {fname ids} {
5315 global ctext curdiffstart treediffs
5317 set i [lsearch -exact $treediffs($ids) $fname]
5318 if {$i >= 0} {
5319 setinlist difffilestart $i $curdiffstart
5321 set l [expr {(78 - [string length $fname]) / 2}]
5322 set pad [string range "----------------------------------------" 1 $l]
5323 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5326 proc getblobdiffline {bdf ids} {
5327 global diffids blobdifffd ctext curdiffstart
5328 global diffnexthead diffnextnote difffilestart
5329 global diffinhdr treediffs
5331 set nr 0
5332 $ctext conf -state normal
5333 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5334 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5335 close $bdf
5336 return 0
5338 if {![string compare -length 11 "diff --git " $line]} {
5339 # trim off "diff --git "
5340 set line [string range $line 11 end]
5341 set diffinhdr 1
5342 # start of a new file
5343 $ctext insert end "\n"
5344 set curdiffstart [$ctext index "end - 1c"]
5345 $ctext insert end "\n" filesep
5346 # If the name hasn't changed the length will be odd,
5347 # the middle char will be a space, and the two bits either
5348 # side will be a/name and b/name, or "a/name" and "b/name".
5349 # If the name has changed we'll get "rename from" and
5350 # "rename to" or "copy from" and "copy to" lines following this,
5351 # and we'll use them to get the filenames.
5352 # This complexity is necessary because spaces in the filename(s)
5353 # don't get escaped.
5354 set l [string length $line]
5355 set i [expr {$l / 2}]
5356 if {!(($l & 1) && [string index $line $i] eq " " &&
5357 [string range $line 2 [expr {$i - 1}]] eq \
5358 [string range $line [expr {$i + 3}] end])} {
5359 continue
5361 # unescape if quoted and chop off the a/ from the front
5362 if {[string index $line 0] eq "\""} {
5363 set fname [string range [lindex $line 0] 2 end]
5364 } else {
5365 set fname [string range $line 2 [expr {$i - 1}]]
5367 makediffhdr $fname $ids
5369 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5370 $line match f1l f1c f2l f2c rest]} {
5371 $ctext insert end "$line\n" hunksep
5372 set diffinhdr 0
5374 } elseif {$diffinhdr} {
5375 if {![string compare -length 12 "rename from " $line]} {
5376 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5377 if {[string index $fname 0] eq "\""} {
5378 set fname [lindex $fname 0]
5380 set i [lsearch -exact $treediffs($ids) $fname]
5381 if {$i >= 0} {
5382 setinlist difffilestart $i $curdiffstart
5384 } elseif {![string compare -length 10 $line "rename to "] ||
5385 ![string compare -length 8 $line "copy to "]} {
5386 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5387 if {[string index $fname 0] eq "\""} {
5388 set fname [lindex $fname 0]
5390 makediffhdr $fname $ids
5391 } elseif {[string compare -length 3 $line "---"] == 0} {
5392 # do nothing
5393 continue
5394 } elseif {[string compare -length 3 $line "+++"] == 0} {
5395 set diffinhdr 0
5396 continue
5398 $ctext insert end "$line\n" filesep
5400 } else {
5401 set x [string range $line 0 0]
5402 if {$x == "-" || $x == "+"} {
5403 set tag [expr {$x == "+"}]
5404 $ctext insert end "$line\n" d$tag
5405 } elseif {$x == " "} {
5406 $ctext insert end "$line\n"
5407 } else {
5408 # "\ No newline at end of file",
5409 # or something else we don't recognize
5410 $ctext insert end "$line\n" hunksep
5414 $ctext conf -state disabled
5415 if {[eof $bdf]} {
5416 close $bdf
5417 return 0
5419 return [expr {$nr >= 1000? 2: 1}]
5422 proc changediffdisp {} {
5423 global ctext diffelide
5425 $ctext tag conf d0 -elide [lindex $diffelide 0]
5426 $ctext tag conf d1 -elide [lindex $diffelide 1]
5429 proc prevfile {} {
5430 global difffilestart ctext
5431 set prev [lindex $difffilestart 0]
5432 set here [$ctext index @0,0]
5433 foreach loc $difffilestart {
5434 if {[$ctext compare $loc >= $here]} {
5435 $ctext yview $prev
5436 return
5438 set prev $loc
5440 $ctext yview $prev
5443 proc nextfile {} {
5444 global difffilestart ctext
5445 set here [$ctext index @0,0]
5446 foreach loc $difffilestart {
5447 if {[$ctext compare $loc > $here]} {
5448 $ctext yview $loc
5449 return
5454 proc clear_ctext {{first 1.0}} {
5455 global ctext smarktop smarkbot
5456 global pendinglinks
5458 set l [lindex [split $first .] 0]
5459 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5460 set smarktop $l
5462 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5463 set smarkbot $l
5465 $ctext delete $first end
5466 if {$first eq "1.0"} {
5467 catch {unset pendinglinks}
5471 proc settabs {{firstab {}}} {
5472 global firsttabstop tabstop ctext have_tk85
5474 if {$firstab ne {} && $have_tk85} {
5475 set firsttabstop $firstab
5477 set w [font measure textfont "0"]
5478 if {$firsttabstop != 0} {
5479 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5480 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5481 } elseif {$have_tk85 || $tabstop != 8} {
5482 $ctext conf -tabs [expr {$tabstop * $w}]
5483 } else {
5484 $ctext conf -tabs {}
5488 proc incrsearch {name ix op} {
5489 global ctext searchstring searchdirn
5491 $ctext tag remove found 1.0 end
5492 if {[catch {$ctext index anchor}]} {
5493 # no anchor set, use start of selection, or of visible area
5494 set sel [$ctext tag ranges sel]
5495 if {$sel ne {}} {
5496 $ctext mark set anchor [lindex $sel 0]
5497 } elseif {$searchdirn eq "-forwards"} {
5498 $ctext mark set anchor @0,0
5499 } else {
5500 $ctext mark set anchor @0,[winfo height $ctext]
5503 if {$searchstring ne {}} {
5504 set here [$ctext search $searchdirn -- $searchstring anchor]
5505 if {$here ne {}} {
5506 $ctext see $here
5508 searchmarkvisible 1
5512 proc dosearch {} {
5513 global sstring ctext searchstring searchdirn
5515 focus $sstring
5516 $sstring icursor end
5517 set searchdirn -forwards
5518 if {$searchstring ne {}} {
5519 set sel [$ctext tag ranges sel]
5520 if {$sel ne {}} {
5521 set start "[lindex $sel 0] + 1c"
5522 } elseif {[catch {set start [$ctext index anchor]}]} {
5523 set start "@0,0"
5525 set match [$ctext search -count mlen -- $searchstring $start]
5526 $ctext tag remove sel 1.0 end
5527 if {$match eq {}} {
5528 bell
5529 return
5531 $ctext see $match
5532 set mend "$match + $mlen c"
5533 $ctext tag add sel $match $mend
5534 $ctext mark unset anchor
5538 proc dosearchback {} {
5539 global sstring ctext searchstring searchdirn
5541 focus $sstring
5542 $sstring icursor end
5543 set searchdirn -backwards
5544 if {$searchstring ne {}} {
5545 set sel [$ctext tag ranges sel]
5546 if {$sel ne {}} {
5547 set start [lindex $sel 0]
5548 } elseif {[catch {set start [$ctext index anchor]}]} {
5549 set start @0,[winfo height $ctext]
5551 set match [$ctext search -backwards -count ml -- $searchstring $start]
5552 $ctext tag remove sel 1.0 end
5553 if {$match eq {}} {
5554 bell
5555 return
5557 $ctext see $match
5558 set mend "$match + $ml c"
5559 $ctext tag add sel $match $mend
5560 $ctext mark unset anchor
5564 proc searchmark {first last} {
5565 global ctext searchstring
5567 set mend $first.0
5568 while {1} {
5569 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5570 if {$match eq {}} break
5571 set mend "$match + $mlen c"
5572 $ctext tag add found $match $mend
5576 proc searchmarkvisible {doall} {
5577 global ctext smarktop smarkbot
5579 set topline [lindex [split [$ctext index @0,0] .] 0]
5580 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5581 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5582 # no overlap with previous
5583 searchmark $topline $botline
5584 set smarktop $topline
5585 set smarkbot $botline
5586 } else {
5587 if {$topline < $smarktop} {
5588 searchmark $topline [expr {$smarktop-1}]
5589 set smarktop $topline
5591 if {$botline > $smarkbot} {
5592 searchmark [expr {$smarkbot+1}] $botline
5593 set smarkbot $botline
5598 proc scrolltext {f0 f1} {
5599 global searchstring
5601 .bleft.sb set $f0 $f1
5602 if {$searchstring ne {}} {
5603 searchmarkvisible 0
5607 proc setcoords {} {
5608 global linespc charspc canvx0 canvy0
5609 global xspc1 xspc2 lthickness
5611 set linespc [font metrics mainfont -linespace]
5612 set charspc [font measure mainfont "m"]
5613 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5614 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5615 set lthickness [expr {int($linespc / 9) + 1}]
5616 set xspc1(0) $linespc
5617 set xspc2 $linespc
5620 proc redisplay {} {
5621 global canv
5622 global selectedline
5624 set ymax [lindex [$canv cget -scrollregion] 3]
5625 if {$ymax eq {} || $ymax == 0} return
5626 set span [$canv yview]
5627 clear_display
5628 setcanvscroll
5629 allcanvs yview moveto [lindex $span 0]
5630 drawvisible
5631 if {[info exists selectedline]} {
5632 selectline $selectedline 0
5633 allcanvs yview moveto [lindex $span 0]
5637 proc parsefont {f n} {
5638 global fontattr
5640 set fontattr($f,family) [lindex $n 0]
5641 set s [lindex $n 1]
5642 if {$s eq {} || $s == 0} {
5643 set s 10
5644 } elseif {$s < 0} {
5645 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5647 set fontattr($f,size) $s
5648 set fontattr($f,weight) normal
5649 set fontattr($f,slant) roman
5650 foreach style [lrange $n 2 end] {
5651 switch -- $style {
5652 "normal" -
5653 "bold" {set fontattr($f,weight) $style}
5654 "roman" -
5655 "italic" {set fontattr($f,slant) $style}
5660 proc fontflags {f {isbold 0}} {
5661 global fontattr
5663 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5664 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5665 -slant $fontattr($f,slant)]
5668 proc fontname {f} {
5669 global fontattr
5671 set n [list $fontattr($f,family) $fontattr($f,size)]
5672 if {$fontattr($f,weight) eq "bold"} {
5673 lappend n "bold"
5675 if {$fontattr($f,slant) eq "italic"} {
5676 lappend n "italic"
5678 return $n
5681 proc incrfont {inc} {
5682 global mainfont textfont ctext canv phase cflist showrefstop
5683 global stopped entries fontattr
5685 unmarkmatches
5686 set s $fontattr(mainfont,size)
5687 incr s $inc
5688 if {$s < 1} {
5689 set s 1
5691 set fontattr(mainfont,size) $s
5692 font config mainfont -size $s
5693 font config mainfontbold -size $s
5694 set mainfont [fontname mainfont]
5695 set s $fontattr(textfont,size)
5696 incr s $inc
5697 if {$s < 1} {
5698 set s 1
5700 set fontattr(textfont,size) $s
5701 font config textfont -size $s
5702 font config textfontbold -size $s
5703 set textfont [fontname textfont]
5704 setcoords
5705 settabs
5706 redisplay
5709 proc clearsha1 {} {
5710 global sha1entry sha1string
5711 if {[string length $sha1string] == 40} {
5712 $sha1entry delete 0 end
5716 proc sha1change {n1 n2 op} {
5717 global sha1string currentid sha1but
5718 if {$sha1string == {}
5719 || ([info exists currentid] && $sha1string == $currentid)} {
5720 set state disabled
5721 } else {
5722 set state normal
5724 if {[$sha1but cget -state] == $state} return
5725 if {$state == "normal"} {
5726 $sha1but conf -state normal -relief raised -text "Goto: "
5727 } else {
5728 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5732 proc gotocommit {} {
5733 global sha1string currentid commitrow tagids headids
5734 global displayorder numcommits curview
5736 if {$sha1string == {}
5737 || ([info exists currentid] && $sha1string == $currentid)} return
5738 if {[info exists tagids($sha1string)]} {
5739 set id $tagids($sha1string)
5740 } elseif {[info exists headids($sha1string)]} {
5741 set id $headids($sha1string)
5742 } else {
5743 set id [string tolower $sha1string]
5744 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5745 set matches {}
5746 foreach i $displayorder {
5747 if {[string match $id* $i]} {
5748 lappend matches $i
5751 if {$matches ne {}} {
5752 if {[llength $matches] > 1} {
5753 error_popup "Short SHA1 id $id is ambiguous"
5754 return
5756 set id [lindex $matches 0]
5760 if {[info exists commitrow($curview,$id)]} {
5761 selectline $commitrow($curview,$id) 1
5762 return
5764 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5765 set type "SHA1 id"
5766 } else {
5767 set type "Tag/Head"
5769 error_popup "$type $sha1string is not known"
5772 proc lineenter {x y id} {
5773 global hoverx hovery hoverid hovertimer
5774 global commitinfo canv
5776 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5777 set hoverx $x
5778 set hovery $y
5779 set hoverid $id
5780 if {[info exists hovertimer]} {
5781 after cancel $hovertimer
5783 set hovertimer [after 500 linehover]
5784 $canv delete hover
5787 proc linemotion {x y id} {
5788 global hoverx hovery hoverid hovertimer
5790 if {[info exists hoverid] && $id == $hoverid} {
5791 set hoverx $x
5792 set hovery $y
5793 if {[info exists hovertimer]} {
5794 after cancel $hovertimer
5796 set hovertimer [after 500 linehover]
5800 proc lineleave {id} {
5801 global hoverid hovertimer canv
5803 if {[info exists hoverid] && $id == $hoverid} {
5804 $canv delete hover
5805 if {[info exists hovertimer]} {
5806 after cancel $hovertimer
5807 unset hovertimer
5809 unset hoverid
5813 proc linehover {} {
5814 global hoverx hovery hoverid hovertimer
5815 global canv linespc lthickness
5816 global commitinfo
5818 set text [lindex $commitinfo($hoverid) 0]
5819 set ymax [lindex [$canv cget -scrollregion] 3]
5820 if {$ymax == {}} return
5821 set yfrac [lindex [$canv yview] 0]
5822 set x [expr {$hoverx + 2 * $linespc}]
5823 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5824 set x0 [expr {$x - 2 * $lthickness}]
5825 set y0 [expr {$y - 2 * $lthickness}]
5826 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5827 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5828 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5829 -fill \#ffff80 -outline black -width 1 -tags hover]
5830 $canv raise $t
5831 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5832 -font mainfont]
5833 $canv raise $t
5836 proc clickisonarrow {id y} {
5837 global lthickness
5839 set ranges [rowranges $id]
5840 set thresh [expr {2 * $lthickness + 6}]
5841 set n [expr {[llength $ranges] - 1}]
5842 for {set i 1} {$i < $n} {incr i} {
5843 set row [lindex $ranges $i]
5844 if {abs([yc $row] - $y) < $thresh} {
5845 return $i
5848 return {}
5851 proc arrowjump {id n y} {
5852 global canv
5854 # 1 <-> 2, 3 <-> 4, etc...
5855 set n [expr {(($n - 1) ^ 1) + 1}]
5856 set row [lindex [rowranges $id] $n]
5857 set yt [yc $row]
5858 set ymax [lindex [$canv cget -scrollregion] 3]
5859 if {$ymax eq {} || $ymax <= 0} return
5860 set view [$canv yview]
5861 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5862 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5863 if {$yfrac < 0} {
5864 set yfrac 0
5866 allcanvs yview moveto $yfrac
5869 proc lineclick {x y id isnew} {
5870 global ctext commitinfo children canv thickerline curview commitrow
5872 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5873 unmarkmatches
5874 unselectline
5875 normalline
5876 $canv delete hover
5877 # draw this line thicker than normal
5878 set thickerline $id
5879 drawlines $id
5880 if {$isnew} {
5881 set ymax [lindex [$canv cget -scrollregion] 3]
5882 if {$ymax eq {}} return
5883 set yfrac [lindex [$canv yview] 0]
5884 set y [expr {$y + $yfrac * $ymax}]
5886 set dirn [clickisonarrow $id $y]
5887 if {$dirn ne {}} {
5888 arrowjump $id $dirn $y
5889 return
5892 if {$isnew} {
5893 addtohistory [list lineclick $x $y $id 0]
5895 # fill the details pane with info about this line
5896 $ctext conf -state normal
5897 clear_ctext
5898 settabs 0
5899 $ctext insert end "Parent:\t"
5900 $ctext insert end $id link0
5901 setlink $id link0
5902 set info $commitinfo($id)
5903 $ctext insert end "\n\t[lindex $info 0]\n"
5904 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5905 set date [formatdate [lindex $info 2]]
5906 $ctext insert end "\tDate:\t$date\n"
5907 set kids $children($curview,$id)
5908 if {$kids ne {}} {
5909 $ctext insert end "\nChildren:"
5910 set i 0
5911 foreach child $kids {
5912 incr i
5913 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5914 set info $commitinfo($child)
5915 $ctext insert end "\n\t"
5916 $ctext insert end $child link$i
5917 setlink $child link$i
5918 $ctext insert end "\n\t[lindex $info 0]"
5919 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5920 set date [formatdate [lindex $info 2]]
5921 $ctext insert end "\n\tDate:\t$date\n"
5924 $ctext conf -state disabled
5925 init_flist {}
5928 proc normalline {} {
5929 global thickerline
5930 if {[info exists thickerline]} {
5931 set id $thickerline
5932 unset thickerline
5933 drawlines $id
5937 proc selbyid {id} {
5938 global commitrow curview
5939 if {[info exists commitrow($curview,$id)]} {
5940 selectline $commitrow($curview,$id) 1
5944 proc mstime {} {
5945 global startmstime
5946 if {![info exists startmstime]} {
5947 set startmstime [clock clicks -milliseconds]
5949 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5952 proc rowmenu {x y id} {
5953 global rowctxmenu commitrow selectedline rowmenuid curview
5954 global nullid nullid2 fakerowmenu mainhead
5956 stopfinding
5957 set rowmenuid $id
5958 if {![info exists selectedline]
5959 || $commitrow($curview,$id) eq $selectedline} {
5960 set state disabled
5961 } else {
5962 set state normal
5964 if {$id ne $nullid && $id ne $nullid2} {
5965 set menu $rowctxmenu
5966 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5967 } else {
5968 set menu $fakerowmenu
5970 $menu entryconfigure "Diff this*" -state $state
5971 $menu entryconfigure "Diff selected*" -state $state
5972 $menu entryconfigure "Make patch" -state $state
5973 tk_popup $menu $x $y
5976 proc diffvssel {dirn} {
5977 global rowmenuid selectedline displayorder
5979 if {![info exists selectedline]} return
5980 if {$dirn} {
5981 set oldid [lindex $displayorder $selectedline]
5982 set newid $rowmenuid
5983 } else {
5984 set oldid $rowmenuid
5985 set newid [lindex $displayorder $selectedline]
5987 addtohistory [list doseldiff $oldid $newid]
5988 doseldiff $oldid $newid
5991 proc doseldiff {oldid newid} {
5992 global ctext
5993 global commitinfo
5995 $ctext conf -state normal
5996 clear_ctext
5997 init_flist "Top"
5998 $ctext insert end "From "
5999 $ctext insert end $oldid link0
6000 setlink $oldid link0
6001 $ctext insert end "\n "
6002 $ctext insert end [lindex $commitinfo($oldid) 0]
6003 $ctext insert end "\n\nTo "
6004 $ctext insert end $newid link1
6005 setlink $newid link1
6006 $ctext insert end "\n "
6007 $ctext insert end [lindex $commitinfo($newid) 0]
6008 $ctext insert end "\n"
6009 $ctext conf -state disabled
6010 $ctext tag remove found 1.0 end
6011 startdiff [list $oldid $newid]
6014 proc mkpatch {} {
6015 global rowmenuid currentid commitinfo patchtop patchnum
6017 if {![info exists currentid]} return
6018 set oldid $currentid
6019 set oldhead [lindex $commitinfo($oldid) 0]
6020 set newid $rowmenuid
6021 set newhead [lindex $commitinfo($newid) 0]
6022 set top .patch
6023 set patchtop $top
6024 catch {destroy $top}
6025 toplevel $top
6026 label $top.title -text "Generate patch"
6027 grid $top.title - -pady 10
6028 label $top.from -text "From:"
6029 entry $top.fromsha1 -width 40 -relief flat
6030 $top.fromsha1 insert 0 $oldid
6031 $top.fromsha1 conf -state readonly
6032 grid $top.from $top.fromsha1 -sticky w
6033 entry $top.fromhead -width 60 -relief flat
6034 $top.fromhead insert 0 $oldhead
6035 $top.fromhead conf -state readonly
6036 grid x $top.fromhead -sticky w
6037 label $top.to -text "To:"
6038 entry $top.tosha1 -width 40 -relief flat
6039 $top.tosha1 insert 0 $newid
6040 $top.tosha1 conf -state readonly
6041 grid $top.to $top.tosha1 -sticky w
6042 entry $top.tohead -width 60 -relief flat
6043 $top.tohead insert 0 $newhead
6044 $top.tohead conf -state readonly
6045 grid x $top.tohead -sticky w
6046 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6047 grid $top.rev x -pady 10
6048 label $top.flab -text "Output file:"
6049 entry $top.fname -width 60
6050 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6051 incr patchnum
6052 grid $top.flab $top.fname -sticky w
6053 frame $top.buts
6054 button $top.buts.gen -text "Generate" -command mkpatchgo
6055 button $top.buts.can -text "Cancel" -command mkpatchcan
6056 grid $top.buts.gen $top.buts.can
6057 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6058 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6059 grid $top.buts - -pady 10 -sticky ew
6060 focus $top.fname
6063 proc mkpatchrev {} {
6064 global patchtop
6066 set oldid [$patchtop.fromsha1 get]
6067 set oldhead [$patchtop.fromhead get]
6068 set newid [$patchtop.tosha1 get]
6069 set newhead [$patchtop.tohead get]
6070 foreach e [list fromsha1 fromhead tosha1 tohead] \
6071 v [list $newid $newhead $oldid $oldhead] {
6072 $patchtop.$e conf -state normal
6073 $patchtop.$e delete 0 end
6074 $patchtop.$e insert 0 $v
6075 $patchtop.$e conf -state readonly
6079 proc mkpatchgo {} {
6080 global patchtop nullid nullid2
6082 set oldid [$patchtop.fromsha1 get]
6083 set newid [$patchtop.tosha1 get]
6084 set fname [$patchtop.fname get]
6085 set cmd [diffcmd [list $oldid $newid] -p]
6086 # trim off the initial "|"
6087 set cmd [lrange $cmd 1 end]
6088 lappend cmd >$fname &
6089 if {[catch {eval exec $cmd} err]} {
6090 error_popup "Error creating patch: $err"
6092 catch {destroy $patchtop}
6093 unset patchtop
6096 proc mkpatchcan {} {
6097 global patchtop
6099 catch {destroy $patchtop}
6100 unset patchtop
6103 proc mktag {} {
6104 global rowmenuid mktagtop commitinfo
6106 set top .maketag
6107 set mktagtop $top
6108 catch {destroy $top}
6109 toplevel $top
6110 label $top.title -text "Create tag"
6111 grid $top.title - -pady 10
6112 label $top.id -text "ID:"
6113 entry $top.sha1 -width 40 -relief flat
6114 $top.sha1 insert 0 $rowmenuid
6115 $top.sha1 conf -state readonly
6116 grid $top.id $top.sha1 -sticky w
6117 entry $top.head -width 60 -relief flat
6118 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6119 $top.head conf -state readonly
6120 grid x $top.head -sticky w
6121 label $top.tlab -text "Tag name:"
6122 entry $top.tag -width 60
6123 grid $top.tlab $top.tag -sticky w
6124 frame $top.buts
6125 button $top.buts.gen -text "Create" -command mktaggo
6126 button $top.buts.can -text "Cancel" -command mktagcan
6127 grid $top.buts.gen $top.buts.can
6128 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6129 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6130 grid $top.buts - -pady 10 -sticky ew
6131 focus $top.tag
6134 proc domktag {} {
6135 global mktagtop env tagids idtags
6137 set id [$mktagtop.sha1 get]
6138 set tag [$mktagtop.tag get]
6139 if {$tag == {}} {
6140 error_popup "No tag name specified"
6141 return
6143 if {[info exists tagids($tag)]} {
6144 error_popup "Tag \"$tag\" already exists"
6145 return
6147 if {[catch {
6148 set dir [gitdir]
6149 set fname [file join $dir "refs/tags" $tag]
6150 set f [open $fname w]
6151 puts $f $id
6152 close $f
6153 } err]} {
6154 error_popup "Error creating tag: $err"
6155 return
6158 set tagids($tag) $id
6159 lappend idtags($id) $tag
6160 redrawtags $id
6161 addedtag $id
6162 dispneartags 0
6163 run refill_reflist
6166 proc redrawtags {id} {
6167 global canv linehtag commitrow idpos selectedline curview
6168 global canvxmax iddrawn
6170 if {![info exists commitrow($curview,$id)]} return
6171 if {![info exists iddrawn($id)]} return
6172 drawcommits $commitrow($curview,$id)
6173 $canv delete tag.$id
6174 set xt [eval drawtags $id $idpos($id)]
6175 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6176 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6177 set xr [expr {$xt + [font measure mainfont $text]}]
6178 if {$xr > $canvxmax} {
6179 set canvxmax $xr
6180 setcanvscroll
6182 if {[info exists selectedline]
6183 && $selectedline == $commitrow($curview,$id)} {
6184 selectline $selectedline 0
6188 proc mktagcan {} {
6189 global mktagtop
6191 catch {destroy $mktagtop}
6192 unset mktagtop
6195 proc mktaggo {} {
6196 domktag
6197 mktagcan
6200 proc writecommit {} {
6201 global rowmenuid wrcomtop commitinfo wrcomcmd
6203 set top .writecommit
6204 set wrcomtop $top
6205 catch {destroy $top}
6206 toplevel $top
6207 label $top.title -text "Write commit to file"
6208 grid $top.title - -pady 10
6209 label $top.id -text "ID:"
6210 entry $top.sha1 -width 40 -relief flat
6211 $top.sha1 insert 0 $rowmenuid
6212 $top.sha1 conf -state readonly
6213 grid $top.id $top.sha1 -sticky w
6214 entry $top.head -width 60 -relief flat
6215 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6216 $top.head conf -state readonly
6217 grid x $top.head -sticky w
6218 label $top.clab -text "Command:"
6219 entry $top.cmd -width 60 -textvariable wrcomcmd
6220 grid $top.clab $top.cmd -sticky w -pady 10
6221 label $top.flab -text "Output file:"
6222 entry $top.fname -width 60
6223 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6224 grid $top.flab $top.fname -sticky w
6225 frame $top.buts
6226 button $top.buts.gen -text "Write" -command wrcomgo
6227 button $top.buts.can -text "Cancel" -command wrcomcan
6228 grid $top.buts.gen $top.buts.can
6229 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6230 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6231 grid $top.buts - -pady 10 -sticky ew
6232 focus $top.fname
6235 proc wrcomgo {} {
6236 global wrcomtop
6238 set id [$wrcomtop.sha1 get]
6239 set cmd "echo $id | [$wrcomtop.cmd get]"
6240 set fname [$wrcomtop.fname get]
6241 if {[catch {exec sh -c $cmd >$fname &} err]} {
6242 error_popup "Error writing commit: $err"
6244 catch {destroy $wrcomtop}
6245 unset wrcomtop
6248 proc wrcomcan {} {
6249 global wrcomtop
6251 catch {destroy $wrcomtop}
6252 unset wrcomtop
6255 proc mkbranch {} {
6256 global rowmenuid mkbrtop
6258 set top .makebranch
6259 catch {destroy $top}
6260 toplevel $top
6261 label $top.title -text "Create new branch"
6262 grid $top.title - -pady 10
6263 label $top.id -text "ID:"
6264 entry $top.sha1 -width 40 -relief flat
6265 $top.sha1 insert 0 $rowmenuid
6266 $top.sha1 conf -state readonly
6267 grid $top.id $top.sha1 -sticky w
6268 label $top.nlab -text "Name:"
6269 entry $top.name -width 40
6270 grid $top.nlab $top.name -sticky w
6271 frame $top.buts
6272 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6273 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6274 grid $top.buts.go $top.buts.can
6275 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6276 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6277 grid $top.buts - -pady 10 -sticky ew
6278 focus $top.name
6281 proc mkbrgo {top} {
6282 global headids idheads
6284 set name [$top.name get]
6285 set id [$top.sha1 get]
6286 if {$name eq {}} {
6287 error_popup "Please specify a name for the new branch"
6288 return
6290 catch {destroy $top}
6291 nowbusy newbranch
6292 update
6293 if {[catch {
6294 exec git branch $name $id
6295 } err]} {
6296 notbusy newbranch
6297 error_popup $err
6298 } else {
6299 set headids($name) $id
6300 lappend idheads($id) $name
6301 addedhead $id $name
6302 notbusy newbranch
6303 redrawtags $id
6304 dispneartags 0
6305 run refill_reflist
6309 proc cherrypick {} {
6310 global rowmenuid curview commitrow
6311 global mainhead
6313 set oldhead [exec git rev-parse HEAD]
6314 set dheads [descheads $rowmenuid]
6315 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6316 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6317 included in branch $mainhead -- really re-apply it?"]
6318 if {!$ok} return
6320 nowbusy cherrypick "Cherry-picking"
6321 update
6322 # Unfortunately git-cherry-pick writes stuff to stderr even when
6323 # no error occurs, and exec takes that as an indication of error...
6324 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6325 notbusy cherrypick
6326 error_popup $err
6327 return
6329 set newhead [exec git rev-parse HEAD]
6330 if {$newhead eq $oldhead} {
6331 notbusy cherrypick
6332 error_popup "No changes committed"
6333 return
6335 addnewchild $newhead $oldhead
6336 if {[info exists commitrow($curview,$oldhead)]} {
6337 insertrow $commitrow($curview,$oldhead) $newhead
6338 if {$mainhead ne {}} {
6339 movehead $newhead $mainhead
6340 movedhead $newhead $mainhead
6342 redrawtags $oldhead
6343 redrawtags $newhead
6345 notbusy cherrypick
6348 proc resethead {} {
6349 global mainheadid mainhead rowmenuid confirm_ok resettype
6351 set confirm_ok 0
6352 set w ".confirmreset"
6353 toplevel $w
6354 wm transient $w .
6355 wm title $w "Confirm reset"
6356 message $w.m -text \
6357 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6358 -justify center -aspect 1000
6359 pack $w.m -side top -fill x -padx 20 -pady 20
6360 frame $w.f -relief sunken -border 2
6361 message $w.f.rt -text "Reset type:" -aspect 1000
6362 grid $w.f.rt -sticky w
6363 set resettype mixed
6364 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6365 -text "Soft: Leave working tree and index untouched"
6366 grid $w.f.soft -sticky w
6367 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6368 -text "Mixed: Leave working tree untouched, reset index"
6369 grid $w.f.mixed -sticky w
6370 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6371 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6372 grid $w.f.hard -sticky w
6373 pack $w.f -side top -fill x
6374 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6375 pack $w.ok -side left -fill x -padx 20 -pady 20
6376 button $w.cancel -text Cancel -command "destroy $w"
6377 pack $w.cancel -side right -fill x -padx 20 -pady 20
6378 bind $w <Visibility> "grab $w; focus $w"
6379 tkwait window $w
6380 if {!$confirm_ok} return
6381 if {[catch {set fd [open \
6382 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6383 error_popup $err
6384 } else {
6385 dohidelocalchanges
6386 filerun $fd [list readresetstat $fd]
6387 nowbusy reset "Resetting"
6391 proc readresetstat {fd} {
6392 global mainhead mainheadid showlocalchanges rprogcoord
6394 if {[gets $fd line] >= 0} {
6395 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6396 set rprogcoord [expr {1.0 * $m / $n}]
6397 adjustprogress
6399 return 1
6401 set rprogcoord 0
6402 adjustprogress
6403 notbusy reset
6404 if {[catch {close $fd} err]} {
6405 error_popup $err
6407 set oldhead $mainheadid
6408 set newhead [exec git rev-parse HEAD]
6409 if {$newhead ne $oldhead} {
6410 movehead $newhead $mainhead
6411 movedhead $newhead $mainhead
6412 set mainheadid $newhead
6413 redrawtags $oldhead
6414 redrawtags $newhead
6416 if {$showlocalchanges} {
6417 doshowlocalchanges
6419 return 0
6422 # context menu for a head
6423 proc headmenu {x y id head} {
6424 global headmenuid headmenuhead headctxmenu mainhead
6426 stopfinding
6427 set headmenuid $id
6428 set headmenuhead $head
6429 set state normal
6430 if {$head eq $mainhead} {
6431 set state disabled
6433 $headctxmenu entryconfigure 0 -state $state
6434 $headctxmenu entryconfigure 1 -state $state
6435 tk_popup $headctxmenu $x $y
6438 proc cobranch {} {
6439 global headmenuid headmenuhead mainhead headids
6440 global showlocalchanges mainheadid
6442 # check the tree is clean first??
6443 set oldmainhead $mainhead
6444 nowbusy checkout "Checking out"
6445 update
6446 dohidelocalchanges
6447 if {[catch {
6448 exec git checkout -q $headmenuhead
6449 } err]} {
6450 notbusy checkout
6451 error_popup $err
6452 } else {
6453 notbusy checkout
6454 set mainhead $headmenuhead
6455 set mainheadid $headmenuid
6456 if {[info exists headids($oldmainhead)]} {
6457 redrawtags $headids($oldmainhead)
6459 redrawtags $headmenuid
6461 if {$showlocalchanges} {
6462 dodiffindex
6466 proc rmbranch {} {
6467 global headmenuid headmenuhead mainhead
6468 global idheads
6470 set head $headmenuhead
6471 set id $headmenuid
6472 # this check shouldn't be needed any more...
6473 if {$head eq $mainhead} {
6474 error_popup "Cannot delete the currently checked-out branch"
6475 return
6477 set dheads [descheads $id]
6478 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6479 # the stuff on this branch isn't on any other branch
6480 if {![confirm_popup "The commits on branch $head aren't on any other\
6481 branch.\nReally delete branch $head?"]} return
6483 nowbusy rmbranch
6484 update
6485 if {[catch {exec git branch -D $head} err]} {
6486 notbusy rmbranch
6487 error_popup $err
6488 return
6490 removehead $id $head
6491 removedhead $id $head
6492 redrawtags $id
6493 notbusy rmbranch
6494 dispneartags 0
6495 run refill_reflist
6498 # Display a list of tags and heads
6499 proc showrefs {} {
6500 global showrefstop bgcolor fgcolor selectbgcolor
6501 global bglist fglist reflistfilter reflist maincursor
6503 set top .showrefs
6504 set showrefstop $top
6505 if {[winfo exists $top]} {
6506 raise $top
6507 refill_reflist
6508 return
6510 toplevel $top
6511 wm title $top "Tags and heads: [file tail [pwd]]"
6512 text $top.list -background $bgcolor -foreground $fgcolor \
6513 -selectbackground $selectbgcolor -font mainfont \
6514 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6515 -width 30 -height 20 -cursor $maincursor \
6516 -spacing1 1 -spacing3 1 -state disabled
6517 $top.list tag configure highlight -background $selectbgcolor
6518 lappend bglist $top.list
6519 lappend fglist $top.list
6520 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6521 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6522 grid $top.list $top.ysb -sticky nsew
6523 grid $top.xsb x -sticky ew
6524 frame $top.f
6525 label $top.f.l -text "Filter: " -font uifont
6526 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
6527 set reflistfilter "*"
6528 trace add variable reflistfilter write reflistfilter_change
6529 pack $top.f.e -side right -fill x -expand 1
6530 pack $top.f.l -side left
6531 grid $top.f - -sticky ew -pady 2
6532 button $top.close -command [list destroy $top] -text "Close" \
6533 -font uifont
6534 grid $top.close -
6535 grid columnconfigure $top 0 -weight 1
6536 grid rowconfigure $top 0 -weight 1
6537 bind $top.list <1> {break}
6538 bind $top.list <B1-Motion> {break}
6539 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6540 set reflist {}
6541 refill_reflist
6544 proc sel_reflist {w x y} {
6545 global showrefstop reflist headids tagids otherrefids
6547 if {![winfo exists $showrefstop]} return
6548 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6549 set ref [lindex $reflist [expr {$l-1}]]
6550 set n [lindex $ref 0]
6551 switch -- [lindex $ref 1] {
6552 "H" {selbyid $headids($n)}
6553 "T" {selbyid $tagids($n)}
6554 "o" {selbyid $otherrefids($n)}
6556 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6559 proc unsel_reflist {} {
6560 global showrefstop
6562 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6563 $showrefstop.list tag remove highlight 0.0 end
6566 proc reflistfilter_change {n1 n2 op} {
6567 global reflistfilter
6569 after cancel refill_reflist
6570 after 200 refill_reflist
6573 proc refill_reflist {} {
6574 global reflist reflistfilter showrefstop headids tagids otherrefids
6575 global commitrow curview commitinterest
6577 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6578 set refs {}
6579 foreach n [array names headids] {
6580 if {[string match $reflistfilter $n]} {
6581 if {[info exists commitrow($curview,$headids($n))]} {
6582 lappend refs [list $n H]
6583 } else {
6584 set commitinterest($headids($n)) {run refill_reflist}
6588 foreach n [array names tagids] {
6589 if {[string match $reflistfilter $n]} {
6590 if {[info exists commitrow($curview,$tagids($n))]} {
6591 lappend refs [list $n T]
6592 } else {
6593 set commitinterest($tagids($n)) {run refill_reflist}
6597 foreach n [array names otherrefids] {
6598 if {[string match $reflistfilter $n]} {
6599 if {[info exists commitrow($curview,$otherrefids($n))]} {
6600 lappend refs [list $n o]
6601 } else {
6602 set commitinterest($otherrefids($n)) {run refill_reflist}
6606 set refs [lsort -index 0 $refs]
6607 if {$refs eq $reflist} return
6609 # Update the contents of $showrefstop.list according to the
6610 # differences between $reflist (old) and $refs (new)
6611 $showrefstop.list conf -state normal
6612 $showrefstop.list insert end "\n"
6613 set i 0
6614 set j 0
6615 while {$i < [llength $reflist] || $j < [llength $refs]} {
6616 if {$i < [llength $reflist]} {
6617 if {$j < [llength $refs]} {
6618 set cmp [string compare [lindex $reflist $i 0] \
6619 [lindex $refs $j 0]]
6620 if {$cmp == 0} {
6621 set cmp [string compare [lindex $reflist $i 1] \
6622 [lindex $refs $j 1]]
6624 } else {
6625 set cmp -1
6627 } else {
6628 set cmp 1
6630 switch -- $cmp {
6631 -1 {
6632 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6633 incr i
6636 incr i
6637 incr j
6640 set l [expr {$j + 1}]
6641 $showrefstop.list image create $l.0 -align baseline \
6642 -image reficon-[lindex $refs $j 1] -padx 2
6643 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6644 incr j
6648 set reflist $refs
6649 # delete last newline
6650 $showrefstop.list delete end-2c end-1c
6651 $showrefstop.list conf -state disabled
6654 # Stuff for finding nearby tags
6655 proc getallcommits {} {
6656 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6657 global idheads idtags idotherrefs allparents tagobjid
6659 if {![info exists allcommits]} {
6660 set nextarc 0
6661 set allcommits 0
6662 set seeds {}
6663 set allcwait 0
6664 set cachedarcs 0
6665 set allccache [file join [gitdir] "gitk.cache"]
6666 if {![catch {
6667 set f [open $allccache r]
6668 set allcwait 1
6669 getcache $f
6670 }]} return
6673 if {$allcwait} {
6674 return
6676 set cmd [list | git rev-list --parents]
6677 set allcupdate [expr {$seeds ne {}}]
6678 if {!$allcupdate} {
6679 set ids "--all"
6680 } else {
6681 set refs [concat [array names idheads] [array names idtags] \
6682 [array names idotherrefs]]
6683 set ids {}
6684 set tagobjs {}
6685 foreach name [array names tagobjid] {
6686 lappend tagobjs $tagobjid($name)
6688 foreach id [lsort -unique $refs] {
6689 if {![info exists allparents($id)] &&
6690 [lsearch -exact $tagobjs $id] < 0} {
6691 lappend ids $id
6694 if {$ids ne {}} {
6695 foreach id $seeds {
6696 lappend ids "^$id"
6700 if {$ids ne {}} {
6701 set fd [open [concat $cmd $ids] r]
6702 fconfigure $fd -blocking 0
6703 incr allcommits
6704 nowbusy allcommits
6705 filerun $fd [list getallclines $fd]
6706 } else {
6707 dispneartags 0
6711 # Since most commits have 1 parent and 1 child, we group strings of
6712 # such commits into "arcs" joining branch/merge points (BMPs), which
6713 # are commits that either don't have 1 parent or don't have 1 child.
6715 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6716 # arcout(id) - outgoing arcs for BMP
6717 # arcids(a) - list of IDs on arc including end but not start
6718 # arcstart(a) - BMP ID at start of arc
6719 # arcend(a) - BMP ID at end of arc
6720 # growing(a) - arc a is still growing
6721 # arctags(a) - IDs out of arcids (excluding end) that have tags
6722 # archeads(a) - IDs out of arcids (excluding end) that have heads
6723 # The start of an arc is at the descendent end, so "incoming" means
6724 # coming from descendents, and "outgoing" means going towards ancestors.
6726 proc getallclines {fd} {
6727 global allparents allchildren idtags idheads nextarc
6728 global arcnos arcids arctags arcout arcend arcstart archeads growing
6729 global seeds allcommits cachedarcs allcupdate
6731 set nid 0
6732 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6733 set id [lindex $line 0]
6734 if {[info exists allparents($id)]} {
6735 # seen it already
6736 continue
6738 set cachedarcs 0
6739 set olds [lrange $line 1 end]
6740 set allparents($id) $olds
6741 if {![info exists allchildren($id)]} {
6742 set allchildren($id) {}
6743 set arcnos($id) {}
6744 lappend seeds $id
6745 } else {
6746 set a $arcnos($id)
6747 if {[llength $olds] == 1 && [llength $a] == 1} {
6748 lappend arcids($a) $id
6749 if {[info exists idtags($id)]} {
6750 lappend arctags($a) $id
6752 if {[info exists idheads($id)]} {
6753 lappend archeads($a) $id
6755 if {[info exists allparents($olds)]} {
6756 # seen parent already
6757 if {![info exists arcout($olds)]} {
6758 splitarc $olds
6760 lappend arcids($a) $olds
6761 set arcend($a) $olds
6762 unset growing($a)
6764 lappend allchildren($olds) $id
6765 lappend arcnos($olds) $a
6766 continue
6769 foreach a $arcnos($id) {
6770 lappend arcids($a) $id
6771 set arcend($a) $id
6772 unset growing($a)
6775 set ao {}
6776 foreach p $olds {
6777 lappend allchildren($p) $id
6778 set a [incr nextarc]
6779 set arcstart($a) $id
6780 set archeads($a) {}
6781 set arctags($a) {}
6782 set archeads($a) {}
6783 set arcids($a) {}
6784 lappend ao $a
6785 set growing($a) 1
6786 if {[info exists allparents($p)]} {
6787 # seen it already, may need to make a new branch
6788 if {![info exists arcout($p)]} {
6789 splitarc $p
6791 lappend arcids($a) $p
6792 set arcend($a) $p
6793 unset growing($a)
6795 lappend arcnos($p) $a
6797 set arcout($id) $ao
6799 if {$nid > 0} {
6800 global cached_dheads cached_dtags cached_atags
6801 catch {unset cached_dheads}
6802 catch {unset cached_dtags}
6803 catch {unset cached_atags}
6805 if {![eof $fd]} {
6806 return [expr {$nid >= 1000? 2: 1}]
6808 set cacheok 1
6809 if {[catch {
6810 fconfigure $fd -blocking 1
6811 close $fd
6812 } err]} {
6813 # got an error reading the list of commits
6814 # if we were updating, try rereading the whole thing again
6815 if {$allcupdate} {
6816 incr allcommits -1
6817 dropcache $err
6818 return
6820 error_popup "Error reading commit topology information;\
6821 branch and preceding/following tag information\
6822 will be incomplete.\n($err)"
6823 set cacheok 0
6825 if {[incr allcommits -1] == 0} {
6826 notbusy allcommits
6827 if {$cacheok} {
6828 run savecache
6831 dispneartags 0
6832 return 0
6835 proc recalcarc {a} {
6836 global arctags archeads arcids idtags idheads
6838 set at {}
6839 set ah {}
6840 foreach id [lrange $arcids($a) 0 end-1] {
6841 if {[info exists idtags($id)]} {
6842 lappend at $id
6844 if {[info exists idheads($id)]} {
6845 lappend ah $id
6848 set arctags($a) $at
6849 set archeads($a) $ah
6852 proc splitarc {p} {
6853 global arcnos arcids nextarc arctags archeads idtags idheads
6854 global arcstart arcend arcout allparents growing
6856 set a $arcnos($p)
6857 if {[llength $a] != 1} {
6858 puts "oops splitarc called but [llength $a] arcs already"
6859 return
6861 set a [lindex $a 0]
6862 set i [lsearch -exact $arcids($a) $p]
6863 if {$i < 0} {
6864 puts "oops splitarc $p not in arc $a"
6865 return
6867 set na [incr nextarc]
6868 if {[info exists arcend($a)]} {
6869 set arcend($na) $arcend($a)
6870 } else {
6871 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6872 set j [lsearch -exact $arcnos($l) $a]
6873 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6875 set tail [lrange $arcids($a) [expr {$i+1}] end]
6876 set arcids($a) [lrange $arcids($a) 0 $i]
6877 set arcend($a) $p
6878 set arcstart($na) $p
6879 set arcout($p) $na
6880 set arcids($na) $tail
6881 if {[info exists growing($a)]} {
6882 set growing($na) 1
6883 unset growing($a)
6886 foreach id $tail {
6887 if {[llength $arcnos($id)] == 1} {
6888 set arcnos($id) $na
6889 } else {
6890 set j [lsearch -exact $arcnos($id) $a]
6891 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6895 # reconstruct tags and heads lists
6896 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6897 recalcarc $a
6898 recalcarc $na
6899 } else {
6900 set arctags($na) {}
6901 set archeads($na) {}
6905 # Update things for a new commit added that is a child of one
6906 # existing commit. Used when cherry-picking.
6907 proc addnewchild {id p} {
6908 global allparents allchildren idtags nextarc
6909 global arcnos arcids arctags arcout arcend arcstart archeads growing
6910 global seeds allcommits
6912 if {![info exists allcommits] || ![info exists arcnos($p)]} return
6913 set allparents($id) [list $p]
6914 set allchildren($id) {}
6915 set arcnos($id) {}
6916 lappend seeds $id
6917 lappend allchildren($p) $id
6918 set a [incr nextarc]
6919 set arcstart($a) $id
6920 set archeads($a) {}
6921 set arctags($a) {}
6922 set arcids($a) [list $p]
6923 set arcend($a) $p
6924 if {![info exists arcout($p)]} {
6925 splitarc $p
6927 lappend arcnos($p) $a
6928 set arcout($id) [list $a]
6931 # This implements a cache for the topology information.
6932 # The cache saves, for each arc, the start and end of the arc,
6933 # the ids on the arc, and the outgoing arcs from the end.
6934 proc readcache {f} {
6935 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6936 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6937 global allcwait
6939 set a $nextarc
6940 set lim $cachedarcs
6941 if {$lim - $a > 500} {
6942 set lim [expr {$a + 500}]
6944 if {[catch {
6945 if {$a == $lim} {
6946 # finish reading the cache and setting up arctags, etc.
6947 set line [gets $f]
6948 if {$line ne "1"} {error "bad final version"}
6949 close $f
6950 foreach id [array names idtags] {
6951 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6952 [llength $allparents($id)] == 1} {
6953 set a [lindex $arcnos($id) 0]
6954 if {$arctags($a) eq {}} {
6955 recalcarc $a
6959 foreach id [array names idheads] {
6960 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6961 [llength $allparents($id)] == 1} {
6962 set a [lindex $arcnos($id) 0]
6963 if {$archeads($a) eq {}} {
6964 recalcarc $a
6968 foreach id [lsort -unique $possible_seeds] {
6969 if {$arcnos($id) eq {}} {
6970 lappend seeds $id
6973 set allcwait 0
6974 } else {
6975 while {[incr a] <= $lim} {
6976 set line [gets $f]
6977 if {[llength $line] != 3} {error "bad line"}
6978 set s [lindex $line 0]
6979 set arcstart($a) $s
6980 lappend arcout($s) $a
6981 if {![info exists arcnos($s)]} {
6982 lappend possible_seeds $s
6983 set arcnos($s) {}
6985 set e [lindex $line 1]
6986 if {$e eq {}} {
6987 set growing($a) 1
6988 } else {
6989 set arcend($a) $e
6990 if {![info exists arcout($e)]} {
6991 set arcout($e) {}
6994 set arcids($a) [lindex $line 2]
6995 foreach id $arcids($a) {
6996 lappend allparents($s) $id
6997 set s $id
6998 lappend arcnos($id) $a
7000 if {![info exists allparents($s)]} {
7001 set allparents($s) {}
7003 set arctags($a) {}
7004 set archeads($a) {}
7006 set nextarc [expr {$a - 1}]
7008 } err]} {
7009 dropcache $err
7010 return 0
7012 if {!$allcwait} {
7013 getallcommits
7015 return $allcwait
7018 proc getcache {f} {
7019 global nextarc cachedarcs possible_seeds
7021 if {[catch {
7022 set line [gets $f]
7023 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7024 # make sure it's an integer
7025 set cachedarcs [expr {int([lindex $line 1])}]
7026 if {$cachedarcs < 0} {error "bad number of arcs"}
7027 set nextarc 0
7028 set possible_seeds {}
7029 run readcache $f
7030 } err]} {
7031 dropcache $err
7033 return 0
7036 proc dropcache {err} {
7037 global allcwait nextarc cachedarcs seeds
7039 #puts "dropping cache ($err)"
7040 foreach v {arcnos arcout arcids arcstart arcend growing \
7041 arctags archeads allparents allchildren} {
7042 global $v
7043 catch {unset $v}
7045 set allcwait 0
7046 set nextarc 0
7047 set cachedarcs 0
7048 set seeds {}
7049 getallcommits
7052 proc writecache {f} {
7053 global cachearc cachedarcs allccache
7054 global arcstart arcend arcnos arcids arcout
7056 set a $cachearc
7057 set lim $cachedarcs
7058 if {$lim - $a > 1000} {
7059 set lim [expr {$a + 1000}]
7061 if {[catch {
7062 while {[incr a] <= $lim} {
7063 if {[info exists arcend($a)]} {
7064 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7065 } else {
7066 puts $f [list $arcstart($a) {} $arcids($a)]
7069 } err]} {
7070 catch {close $f}
7071 catch {file delete $allccache}
7072 #puts "writing cache failed ($err)"
7073 return 0
7075 set cachearc [expr {$a - 1}]
7076 if {$a > $cachedarcs} {
7077 puts $f "1"
7078 close $f
7079 return 0
7081 return 1
7084 proc savecache {} {
7085 global nextarc cachedarcs cachearc allccache
7087 if {$nextarc == $cachedarcs} return
7088 set cachearc 0
7089 set cachedarcs $nextarc
7090 catch {
7091 set f [open $allccache w]
7092 puts $f [list 1 $cachedarcs]
7093 run writecache $f
7097 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7098 # or 0 if neither is true.
7099 proc anc_or_desc {a b} {
7100 global arcout arcstart arcend arcnos cached_isanc
7102 if {$arcnos($a) eq $arcnos($b)} {
7103 # Both are on the same arc(s); either both are the same BMP,
7104 # or if one is not a BMP, the other is also not a BMP or is
7105 # the BMP at end of the arc (and it only has 1 incoming arc).
7106 # Or both can be BMPs with no incoming arcs.
7107 if {$a eq $b || $arcnos($a) eq {}} {
7108 return 0
7110 # assert {[llength $arcnos($a)] == 1}
7111 set arc [lindex $arcnos($a) 0]
7112 set i [lsearch -exact $arcids($arc) $a]
7113 set j [lsearch -exact $arcids($arc) $b]
7114 if {$i < 0 || $i > $j} {
7115 return 1
7116 } else {
7117 return -1
7121 if {![info exists arcout($a)]} {
7122 set arc [lindex $arcnos($a) 0]
7123 if {[info exists arcend($arc)]} {
7124 set aend $arcend($arc)
7125 } else {
7126 set aend {}
7128 set a $arcstart($arc)
7129 } else {
7130 set aend $a
7132 if {![info exists arcout($b)]} {
7133 set arc [lindex $arcnos($b) 0]
7134 if {[info exists arcend($arc)]} {
7135 set bend $arcend($arc)
7136 } else {
7137 set bend {}
7139 set b $arcstart($arc)
7140 } else {
7141 set bend $b
7143 if {$a eq $bend} {
7144 return 1
7146 if {$b eq $aend} {
7147 return -1
7149 if {[info exists cached_isanc($a,$bend)]} {
7150 if {$cached_isanc($a,$bend)} {
7151 return 1
7154 if {[info exists cached_isanc($b,$aend)]} {
7155 if {$cached_isanc($b,$aend)} {
7156 return -1
7158 if {[info exists cached_isanc($a,$bend)]} {
7159 return 0
7163 set todo [list $a $b]
7164 set anc($a) a
7165 set anc($b) b
7166 for {set i 0} {$i < [llength $todo]} {incr i} {
7167 set x [lindex $todo $i]
7168 if {$anc($x) eq {}} {
7169 continue
7171 foreach arc $arcnos($x) {
7172 set xd $arcstart($arc)
7173 if {$xd eq $bend} {
7174 set cached_isanc($a,$bend) 1
7175 set cached_isanc($b,$aend) 0
7176 return 1
7177 } elseif {$xd eq $aend} {
7178 set cached_isanc($b,$aend) 1
7179 set cached_isanc($a,$bend) 0
7180 return -1
7182 if {![info exists anc($xd)]} {
7183 set anc($xd) $anc($x)
7184 lappend todo $xd
7185 } elseif {$anc($xd) ne $anc($x)} {
7186 set anc($xd) {}
7190 set cached_isanc($a,$bend) 0
7191 set cached_isanc($b,$aend) 0
7192 return 0
7195 # This identifies whether $desc has an ancestor that is
7196 # a growing tip of the graph and which is not an ancestor of $anc
7197 # and returns 0 if so and 1 if not.
7198 # If we subsequently discover a tag on such a growing tip, and that
7199 # turns out to be a descendent of $anc (which it could, since we
7200 # don't necessarily see children before parents), then $desc
7201 # isn't a good choice to display as a descendent tag of
7202 # $anc (since it is the descendent of another tag which is
7203 # a descendent of $anc). Similarly, $anc isn't a good choice to
7204 # display as a ancestor tag of $desc.
7206 proc is_certain {desc anc} {
7207 global arcnos arcout arcstart arcend growing problems
7209 set certain {}
7210 if {[llength $arcnos($anc)] == 1} {
7211 # tags on the same arc are certain
7212 if {$arcnos($desc) eq $arcnos($anc)} {
7213 return 1
7215 if {![info exists arcout($anc)]} {
7216 # if $anc is partway along an arc, use the start of the arc instead
7217 set a [lindex $arcnos($anc) 0]
7218 set anc $arcstart($a)
7221 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7222 set x $desc
7223 } else {
7224 set a [lindex $arcnos($desc) 0]
7225 set x $arcend($a)
7227 if {$x == $anc} {
7228 return 1
7230 set anclist [list $x]
7231 set dl($x) 1
7232 set nnh 1
7233 set ngrowanc 0
7234 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7235 set x [lindex $anclist $i]
7236 if {$dl($x)} {
7237 incr nnh -1
7239 set done($x) 1
7240 foreach a $arcout($x) {
7241 if {[info exists growing($a)]} {
7242 if {![info exists growanc($x)] && $dl($x)} {
7243 set growanc($x) 1
7244 incr ngrowanc
7246 } else {
7247 set y $arcend($a)
7248 if {[info exists dl($y)]} {
7249 if {$dl($y)} {
7250 if {!$dl($x)} {
7251 set dl($y) 0
7252 if {![info exists done($y)]} {
7253 incr nnh -1
7255 if {[info exists growanc($x)]} {
7256 incr ngrowanc -1
7258 set xl [list $y]
7259 for {set k 0} {$k < [llength $xl]} {incr k} {
7260 set z [lindex $xl $k]
7261 foreach c $arcout($z) {
7262 if {[info exists arcend($c)]} {
7263 set v $arcend($c)
7264 if {[info exists dl($v)] && $dl($v)} {
7265 set dl($v) 0
7266 if {![info exists done($v)]} {
7267 incr nnh -1
7269 if {[info exists growanc($v)]} {
7270 incr ngrowanc -1
7272 lappend xl $v
7279 } elseif {$y eq $anc || !$dl($x)} {
7280 set dl($y) 0
7281 lappend anclist $y
7282 } else {
7283 set dl($y) 1
7284 lappend anclist $y
7285 incr nnh
7290 foreach x [array names growanc] {
7291 if {$dl($x)} {
7292 return 0
7294 return 0
7296 return 1
7299 proc validate_arctags {a} {
7300 global arctags idtags
7302 set i -1
7303 set na $arctags($a)
7304 foreach id $arctags($a) {
7305 incr i
7306 if {![info exists idtags($id)]} {
7307 set na [lreplace $na $i $i]
7308 incr i -1
7311 set arctags($a) $na
7314 proc validate_archeads {a} {
7315 global archeads idheads
7317 set i -1
7318 set na $archeads($a)
7319 foreach id $archeads($a) {
7320 incr i
7321 if {![info exists idheads($id)]} {
7322 set na [lreplace $na $i $i]
7323 incr i -1
7326 set archeads($a) $na
7329 # Return the list of IDs that have tags that are descendents of id,
7330 # ignoring IDs that are descendents of IDs already reported.
7331 proc desctags {id} {
7332 global arcnos arcstart arcids arctags idtags allparents
7333 global growing cached_dtags
7335 if {![info exists allparents($id)]} {
7336 return {}
7338 set t1 [clock clicks -milliseconds]
7339 set argid $id
7340 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7341 # part-way along an arc; check that arc first
7342 set a [lindex $arcnos($id) 0]
7343 if {$arctags($a) ne {}} {
7344 validate_arctags $a
7345 set i [lsearch -exact $arcids($a) $id]
7346 set tid {}
7347 foreach t $arctags($a) {
7348 set j [lsearch -exact $arcids($a) $t]
7349 if {$j >= $i} break
7350 set tid $t
7352 if {$tid ne {}} {
7353 return $tid
7356 set id $arcstart($a)
7357 if {[info exists idtags($id)]} {
7358 return $id
7361 if {[info exists cached_dtags($id)]} {
7362 return $cached_dtags($id)
7365 set origid $id
7366 set todo [list $id]
7367 set queued($id) 1
7368 set nc 1
7369 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7370 set id [lindex $todo $i]
7371 set done($id) 1
7372 set ta [info exists hastaggedancestor($id)]
7373 if {!$ta} {
7374 incr nc -1
7376 # ignore tags on starting node
7377 if {!$ta && $i > 0} {
7378 if {[info exists idtags($id)]} {
7379 set tagloc($id) $id
7380 set ta 1
7381 } elseif {[info exists cached_dtags($id)]} {
7382 set tagloc($id) $cached_dtags($id)
7383 set ta 1
7386 foreach a $arcnos($id) {
7387 set d $arcstart($a)
7388 if {!$ta && $arctags($a) ne {}} {
7389 validate_arctags $a
7390 if {$arctags($a) ne {}} {
7391 lappend tagloc($id) [lindex $arctags($a) end]
7394 if {$ta || $arctags($a) ne {}} {
7395 set tomark [list $d]
7396 for {set j 0} {$j < [llength $tomark]} {incr j} {
7397 set dd [lindex $tomark $j]
7398 if {![info exists hastaggedancestor($dd)]} {
7399 if {[info exists done($dd)]} {
7400 foreach b $arcnos($dd) {
7401 lappend tomark $arcstart($b)
7403 if {[info exists tagloc($dd)]} {
7404 unset tagloc($dd)
7406 } elseif {[info exists queued($dd)]} {
7407 incr nc -1
7409 set hastaggedancestor($dd) 1
7413 if {![info exists queued($d)]} {
7414 lappend todo $d
7415 set queued($d) 1
7416 if {![info exists hastaggedancestor($d)]} {
7417 incr nc
7422 set tags {}
7423 foreach id [array names tagloc] {
7424 if {![info exists hastaggedancestor($id)]} {
7425 foreach t $tagloc($id) {
7426 if {[lsearch -exact $tags $t] < 0} {
7427 lappend tags $t
7432 set t2 [clock clicks -milliseconds]
7433 set loopix $i
7435 # remove tags that are descendents of other tags
7436 for {set i 0} {$i < [llength $tags]} {incr i} {
7437 set a [lindex $tags $i]
7438 for {set j 0} {$j < $i} {incr j} {
7439 set b [lindex $tags $j]
7440 set r [anc_or_desc $a $b]
7441 if {$r == 1} {
7442 set tags [lreplace $tags $j $j]
7443 incr j -1
7444 incr i -1
7445 } elseif {$r == -1} {
7446 set tags [lreplace $tags $i $i]
7447 incr i -1
7448 break
7453 if {[array names growing] ne {}} {
7454 # graph isn't finished, need to check if any tag could get
7455 # eclipsed by another tag coming later. Simply ignore any
7456 # tags that could later get eclipsed.
7457 set ctags {}
7458 foreach t $tags {
7459 if {[is_certain $t $origid]} {
7460 lappend ctags $t
7463 if {$tags eq $ctags} {
7464 set cached_dtags($origid) $tags
7465 } else {
7466 set tags $ctags
7468 } else {
7469 set cached_dtags($origid) $tags
7471 set t3 [clock clicks -milliseconds]
7472 if {0 && $t3 - $t1 >= 100} {
7473 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7474 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7476 return $tags
7479 proc anctags {id} {
7480 global arcnos arcids arcout arcend arctags idtags allparents
7481 global growing cached_atags
7483 if {![info exists allparents($id)]} {
7484 return {}
7486 set t1 [clock clicks -milliseconds]
7487 set argid $id
7488 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7489 # part-way along an arc; check that arc first
7490 set a [lindex $arcnos($id) 0]
7491 if {$arctags($a) ne {}} {
7492 validate_arctags $a
7493 set i [lsearch -exact $arcids($a) $id]
7494 foreach t $arctags($a) {
7495 set j [lsearch -exact $arcids($a) $t]
7496 if {$j > $i} {
7497 return $t
7501 if {![info exists arcend($a)]} {
7502 return {}
7504 set id $arcend($a)
7505 if {[info exists idtags($id)]} {
7506 return $id
7509 if {[info exists cached_atags($id)]} {
7510 return $cached_atags($id)
7513 set origid $id
7514 set todo [list $id]
7515 set queued($id) 1
7516 set taglist {}
7517 set nc 1
7518 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7519 set id [lindex $todo $i]
7520 set done($id) 1
7521 set td [info exists hastaggeddescendent($id)]
7522 if {!$td} {
7523 incr nc -1
7525 # ignore tags on starting node
7526 if {!$td && $i > 0} {
7527 if {[info exists idtags($id)]} {
7528 set tagloc($id) $id
7529 set td 1
7530 } elseif {[info exists cached_atags($id)]} {
7531 set tagloc($id) $cached_atags($id)
7532 set td 1
7535 foreach a $arcout($id) {
7536 if {!$td && $arctags($a) ne {}} {
7537 validate_arctags $a
7538 if {$arctags($a) ne {}} {
7539 lappend tagloc($id) [lindex $arctags($a) 0]
7542 if {![info exists arcend($a)]} continue
7543 set d $arcend($a)
7544 if {$td || $arctags($a) ne {}} {
7545 set tomark [list $d]
7546 for {set j 0} {$j < [llength $tomark]} {incr j} {
7547 set dd [lindex $tomark $j]
7548 if {![info exists hastaggeddescendent($dd)]} {
7549 if {[info exists done($dd)]} {
7550 foreach b $arcout($dd) {
7551 if {[info exists arcend($b)]} {
7552 lappend tomark $arcend($b)
7555 if {[info exists tagloc($dd)]} {
7556 unset tagloc($dd)
7558 } elseif {[info exists queued($dd)]} {
7559 incr nc -1
7561 set hastaggeddescendent($dd) 1
7565 if {![info exists queued($d)]} {
7566 lappend todo $d
7567 set queued($d) 1
7568 if {![info exists hastaggeddescendent($d)]} {
7569 incr nc
7574 set t2 [clock clicks -milliseconds]
7575 set loopix $i
7576 set tags {}
7577 foreach id [array names tagloc] {
7578 if {![info exists hastaggeddescendent($id)]} {
7579 foreach t $tagloc($id) {
7580 if {[lsearch -exact $tags $t] < 0} {
7581 lappend tags $t
7587 # remove tags that are ancestors of other tags
7588 for {set i 0} {$i < [llength $tags]} {incr i} {
7589 set a [lindex $tags $i]
7590 for {set j 0} {$j < $i} {incr j} {
7591 set b [lindex $tags $j]
7592 set r [anc_or_desc $a $b]
7593 if {$r == -1} {
7594 set tags [lreplace $tags $j $j]
7595 incr j -1
7596 incr i -1
7597 } elseif {$r == 1} {
7598 set tags [lreplace $tags $i $i]
7599 incr i -1
7600 break
7605 if {[array names growing] ne {}} {
7606 # graph isn't finished, need to check if any tag could get
7607 # eclipsed by another tag coming later. Simply ignore any
7608 # tags that could later get eclipsed.
7609 set ctags {}
7610 foreach t $tags {
7611 if {[is_certain $origid $t]} {
7612 lappend ctags $t
7615 if {$tags eq $ctags} {
7616 set cached_atags($origid) $tags
7617 } else {
7618 set tags $ctags
7620 } else {
7621 set cached_atags($origid) $tags
7623 set t3 [clock clicks -milliseconds]
7624 if {0 && $t3 - $t1 >= 100} {
7625 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7626 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7628 return $tags
7631 # Return the list of IDs that have heads that are descendents of id,
7632 # including id itself if it has a head.
7633 proc descheads {id} {
7634 global arcnos arcstart arcids archeads idheads cached_dheads
7635 global allparents
7637 if {![info exists allparents($id)]} {
7638 return {}
7640 set aret {}
7641 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7642 # part-way along an arc; check it first
7643 set a [lindex $arcnos($id) 0]
7644 if {$archeads($a) ne {}} {
7645 validate_archeads $a
7646 set i [lsearch -exact $arcids($a) $id]
7647 foreach t $archeads($a) {
7648 set j [lsearch -exact $arcids($a) $t]
7649 if {$j > $i} break
7650 lappend aret $t
7653 set id $arcstart($a)
7655 set origid $id
7656 set todo [list $id]
7657 set seen($id) 1
7658 set ret {}
7659 for {set i 0} {$i < [llength $todo]} {incr i} {
7660 set id [lindex $todo $i]
7661 if {[info exists cached_dheads($id)]} {
7662 set ret [concat $ret $cached_dheads($id)]
7663 } else {
7664 if {[info exists idheads($id)]} {
7665 lappend ret $id
7667 foreach a $arcnos($id) {
7668 if {$archeads($a) ne {}} {
7669 validate_archeads $a
7670 if {$archeads($a) ne {}} {
7671 set ret [concat $ret $archeads($a)]
7674 set d $arcstart($a)
7675 if {![info exists seen($d)]} {
7676 lappend todo $d
7677 set seen($d) 1
7682 set ret [lsort -unique $ret]
7683 set cached_dheads($origid) $ret
7684 return [concat $ret $aret]
7687 proc addedtag {id} {
7688 global arcnos arcout cached_dtags cached_atags
7690 if {![info exists arcnos($id)]} return
7691 if {![info exists arcout($id)]} {
7692 recalcarc [lindex $arcnos($id) 0]
7694 catch {unset cached_dtags}
7695 catch {unset cached_atags}
7698 proc addedhead {hid head} {
7699 global arcnos arcout cached_dheads
7701 if {![info exists arcnos($hid)]} return
7702 if {![info exists arcout($hid)]} {
7703 recalcarc [lindex $arcnos($hid) 0]
7705 catch {unset cached_dheads}
7708 proc removedhead {hid head} {
7709 global cached_dheads
7711 catch {unset cached_dheads}
7714 proc movedhead {hid head} {
7715 global arcnos arcout cached_dheads
7717 if {![info exists arcnos($hid)]} return
7718 if {![info exists arcout($hid)]} {
7719 recalcarc [lindex $arcnos($hid) 0]
7721 catch {unset cached_dheads}
7724 proc changedrefs {} {
7725 global cached_dheads cached_dtags cached_atags
7726 global arctags archeads arcnos arcout idheads idtags
7728 foreach id [concat [array names idheads] [array names idtags]] {
7729 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7730 set a [lindex $arcnos($id) 0]
7731 if {![info exists donearc($a)]} {
7732 recalcarc $a
7733 set donearc($a) 1
7737 catch {unset cached_dtags}
7738 catch {unset cached_atags}
7739 catch {unset cached_dheads}
7742 proc rereadrefs {} {
7743 global idtags idheads idotherrefs mainhead
7745 set refids [concat [array names idtags] \
7746 [array names idheads] [array names idotherrefs]]
7747 foreach id $refids {
7748 if {![info exists ref($id)]} {
7749 set ref($id) [listrefs $id]
7752 set oldmainhead $mainhead
7753 readrefs
7754 changedrefs
7755 set refids [lsort -unique [concat $refids [array names idtags] \
7756 [array names idheads] [array names idotherrefs]]]
7757 foreach id $refids {
7758 set v [listrefs $id]
7759 if {![info exists ref($id)] || $ref($id) != $v ||
7760 ($id eq $oldmainhead && $id ne $mainhead) ||
7761 ($id eq $mainhead && $id ne $oldmainhead)} {
7762 redrawtags $id
7765 run refill_reflist
7768 proc listrefs {id} {
7769 global idtags idheads idotherrefs
7771 set x {}
7772 if {[info exists idtags($id)]} {
7773 set x $idtags($id)
7775 set y {}
7776 if {[info exists idheads($id)]} {
7777 set y $idheads($id)
7779 set z {}
7780 if {[info exists idotherrefs($id)]} {
7781 set z $idotherrefs($id)
7783 return [list $x $y $z]
7786 proc showtag {tag isnew} {
7787 global ctext tagcontents tagids linknum tagobjid
7789 if {$isnew} {
7790 addtohistory [list showtag $tag 0]
7792 $ctext conf -state normal
7793 clear_ctext
7794 settabs 0
7795 set linknum 0
7796 if {![info exists tagcontents($tag)]} {
7797 catch {
7798 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7801 if {[info exists tagcontents($tag)]} {
7802 set text $tagcontents($tag)
7803 } else {
7804 set text "Tag: $tag\nId: $tagids($tag)"
7806 appendwithlinks $text {}
7807 $ctext conf -state disabled
7808 init_flist {}
7811 proc doquit {} {
7812 global stopped
7813 set stopped 100
7814 savestuff .
7815 destroy .
7818 proc mkfontdisp {font top which} {
7819 global fontattr fontpref $font
7821 set fontpref($font) [set $font]
7822 button $top.${font}but -text $which -font optionfont \
7823 -command [list choosefont $font $which]
7824 label $top.$font -relief flat -font $font \
7825 -text $fontattr($font,family) -justify left
7826 grid x $top.${font}but $top.$font -sticky w
7829 proc choosefont {font which} {
7830 global fontparam fontlist fonttop fontattr
7832 set fontparam(which) $which
7833 set fontparam(font) $font
7834 set fontparam(family) [font actual $font -family]
7835 set fontparam(size) $fontattr($font,size)
7836 set fontparam(weight) $fontattr($font,weight)
7837 set fontparam(slant) $fontattr($font,slant)
7838 set top .gitkfont
7839 set fonttop $top
7840 if {![winfo exists $top]} {
7841 font create sample
7842 eval font config sample [font actual $font]
7843 toplevel $top
7844 wm title $top "Gitk font chooser"
7845 label $top.l -textvariable fontparam(which) -font uifont
7846 pack $top.l -side top
7847 set fontlist [lsort [font families]]
7848 frame $top.f
7849 listbox $top.f.fam -listvariable fontlist \
7850 -yscrollcommand [list $top.f.sb set]
7851 bind $top.f.fam <<ListboxSelect>> selfontfam
7852 scrollbar $top.f.sb -command [list $top.f.fam yview]
7853 pack $top.f.sb -side right -fill y
7854 pack $top.f.fam -side left -fill both -expand 1
7855 pack $top.f -side top -fill both -expand 1
7856 frame $top.g
7857 spinbox $top.g.size -from 4 -to 40 -width 4 \
7858 -textvariable fontparam(size) \
7859 -validatecommand {string is integer -strict %s}
7860 checkbutton $top.g.bold -padx 5 \
7861 -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
7862 -variable fontparam(weight) -onvalue bold -offvalue normal
7863 checkbutton $top.g.ital -padx 5 \
7864 -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0 \
7865 -variable fontparam(slant) -onvalue italic -offvalue roman
7866 pack $top.g.size $top.g.bold $top.g.ital -side left
7867 pack $top.g -side top
7868 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7869 -background white
7870 $top.c create text 100 25 -anchor center -text $which -font sample \
7871 -fill black -tags text
7872 bind $top.c <Configure> [list centertext $top.c]
7873 pack $top.c -side top -fill x
7874 frame $top.buts
7875 button $top.buts.ok -text "OK" -command fontok -default active \
7876 -font uifont
7877 button $top.buts.can -text "Cancel" -command fontcan -default normal \
7878 -font uifont
7879 grid $top.buts.ok $top.buts.can
7880 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7881 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7882 pack $top.buts -side bottom -fill x
7883 trace add variable fontparam write chg_fontparam
7884 } else {
7885 raise $top
7886 $top.c itemconf text -text $which
7888 set i [lsearch -exact $fontlist $fontparam(family)]
7889 if {$i >= 0} {
7890 $top.f.fam selection set $i
7891 $top.f.fam see $i
7895 proc centertext {w} {
7896 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7899 proc fontok {} {
7900 global fontparam fontpref prefstop
7902 set f $fontparam(font)
7903 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7904 if {$fontparam(weight) eq "bold"} {
7905 lappend fontpref($f) "bold"
7907 if {$fontparam(slant) eq "italic"} {
7908 lappend fontpref($f) "italic"
7910 set w $prefstop.$f
7911 $w conf -text $fontparam(family) -font $fontpref($f)
7913 fontcan
7916 proc fontcan {} {
7917 global fonttop fontparam
7919 if {[info exists fonttop]} {
7920 catch {destroy $fonttop}
7921 catch {font delete sample}
7922 unset fonttop
7923 unset fontparam
7927 proc selfontfam {} {
7928 global fonttop fontparam
7930 set i [$fonttop.f.fam curselection]
7931 if {$i ne {}} {
7932 set fontparam(family) [$fonttop.f.fam get $i]
7936 proc chg_fontparam {v sub op} {
7937 global fontparam
7939 font config sample -$sub $fontparam($sub)
7942 proc doprefs {} {
7943 global maxwidth maxgraphpct
7944 global oldprefs prefstop showneartags showlocalchanges
7945 global bgcolor fgcolor ctext diffcolors selectbgcolor
7946 global uifont tabstop limitdiffs
7948 set top .gitkprefs
7949 set prefstop $top
7950 if {[winfo exists $top]} {
7951 raise $top
7952 return
7954 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
7955 limitdiffs tabstop} {
7956 set oldprefs($v) [set $v]
7958 toplevel $top
7959 wm title $top "Gitk preferences"
7960 label $top.ldisp -text "Commit list display options"
7961 $top.ldisp configure -font uifont
7962 grid $top.ldisp - -sticky w -pady 10
7963 label $top.spacer -text " "
7964 label $top.maxwidthl -text "Maximum graph width (lines)" \
7965 -font optionfont
7966 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7967 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7968 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7969 -font optionfont
7970 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7971 grid x $top.maxpctl $top.maxpct -sticky w
7972 frame $top.showlocal
7973 label $top.showlocal.l -text "Show local changes" -font optionfont
7974 checkbutton $top.showlocal.b -variable showlocalchanges
7975 pack $top.showlocal.b $top.showlocal.l -side left
7976 grid x $top.showlocal -sticky w
7978 label $top.ddisp -text "Diff display options"
7979 $top.ddisp configure -font uifont
7980 grid $top.ddisp - -sticky w -pady 10
7981 label $top.tabstopl -text "Tab spacing" -font optionfont
7982 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7983 grid x $top.tabstopl $top.tabstop -sticky w
7984 frame $top.ntag
7985 label $top.ntag.l -text "Display nearby tags" -font optionfont
7986 checkbutton $top.ntag.b -variable showneartags
7987 pack $top.ntag.b $top.ntag.l -side left
7988 grid x $top.ntag -sticky w
7989 frame $top.ldiff
7990 label $top.ldiff.l -text "Limit diffs to listed paths" -font optionfont
7991 checkbutton $top.ldiff.b -variable limitdiffs
7992 pack $top.ldiff.b $top.ldiff.l -side left
7993 grid x $top.ldiff -sticky w
7995 label $top.cdisp -text "Colors: press to choose"
7996 $top.cdisp configure -font uifont
7997 grid $top.cdisp - -sticky w -pady 10
7998 label $top.bg -padx 40 -relief sunk -background $bgcolor
7999 button $top.bgbut -text "Background" -font optionfont \
8000 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8001 grid x $top.bgbut $top.bg -sticky w
8002 label $top.fg -padx 40 -relief sunk -background $fgcolor
8003 button $top.fgbut -text "Foreground" -font optionfont \
8004 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8005 grid x $top.fgbut $top.fg -sticky w
8006 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8007 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8008 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8009 [list $ctext tag conf d0 -foreground]]
8010 grid x $top.diffoldbut $top.diffold -sticky w
8011 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8012 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8013 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8014 [list $ctext tag conf d1 -foreground]]
8015 grid x $top.diffnewbut $top.diffnew -sticky w
8016 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8017 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8018 -command [list choosecolor diffcolors 2 $top.hunksep \
8019 "diff hunk header" \
8020 [list $ctext tag conf hunksep -foreground]]
8021 grid x $top.hunksepbut $top.hunksep -sticky w
8022 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8023 button $top.selbgbut -text "Select bg" -font optionfont \
8024 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8025 grid x $top.selbgbut $top.selbgsep -sticky w
8027 label $top.cfont -text "Fonts: press to choose"
8028 $top.cfont configure -font uifont
8029 grid $top.cfont - -sticky w -pady 10
8030 mkfontdisp mainfont $top "Main font"
8031 mkfontdisp textfont $top "Diff display font"
8032 mkfontdisp uifont $top "User interface font"
8034 frame $top.buts
8035 button $top.buts.ok -text "OK" -command prefsok -default active
8036 $top.buts.ok configure -font uifont
8037 button $top.buts.can -text "Cancel" -command prefscan -default normal
8038 $top.buts.can configure -font uifont
8039 grid $top.buts.ok $top.buts.can
8040 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8041 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8042 grid $top.buts - - -pady 10 -sticky ew
8043 bind $top <Visibility> "focus $top.buts.ok"
8046 proc choosecolor {v vi w x cmd} {
8047 global $v
8049 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8050 -title "Gitk: choose color for $x"]
8051 if {$c eq {}} return
8052 $w conf -background $c
8053 lset $v $vi $c
8054 eval $cmd $c
8057 proc setselbg {c} {
8058 global bglist cflist
8059 foreach w $bglist {
8060 $w configure -selectbackground $c
8062 $cflist tag configure highlight \
8063 -background [$cflist cget -selectbackground]
8064 allcanvs itemconf secsel -fill $c
8067 proc setbg {c} {
8068 global bglist
8070 foreach w $bglist {
8071 $w conf -background $c
8075 proc setfg {c} {
8076 global fglist canv
8078 foreach w $fglist {
8079 $w conf -foreground $c
8081 allcanvs itemconf text -fill $c
8082 $canv itemconf circle -outline $c
8085 proc prefscan {} {
8086 global oldprefs prefstop
8088 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8089 limitdiffs tabstop} {
8090 global $v
8091 set $v $oldprefs($v)
8093 catch {destroy $prefstop}
8094 unset prefstop
8095 fontcan
8098 proc prefsok {} {
8099 global maxwidth maxgraphpct
8100 global oldprefs prefstop showneartags showlocalchanges
8101 global fontpref mainfont textfont uifont
8102 global limitdiffs treediffs
8104 catch {destroy $prefstop}
8105 unset prefstop
8106 fontcan
8107 set fontchanged 0
8108 if {$mainfont ne $fontpref(mainfont)} {
8109 set mainfont $fontpref(mainfont)
8110 parsefont mainfont $mainfont
8111 eval font configure mainfont [fontflags mainfont]
8112 eval font configure mainfontbold [fontflags mainfont 1]
8113 setcoords
8114 set fontchanged 1
8116 if {$textfont ne $fontpref(textfont)} {
8117 set textfont $fontpref(textfont)
8118 parsefont textfont $textfont
8119 eval font configure textfont [fontflags textfont]
8120 eval font configure textfontbold [fontflags textfont 1]
8122 if {$uifont ne $fontpref(uifont)} {
8123 set uifont $fontpref(uifont)
8124 parsefont uifont $uifont
8125 eval font configure uifont [fontflags uifont]
8127 settabs
8128 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8129 if {$showlocalchanges} {
8130 doshowlocalchanges
8131 } else {
8132 dohidelocalchanges
8135 if {$limitdiffs != $oldprefs(limitdiffs)} {
8136 # treediffs elements are limited by path
8137 catch {unset treediffs}
8139 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8140 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8141 redisplay
8142 } elseif {$showneartags != $oldprefs(showneartags) ||
8143 $limitdiffs != $oldprefs(limitdiffs)} {
8144 reselectline
8148 proc formatdate {d} {
8149 global datetimeformat
8150 if {$d ne {}} {
8151 set d [clock format $d -format $datetimeformat]
8153 return $d
8156 # This list of encoding names and aliases is distilled from
8157 # http://www.iana.org/assignments/character-sets.
8158 # Not all of them are supported by Tcl.
8159 set encoding_aliases {
8160 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8161 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8162 { ISO-10646-UTF-1 csISO10646UTF1 }
8163 { ISO_646.basic:1983 ref csISO646basic1983 }
8164 { INVARIANT csINVARIANT }
8165 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8166 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8167 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8168 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8169 { NATS-DANO iso-ir-9-1 csNATSDANO }
8170 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8171 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8172 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8173 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8174 { ISO-2022-KR csISO2022KR }
8175 { EUC-KR csEUCKR }
8176 { ISO-2022-JP csISO2022JP }
8177 { ISO-2022-JP-2 csISO2022JP2 }
8178 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8179 csISO13JISC6220jp }
8180 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8181 { IT iso-ir-15 ISO646-IT csISO15Italian }
8182 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8183 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8184 { greek7-old iso-ir-18 csISO18Greek7Old }
8185 { latin-greek iso-ir-19 csISO19LatinGreek }
8186 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8187 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8188 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8189 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8190 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8191 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8192 { INIS iso-ir-49 csISO49INIS }
8193 { INIS-8 iso-ir-50 csISO50INIS8 }
8194 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8195 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8196 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8197 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8198 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8199 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8200 csISO60Norwegian1 }
8201 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8202 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8203 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8204 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8205 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8206 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8207 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8208 { greek7 iso-ir-88 csISO88Greek7 }
8209 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8210 { iso-ir-90 csISO90 }
8211 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8212 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8213 csISO92JISC62991984b }
8214 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8215 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8216 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8217 csISO95JIS62291984handadd }
8218 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8219 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8220 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8221 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8222 CP819 csISOLatin1 }
8223 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8224 { T.61-7bit iso-ir-102 csISO102T617bit }
8225 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8226 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8227 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8228 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8229 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8230 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8231 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8232 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8233 arabic csISOLatinArabic }
8234 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8235 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8236 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8237 greek greek8 csISOLatinGreek }
8238 { T.101-G2 iso-ir-128 csISO128T101G2 }
8239 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8240 csISOLatinHebrew }
8241 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8242 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8243 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8244 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8245 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8246 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8247 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8248 csISOLatinCyrillic }
8249 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8250 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8251 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8252 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8253 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8254 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8255 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8256 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8257 { ISO_10367-box iso-ir-155 csISO10367Box }
8258 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8259 { latin-lap lap iso-ir-158 csISO158Lap }
8260 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8261 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8262 { us-dk csUSDK }
8263 { dk-us csDKUS }
8264 { JIS_X0201 X0201 csHalfWidthKatakana }
8265 { KSC5636 ISO646-KR csKSC5636 }
8266 { ISO-10646-UCS-2 csUnicode }
8267 { ISO-10646-UCS-4 csUCS4 }
8268 { DEC-MCS dec csDECMCS }
8269 { hp-roman8 roman8 r8 csHPRoman8 }
8270 { macintosh mac csMacintosh }
8271 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8272 csIBM037 }
8273 { IBM038 EBCDIC-INT cp038 csIBM038 }
8274 { IBM273 CP273 csIBM273 }
8275 { IBM274 EBCDIC-BE CP274 csIBM274 }
8276 { IBM275 EBCDIC-BR cp275 csIBM275 }
8277 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8278 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8279 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8280 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8281 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8282 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8283 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8284 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8285 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8286 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8287 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8288 { IBM437 cp437 437 csPC8CodePage437 }
8289 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8290 { IBM775 cp775 csPC775Baltic }
8291 { IBM850 cp850 850 csPC850Multilingual }
8292 { IBM851 cp851 851 csIBM851 }
8293 { IBM852 cp852 852 csPCp852 }
8294 { IBM855 cp855 855 csIBM855 }
8295 { IBM857 cp857 857 csIBM857 }
8296 { IBM860 cp860 860 csIBM860 }
8297 { IBM861 cp861 861 cp-is csIBM861 }
8298 { IBM862 cp862 862 csPC862LatinHebrew }
8299 { IBM863 cp863 863 csIBM863 }
8300 { IBM864 cp864 csIBM864 }
8301 { IBM865 cp865 865 csIBM865 }
8302 { IBM866 cp866 866 csIBM866 }
8303 { IBM868 CP868 cp-ar csIBM868 }
8304 { IBM869 cp869 869 cp-gr csIBM869 }
8305 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8306 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8307 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8308 { IBM891 cp891 csIBM891 }
8309 { IBM903 cp903 csIBM903 }
8310 { IBM904 cp904 904 csIBBM904 }
8311 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8312 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8313 { IBM1026 CP1026 csIBM1026 }
8314 { EBCDIC-AT-DE csIBMEBCDICATDE }
8315 { EBCDIC-AT-DE-A csEBCDICATDEA }
8316 { EBCDIC-CA-FR csEBCDICCAFR }
8317 { EBCDIC-DK-NO csEBCDICDKNO }
8318 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8319 { EBCDIC-FI-SE csEBCDICFISE }
8320 { EBCDIC-FI-SE-A csEBCDICFISEA }
8321 { EBCDIC-FR csEBCDICFR }
8322 { EBCDIC-IT csEBCDICIT }
8323 { EBCDIC-PT csEBCDICPT }
8324 { EBCDIC-ES csEBCDICES }
8325 { EBCDIC-ES-A csEBCDICESA }
8326 { EBCDIC-ES-S csEBCDICESS }
8327 { EBCDIC-UK csEBCDICUK }
8328 { EBCDIC-US csEBCDICUS }
8329 { UNKNOWN-8BIT csUnknown8BiT }
8330 { MNEMONIC csMnemonic }
8331 { MNEM csMnem }
8332 { VISCII csVISCII }
8333 { VIQR csVIQR }
8334 { KOI8-R csKOI8R }
8335 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8336 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8337 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8338 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8339 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8340 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8341 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8342 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8343 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8344 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8345 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8346 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8347 { IBM1047 IBM-1047 }
8348 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8349 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8350 { UNICODE-1-1 csUnicode11 }
8351 { CESU-8 csCESU-8 }
8352 { BOCU-1 csBOCU-1 }
8353 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8354 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8355 l8 }
8356 { ISO-8859-15 ISO_8859-15 Latin-9 }
8357 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8358 { GBK CP936 MS936 windows-936 }
8359 { JIS_Encoding csJISEncoding }
8360 { Shift_JIS MS_Kanji csShiftJIS }
8361 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8362 EUC-JP }
8363 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8364 { ISO-10646-UCS-Basic csUnicodeASCII }
8365 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8366 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8367 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8368 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8369 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8370 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8371 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8372 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8373 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8374 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8375 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8376 { Ventura-US csVenturaUS }
8377 { Ventura-International csVenturaInternational }
8378 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8379 { PC8-Turkish csPC8Turkish }
8380 { IBM-Symbols csIBMSymbols }
8381 { IBM-Thai csIBMThai }
8382 { HP-Legal csHPLegal }
8383 { HP-Pi-font csHPPiFont }
8384 { HP-Math8 csHPMath8 }
8385 { Adobe-Symbol-Encoding csHPPSMath }
8386 { HP-DeskTop csHPDesktop }
8387 { Ventura-Math csVenturaMath }
8388 { Microsoft-Publishing csMicrosoftPublishing }
8389 { Windows-31J csWindows31J }
8390 { GB2312 csGB2312 }
8391 { Big5 csBig5 }
8394 proc tcl_encoding {enc} {
8395 global encoding_aliases
8396 set names [encoding names]
8397 set lcnames [string tolower $names]
8398 set enc [string tolower $enc]
8399 set i [lsearch -exact $lcnames $enc]
8400 if {$i < 0} {
8401 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8402 if {[regsub {^iso[-_]} $enc iso encx]} {
8403 set i [lsearch -exact $lcnames $encx]
8406 if {$i < 0} {
8407 foreach l $encoding_aliases {
8408 set ll [string tolower $l]
8409 if {[lsearch -exact $ll $enc] < 0} continue
8410 # look through the aliases for one that tcl knows about
8411 foreach e $ll {
8412 set i [lsearch -exact $lcnames $e]
8413 if {$i < 0} {
8414 if {[regsub {^iso[-_]} $e iso ex]} {
8415 set i [lsearch -exact $lcnames $ex]
8418 if {$i >= 0} break
8420 break
8423 if {$i >= 0} {
8424 return [lindex $names $i]
8426 return {}
8429 # First check that Tcl/Tk is recent enough
8430 if {[catch {package require Tk 8.4} err]} {
8431 show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8432 Gitk requires at least Tcl/Tk 8.4."
8433 exit 1
8436 # defaults...
8437 set datemode 0
8438 set wrcomcmd "git diff-tree --stdin -p --pretty"
8440 set gitencoding {}
8441 catch {
8442 set gitencoding [exec git config --get i18n.commitencoding]
8444 if {$gitencoding == ""} {
8445 set gitencoding "utf-8"
8447 set tclencoding [tcl_encoding $gitencoding]
8448 if {$tclencoding == {}} {
8449 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8452 set mainfont {Helvetica 9}
8453 set textfont {Courier 9}
8454 set uifont {Helvetica 9 bold}
8455 set tabstop 8
8456 set findmergefiles 0
8457 set maxgraphpct 50
8458 set maxwidth 16
8459 set revlistorder 0
8460 set fastdate 0
8461 set uparrowlen 5
8462 set downarrowlen 5
8463 set mingaplen 100
8464 set cmitmode "patch"
8465 set wrapcomment "none"
8466 set showneartags 1
8467 set maxrefs 20
8468 set maxlinelen 200
8469 set showlocalchanges 1
8470 set limitdiffs 1
8471 set datetimeformat "%Y-%m-%d %H:%M:%S"
8473 set colors {green red blue magenta darkgrey brown orange}
8474 set bgcolor white
8475 set fgcolor black
8476 set diffcolors {red "#00a000" blue}
8477 set diffcontext 3
8478 set selectbgcolor gray85
8480 catch {source ~/.gitk}
8482 font create optionfont -family sans-serif -size -12
8484 parsefont mainfont $mainfont
8485 eval font create mainfont [fontflags mainfont]
8486 eval font create mainfontbold [fontflags mainfont 1]
8488 parsefont textfont $textfont
8489 eval font create textfont [fontflags textfont]
8490 eval font create textfontbold [fontflags textfont 1]
8492 parsefont uifont $uifont
8493 eval font create uifont [fontflags uifont]
8495 # check that we can find a .git directory somewhere...
8496 if {[catch {set gitdir [gitdir]}]} {
8497 show_error {} . "Cannot find a git repository here."
8498 exit 1
8500 if {![file isdirectory $gitdir]} {
8501 show_error {} . "Cannot find the git directory \"$gitdir\"."
8502 exit 1
8505 set mergeonly 0
8506 set revtreeargs {}
8507 set cmdline_files {}
8508 set i 0
8509 foreach arg $argv {
8510 switch -- $arg {
8511 "" { }
8512 "-d" { set datemode 1 }
8513 "--merge" {
8514 set mergeonly 1
8515 lappend revtreeargs $arg
8517 "--" {
8518 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8519 break
8521 default {
8522 lappend revtreeargs $arg
8525 incr i
8528 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8529 # no -- on command line, but some arguments (other than -d)
8530 if {[catch {
8531 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8532 set cmdline_files [split $f "\n"]
8533 set n [llength $cmdline_files]
8534 set revtreeargs [lrange $revtreeargs 0 end-$n]
8535 # Unfortunately git rev-parse doesn't produce an error when
8536 # something is both a revision and a filename. To be consistent
8537 # with git log and git rev-list, check revtreeargs for filenames.
8538 foreach arg $revtreeargs {
8539 if {[file exists $arg]} {
8540 show_error {} . "Ambiguous argument '$arg': both revision\
8541 and filename"
8542 exit 1
8545 } err]} {
8546 # unfortunately we get both stdout and stderr in $err,
8547 # so look for "fatal:".
8548 set i [string first "fatal:" $err]
8549 if {$i > 0} {
8550 set err [string range $err [expr {$i + 6}] end]
8552 show_error {} . "Bad arguments to gitk:\n$err"
8553 exit 1
8557 if {$mergeonly} {
8558 # find the list of unmerged files
8559 set mlist {}
8560 set nr_unmerged 0
8561 if {[catch {
8562 set fd [open "| git ls-files -u" r]
8563 } err]} {
8564 show_error {} . "Couldn't get list of unmerged files: $err"
8565 exit 1
8567 while {[gets $fd line] >= 0} {
8568 set i [string first "\t" $line]
8569 if {$i < 0} continue
8570 set fname [string range $line [expr {$i+1}] end]
8571 if {[lsearch -exact $mlist $fname] >= 0} continue
8572 incr nr_unmerged
8573 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8574 lappend mlist $fname
8577 catch {close $fd}
8578 if {$mlist eq {}} {
8579 if {$nr_unmerged == 0} {
8580 show_error {} . "No files selected: --merge specified but\
8581 no files are unmerged."
8582 } else {
8583 show_error {} . "No files selected: --merge specified but\
8584 no unmerged files are within file limit."
8586 exit 1
8588 set cmdline_files $mlist
8591 set nullid "0000000000000000000000000000000000000000"
8592 set nullid2 "0000000000000000000000000000000000000001"
8594 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8596 set runq {}
8597 set history {}
8598 set historyindex 0
8599 set fh_serial 0
8600 set nhl_names {}
8601 set highlight_paths {}
8602 set findpattern {}
8603 set searchdirn -forwards
8604 set boldrows {}
8605 set boldnamerows {}
8606 set diffelide {0 0}
8607 set markingmatches 0
8608 set linkentercount 0
8609 set need_redisplay 0
8610 set nrows_drawn 0
8611 set firsttabstop 0
8613 set nextviewnum 1
8614 set curview 0
8615 set selectedview 0
8616 set selectedhlview None
8617 set highlight_related None
8618 set highlight_files {}
8619 set viewfiles(0) {}
8620 set viewperm(0) 0
8621 set viewargs(0) {}
8623 set cmdlineok 0
8624 set stopped 0
8625 set stuffsaved 0
8626 set patchnum 0
8627 set localirow -1
8628 set localfrow -1
8629 set lserial 0
8630 setcoords
8631 makewindow
8632 # wait for the window to become visible
8633 tkwait visibility .
8634 wm title . "[file tail $argv0]: [file tail [pwd]]"
8635 readrefs
8637 if {$cmdline_files ne {} || $revtreeargs ne {}} {
8638 # create a view for the files/dirs specified on the command line
8639 set curview 1
8640 set selectedview 1
8641 set nextviewnum 2
8642 set viewname(1) "Command line"
8643 set viewfiles(1) $cmdline_files
8644 set viewargs(1) $revtreeargs
8645 set viewperm(1) 0
8646 addviewmenu 1
8647 .bar.view entryconf Edit* -state normal
8648 .bar.view entryconf Delete* -state normal
8651 if {[info exists permviews]} {
8652 foreach v $permviews {
8653 set n $nextviewnum
8654 incr nextviewnum
8655 set viewname($n) [lindex $v 0]
8656 set viewfiles($n) [lindex $v 1]
8657 set viewargs($n) [lindex $v 2]
8658 set viewperm($n) 1
8659 addviewmenu $n
8662 focus -force .
8663 getcommits