gitk: Integrate the reset progress bar in the main frame
[git/mingw.git] / gitk
blob722e47869b86265592180583b5b83eab41d3f769
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 -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
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 -font uifont
768 button .tf.lbar.fprev -text "prev" -command {dofind 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" \
834 -command changediffdisp -variable diffelide -value {0 0}
835 radiobutton .bleft.mid.old -text "Old version" \
836 -command changediffdisp -variable diffelide -value {0 1}
837 radiobutton .bleft.mid.new -text "New version" \
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"
950 bindall <2> "canvscan mark %W %x %y"
951 bindall <B2-Motion> "canvscan dragto %W %x %y"
952 bindkey <Home> selfirstline
953 bindkey <End> sellastline
954 bind . <Key-Up> "selnextline -1"
955 bind . <Key-Down> "selnextline 1"
956 bindkey <Key-Right> "goforw"
957 bindkey <Key-Left> "goback"
958 bind . <Key-Prior> "selnextpage -1"
959 bind . <Key-Next> "selnextpage 1"
960 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
961 bind . <$M1B-End> "allcanvs yview moveto 1.0"
962 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
963 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
964 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
965 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
966 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
967 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
968 bindkey <Key-space> "$ctext yview scroll 1 pages"
969 bindkey p "selnextline -1"
970 bindkey n "selnextline 1"
971 bindkey z "goback"
972 bindkey x "goforw"
973 bindkey i "selnextline -1"
974 bindkey k "selnextline 1"
975 bindkey j "goback"
976 bindkey l "goforw"
977 bindkey b "$ctext yview scroll -1 pages"
978 bindkey d "$ctext yview scroll 18 units"
979 bindkey u "$ctext yview scroll -18 units"
980 bindkey / {findnext 1}
981 bindkey <Key-Return> {findnext 0}
982 bindkey ? findprev
983 bindkey f nextfile
984 bindkey <F5> updatecommits
985 bind . <$M1B-q> doquit
986 bind . <$M1B-f> dofind
987 bind . <$M1B-g> {findnext 0}
988 bind . <$M1B-r> dosearchback
989 bind . <$M1B-s> dosearch
990 bind . <$M1B-equal> {incrfont 1}
991 bind . <$M1B-KP_Add> {incrfont 1}
992 bind . <$M1B-minus> {incrfont -1}
993 bind . <$M1B-KP_Subtract> {incrfont -1}
994 wm protocol . WM_DELETE_WINDOW doquit
995 bind . <Button-1> "click %W"
996 bind $fstring <Key-Return> dofind
997 bind $sha1entry <Key-Return> gotocommit
998 bind $sha1entry <<PasteSelection>> clearsha1
999 bind $cflist <1> {sel_flist %W %x %y; break}
1000 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1001 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1002 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1004 set maincursor [. cget -cursor]
1005 set textcursor [$ctext cget -cursor]
1006 set curtextcursor $textcursor
1008 set rowctxmenu .rowctxmenu
1009 menu $rowctxmenu -tearoff 0
1010 $rowctxmenu add command -label "Diff this -> selected" \
1011 -command {diffvssel 0}
1012 $rowctxmenu add command -label "Diff selected -> this" \
1013 -command {diffvssel 1}
1014 $rowctxmenu add command -label "Make patch" -command mkpatch
1015 $rowctxmenu add command -label "Create tag" -command mktag
1016 $rowctxmenu add command -label "Write commit to file" -command writecommit
1017 $rowctxmenu add command -label "Create new branch" -command mkbranch
1018 $rowctxmenu add command -label "Cherry-pick this commit" \
1019 -command cherrypick
1020 $rowctxmenu add command -label "Reset HEAD branch to here" \
1021 -command resethead
1023 set fakerowmenu .fakerowmenu
1024 menu $fakerowmenu -tearoff 0
1025 $fakerowmenu add command -label "Diff this -> selected" \
1026 -command {diffvssel 0}
1027 $fakerowmenu add command -label "Diff selected -> this" \
1028 -command {diffvssel 1}
1029 $fakerowmenu add command -label "Make patch" -command mkpatch
1030 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1031 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1032 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
1034 set headctxmenu .headctxmenu
1035 menu $headctxmenu -tearoff 0
1036 $headctxmenu add command -label "Check out this branch" \
1037 -command cobranch
1038 $headctxmenu add command -label "Remove this branch" \
1039 -command rmbranch
1041 global flist_menu
1042 set flist_menu .flistctxmenu
1043 menu $flist_menu -tearoff 0
1044 $flist_menu add command -label "Highlight this too" \
1045 -command {flist_hl 0}
1046 $flist_menu add command -label "Highlight this only" \
1047 -command {flist_hl 1}
1050 # Windows sends all mouse wheel events to the current focused window, not
1051 # the one where the mouse hovers, so bind those events here and redirect
1052 # to the correct window
1053 proc windows_mousewheel_redirector {W X Y D} {
1054 global canv canv2 canv3
1055 set w [winfo containing -displayof $W $X $Y]
1056 if {$w ne ""} {
1057 set u [expr {$D < 0 ? 5 : -5}]
1058 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1059 allcanvs yview scroll $u units
1060 } else {
1061 catch {
1062 $w yview scroll $u units
1068 # mouse-2 makes all windows scan vertically, but only the one
1069 # the cursor is in scans horizontally
1070 proc canvscan {op w x y} {
1071 global canv canv2 canv3
1072 foreach c [list $canv $canv2 $canv3] {
1073 if {$c == $w} {
1074 $c scan $op $x $y
1075 } else {
1076 $c scan $op 0 $y
1081 proc scrollcanv {cscroll f0 f1} {
1082 $cscroll set $f0 $f1
1083 drawfrac $f0 $f1
1084 flushhighlights
1087 # when we make a key binding for the toplevel, make sure
1088 # it doesn't get triggered when that key is pressed in the
1089 # find string entry widget.
1090 proc bindkey {ev script} {
1091 global entries
1092 bind . $ev $script
1093 set escript [bind Entry $ev]
1094 if {$escript == {}} {
1095 set escript [bind Entry <Key>]
1097 foreach e $entries {
1098 bind $e $ev "$escript; break"
1102 # set the focus back to the toplevel for any click outside
1103 # the entry widgets
1104 proc click {w} {
1105 global ctext entries
1106 foreach e [concat $entries $ctext] {
1107 if {$w == $e} return
1109 focus .
1112 # Adjust the progress bar for a change in requested extent or canvas size
1113 proc adjustprogress {} {
1114 global progresscanv progressitem progresscoords
1115 global fprogitem fprogcoord lastprogupdate progupdatepending
1116 global rprogitem rprogcoord
1118 set w [expr {[winfo width $progresscanv] - 4}]
1119 set x0 [expr {$w * [lindex $progresscoords 0]}]
1120 set x1 [expr {$w * [lindex $progresscoords 1]}]
1121 set h [winfo height $progresscanv]
1122 $progresscanv coords $progressitem $x0 0 $x1 $h
1123 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1124 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1125 set now [clock clicks -milliseconds]
1126 if {$now >= $lastprogupdate + 100} {
1127 set progupdatepending 0
1128 update
1129 } elseif {!$progupdatepending} {
1130 set progupdatepending 1
1131 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1135 proc doprogupdate {} {
1136 global lastprogupdate progupdatepending
1138 if {$progupdatepending} {
1139 set progupdatepending 0
1140 set lastprogupdate [clock clicks -milliseconds]
1141 update
1145 proc savestuff {w} {
1146 global canv canv2 canv3 mainfont textfont uifont tabstop
1147 global stuffsaved findmergefiles maxgraphpct
1148 global maxwidth showneartags showlocalchanges
1149 global viewname viewfiles viewargs viewperm nextviewnum
1150 global cmitmode wrapcomment datetimeformat
1151 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1153 if {$stuffsaved} return
1154 if {![winfo viewable .]} return
1155 catch {
1156 set f [open "~/.gitk-new" w]
1157 puts $f [list set mainfont $mainfont]
1158 puts $f [list set textfont $textfont]
1159 puts $f [list set uifont $uifont]
1160 puts $f [list set tabstop $tabstop]
1161 puts $f [list set findmergefiles $findmergefiles]
1162 puts $f [list set maxgraphpct $maxgraphpct]
1163 puts $f [list set maxwidth $maxwidth]
1164 puts $f [list set cmitmode $cmitmode]
1165 puts $f [list set wrapcomment $wrapcomment]
1166 puts $f [list set showneartags $showneartags]
1167 puts $f [list set showlocalchanges $showlocalchanges]
1168 puts $f [list set datetimeformat $datetimeformat]
1169 puts $f [list set bgcolor $bgcolor]
1170 puts $f [list set fgcolor $fgcolor]
1171 puts $f [list set colors $colors]
1172 puts $f [list set diffcolors $diffcolors]
1173 puts $f [list set diffcontext $diffcontext]
1174 puts $f [list set selectbgcolor $selectbgcolor]
1176 puts $f "set geometry(main) [wm geometry .]"
1177 puts $f "set geometry(topwidth) [winfo width .tf]"
1178 puts $f "set geometry(topheight) [winfo height .tf]"
1179 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1180 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1181 puts $f "set geometry(botwidth) [winfo width .bleft]"
1182 puts $f "set geometry(botheight) [winfo height .bleft]"
1184 puts -nonewline $f "set permviews {"
1185 for {set v 0} {$v < $nextviewnum} {incr v} {
1186 if {$viewperm($v)} {
1187 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1190 puts $f "}"
1191 close $f
1192 file rename -force "~/.gitk-new" "~/.gitk"
1194 set stuffsaved 1
1197 proc resizeclistpanes {win w} {
1198 global oldwidth
1199 if {[info exists oldwidth($win)]} {
1200 set s0 [$win sash coord 0]
1201 set s1 [$win sash coord 1]
1202 if {$w < 60} {
1203 set sash0 [expr {int($w/2 - 2)}]
1204 set sash1 [expr {int($w*5/6 - 2)}]
1205 } else {
1206 set factor [expr {1.0 * $w / $oldwidth($win)}]
1207 set sash0 [expr {int($factor * [lindex $s0 0])}]
1208 set sash1 [expr {int($factor * [lindex $s1 0])}]
1209 if {$sash0 < 30} {
1210 set sash0 30
1212 if {$sash1 < $sash0 + 20} {
1213 set sash1 [expr {$sash0 + 20}]
1215 if {$sash1 > $w - 10} {
1216 set sash1 [expr {$w - 10}]
1217 if {$sash0 > $sash1 - 20} {
1218 set sash0 [expr {$sash1 - 20}]
1222 $win sash place 0 $sash0 [lindex $s0 1]
1223 $win sash place 1 $sash1 [lindex $s1 1]
1225 set oldwidth($win) $w
1228 proc resizecdetpanes {win w} {
1229 global oldwidth
1230 if {[info exists oldwidth($win)]} {
1231 set s0 [$win sash coord 0]
1232 if {$w < 60} {
1233 set sash0 [expr {int($w*3/4 - 2)}]
1234 } else {
1235 set factor [expr {1.0 * $w / $oldwidth($win)}]
1236 set sash0 [expr {int($factor * [lindex $s0 0])}]
1237 if {$sash0 < 45} {
1238 set sash0 45
1240 if {$sash0 > $w - 15} {
1241 set sash0 [expr {$w - 15}]
1244 $win sash place 0 $sash0 [lindex $s0 1]
1246 set oldwidth($win) $w
1249 proc allcanvs args {
1250 global canv canv2 canv3
1251 eval $canv $args
1252 eval $canv2 $args
1253 eval $canv3 $args
1256 proc bindall {event action} {
1257 global canv canv2 canv3
1258 bind $canv $event $action
1259 bind $canv2 $event $action
1260 bind $canv3 $event $action
1263 proc about {} {
1264 global uifont
1265 set w .about
1266 if {[winfo exists $w]} {
1267 raise $w
1268 return
1270 toplevel $w
1271 wm title $w "About gitk"
1272 message $w.m -text {
1273 Gitk - a commit viewer for git
1275 Copyright © 2005-2006 Paul Mackerras
1277 Use and redistribute under the terms of the GNU General Public License} \
1278 -justify center -aspect 400 -border 2 -bg white -relief groove
1279 pack $w.m -side top -fill x -padx 2 -pady 2
1280 $w.m configure -font uifont
1281 button $w.ok -text Close -command "destroy $w" -default active
1282 pack $w.ok -side bottom
1283 $w.ok configure -font uifont
1284 bind $w <Visibility> "focus $w.ok"
1285 bind $w <Key-Escape> "destroy $w"
1286 bind $w <Key-Return> "destroy $w"
1289 proc keys {} {
1290 global uifont
1291 set w .keys
1292 if {[winfo exists $w]} {
1293 raise $w
1294 return
1296 if {[tk windowingsystem] eq {aqua}} {
1297 set M1T Cmd
1298 } else {
1299 set M1T Ctrl
1301 toplevel $w
1302 wm title $w "Gitk key bindings"
1303 message $w.m -text "
1304 Gitk key bindings:
1306 <$M1T-Q> Quit
1307 <Home> Move to first commit
1308 <End> Move to last commit
1309 <Up>, p, i Move up one commit
1310 <Down>, n, k Move down one commit
1311 <Left>, z, j Go back in history list
1312 <Right>, x, l Go forward in history list
1313 <PageUp> Move up one page in commit list
1314 <PageDown> Move down one page in commit list
1315 <$M1T-Home> Scroll to top of commit list
1316 <$M1T-End> Scroll to bottom of commit list
1317 <$M1T-Up> Scroll commit list up one line
1318 <$M1T-Down> Scroll commit list down one line
1319 <$M1T-PageUp> Scroll commit list up one page
1320 <$M1T-PageDown> Scroll commit list down one page
1321 <Shift-Up> Move to previous highlighted line
1322 <Shift-Down> Move to next highlighted line
1323 <Delete>, b Scroll diff view up one page
1324 <Backspace> Scroll diff view up one page
1325 <Space> Scroll diff view down one page
1326 u Scroll diff view up 18 lines
1327 d Scroll diff view down 18 lines
1328 <$M1T-F> Find
1329 <$M1T-G> Move to next find hit
1330 <Return> Move to next find hit
1331 / Move to next find hit, or redo find
1332 ? Move to previous find hit
1333 f Scroll diff view to next file
1334 <$M1T-S> Search for next hit in diff view
1335 <$M1T-R> Search for previous hit in diff view
1336 <$M1T-KP+> Increase font size
1337 <$M1T-plus> Increase font size
1338 <$M1T-KP-> Decrease font size
1339 <$M1T-minus> Decrease font size
1340 <F5> Update
1342 -justify left -bg white -border 2 -relief groove
1343 pack $w.m -side top -fill both -padx 2 -pady 2
1344 $w.m configure -font uifont
1345 button $w.ok -text Close -command "destroy $w" -default active
1346 pack $w.ok -side bottom
1347 $w.ok configure -font uifont
1348 bind $w <Visibility> "focus $w.ok"
1349 bind $w <Key-Escape> "destroy $w"
1350 bind $w <Key-Return> "destroy $w"
1353 # Procedures for manipulating the file list window at the
1354 # bottom right of the overall window.
1356 proc treeview {w l openlevs} {
1357 global treecontents treediropen treeheight treeparent treeindex
1359 set ix 0
1360 set treeindex() 0
1361 set lev 0
1362 set prefix {}
1363 set prefixend -1
1364 set prefendstack {}
1365 set htstack {}
1366 set ht 0
1367 set treecontents() {}
1368 $w conf -state normal
1369 foreach f $l {
1370 while {[string range $f 0 $prefixend] ne $prefix} {
1371 if {$lev <= $openlevs} {
1372 $w mark set e:$treeindex($prefix) "end -1c"
1373 $w mark gravity e:$treeindex($prefix) left
1375 set treeheight($prefix) $ht
1376 incr ht [lindex $htstack end]
1377 set htstack [lreplace $htstack end end]
1378 set prefixend [lindex $prefendstack end]
1379 set prefendstack [lreplace $prefendstack end end]
1380 set prefix [string range $prefix 0 $prefixend]
1381 incr lev -1
1383 set tail [string range $f [expr {$prefixend+1}] end]
1384 while {[set slash [string first "/" $tail]] >= 0} {
1385 lappend htstack $ht
1386 set ht 0
1387 lappend prefendstack $prefixend
1388 incr prefixend [expr {$slash + 1}]
1389 set d [string range $tail 0 $slash]
1390 lappend treecontents($prefix) $d
1391 set oldprefix $prefix
1392 append prefix $d
1393 set treecontents($prefix) {}
1394 set treeindex($prefix) [incr ix]
1395 set treeparent($prefix) $oldprefix
1396 set tail [string range $tail [expr {$slash+1}] end]
1397 if {$lev <= $openlevs} {
1398 set ht 1
1399 set treediropen($prefix) [expr {$lev < $openlevs}]
1400 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1401 $w mark set d:$ix "end -1c"
1402 $w mark gravity d:$ix left
1403 set str "\n"
1404 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1405 $w insert end $str
1406 $w image create end -align center -image $bm -padx 1 \
1407 -name a:$ix
1408 $w insert end $d [highlight_tag $prefix]
1409 $w mark set s:$ix "end -1c"
1410 $w mark gravity s:$ix left
1412 incr lev
1414 if {$tail ne {}} {
1415 if {$lev <= $openlevs} {
1416 incr ht
1417 set str "\n"
1418 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1419 $w insert end $str
1420 $w insert end $tail [highlight_tag $f]
1422 lappend treecontents($prefix) $tail
1425 while {$htstack ne {}} {
1426 set treeheight($prefix) $ht
1427 incr ht [lindex $htstack end]
1428 set htstack [lreplace $htstack end end]
1429 set prefixend [lindex $prefendstack end]
1430 set prefendstack [lreplace $prefendstack end end]
1431 set prefix [string range $prefix 0 $prefixend]
1433 $w conf -state disabled
1436 proc linetoelt {l} {
1437 global treeheight treecontents
1439 set y 2
1440 set prefix {}
1441 while {1} {
1442 foreach e $treecontents($prefix) {
1443 if {$y == $l} {
1444 return "$prefix$e"
1446 set n 1
1447 if {[string index $e end] eq "/"} {
1448 set n $treeheight($prefix$e)
1449 if {$y + $n > $l} {
1450 append prefix $e
1451 incr y
1452 break
1455 incr y $n
1460 proc highlight_tree {y prefix} {
1461 global treeheight treecontents cflist
1463 foreach e $treecontents($prefix) {
1464 set path $prefix$e
1465 if {[highlight_tag $path] ne {}} {
1466 $cflist tag add bold $y.0 "$y.0 lineend"
1468 incr y
1469 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1470 set y [highlight_tree $y $path]
1473 return $y
1476 proc treeclosedir {w dir} {
1477 global treediropen treeheight treeparent treeindex
1479 set ix $treeindex($dir)
1480 $w conf -state normal
1481 $w delete s:$ix e:$ix
1482 set treediropen($dir) 0
1483 $w image configure a:$ix -image tri-rt
1484 $w conf -state disabled
1485 set n [expr {1 - $treeheight($dir)}]
1486 while {$dir ne {}} {
1487 incr treeheight($dir) $n
1488 set dir $treeparent($dir)
1492 proc treeopendir {w dir} {
1493 global treediropen treeheight treeparent treecontents treeindex
1495 set ix $treeindex($dir)
1496 $w conf -state normal
1497 $w image configure a:$ix -image tri-dn
1498 $w mark set e:$ix s:$ix
1499 $w mark gravity e:$ix right
1500 set lev 0
1501 set str "\n"
1502 set n [llength $treecontents($dir)]
1503 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1504 incr lev
1505 append str "\t"
1506 incr treeheight($x) $n
1508 foreach e $treecontents($dir) {
1509 set de $dir$e
1510 if {[string index $e end] eq "/"} {
1511 set iy $treeindex($de)
1512 $w mark set d:$iy e:$ix
1513 $w mark gravity d:$iy left
1514 $w insert e:$ix $str
1515 set treediropen($de) 0
1516 $w image create e:$ix -align center -image tri-rt -padx 1 \
1517 -name a:$iy
1518 $w insert e:$ix $e [highlight_tag $de]
1519 $w mark set s:$iy e:$ix
1520 $w mark gravity s:$iy left
1521 set treeheight($de) 1
1522 } else {
1523 $w insert e:$ix $str
1524 $w insert e:$ix $e [highlight_tag $de]
1527 $w mark gravity e:$ix left
1528 $w conf -state disabled
1529 set treediropen($dir) 1
1530 set top [lindex [split [$w index @0,0] .] 0]
1531 set ht [$w cget -height]
1532 set l [lindex [split [$w index s:$ix] .] 0]
1533 if {$l < $top} {
1534 $w yview $l.0
1535 } elseif {$l + $n + 1 > $top + $ht} {
1536 set top [expr {$l + $n + 2 - $ht}]
1537 if {$l < $top} {
1538 set top $l
1540 $w yview $top.0
1544 proc treeclick {w x y} {
1545 global treediropen cmitmode ctext cflist cflist_top
1547 if {$cmitmode ne "tree"} return
1548 if {![info exists cflist_top]} return
1549 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1550 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1551 $cflist tag add highlight $l.0 "$l.0 lineend"
1552 set cflist_top $l
1553 if {$l == 1} {
1554 $ctext yview 1.0
1555 return
1557 set e [linetoelt $l]
1558 if {[string index $e end] ne "/"} {
1559 showfile $e
1560 } elseif {$treediropen($e)} {
1561 treeclosedir $w $e
1562 } else {
1563 treeopendir $w $e
1567 proc setfilelist {id} {
1568 global treefilelist cflist
1570 treeview $cflist $treefilelist($id) 0
1573 image create bitmap tri-rt -background black -foreground blue -data {
1574 #define tri-rt_width 13
1575 #define tri-rt_height 13
1576 static unsigned char tri-rt_bits[] = {
1577 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1578 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1579 0x00, 0x00};
1580 } -maskdata {
1581 #define tri-rt-mask_width 13
1582 #define tri-rt-mask_height 13
1583 static unsigned char tri-rt-mask_bits[] = {
1584 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1585 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1586 0x08, 0x00};
1588 image create bitmap tri-dn -background black -foreground blue -data {
1589 #define tri-dn_width 13
1590 #define tri-dn_height 13
1591 static unsigned char tri-dn_bits[] = {
1592 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1593 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1594 0x00, 0x00};
1595 } -maskdata {
1596 #define tri-dn-mask_width 13
1597 #define tri-dn-mask_height 13
1598 static unsigned char tri-dn-mask_bits[] = {
1599 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1600 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1601 0x00, 0x00};
1604 image create bitmap reficon-T -background black -foreground yellow -data {
1605 #define tagicon_width 13
1606 #define tagicon_height 9
1607 static unsigned char tagicon_bits[] = {
1608 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1609 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1610 } -maskdata {
1611 #define tagicon-mask_width 13
1612 #define tagicon-mask_height 9
1613 static unsigned char tagicon-mask_bits[] = {
1614 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1615 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1617 set rectdata {
1618 #define headicon_width 13
1619 #define headicon_height 9
1620 static unsigned char headicon_bits[] = {
1621 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1622 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1624 set rectmask {
1625 #define headicon-mask_width 13
1626 #define headicon-mask_height 9
1627 static unsigned char headicon-mask_bits[] = {
1628 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1629 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1631 image create bitmap reficon-H -background black -foreground green \
1632 -data $rectdata -maskdata $rectmask
1633 image create bitmap reficon-o -background black -foreground "#ddddff" \
1634 -data $rectdata -maskdata $rectmask
1636 proc init_flist {first} {
1637 global cflist cflist_top selectedline difffilestart
1639 $cflist conf -state normal
1640 $cflist delete 0.0 end
1641 if {$first ne {}} {
1642 $cflist insert end $first
1643 set cflist_top 1
1644 $cflist tag add highlight 1.0 "1.0 lineend"
1645 } else {
1646 catch {unset cflist_top}
1648 $cflist conf -state disabled
1649 set difffilestart {}
1652 proc highlight_tag {f} {
1653 global highlight_paths
1655 foreach p $highlight_paths {
1656 if {[string match $p $f]} {
1657 return "bold"
1660 return {}
1663 proc highlight_filelist {} {
1664 global cmitmode cflist
1666 $cflist conf -state normal
1667 if {$cmitmode ne "tree"} {
1668 set end [lindex [split [$cflist index end] .] 0]
1669 for {set l 2} {$l < $end} {incr l} {
1670 set line [$cflist get $l.0 "$l.0 lineend"]
1671 if {[highlight_tag $line] ne {}} {
1672 $cflist tag add bold $l.0 "$l.0 lineend"
1675 } else {
1676 highlight_tree 2 {}
1678 $cflist conf -state disabled
1681 proc unhighlight_filelist {} {
1682 global cflist
1684 $cflist conf -state normal
1685 $cflist tag remove bold 1.0 end
1686 $cflist conf -state disabled
1689 proc add_flist {fl} {
1690 global cflist
1692 $cflist conf -state normal
1693 foreach f $fl {
1694 $cflist insert end "\n"
1695 $cflist insert end $f [highlight_tag $f]
1697 $cflist conf -state disabled
1700 proc sel_flist {w x y} {
1701 global ctext difffilestart cflist cflist_top cmitmode
1703 if {$cmitmode eq "tree"} return
1704 if {![info exists cflist_top]} return
1705 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1706 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1707 $cflist tag add highlight $l.0 "$l.0 lineend"
1708 set cflist_top $l
1709 if {$l == 1} {
1710 $ctext yview 1.0
1711 } else {
1712 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1716 proc pop_flist_menu {w X Y x y} {
1717 global ctext cflist cmitmode flist_menu flist_menu_file
1718 global treediffs diffids
1720 stopfinding
1721 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1722 if {$l <= 1} return
1723 if {$cmitmode eq "tree"} {
1724 set e [linetoelt $l]
1725 if {[string index $e end] eq "/"} return
1726 } else {
1727 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1729 set flist_menu_file $e
1730 tk_popup $flist_menu $X $Y
1733 proc flist_hl {only} {
1734 global flist_menu_file findstring gdttype
1736 set x [shellquote $flist_menu_file]
1737 if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
1738 set findstring $x
1739 } else {
1740 append findstring " " $x
1742 set gdttype "touching paths:"
1745 # Functions for adding and removing shell-type quoting
1747 proc shellquote {str} {
1748 if {![string match "*\['\"\\ \t]*" $str]} {
1749 return $str
1751 if {![string match "*\['\"\\]*" $str]} {
1752 return "\"$str\""
1754 if {![string match "*'*" $str]} {
1755 return "'$str'"
1757 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1760 proc shellarglist {l} {
1761 set str {}
1762 foreach a $l {
1763 if {$str ne {}} {
1764 append str " "
1766 append str [shellquote $a]
1768 return $str
1771 proc shelldequote {str} {
1772 set ret {}
1773 set used -1
1774 while {1} {
1775 incr used
1776 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1777 append ret [string range $str $used end]
1778 set used [string length $str]
1779 break
1781 set first [lindex $first 0]
1782 set ch [string index $str $first]
1783 if {$first > $used} {
1784 append ret [string range $str $used [expr {$first - 1}]]
1785 set used $first
1787 if {$ch eq " " || $ch eq "\t"} break
1788 incr used
1789 if {$ch eq "'"} {
1790 set first [string first "'" $str $used]
1791 if {$first < 0} {
1792 error "unmatched single-quote"
1794 append ret [string range $str $used [expr {$first - 1}]]
1795 set used $first
1796 continue
1798 if {$ch eq "\\"} {
1799 if {$used >= [string length $str]} {
1800 error "trailing backslash"
1802 append ret [string index $str $used]
1803 continue
1805 # here ch == "\""
1806 while {1} {
1807 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1808 error "unmatched double-quote"
1810 set first [lindex $first 0]
1811 set ch [string index $str $first]
1812 if {$first > $used} {
1813 append ret [string range $str $used [expr {$first - 1}]]
1814 set used $first
1816 if {$ch eq "\""} break
1817 incr used
1818 append ret [string index $str $used]
1819 incr used
1822 return [list $used $ret]
1825 proc shellsplit {str} {
1826 set l {}
1827 while {1} {
1828 set str [string trimleft $str]
1829 if {$str eq {}} break
1830 set dq [shelldequote $str]
1831 set n [lindex $dq 0]
1832 set word [lindex $dq 1]
1833 set str [string range $str $n end]
1834 lappend l $word
1836 return $l
1839 # Code to implement multiple views
1841 proc newview {ishighlight} {
1842 global nextviewnum newviewname newviewperm uifont newishighlight
1843 global newviewargs revtreeargs
1845 set newishighlight $ishighlight
1846 set top .gitkview
1847 if {[winfo exists $top]} {
1848 raise $top
1849 return
1851 set newviewname($nextviewnum) "View $nextviewnum"
1852 set newviewperm($nextviewnum) 0
1853 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1854 vieweditor $top $nextviewnum "Gitk view definition"
1857 proc editview {} {
1858 global curview
1859 global viewname viewperm newviewname newviewperm
1860 global viewargs newviewargs
1862 set top .gitkvedit-$curview
1863 if {[winfo exists $top]} {
1864 raise $top
1865 return
1867 set newviewname($curview) $viewname($curview)
1868 set newviewperm($curview) $viewperm($curview)
1869 set newviewargs($curview) [shellarglist $viewargs($curview)]
1870 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1873 proc vieweditor {top n title} {
1874 global newviewname newviewperm viewfiles
1875 global uifont
1877 toplevel $top
1878 wm title $top $title
1879 label $top.nl -text "Name" -font uifont
1880 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
1881 grid $top.nl $top.name -sticky w -pady 5
1882 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1883 -font uifont
1884 grid $top.perm - -pady 5 -sticky w
1885 message $top.al -aspect 1000 -font uifont \
1886 -text "Commits to include (arguments to git rev-list):"
1887 grid $top.al - -sticky w -pady 5
1888 entry $top.args -width 50 -textvariable newviewargs($n) \
1889 -background white -font uifont
1890 grid $top.args - -sticky ew -padx 5
1891 message $top.l -aspect 1000 -font uifont \
1892 -text "Enter files and directories to include, one per line:"
1893 grid $top.l - -sticky w
1894 text $top.t -width 40 -height 10 -background white -font uifont
1895 if {[info exists viewfiles($n)]} {
1896 foreach f $viewfiles($n) {
1897 $top.t insert end $f
1898 $top.t insert end "\n"
1900 $top.t delete {end - 1c} end
1901 $top.t mark set insert 0.0
1903 grid $top.t - -sticky ew -padx 5
1904 frame $top.buts
1905 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1906 -font uifont
1907 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1908 -font uifont
1909 grid $top.buts.ok $top.buts.can
1910 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1911 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1912 grid $top.buts - -pady 10 -sticky ew
1913 focus $top.t
1916 proc doviewmenu {m first cmd op argv} {
1917 set nmenu [$m index end]
1918 for {set i $first} {$i <= $nmenu} {incr i} {
1919 if {[$m entrycget $i -command] eq $cmd} {
1920 eval $m $op $i $argv
1921 break
1926 proc allviewmenus {n op args} {
1927 # global viewhlmenu
1929 doviewmenu .bar.view 5 [list showview $n] $op $args
1930 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1933 proc newviewok {top n} {
1934 global nextviewnum newviewperm newviewname newishighlight
1935 global viewname viewfiles viewperm selectedview curview
1936 global viewargs newviewargs viewhlmenu
1938 if {[catch {
1939 set newargs [shellsplit $newviewargs($n)]
1940 } err]} {
1941 error_popup "Error in commit selection arguments: $err"
1942 wm raise $top
1943 focus $top
1944 return
1946 set files {}
1947 foreach f [split [$top.t get 0.0 end] "\n"] {
1948 set ft [string trim $f]
1949 if {$ft ne {}} {
1950 lappend files $ft
1953 if {![info exists viewfiles($n)]} {
1954 # creating a new view
1955 incr nextviewnum
1956 set viewname($n) $newviewname($n)
1957 set viewperm($n) $newviewperm($n)
1958 set viewfiles($n) $files
1959 set viewargs($n) $newargs
1960 addviewmenu $n
1961 if {!$newishighlight} {
1962 run showview $n
1963 } else {
1964 run addvhighlight $n
1966 } else {
1967 # editing an existing view
1968 set viewperm($n) $newviewperm($n)
1969 if {$newviewname($n) ne $viewname($n)} {
1970 set viewname($n) $newviewname($n)
1971 doviewmenu .bar.view 5 [list showview $n] \
1972 entryconf [list -label $viewname($n)]
1973 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1974 # entryconf [list -label $viewname($n) -value $viewname($n)]
1976 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1977 set viewfiles($n) $files
1978 set viewargs($n) $newargs
1979 if {$curview == $n} {
1980 run updatecommits
1984 catch {destroy $top}
1987 proc delview {} {
1988 global curview viewdata viewperm hlview selectedhlview
1990 if {$curview == 0} return
1991 if {[info exists hlview] && $hlview == $curview} {
1992 set selectedhlview None
1993 unset hlview
1995 allviewmenus $curview delete
1996 set viewdata($curview) {}
1997 set viewperm($curview) 0
1998 showview 0
2001 proc addviewmenu {n} {
2002 global viewname viewhlmenu
2004 .bar.view add radiobutton -label $viewname($n) \
2005 -command [list showview $n] -variable selectedview -value $n
2006 #$viewhlmenu add radiobutton -label $viewname($n) \
2007 # -command [list addvhighlight $n] -variable selectedhlview
2010 proc flatten {var} {
2011 global $var
2013 set ret {}
2014 foreach i [array names $var] {
2015 lappend ret $i [set $var\($i\)]
2017 return $ret
2020 proc unflatten {var l} {
2021 global $var
2023 catch {unset $var}
2024 foreach {i v} $l {
2025 set $var\($i\) $v
2029 proc showview {n} {
2030 global curview viewdata viewfiles
2031 global displayorder parentlist rowidlist rowisopt rowfinal
2032 global colormap rowtextx commitrow nextcolor canvxmax
2033 global numcommits commitlisted
2034 global selectedline currentid canv canvy0
2035 global treediffs
2036 global pending_select phase
2037 global commitidx
2038 global commfd
2039 global selectedview selectfirst
2040 global vparentlist vdisporder vcmitlisted
2041 global hlview selectedhlview commitinterest
2043 if {$n == $curview} return
2044 set selid {}
2045 if {[info exists selectedline]} {
2046 set selid $currentid
2047 set y [yc $selectedline]
2048 set ymax [lindex [$canv cget -scrollregion] 3]
2049 set span [$canv yview]
2050 set ytop [expr {[lindex $span 0] * $ymax}]
2051 set ybot [expr {[lindex $span 1] * $ymax}]
2052 if {$ytop < $y && $y < $ybot} {
2053 set yscreen [expr {$y - $ytop}]
2054 } else {
2055 set yscreen [expr {($ybot - $ytop) / 2}]
2057 } elseif {[info exists pending_select]} {
2058 set selid $pending_select
2059 unset pending_select
2061 unselectline
2062 normalline
2063 if {$curview >= 0} {
2064 set vparentlist($curview) $parentlist
2065 set vdisporder($curview) $displayorder
2066 set vcmitlisted($curview) $commitlisted
2067 if {$phase ne {} ||
2068 ![info exists viewdata($curview)] ||
2069 [lindex $viewdata($curview) 0] ne {}} {
2070 set viewdata($curview) \
2071 [list $phase $rowidlist $rowisopt $rowfinal]
2074 catch {unset treediffs}
2075 clear_display
2076 if {[info exists hlview] && $hlview == $n} {
2077 unset hlview
2078 set selectedhlview None
2080 catch {unset commitinterest}
2082 set curview $n
2083 set selectedview $n
2084 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2085 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2087 run refill_reflist
2088 if {![info exists viewdata($n)]} {
2089 if {$selid ne {}} {
2090 set pending_select $selid
2092 getcommits
2093 return
2096 set v $viewdata($n)
2097 set phase [lindex $v 0]
2098 set displayorder $vdisporder($n)
2099 set parentlist $vparentlist($n)
2100 set commitlisted $vcmitlisted($n)
2101 set rowidlist [lindex $v 1]
2102 set rowisopt [lindex $v 2]
2103 set rowfinal [lindex $v 3]
2104 set numcommits $commitidx($n)
2106 catch {unset colormap}
2107 catch {unset rowtextx}
2108 set nextcolor 0
2109 set canvxmax [$canv cget -width]
2110 set curview $n
2111 set row 0
2112 setcanvscroll
2113 set yf 0
2114 set row {}
2115 set selectfirst 0
2116 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2117 set row $commitrow($n,$selid)
2118 # try to get the selected row in the same position on the screen
2119 set ymax [lindex [$canv cget -scrollregion] 3]
2120 set ytop [expr {[yc $row] - $yscreen}]
2121 if {$ytop < 0} {
2122 set ytop 0
2124 set yf [expr {$ytop * 1.0 / $ymax}]
2126 allcanvs yview moveto $yf
2127 drawvisible
2128 if {$row ne {}} {
2129 selectline $row 0
2130 } elseif {$selid ne {}} {
2131 set pending_select $selid
2132 } else {
2133 set row [first_real_row]
2134 if {$row < $numcommits} {
2135 selectline $row 0
2136 } else {
2137 set selectfirst 1
2140 if {$phase ne {}} {
2141 if {$phase eq "getcommits"} {
2142 show_status "Reading commits..."
2144 run chewcommits $n
2145 } elseif {$numcommits == 0} {
2146 show_status "No commits selected"
2150 # Stuff relating to the highlighting facility
2152 proc ishighlighted {row} {
2153 global vhighlights fhighlights nhighlights rhighlights
2155 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2156 return $nhighlights($row)
2158 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2159 return $vhighlights($row)
2161 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2162 return $fhighlights($row)
2164 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2165 return $rhighlights($row)
2167 return 0
2170 proc bolden {row font} {
2171 global canv linehtag selectedline boldrows
2173 lappend boldrows $row
2174 $canv itemconf $linehtag($row) -font $font
2175 if {[info exists selectedline] && $row == $selectedline} {
2176 $canv delete secsel
2177 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2178 -outline {{}} -tags secsel \
2179 -fill [$canv cget -selectbackground]]
2180 $canv lower $t
2184 proc bolden_name {row font} {
2185 global canv2 linentag selectedline boldnamerows
2187 lappend boldnamerows $row
2188 $canv2 itemconf $linentag($row) -font $font
2189 if {[info exists selectedline] && $row == $selectedline} {
2190 $canv2 delete secsel
2191 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2192 -outline {{}} -tags secsel \
2193 -fill [$canv2 cget -selectbackground]]
2194 $canv2 lower $t
2198 proc unbolden {} {
2199 global boldrows
2201 set stillbold {}
2202 foreach row $boldrows {
2203 if {![ishighlighted $row]} {
2204 bolden $row mainfont
2205 } else {
2206 lappend stillbold $row
2209 set boldrows $stillbold
2212 proc addvhighlight {n} {
2213 global hlview curview viewdata vhl_done vhighlights commitidx
2215 if {[info exists hlview]} {
2216 delvhighlight
2218 set hlview $n
2219 if {$n != $curview && ![info exists viewdata($n)]} {
2220 set viewdata($n) [list getcommits {{}} 0 0 0]
2221 set vparentlist($n) {}
2222 set vdisporder($n) {}
2223 set vcmitlisted($n) {}
2224 start_rev_list $n
2226 set vhl_done $commitidx($hlview)
2227 if {$vhl_done > 0} {
2228 drawvisible
2232 proc delvhighlight {} {
2233 global hlview vhighlights
2235 if {![info exists hlview]} return
2236 unset hlview
2237 catch {unset vhighlights}
2238 unbolden
2241 proc vhighlightmore {} {
2242 global hlview vhl_done commitidx vhighlights
2243 global displayorder vdisporder curview
2245 set max $commitidx($hlview)
2246 if {$hlview == $curview} {
2247 set disp $displayorder
2248 } else {
2249 set disp $vdisporder($hlview)
2251 set vr [visiblerows]
2252 set r0 [lindex $vr 0]
2253 set r1 [lindex $vr 1]
2254 for {set i $vhl_done} {$i < $max} {incr i} {
2255 set id [lindex $disp $i]
2256 if {[info exists commitrow($curview,$id)]} {
2257 set row $commitrow($curview,$id)
2258 if {$r0 <= $row && $row <= $r1} {
2259 if {![highlighted $row]} {
2260 bolden $row mainfontbold
2262 set vhighlights($row) 1
2266 set vhl_done $max
2269 proc askvhighlight {row id} {
2270 global hlview vhighlights commitrow iddrawn
2272 if {[info exists commitrow($hlview,$id)]} {
2273 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2274 bolden $row mainfontbold
2276 set vhighlights($row) 1
2277 } else {
2278 set vhighlights($row) 0
2282 proc hfiles_change {} {
2283 global highlight_files filehighlight fhighlights fh_serial
2284 global highlight_paths gdttype
2286 if {[info exists filehighlight]} {
2287 # delete previous highlights
2288 catch {close $filehighlight}
2289 unset filehighlight
2290 catch {unset fhighlights}
2291 unbolden
2292 unhighlight_filelist
2294 set highlight_paths {}
2295 after cancel do_file_hl $fh_serial
2296 incr fh_serial
2297 if {$highlight_files ne {}} {
2298 after 300 do_file_hl $fh_serial
2302 proc gdttype_change {name ix op} {
2303 global gdttype highlight_files findstring findpattern
2305 stopfinding
2306 if {$findstring ne {}} {
2307 if {$gdttype eq "containing:"} {
2308 if {$highlight_files ne {}} {
2309 set highlight_files {}
2310 hfiles_change
2312 findcom_change
2313 } else {
2314 if {$findpattern ne {}} {
2315 set findpattern {}
2316 findcom_change
2318 set highlight_files $findstring
2319 hfiles_change
2321 drawvisible
2323 # enable/disable findtype/findloc menus too
2326 proc find_change {name ix op} {
2327 global gdttype findstring highlight_files
2329 stopfinding
2330 if {$gdttype eq "containing:"} {
2331 findcom_change
2332 } else {
2333 if {$highlight_files ne $findstring} {
2334 set highlight_files $findstring
2335 hfiles_change
2338 drawvisible
2341 proc findcom_change args {
2342 global nhighlights boldnamerows
2343 global findpattern findtype findstring gdttype
2345 stopfinding
2346 # delete previous highlights, if any
2347 foreach row $boldnamerows {
2348 bolden_name $row mainfont
2350 set boldnamerows {}
2351 catch {unset nhighlights}
2352 unbolden
2353 unmarkmatches
2354 if {$gdttype ne "containing:" || $findstring eq {}} {
2355 set findpattern {}
2356 } elseif {$findtype eq "Regexp"} {
2357 set findpattern $findstring
2358 } else {
2359 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2360 $findstring]
2361 set findpattern "*$e*"
2365 proc makepatterns {l} {
2366 set ret {}
2367 foreach e $l {
2368 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2369 if {[string index $ee end] eq "/"} {
2370 lappend ret "$ee*"
2371 } else {
2372 lappend ret $ee
2373 lappend ret "$ee/*"
2376 return $ret
2379 proc do_file_hl {serial} {
2380 global highlight_files filehighlight highlight_paths gdttype fhl_list
2382 if {$gdttype eq "touching paths:"} {
2383 if {[catch {set paths [shellsplit $highlight_files]}]} return
2384 set highlight_paths [makepatterns $paths]
2385 highlight_filelist
2386 set gdtargs [concat -- $paths]
2387 } elseif {$gdttype eq "adding/removing string:"} {
2388 set gdtargs [list "-S$highlight_files"]
2389 } else {
2390 # must be "containing:", i.e. we're searching commit info
2391 return
2393 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2394 set filehighlight [open $cmd r+]
2395 fconfigure $filehighlight -blocking 0
2396 filerun $filehighlight readfhighlight
2397 set fhl_list {}
2398 drawvisible
2399 flushhighlights
2402 proc flushhighlights {} {
2403 global filehighlight fhl_list
2405 if {[info exists filehighlight]} {
2406 lappend fhl_list {}
2407 puts $filehighlight ""
2408 flush $filehighlight
2412 proc askfilehighlight {row id} {
2413 global filehighlight fhighlights fhl_list
2415 lappend fhl_list $id
2416 set fhighlights($row) -1
2417 puts $filehighlight $id
2420 proc readfhighlight {} {
2421 global filehighlight fhighlights commitrow curview iddrawn
2422 global fhl_list find_dirn
2424 if {![info exists filehighlight]} {
2425 return 0
2427 set nr 0
2428 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2429 set line [string trim $line]
2430 set i [lsearch -exact $fhl_list $line]
2431 if {$i < 0} continue
2432 for {set j 0} {$j < $i} {incr j} {
2433 set id [lindex $fhl_list $j]
2434 if {[info exists commitrow($curview,$id)]} {
2435 set fhighlights($commitrow($curview,$id)) 0
2438 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2439 if {$line eq {}} continue
2440 if {![info exists commitrow($curview,$line)]} continue
2441 set row $commitrow($curview,$line)
2442 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2443 bolden $row mainfontbold
2445 set fhighlights($row) 1
2447 if {[eof $filehighlight]} {
2448 # strange...
2449 puts "oops, git diff-tree died"
2450 catch {close $filehighlight}
2451 unset filehighlight
2452 return 0
2454 if {[info exists find_dirn]} {
2455 if {$find_dirn > 0} {
2456 run findmore
2457 } else {
2458 run findmorerev
2461 return 1
2464 proc doesmatch {f} {
2465 global findtype findpattern
2467 if {$findtype eq "Regexp"} {
2468 return [regexp $findpattern $f]
2469 } elseif {$findtype eq "IgnCase"} {
2470 return [string match -nocase $findpattern $f]
2471 } else {
2472 return [string match $findpattern $f]
2476 proc askfindhighlight {row id} {
2477 global nhighlights commitinfo iddrawn
2478 global findloc
2479 global markingmatches
2481 if {![info exists commitinfo($id)]} {
2482 getcommit $id
2484 set info $commitinfo($id)
2485 set isbold 0
2486 set fldtypes {Headline Author Date Committer CDate Comments}
2487 foreach f $info ty $fldtypes {
2488 if {($findloc eq "All fields" || $findloc eq $ty) &&
2489 [doesmatch $f]} {
2490 if {$ty eq "Author"} {
2491 set isbold 2
2492 break
2494 set isbold 1
2497 if {$isbold && [info exists iddrawn($id)]} {
2498 if {![ishighlighted $row]} {
2499 bolden $row mainfontbold
2500 if {$isbold > 1} {
2501 bolden_name $row mainfontbold
2504 if {$markingmatches} {
2505 markrowmatches $row $id
2508 set nhighlights($row) $isbold
2511 proc markrowmatches {row id} {
2512 global canv canv2 linehtag linentag commitinfo findloc
2514 set headline [lindex $commitinfo($id) 0]
2515 set author [lindex $commitinfo($id) 1]
2516 $canv delete match$row
2517 $canv2 delete match$row
2518 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2519 set m [findmatches $headline]
2520 if {$m ne {}} {
2521 markmatches $canv $row $headline $linehtag($row) $m \
2522 [$canv itemcget $linehtag($row) -font] $row
2525 if {$findloc eq "All fields" || $findloc eq "Author"} {
2526 set m [findmatches $author]
2527 if {$m ne {}} {
2528 markmatches $canv2 $row $author $linentag($row) $m \
2529 [$canv2 itemcget $linentag($row) -font] $row
2534 proc vrel_change {name ix op} {
2535 global highlight_related
2537 rhighlight_none
2538 if {$highlight_related ne "None"} {
2539 run drawvisible
2543 # prepare for testing whether commits are descendents or ancestors of a
2544 proc rhighlight_sel {a} {
2545 global descendent desc_todo ancestor anc_todo
2546 global highlight_related rhighlights
2548 catch {unset descendent}
2549 set desc_todo [list $a]
2550 catch {unset ancestor}
2551 set anc_todo [list $a]
2552 if {$highlight_related ne "None"} {
2553 rhighlight_none
2554 run drawvisible
2558 proc rhighlight_none {} {
2559 global rhighlights
2561 catch {unset rhighlights}
2562 unbolden
2565 proc is_descendent {a} {
2566 global curview children commitrow descendent desc_todo
2568 set v $curview
2569 set la $commitrow($v,$a)
2570 set todo $desc_todo
2571 set leftover {}
2572 set done 0
2573 for {set i 0} {$i < [llength $todo]} {incr i} {
2574 set do [lindex $todo $i]
2575 if {$commitrow($v,$do) < $la} {
2576 lappend leftover $do
2577 continue
2579 foreach nk $children($v,$do) {
2580 if {![info exists descendent($nk)]} {
2581 set descendent($nk) 1
2582 lappend todo $nk
2583 if {$nk eq $a} {
2584 set done 1
2588 if {$done} {
2589 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2590 return
2593 set descendent($a) 0
2594 set desc_todo $leftover
2597 proc is_ancestor {a} {
2598 global curview parentlist commitrow ancestor anc_todo
2600 set v $curview
2601 set la $commitrow($v,$a)
2602 set todo $anc_todo
2603 set leftover {}
2604 set done 0
2605 for {set i 0} {$i < [llength $todo]} {incr i} {
2606 set do [lindex $todo $i]
2607 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2608 lappend leftover $do
2609 continue
2611 foreach np [lindex $parentlist $commitrow($v,$do)] {
2612 if {![info exists ancestor($np)]} {
2613 set ancestor($np) 1
2614 lappend todo $np
2615 if {$np eq $a} {
2616 set done 1
2620 if {$done} {
2621 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2622 return
2625 set ancestor($a) 0
2626 set anc_todo $leftover
2629 proc askrelhighlight {row id} {
2630 global descendent highlight_related iddrawn rhighlights
2631 global selectedline ancestor
2633 if {![info exists selectedline]} return
2634 set isbold 0
2635 if {$highlight_related eq "Descendent" ||
2636 $highlight_related eq "Not descendent"} {
2637 if {![info exists descendent($id)]} {
2638 is_descendent $id
2640 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2641 set isbold 1
2643 } elseif {$highlight_related eq "Ancestor" ||
2644 $highlight_related eq "Not ancestor"} {
2645 if {![info exists ancestor($id)]} {
2646 is_ancestor $id
2648 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2649 set isbold 1
2652 if {[info exists iddrawn($id)]} {
2653 if {$isbold && ![ishighlighted $row]} {
2654 bolden $row mainfontbold
2657 set rhighlights($row) $isbold
2660 # Graph layout functions
2662 proc shortids {ids} {
2663 set res {}
2664 foreach id $ids {
2665 if {[llength $id] > 1} {
2666 lappend res [shortids $id]
2667 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2668 lappend res [string range $id 0 7]
2669 } else {
2670 lappend res $id
2673 return $res
2676 proc ntimes {n o} {
2677 set ret {}
2678 set o [list $o]
2679 for {set mask 1} {$mask <= $n} {incr mask $mask} {
2680 if {($n & $mask) != 0} {
2681 set ret [concat $ret $o]
2683 set o [concat $o $o]
2685 return $ret
2688 # Work out where id should go in idlist so that order-token
2689 # values increase from left to right
2690 proc idcol {idlist id {i 0}} {
2691 global ordertok curview
2693 set t $ordertok($curview,$id)
2694 if {$i >= [llength $idlist] ||
2695 $t < $ordertok($curview,[lindex $idlist $i])} {
2696 if {$i > [llength $idlist]} {
2697 set i [llength $idlist]
2699 while {[incr i -1] >= 0 &&
2700 $t < $ordertok($curview,[lindex $idlist $i])} {}
2701 incr i
2702 } else {
2703 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2704 while {[incr i] < [llength $idlist] &&
2705 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2708 return $i
2711 proc initlayout {} {
2712 global rowidlist rowisopt rowfinal displayorder commitlisted
2713 global numcommits canvxmax canv
2714 global nextcolor
2715 global parentlist
2716 global colormap rowtextx
2717 global selectfirst
2719 set numcommits 0
2720 set displayorder {}
2721 set commitlisted {}
2722 set parentlist {}
2723 set nextcolor 0
2724 set rowidlist {}
2725 set rowisopt {}
2726 set rowfinal {}
2727 set canvxmax [$canv cget -width]
2728 catch {unset colormap}
2729 catch {unset rowtextx}
2730 set selectfirst 1
2733 proc setcanvscroll {} {
2734 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2736 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2737 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2738 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2739 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2742 proc visiblerows {} {
2743 global canv numcommits linespc
2745 set ymax [lindex [$canv cget -scrollregion] 3]
2746 if {$ymax eq {} || $ymax == 0} return
2747 set f [$canv yview]
2748 set y0 [expr {int([lindex $f 0] * $ymax)}]
2749 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2750 if {$r0 < 0} {
2751 set r0 0
2753 set y1 [expr {int([lindex $f 1] * $ymax)}]
2754 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2755 if {$r1 >= $numcommits} {
2756 set r1 [expr {$numcommits - 1}]
2758 return [list $r0 $r1]
2761 proc layoutmore {} {
2762 global commitidx viewcomplete numcommits
2763 global uparrowlen downarrowlen mingaplen curview
2765 set show $commitidx($curview)
2766 if {$show > $numcommits || $viewcomplete($curview)} {
2767 showstuff $show $viewcomplete($curview)
2771 proc showstuff {canshow last} {
2772 global numcommits commitrow pending_select selectedline curview
2773 global mainheadid displayorder selectfirst
2774 global lastscrollset commitinterest
2776 if {$numcommits == 0} {
2777 global phase
2778 set phase "incrdraw"
2779 allcanvs delete all
2781 set r0 $numcommits
2782 set prev $numcommits
2783 set numcommits $canshow
2784 set t [clock clicks -milliseconds]
2785 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2786 set lastscrollset $t
2787 setcanvscroll
2789 set rows [visiblerows]
2790 set r1 [lindex $rows 1]
2791 if {$r1 >= $canshow} {
2792 set r1 [expr {$canshow - 1}]
2794 if {$r0 <= $r1} {
2795 drawcommits $r0 $r1
2797 if {[info exists pending_select] &&
2798 [info exists commitrow($curview,$pending_select)] &&
2799 $commitrow($curview,$pending_select) < $numcommits} {
2800 selectline $commitrow($curview,$pending_select) 1
2802 if {$selectfirst} {
2803 if {[info exists selectedline] || [info exists pending_select]} {
2804 set selectfirst 0
2805 } else {
2806 set l [first_real_row]
2807 selectline $l 1
2808 set selectfirst 0
2813 proc doshowlocalchanges {} {
2814 global curview mainheadid phase commitrow
2816 if {[info exists commitrow($curview,$mainheadid)] &&
2817 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2818 dodiffindex
2819 } elseif {$phase ne {}} {
2820 lappend commitinterest($mainheadid) {}
2824 proc dohidelocalchanges {} {
2825 global localfrow localirow lserial
2827 if {$localfrow >= 0} {
2828 removerow $localfrow
2829 set localfrow -1
2830 if {$localirow > 0} {
2831 incr localirow -1
2834 if {$localirow >= 0} {
2835 removerow $localirow
2836 set localirow -1
2838 incr lserial
2841 # spawn off a process to do git diff-index --cached HEAD
2842 proc dodiffindex {} {
2843 global localirow localfrow lserial showlocalchanges
2845 if {!$showlocalchanges} return
2846 incr lserial
2847 set localfrow -1
2848 set localirow -1
2849 set fd [open "|git diff-index --cached HEAD" r]
2850 fconfigure $fd -blocking 0
2851 filerun $fd [list readdiffindex $fd $lserial]
2854 proc readdiffindex {fd serial} {
2855 global localirow commitrow mainheadid nullid2 curview
2856 global commitinfo commitdata lserial
2858 set isdiff 1
2859 if {[gets $fd line] < 0} {
2860 if {![eof $fd]} {
2861 return 1
2863 set isdiff 0
2865 # we only need to see one line and we don't really care what it says...
2866 close $fd
2868 # now see if there are any local changes not checked in to the index
2869 if {$serial == $lserial} {
2870 set fd [open "|git diff-files" r]
2871 fconfigure $fd -blocking 0
2872 filerun $fd [list readdifffiles $fd $serial]
2875 if {$isdiff && $serial == $lserial && $localirow == -1} {
2876 # add the line for the changes in the index to the graph
2877 set localirow $commitrow($curview,$mainheadid)
2878 set hl "Local changes checked in to index but not committed"
2879 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2880 set commitdata($nullid2) "\n $hl\n"
2881 insertrow $localirow $nullid2
2883 return 0
2886 proc readdifffiles {fd serial} {
2887 global localirow localfrow commitrow mainheadid nullid curview
2888 global commitinfo commitdata lserial
2890 set isdiff 1
2891 if {[gets $fd line] < 0} {
2892 if {![eof $fd]} {
2893 return 1
2895 set isdiff 0
2897 # we only need to see one line and we don't really care what it says...
2898 close $fd
2900 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2901 # add the line for the local diff to the graph
2902 if {$localirow >= 0} {
2903 set localfrow $localirow
2904 incr localirow
2905 } else {
2906 set localfrow $commitrow($curview,$mainheadid)
2908 set hl "Local uncommitted changes, not checked in to index"
2909 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2910 set commitdata($nullid) "\n $hl\n"
2911 insertrow $localfrow $nullid
2913 return 0
2916 proc nextuse {id row} {
2917 global commitrow curview children
2919 if {[info exists children($curview,$id)]} {
2920 foreach kid $children($curview,$id) {
2921 if {![info exists commitrow($curview,$kid)]} {
2922 return -1
2924 if {$commitrow($curview,$kid) > $row} {
2925 return $commitrow($curview,$kid)
2929 if {[info exists commitrow($curview,$id)]} {
2930 return $commitrow($curview,$id)
2932 return -1
2935 proc prevuse {id row} {
2936 global commitrow curview children
2938 set ret -1
2939 if {[info exists children($curview,$id)]} {
2940 foreach kid $children($curview,$id) {
2941 if {![info exists commitrow($curview,$kid)]} break
2942 if {$commitrow($curview,$kid) < $row} {
2943 set ret $commitrow($curview,$kid)
2947 return $ret
2950 proc make_idlist {row} {
2951 global displayorder parentlist uparrowlen downarrowlen mingaplen
2952 global commitidx curview ordertok children commitrow
2954 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
2955 if {$r < 0} {
2956 set r 0
2958 set ra [expr {$row - $downarrowlen}]
2959 if {$ra < 0} {
2960 set ra 0
2962 set rb [expr {$row + $uparrowlen}]
2963 if {$rb > $commitidx($curview)} {
2964 set rb $commitidx($curview)
2966 set ids {}
2967 for {} {$r < $ra} {incr r} {
2968 set nextid [lindex $displayorder [expr {$r + 1}]]
2969 foreach p [lindex $parentlist $r] {
2970 if {$p eq $nextid} continue
2971 set rn [nextuse $p $r]
2972 if {$rn >= $row &&
2973 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
2974 lappend ids [list $ordertok($curview,$p) $p]
2978 for {} {$r < $row} {incr r} {
2979 set nextid [lindex $displayorder [expr {$r + 1}]]
2980 foreach p [lindex $parentlist $r] {
2981 if {$p eq $nextid} continue
2982 set rn [nextuse $p $r]
2983 if {$rn < 0 || $rn >= $row} {
2984 lappend ids [list $ordertok($curview,$p) $p]
2988 set id [lindex $displayorder $row]
2989 lappend ids [list $ordertok($curview,$id) $id]
2990 while {$r < $rb} {
2991 foreach p [lindex $parentlist $r] {
2992 set firstkid [lindex $children($curview,$p) 0]
2993 if {$commitrow($curview,$firstkid) < $row} {
2994 lappend ids [list $ordertok($curview,$p) $p]
2997 incr r
2998 set id [lindex $displayorder $r]
2999 if {$id ne {}} {
3000 set firstkid [lindex $children($curview,$id) 0]
3001 if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
3002 lappend ids [list $ordertok($curview,$id) $id]
3006 set idlist {}
3007 foreach idx [lsort -unique $ids] {
3008 lappend idlist [lindex $idx 1]
3010 return $idlist
3013 proc rowsequal {a b} {
3014 while {[set i [lsearch -exact $a {}]] >= 0} {
3015 set a [lreplace $a $i $i]
3017 while {[set i [lsearch -exact $b {}]] >= 0} {
3018 set b [lreplace $b $i $i]
3020 return [expr {$a eq $b}]
3023 proc makeupline {id row rend col} {
3024 global rowidlist uparrowlen downarrowlen mingaplen
3026 for {set r $rend} {1} {set r $rstart} {
3027 set rstart [prevuse $id $r]
3028 if {$rstart < 0} return
3029 if {$rstart < $row} break
3031 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3032 set rstart [expr {$rend - $uparrowlen - 1}]
3034 for {set r $rstart} {[incr r] <= $row} {} {
3035 set idlist [lindex $rowidlist $r]
3036 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3037 set col [idcol $idlist $id $col]
3038 lset rowidlist $r [linsert $idlist $col $id]
3039 changedrow $r
3044 proc layoutrows {row endrow} {
3045 global rowidlist rowisopt rowfinal displayorder
3046 global uparrowlen downarrowlen maxwidth mingaplen
3047 global children parentlist
3048 global commitidx viewcomplete curview commitrow
3050 set idlist {}
3051 if {$row > 0} {
3052 set rm1 [expr {$row - 1}]
3053 foreach id [lindex $rowidlist $rm1] {
3054 if {$id ne {}} {
3055 lappend idlist $id
3058 set final [lindex $rowfinal $rm1]
3060 for {} {$row < $endrow} {incr row} {
3061 set rm1 [expr {$row - 1}]
3062 if {$rm1 < 0 || $idlist eq {}} {
3063 set idlist [make_idlist $row]
3064 set final 1
3065 } else {
3066 set id [lindex $displayorder $rm1]
3067 set col [lsearch -exact $idlist $id]
3068 set idlist [lreplace $idlist $col $col]
3069 foreach p [lindex $parentlist $rm1] {
3070 if {[lsearch -exact $idlist $p] < 0} {
3071 set col [idcol $idlist $p $col]
3072 set idlist [linsert $idlist $col $p]
3073 # if not the first child, we have to insert a line going up
3074 if {$id ne [lindex $children($curview,$p) 0]} {
3075 makeupline $p $rm1 $row $col
3079 set id [lindex $displayorder $row]
3080 if {$row > $downarrowlen} {
3081 set termrow [expr {$row - $downarrowlen - 1}]
3082 foreach p [lindex $parentlist $termrow] {
3083 set i [lsearch -exact $idlist $p]
3084 if {$i < 0} continue
3085 set nr [nextuse $p $termrow]
3086 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3087 set idlist [lreplace $idlist $i $i]
3091 set col [lsearch -exact $idlist $id]
3092 if {$col < 0} {
3093 set col [idcol $idlist $id]
3094 set idlist [linsert $idlist $col $id]
3095 if {$children($curview,$id) ne {}} {
3096 makeupline $id $rm1 $row $col
3099 set r [expr {$row + $uparrowlen - 1}]
3100 if {$r < $commitidx($curview)} {
3101 set x $col
3102 foreach p [lindex $parentlist $r] {
3103 if {[lsearch -exact $idlist $p] >= 0} continue
3104 set fk [lindex $children($curview,$p) 0]
3105 if {$commitrow($curview,$fk) < $row} {
3106 set x [idcol $idlist $p $x]
3107 set idlist [linsert $idlist $x $p]
3110 if {[incr r] < $commitidx($curview)} {
3111 set p [lindex $displayorder $r]
3112 if {[lsearch -exact $idlist $p] < 0} {
3113 set fk [lindex $children($curview,$p) 0]
3114 if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3115 set x [idcol $idlist $p $x]
3116 set idlist [linsert $idlist $x $p]
3122 if {$final && !$viewcomplete($curview) &&
3123 $row + $uparrowlen + $mingaplen + $downarrowlen
3124 >= $commitidx($curview)} {
3125 set final 0
3127 set l [llength $rowidlist]
3128 if {$row == $l} {
3129 lappend rowidlist $idlist
3130 lappend rowisopt 0
3131 lappend rowfinal $final
3132 } elseif {$row < $l} {
3133 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3134 lset rowidlist $row $idlist
3135 changedrow $row
3137 lset rowfinal $row $final
3138 } else {
3139 set pad [ntimes [expr {$row - $l}] {}]
3140 set rowidlist [concat $rowidlist $pad]
3141 lappend rowidlist $idlist
3142 set rowfinal [concat $rowfinal $pad]
3143 lappend rowfinal $final
3144 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3147 return $row
3150 proc changedrow {row} {
3151 global displayorder iddrawn rowisopt need_redisplay
3153 set l [llength $rowisopt]
3154 if {$row < $l} {
3155 lset rowisopt $row 0
3156 if {$row + 1 < $l} {
3157 lset rowisopt [expr {$row + 1}] 0
3158 if {$row + 2 < $l} {
3159 lset rowisopt [expr {$row + 2}] 0
3163 set id [lindex $displayorder $row]
3164 if {[info exists iddrawn($id)]} {
3165 set need_redisplay 1
3169 proc insert_pad {row col npad} {
3170 global rowidlist
3172 set pad [ntimes $npad {}]
3173 set idlist [lindex $rowidlist $row]
3174 set bef [lrange $idlist 0 [expr {$col - 1}]]
3175 set aft [lrange $idlist $col end]
3176 set i [lsearch -exact $aft {}]
3177 if {$i > 0} {
3178 set aft [lreplace $aft $i $i]
3180 lset rowidlist $row [concat $bef $pad $aft]
3181 changedrow $row
3184 proc optimize_rows {row col endrow} {
3185 global rowidlist rowisopt displayorder curview children
3187 if {$row < 1} {
3188 set row 1
3190 for {} {$row < $endrow} {incr row; set col 0} {
3191 if {[lindex $rowisopt $row]} continue
3192 set haspad 0
3193 set y0 [expr {$row - 1}]
3194 set ym [expr {$row - 2}]
3195 set idlist [lindex $rowidlist $row]
3196 set previdlist [lindex $rowidlist $y0]
3197 if {$idlist eq {} || $previdlist eq {}} continue
3198 if {$ym >= 0} {
3199 set pprevidlist [lindex $rowidlist $ym]
3200 if {$pprevidlist eq {}} continue
3201 } else {
3202 set pprevidlist {}
3204 set x0 -1
3205 set xm -1
3206 for {} {$col < [llength $idlist]} {incr col} {
3207 set id [lindex $idlist $col]
3208 if {[lindex $previdlist $col] eq $id} continue
3209 if {$id eq {}} {
3210 set haspad 1
3211 continue
3213 set x0 [lsearch -exact $previdlist $id]
3214 if {$x0 < 0} continue
3215 set z [expr {$x0 - $col}]
3216 set isarrow 0
3217 set z0 {}
3218 if {$ym >= 0} {
3219 set xm [lsearch -exact $pprevidlist $id]
3220 if {$xm >= 0} {
3221 set z0 [expr {$xm - $x0}]
3224 if {$z0 eq {}} {
3225 # if row y0 is the first child of $id then it's not an arrow
3226 if {[lindex $children($curview,$id) 0] ne
3227 [lindex $displayorder $y0]} {
3228 set isarrow 1
3231 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3232 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3233 set isarrow 1
3235 # Looking at lines from this row to the previous row,
3236 # make them go straight up if they end in an arrow on
3237 # the previous row; otherwise make them go straight up
3238 # or at 45 degrees.
3239 if {$z < -1 || ($z < 0 && $isarrow)} {
3240 # Line currently goes left too much;
3241 # insert pads in the previous row, then optimize it
3242 set npad [expr {-1 - $z + $isarrow}]
3243 insert_pad $y0 $x0 $npad
3244 if {$y0 > 0} {
3245 optimize_rows $y0 $x0 $row
3247 set previdlist [lindex $rowidlist $y0]
3248 set x0 [lsearch -exact $previdlist $id]
3249 set z [expr {$x0 - $col}]
3250 if {$z0 ne {}} {
3251 set pprevidlist [lindex $rowidlist $ym]
3252 set xm [lsearch -exact $pprevidlist $id]
3253 set z0 [expr {$xm - $x0}]
3255 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3256 # Line currently goes right too much;
3257 # insert pads in this line
3258 set npad [expr {$z - 1 + $isarrow}]
3259 insert_pad $row $col $npad
3260 set idlist [lindex $rowidlist $row]
3261 incr col $npad
3262 set z [expr {$x0 - $col}]
3263 set haspad 1
3265 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3266 # this line links to its first child on row $row-2
3267 set id [lindex $displayorder $ym]
3268 set xc [lsearch -exact $pprevidlist $id]
3269 if {$xc >= 0} {
3270 set z0 [expr {$xc - $x0}]
3273 # avoid lines jigging left then immediately right
3274 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3275 insert_pad $y0 $x0 1
3276 incr x0
3277 optimize_rows $y0 $x0 $row
3278 set previdlist [lindex $rowidlist $y0]
3281 if {!$haspad} {
3282 # Find the first column that doesn't have a line going right
3283 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3284 set id [lindex $idlist $col]
3285 if {$id eq {}} break
3286 set x0 [lsearch -exact $previdlist $id]
3287 if {$x0 < 0} {
3288 # check if this is the link to the first child
3289 set kid [lindex $displayorder $y0]
3290 if {[lindex $children($curview,$id) 0] eq $kid} {
3291 # it is, work out offset to child
3292 set x0 [lsearch -exact $previdlist $kid]
3295 if {$x0 <= $col} break
3297 # Insert a pad at that column as long as it has a line and
3298 # isn't the last column
3299 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3300 set idlist [linsert $idlist $col {}]
3301 lset rowidlist $row $idlist
3302 changedrow $row
3308 proc xc {row col} {
3309 global canvx0 linespc
3310 return [expr {$canvx0 + $col * $linespc}]
3313 proc yc {row} {
3314 global canvy0 linespc
3315 return [expr {$canvy0 + $row * $linespc}]
3318 proc linewidth {id} {
3319 global thickerline lthickness
3321 set wid $lthickness
3322 if {[info exists thickerline] && $id eq $thickerline} {
3323 set wid [expr {2 * $lthickness}]
3325 return $wid
3328 proc rowranges {id} {
3329 global commitrow curview children uparrowlen downarrowlen
3330 global rowidlist
3332 set kids $children($curview,$id)
3333 if {$kids eq {}} {
3334 return {}
3336 set ret {}
3337 lappend kids $id
3338 foreach child $kids {
3339 if {![info exists commitrow($curview,$child)]} break
3340 set row $commitrow($curview,$child)
3341 if {![info exists prev]} {
3342 lappend ret [expr {$row + 1}]
3343 } else {
3344 if {$row <= $prevrow} {
3345 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3347 # see if the line extends the whole way from prevrow to row
3348 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3349 [lsearch -exact [lindex $rowidlist \
3350 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3351 # it doesn't, see where it ends
3352 set r [expr {$prevrow + $downarrowlen}]
3353 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3354 while {[incr r -1] > $prevrow &&
3355 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3356 } else {
3357 while {[incr r] <= $row &&
3358 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3359 incr r -1
3361 lappend ret $r
3362 # see where it starts up again
3363 set r [expr {$row - $uparrowlen}]
3364 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3365 while {[incr r] < $row &&
3366 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3367 } else {
3368 while {[incr r -1] >= $prevrow &&
3369 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3370 incr r
3372 lappend ret $r
3375 if {$child eq $id} {
3376 lappend ret $row
3378 set prev $id
3379 set prevrow $row
3381 return $ret
3384 proc drawlineseg {id row endrow arrowlow} {
3385 global rowidlist displayorder iddrawn linesegs
3386 global canv colormap linespc curview maxlinelen parentlist
3388 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3389 set le [expr {$row + 1}]
3390 set arrowhigh 1
3391 while {1} {
3392 set c [lsearch -exact [lindex $rowidlist $le] $id]
3393 if {$c < 0} {
3394 incr le -1
3395 break
3397 lappend cols $c
3398 set x [lindex $displayorder $le]
3399 if {$x eq $id} {
3400 set arrowhigh 0
3401 break
3403 if {[info exists iddrawn($x)] || $le == $endrow} {
3404 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3405 if {$c >= 0} {
3406 lappend cols $c
3407 set arrowhigh 0
3409 break
3411 incr le
3413 if {$le <= $row} {
3414 return $row
3417 set lines {}
3418 set i 0
3419 set joinhigh 0
3420 if {[info exists linesegs($id)]} {
3421 set lines $linesegs($id)
3422 foreach li $lines {
3423 set r0 [lindex $li 0]
3424 if {$r0 > $row} {
3425 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3426 set joinhigh 1
3428 break
3430 incr i
3433 set joinlow 0
3434 if {$i > 0} {
3435 set li [lindex $lines [expr {$i-1}]]
3436 set r1 [lindex $li 1]
3437 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3438 set joinlow 1
3442 set x [lindex $cols [expr {$le - $row}]]
3443 set xp [lindex $cols [expr {$le - 1 - $row}]]
3444 set dir [expr {$xp - $x}]
3445 if {$joinhigh} {
3446 set ith [lindex $lines $i 2]
3447 set coords [$canv coords $ith]
3448 set ah [$canv itemcget $ith -arrow]
3449 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3450 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3451 if {$x2 ne {} && $x - $x2 == $dir} {
3452 set coords [lrange $coords 0 end-2]
3454 } else {
3455 set coords [list [xc $le $x] [yc $le]]
3457 if {$joinlow} {
3458 set itl [lindex $lines [expr {$i-1}] 2]
3459 set al [$canv itemcget $itl -arrow]
3460 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3461 } elseif {$arrowlow} {
3462 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3463 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3464 set arrowlow 0
3467 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3468 for {set y $le} {[incr y -1] > $row} {} {
3469 set x $xp
3470 set xp [lindex $cols [expr {$y - 1 - $row}]]
3471 set ndir [expr {$xp - $x}]
3472 if {$dir != $ndir || $xp < 0} {
3473 lappend coords [xc $y $x] [yc $y]
3475 set dir $ndir
3477 if {!$joinlow} {
3478 if {$xp < 0} {
3479 # join parent line to first child
3480 set ch [lindex $displayorder $row]
3481 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3482 if {$xc < 0} {
3483 puts "oops: drawlineseg: child $ch not on row $row"
3484 } elseif {$xc != $x} {
3485 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3486 set d [expr {int(0.5 * $linespc)}]
3487 set x1 [xc $row $x]
3488 if {$xc < $x} {
3489 set x2 [expr {$x1 - $d}]
3490 } else {
3491 set x2 [expr {$x1 + $d}]
3493 set y2 [yc $row]
3494 set y1 [expr {$y2 + $d}]
3495 lappend coords $x1 $y1 $x2 $y2
3496 } elseif {$xc < $x - 1} {
3497 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3498 } elseif {$xc > $x + 1} {
3499 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3501 set x $xc
3503 lappend coords [xc $row $x] [yc $row]
3504 } else {
3505 set xn [xc $row $xp]
3506 set yn [yc $row]
3507 lappend coords $xn $yn
3509 if {!$joinhigh} {
3510 assigncolor $id
3511 set t [$canv create line $coords -width [linewidth $id] \
3512 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3513 $canv lower $t
3514 bindline $t $id
3515 set lines [linsert $lines $i [list $row $le $t]]
3516 } else {
3517 $canv coords $ith $coords
3518 if {$arrow ne $ah} {
3519 $canv itemconf $ith -arrow $arrow
3521 lset lines $i 0 $row
3523 } else {
3524 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3525 set ndir [expr {$xo - $xp}]
3526 set clow [$canv coords $itl]
3527 if {$dir == $ndir} {
3528 set clow [lrange $clow 2 end]
3530 set coords [concat $coords $clow]
3531 if {!$joinhigh} {
3532 lset lines [expr {$i-1}] 1 $le
3533 } else {
3534 # coalesce two pieces
3535 $canv delete $ith
3536 set b [lindex $lines [expr {$i-1}] 0]
3537 set e [lindex $lines $i 1]
3538 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3540 $canv coords $itl $coords
3541 if {$arrow ne $al} {
3542 $canv itemconf $itl -arrow $arrow
3546 set linesegs($id) $lines
3547 return $le
3550 proc drawparentlinks {id row} {
3551 global rowidlist canv colormap curview parentlist
3552 global idpos linespc
3554 set rowids [lindex $rowidlist $row]
3555 set col [lsearch -exact $rowids $id]
3556 if {$col < 0} return
3557 set olds [lindex $parentlist $row]
3558 set row2 [expr {$row + 1}]
3559 set x [xc $row $col]
3560 set y [yc $row]
3561 set y2 [yc $row2]
3562 set d [expr {int(0.5 * $linespc)}]
3563 set ymid [expr {$y + $d}]
3564 set ids [lindex $rowidlist $row2]
3565 # rmx = right-most X coord used
3566 set rmx 0
3567 foreach p $olds {
3568 set i [lsearch -exact $ids $p]
3569 if {$i < 0} {
3570 puts "oops, parent $p of $id not in list"
3571 continue
3573 set x2 [xc $row2 $i]
3574 if {$x2 > $rmx} {
3575 set rmx $x2
3577 set j [lsearch -exact $rowids $p]
3578 if {$j < 0} {
3579 # drawlineseg will do this one for us
3580 continue
3582 assigncolor $p
3583 # should handle duplicated parents here...
3584 set coords [list $x $y]
3585 if {$i != $col} {
3586 # if attaching to a vertical segment, draw a smaller
3587 # slant for visual distinctness
3588 if {$i == $j} {
3589 if {$i < $col} {
3590 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3591 } else {
3592 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3594 } elseif {$i < $col && $i < $j} {
3595 # segment slants towards us already
3596 lappend coords [xc $row $j] $y
3597 } else {
3598 if {$i < $col - 1} {
3599 lappend coords [expr {$x2 + $linespc}] $y
3600 } elseif {$i > $col + 1} {
3601 lappend coords [expr {$x2 - $linespc}] $y
3603 lappend coords $x2 $y2
3605 } else {
3606 lappend coords $x2 $y2
3608 set t [$canv create line $coords -width [linewidth $p] \
3609 -fill $colormap($p) -tags lines.$p]
3610 $canv lower $t
3611 bindline $t $p
3613 if {$rmx > [lindex $idpos($id) 1]} {
3614 lset idpos($id) 1 $rmx
3615 redrawtags $id
3619 proc drawlines {id} {
3620 global canv
3622 $canv itemconf lines.$id -width [linewidth $id]
3625 proc drawcmittext {id row col} {
3626 global linespc canv canv2 canv3 canvy0 fgcolor curview
3627 global commitlisted commitinfo rowidlist parentlist
3628 global rowtextx idpos idtags idheads idotherrefs
3629 global linehtag linentag linedtag selectedline
3630 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3632 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3633 set listed [lindex $commitlisted $row]
3634 if {$id eq $nullid} {
3635 set ofill red
3636 } elseif {$id eq $nullid2} {
3637 set ofill green
3638 } else {
3639 set ofill [expr {$listed != 0? "blue": "white"}]
3641 set x [xc $row $col]
3642 set y [yc $row]
3643 set orad [expr {$linespc / 3}]
3644 if {$listed <= 1} {
3645 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3646 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3647 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3648 } elseif {$listed == 2} {
3649 # triangle pointing left for left-side commits
3650 set t [$canv create polygon \
3651 [expr {$x - $orad}] $y \
3652 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3653 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3654 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3655 } else {
3656 # triangle pointing right for right-side commits
3657 set t [$canv create polygon \
3658 [expr {$x + $orad - 1}] $y \
3659 [expr {$x - $orad}] [expr {$y - $orad}] \
3660 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3661 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3663 $canv raise $t
3664 $canv bind $t <1> {selcanvline {} %x %y}
3665 set rmx [llength [lindex $rowidlist $row]]
3666 set olds [lindex $parentlist $row]
3667 if {$olds ne {}} {
3668 set nextids [lindex $rowidlist [expr {$row + 1}]]
3669 foreach p $olds {
3670 set i [lsearch -exact $nextids $p]
3671 if {$i > $rmx} {
3672 set rmx $i
3676 set xt [xc $row $rmx]
3677 set rowtextx($row) $xt
3678 set idpos($id) [list $x $xt $y]
3679 if {[info exists idtags($id)] || [info exists idheads($id)]
3680 || [info exists idotherrefs($id)]} {
3681 set xt [drawtags $id $x $xt $y]
3683 set headline [lindex $commitinfo($id) 0]
3684 set name [lindex $commitinfo($id) 1]
3685 set date [lindex $commitinfo($id) 2]
3686 set date [formatdate $date]
3687 set font mainfont
3688 set nfont mainfont
3689 set isbold [ishighlighted $row]
3690 if {$isbold > 0} {
3691 lappend boldrows $row
3692 set font mainfontbold
3693 if {$isbold > 1} {
3694 lappend boldnamerows $row
3695 set nfont mainfontbold
3698 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3699 -text $headline -font $font -tags text]
3700 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3701 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3702 -text $name -font $nfont -tags text]
3703 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3704 -text $date -font mainfont -tags text]
3705 if {[info exists selectedline] && $selectedline == $row} {
3706 make_secsel $row
3708 set xr [expr {$xt + [font measure $font $headline]}]
3709 if {$xr > $canvxmax} {
3710 set canvxmax $xr
3711 setcanvscroll
3715 proc drawcmitrow {row} {
3716 global displayorder rowidlist nrows_drawn
3717 global iddrawn markingmatches
3718 global commitinfo parentlist numcommits
3719 global filehighlight fhighlights findpattern nhighlights
3720 global hlview vhighlights
3721 global highlight_related rhighlights
3723 if {$row >= $numcommits} return
3725 set id [lindex $displayorder $row]
3726 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3727 askvhighlight $row $id
3729 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3730 askfilehighlight $row $id
3732 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
3733 askfindhighlight $row $id
3735 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3736 askrelhighlight $row $id
3738 if {![info exists iddrawn($id)]} {
3739 set col [lsearch -exact [lindex $rowidlist $row] $id]
3740 if {$col < 0} {
3741 puts "oops, row $row id $id not in list"
3742 return
3744 if {![info exists commitinfo($id)]} {
3745 getcommit $id
3747 assigncolor $id
3748 drawcmittext $id $row $col
3749 set iddrawn($id) 1
3750 incr nrows_drawn
3752 if {$markingmatches} {
3753 markrowmatches $row $id
3757 proc drawcommits {row {endrow {}}} {
3758 global numcommits iddrawn displayorder curview need_redisplay
3759 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3761 if {$row < 0} {
3762 set row 0
3764 if {$endrow eq {}} {
3765 set endrow $row
3767 if {$endrow >= $numcommits} {
3768 set endrow [expr {$numcommits - 1}]
3771 set rl1 [expr {$row - $downarrowlen - 3}]
3772 if {$rl1 < 0} {
3773 set rl1 0
3775 set ro1 [expr {$row - 3}]
3776 if {$ro1 < 0} {
3777 set ro1 0
3779 set r2 [expr {$endrow + $uparrowlen + 3}]
3780 if {$r2 > $numcommits} {
3781 set r2 $numcommits
3783 for {set r $rl1} {$r < $r2} {incr r} {
3784 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3785 if {$rl1 < $r} {
3786 layoutrows $rl1 $r
3788 set rl1 [expr {$r + 1}]
3791 if {$rl1 < $r} {
3792 layoutrows $rl1 $r
3794 optimize_rows $ro1 0 $r2
3795 if {$need_redisplay || $nrows_drawn > 2000} {
3796 clear_display
3797 drawvisible
3800 # make the lines join to already-drawn rows either side
3801 set r [expr {$row - 1}]
3802 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3803 set r $row
3805 set er [expr {$endrow + 1}]
3806 if {$er >= $numcommits ||
3807 ![info exists iddrawn([lindex $displayorder $er])]} {
3808 set er $endrow
3810 for {} {$r <= $er} {incr r} {
3811 set id [lindex $displayorder $r]
3812 set wasdrawn [info exists iddrawn($id)]
3813 drawcmitrow $r
3814 if {$r == $er} break
3815 set nextid [lindex $displayorder [expr {$r + 1}]]
3816 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3817 catch {unset prevlines}
3818 continue
3820 drawparentlinks $id $r
3822 if {[info exists lineends($r)]} {
3823 foreach lid $lineends($r) {
3824 unset prevlines($lid)
3827 set rowids [lindex $rowidlist $r]
3828 foreach lid $rowids {
3829 if {$lid eq {}} continue
3830 if {$lid eq $id} {
3831 # see if this is the first child of any of its parents
3832 foreach p [lindex $parentlist $r] {
3833 if {[lsearch -exact $rowids $p] < 0} {
3834 # make this line extend up to the child
3835 set le [drawlineseg $p $r $er 0]
3836 lappend lineends($le) $p
3837 set prevlines($p) 1
3840 } elseif {![info exists prevlines($lid)]} {
3841 set le [drawlineseg $lid $r $er 1]
3842 lappend lineends($le) $lid
3843 set prevlines($lid) 1
3849 proc drawfrac {f0 f1} {
3850 global canv linespc
3852 set ymax [lindex [$canv cget -scrollregion] 3]
3853 if {$ymax eq {} || $ymax == 0} return
3854 set y0 [expr {int($f0 * $ymax)}]
3855 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3856 set y1 [expr {int($f1 * $ymax)}]
3857 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3858 drawcommits $row $endrow
3861 proc drawvisible {} {
3862 global canv
3863 eval drawfrac [$canv yview]
3866 proc clear_display {} {
3867 global iddrawn linesegs need_redisplay nrows_drawn
3868 global vhighlights fhighlights nhighlights rhighlights
3870 allcanvs delete all
3871 catch {unset iddrawn}
3872 catch {unset linesegs}
3873 catch {unset vhighlights}
3874 catch {unset fhighlights}
3875 catch {unset nhighlights}
3876 catch {unset rhighlights}
3877 set need_redisplay 0
3878 set nrows_drawn 0
3881 proc findcrossings {id} {
3882 global rowidlist parentlist numcommits displayorder
3884 set cross {}
3885 set ccross {}
3886 foreach {s e} [rowranges $id] {
3887 if {$e >= $numcommits} {
3888 set e [expr {$numcommits - 1}]
3890 if {$e <= $s} continue
3891 for {set row $e} {[incr row -1] >= $s} {} {
3892 set x [lsearch -exact [lindex $rowidlist $row] $id]
3893 if {$x < 0} break
3894 set olds [lindex $parentlist $row]
3895 set kid [lindex $displayorder $row]
3896 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3897 if {$kidx < 0} continue
3898 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3899 foreach p $olds {
3900 set px [lsearch -exact $nextrow $p]
3901 if {$px < 0} continue
3902 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3903 if {[lsearch -exact $ccross $p] >= 0} continue
3904 if {$x == $px + ($kidx < $px? -1: 1)} {
3905 lappend ccross $p
3906 } elseif {[lsearch -exact $cross $p] < 0} {
3907 lappend cross $p
3913 return [concat $ccross {{}} $cross]
3916 proc assigncolor {id} {
3917 global colormap colors nextcolor
3918 global commitrow parentlist children children curview
3920 if {[info exists colormap($id)]} return
3921 set ncolors [llength $colors]
3922 if {[info exists children($curview,$id)]} {
3923 set kids $children($curview,$id)
3924 } else {
3925 set kids {}
3927 if {[llength $kids] == 1} {
3928 set child [lindex $kids 0]
3929 if {[info exists colormap($child)]
3930 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3931 set colormap($id) $colormap($child)
3932 return
3935 set badcolors {}
3936 set origbad {}
3937 foreach x [findcrossings $id] {
3938 if {$x eq {}} {
3939 # delimiter between corner crossings and other crossings
3940 if {[llength $badcolors] >= $ncolors - 1} break
3941 set origbad $badcolors
3943 if {[info exists colormap($x)]
3944 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3945 lappend badcolors $colormap($x)
3948 if {[llength $badcolors] >= $ncolors} {
3949 set badcolors $origbad
3951 set origbad $badcolors
3952 if {[llength $badcolors] < $ncolors - 1} {
3953 foreach child $kids {
3954 if {[info exists colormap($child)]
3955 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3956 lappend badcolors $colormap($child)
3958 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3959 if {[info exists colormap($p)]
3960 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3961 lappend badcolors $colormap($p)
3965 if {[llength $badcolors] >= $ncolors} {
3966 set badcolors $origbad
3969 for {set i 0} {$i <= $ncolors} {incr i} {
3970 set c [lindex $colors $nextcolor]
3971 if {[incr nextcolor] >= $ncolors} {
3972 set nextcolor 0
3974 if {[lsearch -exact $badcolors $c]} break
3976 set colormap($id) $c
3979 proc bindline {t id} {
3980 global canv
3982 $canv bind $t <Enter> "lineenter %x %y $id"
3983 $canv bind $t <Motion> "linemotion %x %y $id"
3984 $canv bind $t <Leave> "lineleave $id"
3985 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3988 proc drawtags {id x xt y1} {
3989 global idtags idheads idotherrefs mainhead
3990 global linespc lthickness
3991 global canv commitrow rowtextx curview fgcolor bgcolor
3993 set marks {}
3994 set ntags 0
3995 set nheads 0
3996 if {[info exists idtags($id)]} {
3997 set marks $idtags($id)
3998 set ntags [llength $marks]
4000 if {[info exists idheads($id)]} {
4001 set marks [concat $marks $idheads($id)]
4002 set nheads [llength $idheads($id)]
4004 if {[info exists idotherrefs($id)]} {
4005 set marks [concat $marks $idotherrefs($id)]
4007 if {$marks eq {}} {
4008 return $xt
4011 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4012 set yt [expr {$y1 - 0.5 * $linespc}]
4013 set yb [expr {$yt + $linespc - 1}]
4014 set xvals {}
4015 set wvals {}
4016 set i -1
4017 foreach tag $marks {
4018 incr i
4019 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4020 set wid [font measure mainfontbold $tag]
4021 } else {
4022 set wid [font measure mainfont $tag]
4024 lappend xvals $xt
4025 lappend wvals $wid
4026 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4028 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4029 -width $lthickness -fill black -tags tag.$id]
4030 $canv lower $t
4031 foreach tag $marks x $xvals wid $wvals {
4032 set xl [expr {$x + $delta}]
4033 set xr [expr {$x + $delta + $wid + $lthickness}]
4034 set font mainfont
4035 if {[incr ntags -1] >= 0} {
4036 # draw a tag
4037 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4038 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4039 -width 1 -outline black -fill yellow -tags tag.$id]
4040 $canv bind $t <1> [list showtag $tag 1]
4041 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4042 } else {
4043 # draw a head or other ref
4044 if {[incr nheads -1] >= 0} {
4045 set col green
4046 if {$tag eq $mainhead} {
4047 set font mainfontbold
4049 } else {
4050 set col "#ddddff"
4052 set xl [expr {$xl - $delta/2}]
4053 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4054 -width 1 -outline black -fill $col -tags tag.$id
4055 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4056 set rwid [font measure mainfont $remoteprefix]
4057 set xi [expr {$x + 1}]
4058 set yti [expr {$yt + 1}]
4059 set xri [expr {$x + $rwid}]
4060 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4061 -width 0 -fill "#ffddaa" -tags tag.$id
4064 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4065 -font $font -tags [list tag.$id text]]
4066 if {$ntags >= 0} {
4067 $canv bind $t <1> [list showtag $tag 1]
4068 } elseif {$nheads >= 0} {
4069 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4072 return $xt
4075 proc xcoord {i level ln} {
4076 global canvx0 xspc1 xspc2
4078 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4079 if {$i > 0 && $i == $level} {
4080 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4081 } elseif {$i > $level} {
4082 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4084 return $x
4087 proc show_status {msg} {
4088 global canv fgcolor
4090 clear_display
4091 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4092 -tags text -fill $fgcolor
4095 # Insert a new commit as the child of the commit on row $row.
4096 # The new commit will be displayed on row $row and the commits
4097 # on that row and below will move down one row.
4098 proc insertrow {row newcmit} {
4099 global displayorder parentlist commitlisted children
4100 global commitrow curview rowidlist rowisopt rowfinal numcommits
4101 global numcommits
4102 global selectedline commitidx ordertok
4104 if {$row >= $numcommits} {
4105 puts "oops, inserting new row $row but only have $numcommits rows"
4106 return
4108 set p [lindex $displayorder $row]
4109 set displayorder [linsert $displayorder $row $newcmit]
4110 set parentlist [linsert $parentlist $row $p]
4111 set kids $children($curview,$p)
4112 lappend kids $newcmit
4113 set children($curview,$p) $kids
4114 set children($curview,$newcmit) {}
4115 set commitlisted [linsert $commitlisted $row 1]
4116 set l [llength $displayorder]
4117 for {set r $row} {$r < $l} {incr r} {
4118 set id [lindex $displayorder $r]
4119 set commitrow($curview,$id) $r
4121 incr commitidx($curview)
4122 set ordertok($curview,$newcmit) $ordertok($curview,$p)
4124 if {$row < [llength $rowidlist]} {
4125 set idlist [lindex $rowidlist $row]
4126 if {$idlist ne {}} {
4127 if {[llength $kids] == 1} {
4128 set col [lsearch -exact $idlist $p]
4129 lset idlist $col $newcmit
4130 } else {
4131 set col [llength $idlist]
4132 lappend idlist $newcmit
4135 set rowidlist [linsert $rowidlist $row $idlist]
4136 set rowisopt [linsert $rowisopt $row 0]
4137 set rowfinal [linsert $rowfinal $row [lindex $rowfinal $row]]
4140 incr numcommits
4142 if {[info exists selectedline] && $selectedline >= $row} {
4143 incr selectedline
4145 redisplay
4148 # Remove a commit that was inserted with insertrow on row $row.
4149 proc removerow {row} {
4150 global displayorder parentlist commitlisted children
4151 global commitrow curview rowidlist rowisopt rowfinal numcommits
4152 global numcommits
4153 global linesegends selectedline commitidx
4155 if {$row >= $numcommits} {
4156 puts "oops, removing row $row but only have $numcommits rows"
4157 return
4159 set rp1 [expr {$row + 1}]
4160 set id [lindex $displayorder $row]
4161 set p [lindex $parentlist $row]
4162 set displayorder [lreplace $displayorder $row $row]
4163 set parentlist [lreplace $parentlist $row $row]
4164 set commitlisted [lreplace $commitlisted $row $row]
4165 set kids $children($curview,$p)
4166 set i [lsearch -exact $kids $id]
4167 if {$i >= 0} {
4168 set kids [lreplace $kids $i $i]
4169 set children($curview,$p) $kids
4171 set l [llength $displayorder]
4172 for {set r $row} {$r < $l} {incr r} {
4173 set id [lindex $displayorder $r]
4174 set commitrow($curview,$id) $r
4176 incr commitidx($curview) -1
4178 if {$row < [llength $rowidlist]} {
4179 set rowidlist [lreplace $rowidlist $row $row]
4180 set rowisopt [lreplace $rowisopt $row $row]
4181 set rowfinal [lreplace $rowfinal $row $row]
4184 incr numcommits -1
4186 if {[info exists selectedline] && $selectedline > $row} {
4187 incr selectedline -1
4189 redisplay
4192 # Don't change the text pane cursor if it is currently the hand cursor,
4193 # showing that we are over a sha1 ID link.
4194 proc settextcursor {c} {
4195 global ctext curtextcursor
4197 if {[$ctext cget -cursor] == $curtextcursor} {
4198 $ctext config -cursor $c
4200 set curtextcursor $c
4203 proc nowbusy {what {name {}}} {
4204 global isbusy busyname statusw
4206 if {[array names isbusy] eq {}} {
4207 . config -cursor watch
4208 settextcursor watch
4210 set isbusy($what) 1
4211 set busyname($what) $name
4212 if {$name ne {}} {
4213 $statusw conf -text $name
4217 proc notbusy {what} {
4218 global isbusy maincursor textcursor busyname statusw
4220 catch {
4221 unset isbusy($what)
4222 if {$busyname($what) ne {} &&
4223 [$statusw cget -text] eq $busyname($what)} {
4224 $statusw conf -text {}
4227 if {[array names isbusy] eq {}} {
4228 . config -cursor $maincursor
4229 settextcursor $textcursor
4233 proc findmatches {f} {
4234 global findtype findstring
4235 if {$findtype == "Regexp"} {
4236 set matches [regexp -indices -all -inline $findstring $f]
4237 } else {
4238 set fs $findstring
4239 if {$findtype == "IgnCase"} {
4240 set f [string tolower $f]
4241 set fs [string tolower $fs]
4243 set matches {}
4244 set i 0
4245 set l [string length $fs]
4246 while {[set j [string first $fs $f $i]] >= 0} {
4247 lappend matches [list $j [expr {$j+$l-1}]]
4248 set i [expr {$j + $l}]
4251 return $matches
4254 proc dofind {{rev 0}} {
4255 global findstring findstartline findcurline selectedline numcommits
4256 global gdttype filehighlight fh_serial find_dirn
4258 unmarkmatches
4259 focus .
4260 if {$findstring eq {} || $numcommits == 0} return
4261 if {![info exists selectedline]} {
4262 set findstartline [lindex [visiblerows] $rev]
4263 } else {
4264 set findstartline $selectedline
4266 set findcurline $findstartline
4267 nowbusy finding
4268 if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4269 after cancel do_file_hl $fh_serial
4270 do_file_hl $fh_serial
4272 if {!$rev} {
4273 set find_dirn 1
4274 run findmore
4275 } else {
4276 set find_dirn -1
4277 run findmorerev
4281 proc stopfinding {} {
4282 global find_dirn findcurline fprogcoord
4284 if {[info exists find_dirn]} {
4285 unset find_dirn
4286 unset findcurline
4287 notbusy finding
4288 set fprogcoord 0
4289 adjustprogress
4293 proc findnext {restart} {
4294 global findcurline find_dirn
4296 if {[info exists find_dirn]} return
4297 if {![info exists findcurline]} {
4298 if {$restart} {
4299 dofind
4300 } else {
4301 bell
4303 } else {
4304 set find_dirn 1
4305 run findmore
4306 nowbusy finding
4310 proc findprev {} {
4311 global findcurline find_dirn
4313 if {[info exists find_dirn]} return
4314 if {![info exists findcurline]} {
4315 dofind 1
4316 } else {
4317 set find_dirn -1
4318 run findmorerev
4319 nowbusy finding
4323 proc findmore {} {
4324 global commitdata commitinfo numcommits findpattern findloc
4325 global findstartline findcurline displayorder
4326 global find_dirn gdttype fhighlights fprogcoord
4328 if {![info exists find_dirn]} {
4329 return 0
4331 set fldtypes {Headline Author Date Committer CDate Comments}
4332 set l [expr {$findcurline + 1}]
4333 if {$l >= $numcommits} {
4334 set l 0
4336 if {$l <= $findstartline} {
4337 set lim [expr {$findstartline + 1}]
4338 } else {
4339 set lim $numcommits
4341 if {$lim - $l > 500} {
4342 set lim [expr {$l + 500}]
4344 set found 0
4345 set domore 1
4346 if {$gdttype eq "containing:"} {
4347 for {} {$l < $lim} {incr l} {
4348 set id [lindex $displayorder $l]
4349 # shouldn't happen unless git log doesn't give all the commits...
4350 if {![info exists commitdata($id)]} continue
4351 if {![doesmatch $commitdata($id)]} continue
4352 if {![info exists commitinfo($id)]} {
4353 getcommit $id
4355 set info $commitinfo($id)
4356 foreach f $info ty $fldtypes {
4357 if {($findloc eq "All fields" || $findloc eq $ty) &&
4358 [doesmatch $f]} {
4359 set found 1
4360 break
4363 if {$found} break
4365 } else {
4366 for {} {$l < $lim} {incr l} {
4367 set id [lindex $displayorder $l]
4368 if {![info exists fhighlights($l)]} {
4369 askfilehighlight $l $id
4370 if {$domore} {
4371 set domore 0
4372 set findcurline [expr {$l - 1}]
4374 } elseif {$fhighlights($l)} {
4375 set found $domore
4376 break
4380 if {$found || ($domore && $l == $findstartline + 1)} {
4381 unset findcurline
4382 unset find_dirn
4383 notbusy finding
4384 set fprogcoord 0
4385 adjustprogress
4386 if {$found} {
4387 findselectline $l
4388 } else {
4389 bell
4391 return 0
4393 if {!$domore} {
4394 flushhighlights
4395 } else {
4396 set findcurline [expr {$l - 1}]
4398 set n [expr {$findcurline - ($findstartline + 1)}]
4399 if {$n < 0} {
4400 incr n $numcommits
4402 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4403 adjustprogress
4404 return $domore
4407 proc findmorerev {} {
4408 global commitdata commitinfo numcommits findpattern findloc
4409 global findstartline findcurline displayorder
4410 global find_dirn gdttype fhighlights fprogcoord
4412 if {![info exists find_dirn]} {
4413 return 0
4415 set fldtypes {Headline Author Date Committer CDate Comments}
4416 set l $findcurline
4417 if {$l == 0} {
4418 set l $numcommits
4420 incr l -1
4421 if {$l >= $findstartline} {
4422 set lim [expr {$findstartline - 1}]
4423 } else {
4424 set lim -1
4426 if {$l - $lim > 500} {
4427 set lim [expr {$l - 500}]
4429 set found 0
4430 set domore 1
4431 if {$gdttype eq "containing:"} {
4432 for {} {$l > $lim} {incr l -1} {
4433 set id [lindex $displayorder $l]
4434 if {![info exists commitdata($id)]} continue
4435 if {![doesmatch $commitdata($id)]} continue
4436 if {![info exists commitinfo($id)]} {
4437 getcommit $id
4439 set info $commitinfo($id)
4440 foreach f $info ty $fldtypes {
4441 if {($findloc eq "All fields" || $findloc eq $ty) &&
4442 [doesmatch $f]} {
4443 set found 1
4444 break
4447 if {$found} break
4449 } else {
4450 for {} {$l > $lim} {incr l -1} {
4451 set id [lindex $displayorder $l]
4452 if {![info exists fhighlights($l)]} {
4453 askfilehighlight $l $id
4454 if {$domore} {
4455 set domore 0
4456 set findcurline [expr {$l + 1}]
4458 } elseif {$fhighlights($l)} {
4459 set found $domore
4460 break
4464 if {$found || ($domore && $l == $findstartline - 1)} {
4465 unset findcurline
4466 unset find_dirn
4467 notbusy finding
4468 set fprogcoord 0
4469 adjustprogress
4470 if {$found} {
4471 findselectline $l
4472 } else {
4473 bell
4475 return 0
4477 if {!$domore} {
4478 flushhighlights
4479 } else {
4480 set findcurline [expr {$l + 1}]
4482 set n [expr {($findstartline - 1) - $findcurline}]
4483 if {$n < 0} {
4484 incr n $numcommits
4486 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4487 adjustprogress
4488 return $domore
4491 proc findselectline {l} {
4492 global findloc commentend ctext findcurline markingmatches gdttype
4494 set markingmatches 1
4495 set findcurline $l
4496 selectline $l 1
4497 if {$findloc == "All fields" || $findloc == "Comments"} {
4498 # highlight the matches in the comments
4499 set f [$ctext get 1.0 $commentend]
4500 set matches [findmatches $f]
4501 foreach match $matches {
4502 set start [lindex $match 0]
4503 set end [expr {[lindex $match 1] + 1}]
4504 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4507 drawvisible
4510 # mark the bits of a headline or author that match a find string
4511 proc markmatches {canv l str tag matches font row} {
4512 global selectedline
4514 set bbox [$canv bbox $tag]
4515 set x0 [lindex $bbox 0]
4516 set y0 [lindex $bbox 1]
4517 set y1 [lindex $bbox 3]
4518 foreach match $matches {
4519 set start [lindex $match 0]
4520 set end [lindex $match 1]
4521 if {$start > $end} continue
4522 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4523 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4524 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4525 [expr {$x0+$xlen+2}] $y1 \
4526 -outline {} -tags [list match$l matches] -fill yellow]
4527 $canv lower $t
4528 if {[info exists selectedline] && $row == $selectedline} {
4529 $canv raise $t secsel
4534 proc unmarkmatches {} {
4535 global markingmatches
4537 allcanvs delete matches
4538 set markingmatches 0
4539 stopfinding
4542 proc selcanvline {w x y} {
4543 global canv canvy0 ctext linespc
4544 global rowtextx
4545 set ymax [lindex [$canv cget -scrollregion] 3]
4546 if {$ymax == {}} return
4547 set yfrac [lindex [$canv yview] 0]
4548 set y [expr {$y + $yfrac * $ymax}]
4549 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4550 if {$l < 0} {
4551 set l 0
4553 if {$w eq $canv} {
4554 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4556 unmarkmatches
4557 selectline $l 1
4560 proc commit_descriptor {p} {
4561 global commitinfo
4562 if {![info exists commitinfo($p)]} {
4563 getcommit $p
4565 set l "..."
4566 if {[llength $commitinfo($p)] > 1} {
4567 set l [lindex $commitinfo($p) 0]
4569 return "$p ($l)\n"
4572 # append some text to the ctext widget, and make any SHA1 ID
4573 # that we know about be a clickable link.
4574 proc appendwithlinks {text tags} {
4575 global ctext commitrow linknum curview pendinglinks
4577 set start [$ctext index "end - 1c"]
4578 $ctext insert end $text $tags
4579 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4580 foreach l $links {
4581 set s [lindex $l 0]
4582 set e [lindex $l 1]
4583 set linkid [string range $text $s $e]
4584 incr e
4585 $ctext tag delete link$linknum
4586 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4587 setlink $linkid link$linknum
4588 incr linknum
4592 proc setlink {id lk} {
4593 global curview commitrow ctext pendinglinks commitinterest
4595 if {[info exists commitrow($curview,$id)]} {
4596 $ctext tag conf $lk -foreground blue -underline 1
4597 $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4598 $ctext tag bind $lk <Enter> {linkcursor %W 1}
4599 $ctext tag bind $lk <Leave> {linkcursor %W -1}
4600 } else {
4601 lappend pendinglinks($id) $lk
4602 lappend commitinterest($id) {makelink %I}
4606 proc makelink {id} {
4607 global pendinglinks
4609 if {![info exists pendinglinks($id)]} return
4610 foreach lk $pendinglinks($id) {
4611 setlink $id $lk
4613 unset pendinglinks($id)
4616 proc linkcursor {w inc} {
4617 global linkentercount curtextcursor
4619 if {[incr linkentercount $inc] > 0} {
4620 $w configure -cursor hand2
4621 } else {
4622 $w configure -cursor $curtextcursor
4623 if {$linkentercount < 0} {
4624 set linkentercount 0
4629 proc viewnextline {dir} {
4630 global canv linespc
4632 $canv delete hover
4633 set ymax [lindex [$canv cget -scrollregion] 3]
4634 set wnow [$canv yview]
4635 set wtop [expr {[lindex $wnow 0] * $ymax}]
4636 set newtop [expr {$wtop + $dir * $linespc}]
4637 if {$newtop < 0} {
4638 set newtop 0
4639 } elseif {$newtop > $ymax} {
4640 set newtop $ymax
4642 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4645 # add a list of tag or branch names at position pos
4646 # returns the number of names inserted
4647 proc appendrefs {pos ids var} {
4648 global ctext commitrow linknum curview $var maxrefs
4650 if {[catch {$ctext index $pos}]} {
4651 return 0
4653 $ctext conf -state normal
4654 $ctext delete $pos "$pos lineend"
4655 set tags {}
4656 foreach id $ids {
4657 foreach tag [set $var\($id\)] {
4658 lappend tags [list $tag $id]
4661 if {[llength $tags] > $maxrefs} {
4662 $ctext insert $pos "many ([llength $tags])"
4663 } else {
4664 set tags [lsort -index 0 -decreasing $tags]
4665 set sep {}
4666 foreach ti $tags {
4667 set id [lindex $ti 1]
4668 set lk link$linknum
4669 incr linknum
4670 $ctext tag delete $lk
4671 $ctext insert $pos $sep
4672 $ctext insert $pos [lindex $ti 0] $lk
4673 setlink $id $lk
4674 set sep ", "
4677 $ctext conf -state disabled
4678 return [llength $tags]
4681 # called when we have finished computing the nearby tags
4682 proc dispneartags {delay} {
4683 global selectedline currentid showneartags tagphase
4685 if {![info exists selectedline] || !$showneartags} return
4686 after cancel dispnexttag
4687 if {$delay} {
4688 after 200 dispnexttag
4689 set tagphase -1
4690 } else {
4691 after idle dispnexttag
4692 set tagphase 0
4696 proc dispnexttag {} {
4697 global selectedline currentid showneartags tagphase ctext
4699 if {![info exists selectedline] || !$showneartags} return
4700 switch -- $tagphase {
4702 set dtags [desctags $currentid]
4703 if {$dtags ne {}} {
4704 appendrefs precedes $dtags idtags
4708 set atags [anctags $currentid]
4709 if {$atags ne {}} {
4710 appendrefs follows $atags idtags
4714 set dheads [descheads $currentid]
4715 if {$dheads ne {}} {
4716 if {[appendrefs branch $dheads idheads] > 1
4717 && [$ctext get "branch -3c"] eq "h"} {
4718 # turn "Branch" into "Branches"
4719 $ctext conf -state normal
4720 $ctext insert "branch -2c" "es"
4721 $ctext conf -state disabled
4726 if {[incr tagphase] <= 2} {
4727 after idle dispnexttag
4731 proc make_secsel {l} {
4732 global linehtag linentag linedtag canv canv2 canv3
4734 if {![info exists linehtag($l)]} return
4735 $canv delete secsel
4736 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4737 -tags secsel -fill [$canv cget -selectbackground]]
4738 $canv lower $t
4739 $canv2 delete secsel
4740 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4741 -tags secsel -fill [$canv2 cget -selectbackground]]
4742 $canv2 lower $t
4743 $canv3 delete secsel
4744 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4745 -tags secsel -fill [$canv3 cget -selectbackground]]
4746 $canv3 lower $t
4749 proc selectline {l isnew} {
4750 global canv ctext commitinfo selectedline
4751 global displayorder
4752 global canvy0 linespc parentlist children curview
4753 global currentid sha1entry
4754 global commentend idtags linknum
4755 global mergemax numcommits pending_select
4756 global cmitmode showneartags allcommits
4758 catch {unset pending_select}
4759 $canv delete hover
4760 normalline
4761 unsel_reflist
4762 stopfinding
4763 if {$l < 0 || $l >= $numcommits} return
4764 set y [expr {$canvy0 + $l * $linespc}]
4765 set ymax [lindex [$canv cget -scrollregion] 3]
4766 set ytop [expr {$y - $linespc - 1}]
4767 set ybot [expr {$y + $linespc + 1}]
4768 set wnow [$canv yview]
4769 set wtop [expr {[lindex $wnow 0] * $ymax}]
4770 set wbot [expr {[lindex $wnow 1] * $ymax}]
4771 set wh [expr {$wbot - $wtop}]
4772 set newtop $wtop
4773 if {$ytop < $wtop} {
4774 if {$ybot < $wtop} {
4775 set newtop [expr {$y - $wh / 2.0}]
4776 } else {
4777 set newtop $ytop
4778 if {$newtop > $wtop - $linespc} {
4779 set newtop [expr {$wtop - $linespc}]
4782 } elseif {$ybot > $wbot} {
4783 if {$ytop > $wbot} {
4784 set newtop [expr {$y - $wh / 2.0}]
4785 } else {
4786 set newtop [expr {$ybot - $wh}]
4787 if {$newtop < $wtop + $linespc} {
4788 set newtop [expr {$wtop + $linespc}]
4792 if {$newtop != $wtop} {
4793 if {$newtop < 0} {
4794 set newtop 0
4796 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4797 drawvisible
4800 make_secsel $l
4802 if {$isnew} {
4803 addtohistory [list selectline $l 0]
4806 set selectedline $l
4808 set id [lindex $displayorder $l]
4809 set currentid $id
4810 $sha1entry delete 0 end
4811 $sha1entry insert 0 $id
4812 $sha1entry selection from 0
4813 $sha1entry selection to end
4814 rhighlight_sel $id
4816 $ctext conf -state normal
4817 clear_ctext
4818 set linknum 0
4819 set info $commitinfo($id)
4820 set date [formatdate [lindex $info 2]]
4821 $ctext insert end "Author: [lindex $info 1] $date\n"
4822 set date [formatdate [lindex $info 4]]
4823 $ctext insert end "Committer: [lindex $info 3] $date\n"
4824 if {[info exists idtags($id)]} {
4825 $ctext insert end "Tags:"
4826 foreach tag $idtags($id) {
4827 $ctext insert end " $tag"
4829 $ctext insert end "\n"
4832 set headers {}
4833 set olds [lindex $parentlist $l]
4834 if {[llength $olds] > 1} {
4835 set np 0
4836 foreach p $olds {
4837 if {$np >= $mergemax} {
4838 set tag mmax
4839 } else {
4840 set tag m$np
4842 $ctext insert end "Parent: " $tag
4843 appendwithlinks [commit_descriptor $p] {}
4844 incr np
4846 } else {
4847 foreach p $olds {
4848 append headers "Parent: [commit_descriptor $p]"
4852 foreach c $children($curview,$id) {
4853 append headers "Child: [commit_descriptor $c]"
4856 # make anything that looks like a SHA1 ID be a clickable link
4857 appendwithlinks $headers {}
4858 if {$showneartags} {
4859 if {![info exists allcommits]} {
4860 getallcommits
4862 $ctext insert end "Branch: "
4863 $ctext mark set branch "end -1c"
4864 $ctext mark gravity branch left
4865 $ctext insert end "\nFollows: "
4866 $ctext mark set follows "end -1c"
4867 $ctext mark gravity follows left
4868 $ctext insert end "\nPrecedes: "
4869 $ctext mark set precedes "end -1c"
4870 $ctext mark gravity precedes left
4871 $ctext insert end "\n"
4872 dispneartags 1
4874 $ctext insert end "\n"
4875 set comment [lindex $info 5]
4876 if {[string first "\r" $comment] >= 0} {
4877 set comment [string map {"\r" "\n "} $comment]
4879 appendwithlinks $comment {comment}
4881 $ctext tag remove found 1.0 end
4882 $ctext conf -state disabled
4883 set commentend [$ctext index "end - 1c"]
4885 init_flist "Comments"
4886 if {$cmitmode eq "tree"} {
4887 gettree $id
4888 } elseif {[llength $olds] <= 1} {
4889 startdiff $id
4890 } else {
4891 mergediff $id $l
4895 proc selfirstline {} {
4896 unmarkmatches
4897 selectline 0 1
4900 proc sellastline {} {
4901 global numcommits
4902 unmarkmatches
4903 set l [expr {$numcommits - 1}]
4904 selectline $l 1
4907 proc selnextline {dir} {
4908 global selectedline
4909 focus .
4910 if {![info exists selectedline]} return
4911 set l [expr {$selectedline + $dir}]
4912 unmarkmatches
4913 selectline $l 1
4916 proc selnextpage {dir} {
4917 global canv linespc selectedline numcommits
4919 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4920 if {$lpp < 1} {
4921 set lpp 1
4923 allcanvs yview scroll [expr {$dir * $lpp}] units
4924 drawvisible
4925 if {![info exists selectedline]} return
4926 set l [expr {$selectedline + $dir * $lpp}]
4927 if {$l < 0} {
4928 set l 0
4929 } elseif {$l >= $numcommits} {
4930 set l [expr $numcommits - 1]
4932 unmarkmatches
4933 selectline $l 1
4936 proc unselectline {} {
4937 global selectedline currentid
4939 catch {unset selectedline}
4940 catch {unset currentid}
4941 allcanvs delete secsel
4942 rhighlight_none
4945 proc reselectline {} {
4946 global selectedline
4948 if {[info exists selectedline]} {
4949 selectline $selectedline 0
4953 proc addtohistory {cmd} {
4954 global history historyindex curview
4956 set elt [list $curview $cmd]
4957 if {$historyindex > 0
4958 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4959 return
4962 if {$historyindex < [llength $history]} {
4963 set history [lreplace $history $historyindex end $elt]
4964 } else {
4965 lappend history $elt
4967 incr historyindex
4968 if {$historyindex > 1} {
4969 .tf.bar.leftbut conf -state normal
4970 } else {
4971 .tf.bar.leftbut conf -state disabled
4973 .tf.bar.rightbut conf -state disabled
4976 proc godo {elt} {
4977 global curview
4979 set view [lindex $elt 0]
4980 set cmd [lindex $elt 1]
4981 if {$curview != $view} {
4982 showview $view
4984 eval $cmd
4987 proc goback {} {
4988 global history historyindex
4989 focus .
4991 if {$historyindex > 1} {
4992 incr historyindex -1
4993 godo [lindex $history [expr {$historyindex - 1}]]
4994 .tf.bar.rightbut conf -state normal
4996 if {$historyindex <= 1} {
4997 .tf.bar.leftbut conf -state disabled
5001 proc goforw {} {
5002 global history historyindex
5003 focus .
5005 if {$historyindex < [llength $history]} {
5006 set cmd [lindex $history $historyindex]
5007 incr historyindex
5008 godo $cmd
5009 .tf.bar.leftbut conf -state normal
5011 if {$historyindex >= [llength $history]} {
5012 .tf.bar.rightbut conf -state disabled
5016 proc gettree {id} {
5017 global treefilelist treeidlist diffids diffmergeid treepending
5018 global nullid nullid2
5020 set diffids $id
5021 catch {unset diffmergeid}
5022 if {![info exists treefilelist($id)]} {
5023 if {![info exists treepending]} {
5024 if {$id eq $nullid} {
5025 set cmd [list | git ls-files]
5026 } elseif {$id eq $nullid2} {
5027 set cmd [list | git ls-files --stage -t]
5028 } else {
5029 set cmd [list | git ls-tree -r $id]
5031 if {[catch {set gtf [open $cmd r]}]} {
5032 return
5034 set treepending $id
5035 set treefilelist($id) {}
5036 set treeidlist($id) {}
5037 fconfigure $gtf -blocking 0
5038 filerun $gtf [list gettreeline $gtf $id]
5040 } else {
5041 setfilelist $id
5045 proc gettreeline {gtf id} {
5046 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5048 set nl 0
5049 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5050 if {$diffids eq $nullid} {
5051 set fname $line
5052 } else {
5053 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5054 set i [string first "\t" $line]
5055 if {$i < 0} continue
5056 set sha1 [lindex $line 2]
5057 set fname [string range $line [expr {$i+1}] end]
5058 if {[string index $fname 0] eq "\""} {
5059 set fname [lindex $fname 0]
5061 lappend treeidlist($id) $sha1
5063 lappend treefilelist($id) $fname
5065 if {![eof $gtf]} {
5066 return [expr {$nl >= 1000? 2: 1}]
5068 close $gtf
5069 unset treepending
5070 if {$cmitmode ne "tree"} {
5071 if {![info exists diffmergeid]} {
5072 gettreediffs $diffids
5074 } elseif {$id ne $diffids} {
5075 gettree $diffids
5076 } else {
5077 setfilelist $id
5079 return 0
5082 proc showfile {f} {
5083 global treefilelist treeidlist diffids nullid nullid2
5084 global ctext commentend
5086 set i [lsearch -exact $treefilelist($diffids) $f]
5087 if {$i < 0} {
5088 puts "oops, $f not in list for id $diffids"
5089 return
5091 if {$diffids eq $nullid} {
5092 if {[catch {set bf [open $f r]} err]} {
5093 puts "oops, can't read $f: $err"
5094 return
5096 } else {
5097 set blob [lindex $treeidlist($diffids) $i]
5098 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5099 puts "oops, error reading blob $blob: $err"
5100 return
5103 fconfigure $bf -blocking 0
5104 filerun $bf [list getblobline $bf $diffids]
5105 $ctext config -state normal
5106 clear_ctext $commentend
5107 $ctext insert end "\n"
5108 $ctext insert end "$f\n" filesep
5109 $ctext config -state disabled
5110 $ctext yview $commentend
5111 settabs 0
5114 proc getblobline {bf id} {
5115 global diffids cmitmode ctext
5117 if {$id ne $diffids || $cmitmode ne "tree"} {
5118 catch {close $bf}
5119 return 0
5121 $ctext config -state normal
5122 set nl 0
5123 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5124 $ctext insert end "$line\n"
5126 if {[eof $bf]} {
5127 # delete last newline
5128 $ctext delete "end - 2c" "end - 1c"
5129 close $bf
5130 return 0
5132 $ctext config -state disabled
5133 return [expr {$nl >= 1000? 2: 1}]
5136 proc mergediff {id l} {
5137 global diffmergeid mdifffd
5138 global diffids
5139 global parentlist
5141 set diffmergeid $id
5142 set diffids $id
5143 # this doesn't seem to actually affect anything...
5144 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5145 if {[catch {set mdf [open $cmd r]} err]} {
5146 error_popup "Error getting merge diffs: $err"
5147 return
5149 fconfigure $mdf -blocking 0
5150 set mdifffd($id) $mdf
5151 set np [llength [lindex $parentlist $l]]
5152 settabs $np
5153 filerun $mdf [list getmergediffline $mdf $id $np]
5156 proc getmergediffline {mdf id np} {
5157 global diffmergeid ctext cflist mergemax
5158 global difffilestart mdifffd
5160 $ctext conf -state normal
5161 set nr 0
5162 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5163 if {![info exists diffmergeid] || $id != $diffmergeid
5164 || $mdf != $mdifffd($id)} {
5165 close $mdf
5166 return 0
5168 if {[regexp {^diff --cc (.*)} $line match fname]} {
5169 # start of a new file
5170 $ctext insert end "\n"
5171 set here [$ctext index "end - 1c"]
5172 lappend difffilestart $here
5173 add_flist [list $fname]
5174 set l [expr {(78 - [string length $fname]) / 2}]
5175 set pad [string range "----------------------------------------" 1 $l]
5176 $ctext insert end "$pad $fname $pad\n" filesep
5177 } elseif {[regexp {^@@} $line]} {
5178 $ctext insert end "$line\n" hunksep
5179 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5180 # do nothing
5181 } else {
5182 # parse the prefix - one ' ', '-' or '+' for each parent
5183 set spaces {}
5184 set minuses {}
5185 set pluses {}
5186 set isbad 0
5187 for {set j 0} {$j < $np} {incr j} {
5188 set c [string range $line $j $j]
5189 if {$c == " "} {
5190 lappend spaces $j
5191 } elseif {$c == "-"} {
5192 lappend minuses $j
5193 } elseif {$c == "+"} {
5194 lappend pluses $j
5195 } else {
5196 set isbad 1
5197 break
5200 set tags {}
5201 set num {}
5202 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5203 # line doesn't appear in result, parents in $minuses have the line
5204 set num [lindex $minuses 0]
5205 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5206 # line appears in result, parents in $pluses don't have the line
5207 lappend tags mresult
5208 set num [lindex $spaces 0]
5210 if {$num ne {}} {
5211 if {$num >= $mergemax} {
5212 set num "max"
5214 lappend tags m$num
5216 $ctext insert end "$line\n" $tags
5219 $ctext conf -state disabled
5220 if {[eof $mdf]} {
5221 close $mdf
5222 return 0
5224 return [expr {$nr >= 1000? 2: 1}]
5227 proc startdiff {ids} {
5228 global treediffs diffids treepending diffmergeid nullid nullid2
5230 settabs 1
5231 set diffids $ids
5232 catch {unset diffmergeid}
5233 if {![info exists treediffs($ids)] ||
5234 [lsearch -exact $ids $nullid] >= 0 ||
5235 [lsearch -exact $ids $nullid2] >= 0} {
5236 if {![info exists treepending]} {
5237 gettreediffs $ids
5239 } else {
5240 addtocflist $ids
5244 proc addtocflist {ids} {
5245 global treediffs cflist
5246 add_flist $treediffs($ids)
5247 getblobdiffs $ids
5250 proc diffcmd {ids flags} {
5251 global nullid nullid2
5253 set i [lsearch -exact $ids $nullid]
5254 set j [lsearch -exact $ids $nullid2]
5255 if {$i >= 0} {
5256 if {[llength $ids] > 1 && $j < 0} {
5257 # comparing working directory with some specific revision
5258 set cmd [concat | git diff-index $flags]
5259 if {$i == 0} {
5260 lappend cmd -R [lindex $ids 1]
5261 } else {
5262 lappend cmd [lindex $ids 0]
5264 } else {
5265 # comparing working directory with index
5266 set cmd [concat | git diff-files $flags]
5267 if {$j == 1} {
5268 lappend cmd -R
5271 } elseif {$j >= 0} {
5272 set cmd [concat | git diff-index --cached $flags]
5273 if {[llength $ids] > 1} {
5274 # comparing index with specific revision
5275 if {$i == 0} {
5276 lappend cmd -R [lindex $ids 1]
5277 } else {
5278 lappend cmd [lindex $ids 0]
5280 } else {
5281 # comparing index with HEAD
5282 lappend cmd HEAD
5284 } else {
5285 set cmd [concat | git diff-tree -r $flags $ids]
5287 return $cmd
5290 proc gettreediffs {ids} {
5291 global treediff treepending
5293 set treepending $ids
5294 set treediff {}
5295 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5296 fconfigure $gdtf -blocking 0
5297 filerun $gdtf [list gettreediffline $gdtf $ids]
5300 proc gettreediffline {gdtf ids} {
5301 global treediff treediffs treepending diffids diffmergeid
5302 global cmitmode
5304 set nr 0
5305 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5306 set i [string first "\t" $line]
5307 if {$i >= 0} {
5308 set file [string range $line [expr {$i+1}] end]
5309 if {[string index $file 0] eq "\""} {
5310 set file [lindex $file 0]
5312 lappend treediff $file
5315 if {![eof $gdtf]} {
5316 return [expr {$nr >= 1000? 2: 1}]
5318 close $gdtf
5319 set treediffs($ids) $treediff
5320 unset treepending
5321 if {$cmitmode eq "tree"} {
5322 gettree $diffids
5323 } elseif {$ids != $diffids} {
5324 if {![info exists diffmergeid]} {
5325 gettreediffs $diffids
5327 } else {
5328 addtocflist $ids
5330 return 0
5333 # empty string or positive integer
5334 proc diffcontextvalidate {v} {
5335 return [regexp {^(|[1-9][0-9]*)$} $v]
5338 proc diffcontextchange {n1 n2 op} {
5339 global diffcontextstring diffcontext
5341 if {[string is integer -strict $diffcontextstring]} {
5342 if {$diffcontextstring > 0} {
5343 set diffcontext $diffcontextstring
5344 reselectline
5349 proc getblobdiffs {ids} {
5350 global blobdifffd diffids env
5351 global diffinhdr treediffs
5352 global diffcontext
5354 if {[catch {set bdf [open [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"] r]} err]} {
5355 puts "error getting diffs: $err"
5356 return
5358 set diffinhdr 0
5359 fconfigure $bdf -blocking 0
5360 set blobdifffd($ids) $bdf
5361 filerun $bdf [list getblobdiffline $bdf $diffids]
5364 proc setinlist {var i val} {
5365 global $var
5367 while {[llength [set $var]] < $i} {
5368 lappend $var {}
5370 if {[llength [set $var]] == $i} {
5371 lappend $var $val
5372 } else {
5373 lset $var $i $val
5377 proc makediffhdr {fname ids} {
5378 global ctext curdiffstart treediffs
5380 set i [lsearch -exact $treediffs($ids) $fname]
5381 if {$i >= 0} {
5382 setinlist difffilestart $i $curdiffstart
5384 set l [expr {(78 - [string length $fname]) / 2}]
5385 set pad [string range "----------------------------------------" 1 $l]
5386 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5389 proc getblobdiffline {bdf ids} {
5390 global diffids blobdifffd ctext curdiffstart
5391 global diffnexthead diffnextnote difffilestart
5392 global diffinhdr treediffs
5394 set nr 0
5395 $ctext conf -state normal
5396 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5397 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5398 close $bdf
5399 return 0
5401 if {![string compare -length 11 "diff --git " $line]} {
5402 # trim off "diff --git "
5403 set line [string range $line 11 end]
5404 set diffinhdr 1
5405 # start of a new file
5406 $ctext insert end "\n"
5407 set curdiffstart [$ctext index "end - 1c"]
5408 $ctext insert end "\n" filesep
5409 # If the name hasn't changed the length will be odd,
5410 # the middle char will be a space, and the two bits either
5411 # side will be a/name and b/name, or "a/name" and "b/name".
5412 # If the name has changed we'll get "rename from" and
5413 # "rename to" or "copy from" and "copy to" lines following this,
5414 # and we'll use them to get the filenames.
5415 # This complexity is necessary because spaces in the filename(s)
5416 # don't get escaped.
5417 set l [string length $line]
5418 set i [expr {$l / 2}]
5419 if {!(($l & 1) && [string index $line $i] eq " " &&
5420 [string range $line 2 [expr {$i - 1}]] eq \
5421 [string range $line [expr {$i + 3}] end])} {
5422 continue
5424 # unescape if quoted and chop off the a/ from the front
5425 if {[string index $line 0] eq "\""} {
5426 set fname [string range [lindex $line 0] 2 end]
5427 } else {
5428 set fname [string range $line 2 [expr {$i - 1}]]
5430 makediffhdr $fname $ids
5432 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5433 $line match f1l f1c f2l f2c rest]} {
5434 $ctext insert end "$line\n" hunksep
5435 set diffinhdr 0
5437 } elseif {$diffinhdr} {
5438 if {![string compare -length 12 "rename from " $line] ||
5439 ![string compare -length 10 "copy from " $line]} {
5440 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5441 if {[string index $fname 0] eq "\""} {
5442 set fname [lindex $fname 0]
5444 set i [lsearch -exact $treediffs($ids) $fname]
5445 if {$i >= 0} {
5446 setinlist difffilestart $i $curdiffstart
5448 } elseif {![string compare -length 10 $line "rename to "] ||
5449 ![string compare -length 8 $line "copy to "]} {
5450 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5451 if {[string index $fname 0] eq "\""} {
5452 set fname [lindex $fname 0]
5454 makediffhdr $fname $ids
5455 } elseif {[string compare -length 3 $line "---"] == 0} {
5456 # do nothing
5457 continue
5458 } elseif {[string compare -length 3 $line "+++"] == 0} {
5459 set diffinhdr 0
5460 continue
5462 $ctext insert end "$line\n" filesep
5464 } else {
5465 set x [string range $line 0 0]
5466 if {$x == "-" || $x == "+"} {
5467 set tag [expr {$x == "+"}]
5468 $ctext insert end "$line\n" d$tag
5469 } elseif {$x == " "} {
5470 $ctext insert end "$line\n"
5471 } else {
5472 # "\ No newline at end of file",
5473 # or something else we don't recognize
5474 $ctext insert end "$line\n" hunksep
5478 $ctext conf -state disabled
5479 if {[eof $bdf]} {
5480 close $bdf
5481 return 0
5483 return [expr {$nr >= 1000? 2: 1}]
5486 proc changediffdisp {} {
5487 global ctext diffelide
5489 $ctext tag conf d0 -elide [lindex $diffelide 0]
5490 $ctext tag conf d1 -elide [lindex $diffelide 1]
5493 proc prevfile {} {
5494 global difffilestart ctext
5495 set prev [lindex $difffilestart 0]
5496 set here [$ctext index @0,0]
5497 foreach loc $difffilestart {
5498 if {[$ctext compare $loc >= $here]} {
5499 $ctext yview $prev
5500 return
5502 set prev $loc
5504 $ctext yview $prev
5507 proc nextfile {} {
5508 global difffilestart ctext
5509 set here [$ctext index @0,0]
5510 foreach loc $difffilestart {
5511 if {[$ctext compare $loc > $here]} {
5512 $ctext yview $loc
5513 return
5518 proc clear_ctext {{first 1.0}} {
5519 global ctext smarktop smarkbot
5520 global pendinglinks
5522 set l [lindex [split $first .] 0]
5523 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5524 set smarktop $l
5526 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5527 set smarkbot $l
5529 $ctext delete $first end
5530 if {$first eq "1.0"} {
5531 catch {unset pendinglinks}
5535 proc settabs {{firstab {}}} {
5536 global firsttabstop tabstop ctext have_tk85
5538 if {$firstab ne {} && $have_tk85} {
5539 set firsttabstop $firstab
5541 set w [font measure textfont "0"]
5542 if {$firsttabstop != 0} {
5543 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5544 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5545 } elseif {$have_tk85 || $tabstop != 8} {
5546 $ctext conf -tabs [expr {$tabstop * $w}]
5547 } else {
5548 $ctext conf -tabs {}
5552 proc incrsearch {name ix op} {
5553 global ctext searchstring searchdirn
5555 $ctext tag remove found 1.0 end
5556 if {[catch {$ctext index anchor}]} {
5557 # no anchor set, use start of selection, or of visible area
5558 set sel [$ctext tag ranges sel]
5559 if {$sel ne {}} {
5560 $ctext mark set anchor [lindex $sel 0]
5561 } elseif {$searchdirn eq "-forwards"} {
5562 $ctext mark set anchor @0,0
5563 } else {
5564 $ctext mark set anchor @0,[winfo height $ctext]
5567 if {$searchstring ne {}} {
5568 set here [$ctext search $searchdirn -- $searchstring anchor]
5569 if {$here ne {}} {
5570 $ctext see $here
5572 searchmarkvisible 1
5576 proc dosearch {} {
5577 global sstring ctext searchstring searchdirn
5579 focus $sstring
5580 $sstring icursor end
5581 set searchdirn -forwards
5582 if {$searchstring ne {}} {
5583 set sel [$ctext tag ranges sel]
5584 if {$sel ne {}} {
5585 set start "[lindex $sel 0] + 1c"
5586 } elseif {[catch {set start [$ctext index anchor]}]} {
5587 set start "@0,0"
5589 set match [$ctext search -count mlen -- $searchstring $start]
5590 $ctext tag remove sel 1.0 end
5591 if {$match eq {}} {
5592 bell
5593 return
5595 $ctext see $match
5596 set mend "$match + $mlen c"
5597 $ctext tag add sel $match $mend
5598 $ctext mark unset anchor
5602 proc dosearchback {} {
5603 global sstring ctext searchstring searchdirn
5605 focus $sstring
5606 $sstring icursor end
5607 set searchdirn -backwards
5608 if {$searchstring ne {}} {
5609 set sel [$ctext tag ranges sel]
5610 if {$sel ne {}} {
5611 set start [lindex $sel 0]
5612 } elseif {[catch {set start [$ctext index anchor]}]} {
5613 set start @0,[winfo height $ctext]
5615 set match [$ctext search -backwards -count ml -- $searchstring $start]
5616 $ctext tag remove sel 1.0 end
5617 if {$match eq {}} {
5618 bell
5619 return
5621 $ctext see $match
5622 set mend "$match + $ml c"
5623 $ctext tag add sel $match $mend
5624 $ctext mark unset anchor
5628 proc searchmark {first last} {
5629 global ctext searchstring
5631 set mend $first.0
5632 while {1} {
5633 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5634 if {$match eq {}} break
5635 set mend "$match + $mlen c"
5636 $ctext tag add found $match $mend
5640 proc searchmarkvisible {doall} {
5641 global ctext smarktop smarkbot
5643 set topline [lindex [split [$ctext index @0,0] .] 0]
5644 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5645 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5646 # no overlap with previous
5647 searchmark $topline $botline
5648 set smarktop $topline
5649 set smarkbot $botline
5650 } else {
5651 if {$topline < $smarktop} {
5652 searchmark $topline [expr {$smarktop-1}]
5653 set smarktop $topline
5655 if {$botline > $smarkbot} {
5656 searchmark [expr {$smarkbot+1}] $botline
5657 set smarkbot $botline
5662 proc scrolltext {f0 f1} {
5663 global searchstring
5665 .bleft.sb set $f0 $f1
5666 if {$searchstring ne {}} {
5667 searchmarkvisible 0
5671 proc setcoords {} {
5672 global linespc charspc canvx0 canvy0
5673 global xspc1 xspc2 lthickness
5675 set linespc [font metrics mainfont -linespace]
5676 set charspc [font measure mainfont "m"]
5677 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5678 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5679 set lthickness [expr {int($linespc / 9) + 1}]
5680 set xspc1(0) $linespc
5681 set xspc2 $linespc
5684 proc redisplay {} {
5685 global canv
5686 global selectedline
5688 set ymax [lindex [$canv cget -scrollregion] 3]
5689 if {$ymax eq {} || $ymax == 0} return
5690 set span [$canv yview]
5691 clear_display
5692 setcanvscroll
5693 allcanvs yview moveto [lindex $span 0]
5694 drawvisible
5695 if {[info exists selectedline]} {
5696 selectline $selectedline 0
5697 allcanvs yview moveto [lindex $span 0]
5701 proc parsefont {f n} {
5702 global fontattr
5704 set fontattr($f,family) [lindex $n 0]
5705 set s [lindex $n 1]
5706 if {$s eq {} || $s == 0} {
5707 set s 10
5708 } elseif {$s < 0} {
5709 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5711 set fontattr($f,size) $s
5712 set fontattr($f,weight) normal
5713 set fontattr($f,slant) roman
5714 foreach style [lrange $n 2 end] {
5715 switch -- $style {
5716 "normal" -
5717 "bold" {set fontattr($f,weight) $style}
5718 "roman" -
5719 "italic" {set fontattr($f,slant) $style}
5724 proc fontflags {f {isbold 0}} {
5725 global fontattr
5727 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5728 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5729 -slant $fontattr($f,slant)]
5732 proc fontname {f} {
5733 global fontattr
5735 set n [list $fontattr($f,family) $fontattr($f,size)]
5736 if {$fontattr($f,weight) eq "bold"} {
5737 lappend n "bold"
5739 if {$fontattr($f,slant) eq "italic"} {
5740 lappend n "italic"
5742 return $n
5745 proc incrfont {inc} {
5746 global mainfont textfont ctext canv phase cflist showrefstop
5747 global stopped entries fontattr
5749 unmarkmatches
5750 set s $fontattr(mainfont,size)
5751 incr s $inc
5752 if {$s < 1} {
5753 set s 1
5755 set fontattr(mainfont,size) $s
5756 font config mainfont -size $s
5757 font config mainfontbold -size $s
5758 set mainfont [fontname mainfont]
5759 set s $fontattr(textfont,size)
5760 incr s $inc
5761 if {$s < 1} {
5762 set s 1
5764 set fontattr(textfont,size) $s
5765 font config textfont -size $s
5766 font config textfontbold -size $s
5767 set textfont [fontname textfont]
5768 setcoords
5769 settabs
5770 redisplay
5773 proc clearsha1 {} {
5774 global sha1entry sha1string
5775 if {[string length $sha1string] == 40} {
5776 $sha1entry delete 0 end
5780 proc sha1change {n1 n2 op} {
5781 global sha1string currentid sha1but
5782 if {$sha1string == {}
5783 || ([info exists currentid] && $sha1string == $currentid)} {
5784 set state disabled
5785 } else {
5786 set state normal
5788 if {[$sha1but cget -state] == $state} return
5789 if {$state == "normal"} {
5790 $sha1but conf -state normal -relief raised -text "Goto: "
5791 } else {
5792 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5796 proc gotocommit {} {
5797 global sha1string currentid commitrow tagids headids
5798 global displayorder numcommits curview
5800 if {$sha1string == {}
5801 || ([info exists currentid] && $sha1string == $currentid)} return
5802 if {[info exists tagids($sha1string)]} {
5803 set id $tagids($sha1string)
5804 } elseif {[info exists headids($sha1string)]} {
5805 set id $headids($sha1string)
5806 } else {
5807 set id [string tolower $sha1string]
5808 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5809 set matches {}
5810 foreach i $displayorder {
5811 if {[string match $id* $i]} {
5812 lappend matches $i
5815 if {$matches ne {}} {
5816 if {[llength $matches] > 1} {
5817 error_popup "Short SHA1 id $id is ambiguous"
5818 return
5820 set id [lindex $matches 0]
5824 if {[info exists commitrow($curview,$id)]} {
5825 selectline $commitrow($curview,$id) 1
5826 return
5828 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5829 set type "SHA1 id"
5830 } else {
5831 set type "Tag/Head"
5833 error_popup "$type $sha1string is not known"
5836 proc lineenter {x y id} {
5837 global hoverx hovery hoverid hovertimer
5838 global commitinfo canv
5840 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5841 set hoverx $x
5842 set hovery $y
5843 set hoverid $id
5844 if {[info exists hovertimer]} {
5845 after cancel $hovertimer
5847 set hovertimer [after 500 linehover]
5848 $canv delete hover
5851 proc linemotion {x y id} {
5852 global hoverx hovery hoverid hovertimer
5854 if {[info exists hoverid] && $id == $hoverid} {
5855 set hoverx $x
5856 set hovery $y
5857 if {[info exists hovertimer]} {
5858 after cancel $hovertimer
5860 set hovertimer [after 500 linehover]
5864 proc lineleave {id} {
5865 global hoverid hovertimer canv
5867 if {[info exists hoverid] && $id == $hoverid} {
5868 $canv delete hover
5869 if {[info exists hovertimer]} {
5870 after cancel $hovertimer
5871 unset hovertimer
5873 unset hoverid
5877 proc linehover {} {
5878 global hoverx hovery hoverid hovertimer
5879 global canv linespc lthickness
5880 global commitinfo
5882 set text [lindex $commitinfo($hoverid) 0]
5883 set ymax [lindex [$canv cget -scrollregion] 3]
5884 if {$ymax == {}} return
5885 set yfrac [lindex [$canv yview] 0]
5886 set x [expr {$hoverx + 2 * $linespc}]
5887 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5888 set x0 [expr {$x - 2 * $lthickness}]
5889 set y0 [expr {$y - 2 * $lthickness}]
5890 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5891 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5892 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5893 -fill \#ffff80 -outline black -width 1 -tags hover]
5894 $canv raise $t
5895 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5896 -font mainfont]
5897 $canv raise $t
5900 proc clickisonarrow {id y} {
5901 global lthickness
5903 set ranges [rowranges $id]
5904 set thresh [expr {2 * $lthickness + 6}]
5905 set n [expr {[llength $ranges] - 1}]
5906 for {set i 1} {$i < $n} {incr i} {
5907 set row [lindex $ranges $i]
5908 if {abs([yc $row] - $y) < $thresh} {
5909 return $i
5912 return {}
5915 proc arrowjump {id n y} {
5916 global canv
5918 # 1 <-> 2, 3 <-> 4, etc...
5919 set n [expr {(($n - 1) ^ 1) + 1}]
5920 set row [lindex [rowranges $id] $n]
5921 set yt [yc $row]
5922 set ymax [lindex [$canv cget -scrollregion] 3]
5923 if {$ymax eq {} || $ymax <= 0} return
5924 set view [$canv yview]
5925 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5926 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5927 if {$yfrac < 0} {
5928 set yfrac 0
5930 allcanvs yview moveto $yfrac
5933 proc lineclick {x y id isnew} {
5934 global ctext commitinfo children canv thickerline curview commitrow
5936 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5937 unmarkmatches
5938 unselectline
5939 normalline
5940 $canv delete hover
5941 # draw this line thicker than normal
5942 set thickerline $id
5943 drawlines $id
5944 if {$isnew} {
5945 set ymax [lindex [$canv cget -scrollregion] 3]
5946 if {$ymax eq {}} return
5947 set yfrac [lindex [$canv yview] 0]
5948 set y [expr {$y + $yfrac * $ymax}]
5950 set dirn [clickisonarrow $id $y]
5951 if {$dirn ne {}} {
5952 arrowjump $id $dirn $y
5953 return
5956 if {$isnew} {
5957 addtohistory [list lineclick $x $y $id 0]
5959 # fill the details pane with info about this line
5960 $ctext conf -state normal
5961 clear_ctext
5962 settabs 0
5963 $ctext insert end "Parent:\t"
5964 $ctext insert end $id link0
5965 setlink $id link0
5966 set info $commitinfo($id)
5967 $ctext insert end "\n\t[lindex $info 0]\n"
5968 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5969 set date [formatdate [lindex $info 2]]
5970 $ctext insert end "\tDate:\t$date\n"
5971 set kids $children($curview,$id)
5972 if {$kids ne {}} {
5973 $ctext insert end "\nChildren:"
5974 set i 0
5975 foreach child $kids {
5976 incr i
5977 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5978 set info $commitinfo($child)
5979 $ctext insert end "\n\t"
5980 $ctext insert end $child link$i
5981 setlink $child link$i
5982 $ctext insert end "\n\t[lindex $info 0]"
5983 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5984 set date [formatdate [lindex $info 2]]
5985 $ctext insert end "\n\tDate:\t$date\n"
5988 $ctext conf -state disabled
5989 init_flist {}
5992 proc normalline {} {
5993 global thickerline
5994 if {[info exists thickerline]} {
5995 set id $thickerline
5996 unset thickerline
5997 drawlines $id
6001 proc selbyid {id} {
6002 global commitrow curview
6003 if {[info exists commitrow($curview,$id)]} {
6004 selectline $commitrow($curview,$id) 1
6008 proc mstime {} {
6009 global startmstime
6010 if {![info exists startmstime]} {
6011 set startmstime [clock clicks -milliseconds]
6013 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6016 proc rowmenu {x y id} {
6017 global rowctxmenu commitrow selectedline rowmenuid curview
6018 global nullid nullid2 fakerowmenu mainhead
6020 stopfinding
6021 set rowmenuid $id
6022 if {![info exists selectedline]
6023 || $commitrow($curview,$id) eq $selectedline} {
6024 set state disabled
6025 } else {
6026 set state normal
6028 if {$id ne $nullid && $id ne $nullid2} {
6029 set menu $rowctxmenu
6030 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6031 } else {
6032 set menu $fakerowmenu
6034 $menu entryconfigure "Diff this*" -state $state
6035 $menu entryconfigure "Diff selected*" -state $state
6036 $menu entryconfigure "Make patch" -state $state
6037 tk_popup $menu $x $y
6040 proc diffvssel {dirn} {
6041 global rowmenuid selectedline displayorder
6043 if {![info exists selectedline]} return
6044 if {$dirn} {
6045 set oldid [lindex $displayorder $selectedline]
6046 set newid $rowmenuid
6047 } else {
6048 set oldid $rowmenuid
6049 set newid [lindex $displayorder $selectedline]
6051 addtohistory [list doseldiff $oldid $newid]
6052 doseldiff $oldid $newid
6055 proc doseldiff {oldid newid} {
6056 global ctext
6057 global commitinfo
6059 $ctext conf -state normal
6060 clear_ctext
6061 init_flist "Top"
6062 $ctext insert end "From "
6063 $ctext insert end $oldid link0
6064 setlink $oldid link0
6065 $ctext insert end "\n "
6066 $ctext insert end [lindex $commitinfo($oldid) 0]
6067 $ctext insert end "\n\nTo "
6068 $ctext insert end $newid link1
6069 setlink $newid link1
6070 $ctext insert end "\n "
6071 $ctext insert end [lindex $commitinfo($newid) 0]
6072 $ctext insert end "\n"
6073 $ctext conf -state disabled
6074 $ctext tag remove found 1.0 end
6075 startdiff [list $oldid $newid]
6078 proc mkpatch {} {
6079 global rowmenuid currentid commitinfo patchtop patchnum
6081 if {![info exists currentid]} return
6082 set oldid $currentid
6083 set oldhead [lindex $commitinfo($oldid) 0]
6084 set newid $rowmenuid
6085 set newhead [lindex $commitinfo($newid) 0]
6086 set top .patch
6087 set patchtop $top
6088 catch {destroy $top}
6089 toplevel $top
6090 label $top.title -text "Generate patch"
6091 grid $top.title - -pady 10
6092 label $top.from -text "From:"
6093 entry $top.fromsha1 -width 40 -relief flat
6094 $top.fromsha1 insert 0 $oldid
6095 $top.fromsha1 conf -state readonly
6096 grid $top.from $top.fromsha1 -sticky w
6097 entry $top.fromhead -width 60 -relief flat
6098 $top.fromhead insert 0 $oldhead
6099 $top.fromhead conf -state readonly
6100 grid x $top.fromhead -sticky w
6101 label $top.to -text "To:"
6102 entry $top.tosha1 -width 40 -relief flat
6103 $top.tosha1 insert 0 $newid
6104 $top.tosha1 conf -state readonly
6105 grid $top.to $top.tosha1 -sticky w
6106 entry $top.tohead -width 60 -relief flat
6107 $top.tohead insert 0 $newhead
6108 $top.tohead conf -state readonly
6109 grid x $top.tohead -sticky w
6110 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6111 grid $top.rev x -pady 10
6112 label $top.flab -text "Output file:"
6113 entry $top.fname -width 60
6114 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6115 incr patchnum
6116 grid $top.flab $top.fname -sticky w
6117 frame $top.buts
6118 button $top.buts.gen -text "Generate" -command mkpatchgo
6119 button $top.buts.can -text "Cancel" -command mkpatchcan
6120 grid $top.buts.gen $top.buts.can
6121 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6122 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6123 grid $top.buts - -pady 10 -sticky ew
6124 focus $top.fname
6127 proc mkpatchrev {} {
6128 global patchtop
6130 set oldid [$patchtop.fromsha1 get]
6131 set oldhead [$patchtop.fromhead get]
6132 set newid [$patchtop.tosha1 get]
6133 set newhead [$patchtop.tohead get]
6134 foreach e [list fromsha1 fromhead tosha1 tohead] \
6135 v [list $newid $newhead $oldid $oldhead] {
6136 $patchtop.$e conf -state normal
6137 $patchtop.$e delete 0 end
6138 $patchtop.$e insert 0 $v
6139 $patchtop.$e conf -state readonly
6143 proc mkpatchgo {} {
6144 global patchtop nullid nullid2
6146 set oldid [$patchtop.fromsha1 get]
6147 set newid [$patchtop.tosha1 get]
6148 set fname [$patchtop.fname get]
6149 set cmd [diffcmd [list $oldid $newid] -p]
6150 # trim off the initial "|"
6151 set cmd [lrange $cmd 1 end]
6152 lappend cmd >$fname &
6153 if {[catch {eval exec $cmd} err]} {
6154 error_popup "Error creating patch: $err"
6156 catch {destroy $patchtop}
6157 unset patchtop
6160 proc mkpatchcan {} {
6161 global patchtop
6163 catch {destroy $patchtop}
6164 unset patchtop
6167 proc mktag {} {
6168 global rowmenuid mktagtop commitinfo
6170 set top .maketag
6171 set mktagtop $top
6172 catch {destroy $top}
6173 toplevel $top
6174 label $top.title -text "Create tag"
6175 grid $top.title - -pady 10
6176 label $top.id -text "ID:"
6177 entry $top.sha1 -width 40 -relief flat
6178 $top.sha1 insert 0 $rowmenuid
6179 $top.sha1 conf -state readonly
6180 grid $top.id $top.sha1 -sticky w
6181 entry $top.head -width 60 -relief flat
6182 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6183 $top.head conf -state readonly
6184 grid x $top.head -sticky w
6185 label $top.tlab -text "Tag name:"
6186 entry $top.tag -width 60
6187 grid $top.tlab $top.tag -sticky w
6188 frame $top.buts
6189 button $top.buts.gen -text "Create" -command mktaggo
6190 button $top.buts.can -text "Cancel" -command mktagcan
6191 grid $top.buts.gen $top.buts.can
6192 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6193 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6194 grid $top.buts - -pady 10 -sticky ew
6195 focus $top.tag
6198 proc domktag {} {
6199 global mktagtop env tagids idtags
6201 set id [$mktagtop.sha1 get]
6202 set tag [$mktagtop.tag get]
6203 if {$tag == {}} {
6204 error_popup "No tag name specified"
6205 return
6207 if {[info exists tagids($tag)]} {
6208 error_popup "Tag \"$tag\" already exists"
6209 return
6211 if {[catch {
6212 set dir [gitdir]
6213 set fname [file join $dir "refs/tags" $tag]
6214 set f [open $fname w]
6215 puts $f $id
6216 close $f
6217 } err]} {
6218 error_popup "Error creating tag: $err"
6219 return
6222 set tagids($tag) $id
6223 lappend idtags($id) $tag
6224 redrawtags $id
6225 addedtag $id
6226 dispneartags 0
6227 run refill_reflist
6230 proc redrawtags {id} {
6231 global canv linehtag commitrow idpos selectedline curview
6232 global canvxmax iddrawn
6234 if {![info exists commitrow($curview,$id)]} return
6235 if {![info exists iddrawn($id)]} return
6236 drawcommits $commitrow($curview,$id)
6237 $canv delete tag.$id
6238 set xt [eval drawtags $id $idpos($id)]
6239 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6240 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6241 set xr [expr {$xt + [font measure mainfont $text]}]
6242 if {$xr > $canvxmax} {
6243 set canvxmax $xr
6244 setcanvscroll
6246 if {[info exists selectedline]
6247 && $selectedline == $commitrow($curview,$id)} {
6248 selectline $selectedline 0
6252 proc mktagcan {} {
6253 global mktagtop
6255 catch {destroy $mktagtop}
6256 unset mktagtop
6259 proc mktaggo {} {
6260 domktag
6261 mktagcan
6264 proc writecommit {} {
6265 global rowmenuid wrcomtop commitinfo wrcomcmd
6267 set top .writecommit
6268 set wrcomtop $top
6269 catch {destroy $top}
6270 toplevel $top
6271 label $top.title -text "Write commit to file"
6272 grid $top.title - -pady 10
6273 label $top.id -text "ID:"
6274 entry $top.sha1 -width 40 -relief flat
6275 $top.sha1 insert 0 $rowmenuid
6276 $top.sha1 conf -state readonly
6277 grid $top.id $top.sha1 -sticky w
6278 entry $top.head -width 60 -relief flat
6279 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6280 $top.head conf -state readonly
6281 grid x $top.head -sticky w
6282 label $top.clab -text "Command:"
6283 entry $top.cmd -width 60 -textvariable wrcomcmd
6284 grid $top.clab $top.cmd -sticky w -pady 10
6285 label $top.flab -text "Output file:"
6286 entry $top.fname -width 60
6287 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6288 grid $top.flab $top.fname -sticky w
6289 frame $top.buts
6290 button $top.buts.gen -text "Write" -command wrcomgo
6291 button $top.buts.can -text "Cancel" -command wrcomcan
6292 grid $top.buts.gen $top.buts.can
6293 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6294 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6295 grid $top.buts - -pady 10 -sticky ew
6296 focus $top.fname
6299 proc wrcomgo {} {
6300 global wrcomtop
6302 set id [$wrcomtop.sha1 get]
6303 set cmd "echo $id | [$wrcomtop.cmd get]"
6304 set fname [$wrcomtop.fname get]
6305 if {[catch {exec sh -c $cmd >$fname &} err]} {
6306 error_popup "Error writing commit: $err"
6308 catch {destroy $wrcomtop}
6309 unset wrcomtop
6312 proc wrcomcan {} {
6313 global wrcomtop
6315 catch {destroy $wrcomtop}
6316 unset wrcomtop
6319 proc mkbranch {} {
6320 global rowmenuid mkbrtop
6322 set top .makebranch
6323 catch {destroy $top}
6324 toplevel $top
6325 label $top.title -text "Create new branch"
6326 grid $top.title - -pady 10
6327 label $top.id -text "ID:"
6328 entry $top.sha1 -width 40 -relief flat
6329 $top.sha1 insert 0 $rowmenuid
6330 $top.sha1 conf -state readonly
6331 grid $top.id $top.sha1 -sticky w
6332 label $top.nlab -text "Name:"
6333 entry $top.name -width 40
6334 grid $top.nlab $top.name -sticky w
6335 frame $top.buts
6336 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6337 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6338 grid $top.buts.go $top.buts.can
6339 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6340 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6341 grid $top.buts - -pady 10 -sticky ew
6342 focus $top.name
6345 proc mkbrgo {top} {
6346 global headids idheads
6348 set name [$top.name get]
6349 set id [$top.sha1 get]
6350 if {$name eq {}} {
6351 error_popup "Please specify a name for the new branch"
6352 return
6354 catch {destroy $top}
6355 nowbusy newbranch
6356 update
6357 if {[catch {
6358 exec git branch $name $id
6359 } err]} {
6360 notbusy newbranch
6361 error_popup $err
6362 } else {
6363 set headids($name) $id
6364 lappend idheads($id) $name
6365 addedhead $id $name
6366 notbusy newbranch
6367 redrawtags $id
6368 dispneartags 0
6369 run refill_reflist
6373 proc cherrypick {} {
6374 global rowmenuid curview commitrow
6375 global mainhead
6377 set oldhead [exec git rev-parse HEAD]
6378 set dheads [descheads $rowmenuid]
6379 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6380 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6381 included in branch $mainhead -- really re-apply it?"]
6382 if {!$ok} return
6384 nowbusy cherrypick
6385 update
6386 # Unfortunately git-cherry-pick writes stuff to stderr even when
6387 # no error occurs, and exec takes that as an indication of error...
6388 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6389 notbusy cherrypick
6390 error_popup $err
6391 return
6393 set newhead [exec git rev-parse HEAD]
6394 if {$newhead eq $oldhead} {
6395 notbusy cherrypick
6396 error_popup "No changes committed"
6397 return
6399 addnewchild $newhead $oldhead
6400 if {[info exists commitrow($curview,$oldhead)]} {
6401 insertrow $commitrow($curview,$oldhead) $newhead
6402 if {$mainhead ne {}} {
6403 movehead $newhead $mainhead
6404 movedhead $newhead $mainhead
6406 redrawtags $oldhead
6407 redrawtags $newhead
6409 notbusy cherrypick
6412 proc resethead {} {
6413 global mainheadid mainhead rowmenuid confirm_ok resettype
6415 set confirm_ok 0
6416 set w ".confirmreset"
6417 toplevel $w
6418 wm transient $w .
6419 wm title $w "Confirm reset"
6420 message $w.m -text \
6421 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6422 -justify center -aspect 1000
6423 pack $w.m -side top -fill x -padx 20 -pady 20
6424 frame $w.f -relief sunken -border 2
6425 message $w.f.rt -text "Reset type:" -aspect 1000
6426 grid $w.f.rt -sticky w
6427 set resettype mixed
6428 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6429 -text "Soft: Leave working tree and index untouched"
6430 grid $w.f.soft -sticky w
6431 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6432 -text "Mixed: Leave working tree untouched, reset index"
6433 grid $w.f.mixed -sticky w
6434 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6435 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6436 grid $w.f.hard -sticky w
6437 pack $w.f -side top -fill x
6438 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6439 pack $w.ok -side left -fill x -padx 20 -pady 20
6440 button $w.cancel -text Cancel -command "destroy $w"
6441 pack $w.cancel -side right -fill x -padx 20 -pady 20
6442 bind $w <Visibility> "grab $w; focus $w"
6443 tkwait window $w
6444 if {!$confirm_ok} return
6445 if {[catch {set fd [open \
6446 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6447 error_popup $err
6448 } else {
6449 dohidelocalchanges
6450 filerun $fd [list readresetstat $fd]
6451 nowbusy reset "Resetting"
6455 proc readresetstat {fd} {
6456 global mainhead mainheadid showlocalchanges rprogcoord
6458 if {[gets $fd line] >= 0} {
6459 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6460 set rprogcoord [expr {1.0 * $m / $n}]
6461 adjustprogress
6463 return 1
6465 set rprogcoord 0
6466 adjustprogress
6467 notbusy reset
6468 if {[catch {close $fd} err]} {
6469 error_popup $err
6471 set oldhead $mainheadid
6472 set newhead [exec git rev-parse HEAD]
6473 if {$newhead ne $oldhead} {
6474 movehead $newhead $mainhead
6475 movedhead $newhead $mainhead
6476 set mainheadid $newhead
6477 redrawtags $oldhead
6478 redrawtags $newhead
6480 if {$showlocalchanges} {
6481 doshowlocalchanges
6483 return 0
6486 # context menu for a head
6487 proc headmenu {x y id head} {
6488 global headmenuid headmenuhead headctxmenu mainhead
6490 stopfinding
6491 set headmenuid $id
6492 set headmenuhead $head
6493 set state normal
6494 if {$head eq $mainhead} {
6495 set state disabled
6497 $headctxmenu entryconfigure 0 -state $state
6498 $headctxmenu entryconfigure 1 -state $state
6499 tk_popup $headctxmenu $x $y
6502 proc cobranch {} {
6503 global headmenuid headmenuhead mainhead headids
6504 global showlocalchanges mainheadid
6506 # check the tree is clean first??
6507 set oldmainhead $mainhead
6508 nowbusy checkout
6509 update
6510 dohidelocalchanges
6511 if {[catch {
6512 exec git checkout -q $headmenuhead
6513 } err]} {
6514 notbusy checkout
6515 error_popup $err
6516 } else {
6517 notbusy checkout
6518 set mainhead $headmenuhead
6519 set mainheadid $headmenuid
6520 if {[info exists headids($oldmainhead)]} {
6521 redrawtags $headids($oldmainhead)
6523 redrawtags $headmenuid
6525 if {$showlocalchanges} {
6526 dodiffindex
6530 proc rmbranch {} {
6531 global headmenuid headmenuhead mainhead
6532 global idheads
6534 set head $headmenuhead
6535 set id $headmenuid
6536 # this check shouldn't be needed any more...
6537 if {$head eq $mainhead} {
6538 error_popup "Cannot delete the currently checked-out branch"
6539 return
6541 set dheads [descheads $id]
6542 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6543 # the stuff on this branch isn't on any other branch
6544 if {![confirm_popup "The commits on branch $head aren't on any other\
6545 branch.\nReally delete branch $head?"]} return
6547 nowbusy rmbranch
6548 update
6549 if {[catch {exec git branch -D $head} err]} {
6550 notbusy rmbranch
6551 error_popup $err
6552 return
6554 removehead $id $head
6555 removedhead $id $head
6556 redrawtags $id
6557 notbusy rmbranch
6558 dispneartags 0
6559 run refill_reflist
6562 # Display a list of tags and heads
6563 proc showrefs {} {
6564 global showrefstop bgcolor fgcolor selectbgcolor
6565 global bglist fglist reflistfilter reflist maincursor
6567 set top .showrefs
6568 set showrefstop $top
6569 if {[winfo exists $top]} {
6570 raise $top
6571 refill_reflist
6572 return
6574 toplevel $top
6575 wm title $top "Tags and heads: [file tail [pwd]]"
6576 text $top.list -background $bgcolor -foreground $fgcolor \
6577 -selectbackground $selectbgcolor -font mainfont \
6578 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6579 -width 30 -height 20 -cursor $maincursor \
6580 -spacing1 1 -spacing3 1 -state disabled
6581 $top.list tag configure highlight -background $selectbgcolor
6582 lappend bglist $top.list
6583 lappend fglist $top.list
6584 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6585 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6586 grid $top.list $top.ysb -sticky nsew
6587 grid $top.xsb x -sticky ew
6588 frame $top.f
6589 label $top.f.l -text "Filter: " -font uifont
6590 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
6591 set reflistfilter "*"
6592 trace add variable reflistfilter write reflistfilter_change
6593 pack $top.f.e -side right -fill x -expand 1
6594 pack $top.f.l -side left
6595 grid $top.f - -sticky ew -pady 2
6596 button $top.close -command [list destroy $top] -text "Close" \
6597 -font uifont
6598 grid $top.close -
6599 grid columnconfigure $top 0 -weight 1
6600 grid rowconfigure $top 0 -weight 1
6601 bind $top.list <1> {break}
6602 bind $top.list <B1-Motion> {break}
6603 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6604 set reflist {}
6605 refill_reflist
6608 proc sel_reflist {w x y} {
6609 global showrefstop reflist headids tagids otherrefids
6611 if {![winfo exists $showrefstop]} return
6612 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6613 set ref [lindex $reflist [expr {$l-1}]]
6614 set n [lindex $ref 0]
6615 switch -- [lindex $ref 1] {
6616 "H" {selbyid $headids($n)}
6617 "T" {selbyid $tagids($n)}
6618 "o" {selbyid $otherrefids($n)}
6620 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6623 proc unsel_reflist {} {
6624 global showrefstop
6626 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6627 $showrefstop.list tag remove highlight 0.0 end
6630 proc reflistfilter_change {n1 n2 op} {
6631 global reflistfilter
6633 after cancel refill_reflist
6634 after 200 refill_reflist
6637 proc refill_reflist {} {
6638 global reflist reflistfilter showrefstop headids tagids otherrefids
6639 global commitrow curview commitinterest
6641 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6642 set refs {}
6643 foreach n [array names headids] {
6644 if {[string match $reflistfilter $n]} {
6645 if {[info exists commitrow($curview,$headids($n))]} {
6646 lappend refs [list $n H]
6647 } else {
6648 set commitinterest($headids($n)) {run refill_reflist}
6652 foreach n [array names tagids] {
6653 if {[string match $reflistfilter $n]} {
6654 if {[info exists commitrow($curview,$tagids($n))]} {
6655 lappend refs [list $n T]
6656 } else {
6657 set commitinterest($tagids($n)) {run refill_reflist}
6661 foreach n [array names otherrefids] {
6662 if {[string match $reflistfilter $n]} {
6663 if {[info exists commitrow($curview,$otherrefids($n))]} {
6664 lappend refs [list $n o]
6665 } else {
6666 set commitinterest($otherrefids($n)) {run refill_reflist}
6670 set refs [lsort -index 0 $refs]
6671 if {$refs eq $reflist} return
6673 # Update the contents of $showrefstop.list according to the
6674 # differences between $reflist (old) and $refs (new)
6675 $showrefstop.list conf -state normal
6676 $showrefstop.list insert end "\n"
6677 set i 0
6678 set j 0
6679 while {$i < [llength $reflist] || $j < [llength $refs]} {
6680 if {$i < [llength $reflist]} {
6681 if {$j < [llength $refs]} {
6682 set cmp [string compare [lindex $reflist $i 0] \
6683 [lindex $refs $j 0]]
6684 if {$cmp == 0} {
6685 set cmp [string compare [lindex $reflist $i 1] \
6686 [lindex $refs $j 1]]
6688 } else {
6689 set cmp -1
6691 } else {
6692 set cmp 1
6694 switch -- $cmp {
6695 -1 {
6696 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6697 incr i
6700 incr i
6701 incr j
6704 set l [expr {$j + 1}]
6705 $showrefstop.list image create $l.0 -align baseline \
6706 -image reficon-[lindex $refs $j 1] -padx 2
6707 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6708 incr j
6712 set reflist $refs
6713 # delete last newline
6714 $showrefstop.list delete end-2c end-1c
6715 $showrefstop.list conf -state disabled
6718 # Stuff for finding nearby tags
6719 proc getallcommits {} {
6720 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6721 global idheads idtags idotherrefs allparents tagobjid
6723 if {![info exists allcommits]} {
6724 set nextarc 0
6725 set allcommits 0
6726 set seeds {}
6727 set allcwait 0
6728 set cachedarcs 0
6729 set allccache [file join [gitdir] "gitk.cache"]
6730 if {![catch {
6731 set f [open $allccache r]
6732 set allcwait 1
6733 getcache $f
6734 }]} return
6737 if {$allcwait} {
6738 return
6740 set cmd [list | git rev-list --parents]
6741 set allcupdate [expr {$seeds ne {}}]
6742 if {!$allcupdate} {
6743 set ids "--all"
6744 } else {
6745 set refs [concat [array names idheads] [array names idtags] \
6746 [array names idotherrefs]]
6747 set ids {}
6748 set tagobjs {}
6749 foreach name [array names tagobjid] {
6750 lappend tagobjs $tagobjid($name)
6752 foreach id [lsort -unique $refs] {
6753 if {![info exists allparents($id)] &&
6754 [lsearch -exact $tagobjs $id] < 0} {
6755 lappend ids $id
6758 if {$ids ne {}} {
6759 foreach id $seeds {
6760 lappend ids "^$id"
6764 if {$ids ne {}} {
6765 set fd [open [concat $cmd $ids] r]
6766 fconfigure $fd -blocking 0
6767 incr allcommits
6768 nowbusy allcommits
6769 filerun $fd [list getallclines $fd]
6770 } else {
6771 dispneartags 0
6775 # Since most commits have 1 parent and 1 child, we group strings of
6776 # such commits into "arcs" joining branch/merge points (BMPs), which
6777 # are commits that either don't have 1 parent or don't have 1 child.
6779 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6780 # arcout(id) - outgoing arcs for BMP
6781 # arcids(a) - list of IDs on arc including end but not start
6782 # arcstart(a) - BMP ID at start of arc
6783 # arcend(a) - BMP ID at end of arc
6784 # growing(a) - arc a is still growing
6785 # arctags(a) - IDs out of arcids (excluding end) that have tags
6786 # archeads(a) - IDs out of arcids (excluding end) that have heads
6787 # The start of an arc is at the descendent end, so "incoming" means
6788 # coming from descendents, and "outgoing" means going towards ancestors.
6790 proc getallclines {fd} {
6791 global allparents allchildren idtags idheads nextarc
6792 global arcnos arcids arctags arcout arcend arcstart archeads growing
6793 global seeds allcommits cachedarcs allcupdate
6795 set nid 0
6796 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6797 set id [lindex $line 0]
6798 if {[info exists allparents($id)]} {
6799 # seen it already
6800 continue
6802 set cachedarcs 0
6803 set olds [lrange $line 1 end]
6804 set allparents($id) $olds
6805 if {![info exists allchildren($id)]} {
6806 set allchildren($id) {}
6807 set arcnos($id) {}
6808 lappend seeds $id
6809 } else {
6810 set a $arcnos($id)
6811 if {[llength $olds] == 1 && [llength $a] == 1} {
6812 lappend arcids($a) $id
6813 if {[info exists idtags($id)]} {
6814 lappend arctags($a) $id
6816 if {[info exists idheads($id)]} {
6817 lappend archeads($a) $id
6819 if {[info exists allparents($olds)]} {
6820 # seen parent already
6821 if {![info exists arcout($olds)]} {
6822 splitarc $olds
6824 lappend arcids($a) $olds
6825 set arcend($a) $olds
6826 unset growing($a)
6828 lappend allchildren($olds) $id
6829 lappend arcnos($olds) $a
6830 continue
6833 foreach a $arcnos($id) {
6834 lappend arcids($a) $id
6835 set arcend($a) $id
6836 unset growing($a)
6839 set ao {}
6840 foreach p $olds {
6841 lappend allchildren($p) $id
6842 set a [incr nextarc]
6843 set arcstart($a) $id
6844 set archeads($a) {}
6845 set arctags($a) {}
6846 set archeads($a) {}
6847 set arcids($a) {}
6848 lappend ao $a
6849 set growing($a) 1
6850 if {[info exists allparents($p)]} {
6851 # seen it already, may need to make a new branch
6852 if {![info exists arcout($p)]} {
6853 splitarc $p
6855 lappend arcids($a) $p
6856 set arcend($a) $p
6857 unset growing($a)
6859 lappend arcnos($p) $a
6861 set arcout($id) $ao
6863 if {$nid > 0} {
6864 global cached_dheads cached_dtags cached_atags
6865 catch {unset cached_dheads}
6866 catch {unset cached_dtags}
6867 catch {unset cached_atags}
6869 if {![eof $fd]} {
6870 return [expr {$nid >= 1000? 2: 1}]
6872 set cacheok 1
6873 if {[catch {
6874 fconfigure $fd -blocking 1
6875 close $fd
6876 } err]} {
6877 # got an error reading the list of commits
6878 # if we were updating, try rereading the whole thing again
6879 if {$allcupdate} {
6880 incr allcommits -1
6881 dropcache $err
6882 return
6884 error_popup "Error reading commit topology information;\
6885 branch and preceding/following tag information\
6886 will be incomplete.\n($err)"
6887 set cacheok 0
6889 if {[incr allcommits -1] == 0} {
6890 notbusy allcommits
6891 if {$cacheok} {
6892 run savecache
6895 dispneartags 0
6896 return 0
6899 proc recalcarc {a} {
6900 global arctags archeads arcids idtags idheads
6902 set at {}
6903 set ah {}
6904 foreach id [lrange $arcids($a) 0 end-1] {
6905 if {[info exists idtags($id)]} {
6906 lappend at $id
6908 if {[info exists idheads($id)]} {
6909 lappend ah $id
6912 set arctags($a) $at
6913 set archeads($a) $ah
6916 proc splitarc {p} {
6917 global arcnos arcids nextarc arctags archeads idtags idheads
6918 global arcstart arcend arcout allparents growing
6920 set a $arcnos($p)
6921 if {[llength $a] != 1} {
6922 puts "oops splitarc called but [llength $a] arcs already"
6923 return
6925 set a [lindex $a 0]
6926 set i [lsearch -exact $arcids($a) $p]
6927 if {$i < 0} {
6928 puts "oops splitarc $p not in arc $a"
6929 return
6931 set na [incr nextarc]
6932 if {[info exists arcend($a)]} {
6933 set arcend($na) $arcend($a)
6934 } else {
6935 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6936 set j [lsearch -exact $arcnos($l) $a]
6937 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6939 set tail [lrange $arcids($a) [expr {$i+1}] end]
6940 set arcids($a) [lrange $arcids($a) 0 $i]
6941 set arcend($a) $p
6942 set arcstart($na) $p
6943 set arcout($p) $na
6944 set arcids($na) $tail
6945 if {[info exists growing($a)]} {
6946 set growing($na) 1
6947 unset growing($a)
6950 foreach id $tail {
6951 if {[llength $arcnos($id)] == 1} {
6952 set arcnos($id) $na
6953 } else {
6954 set j [lsearch -exact $arcnos($id) $a]
6955 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6959 # reconstruct tags and heads lists
6960 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6961 recalcarc $a
6962 recalcarc $na
6963 } else {
6964 set arctags($na) {}
6965 set archeads($na) {}
6969 # Update things for a new commit added that is a child of one
6970 # existing commit. Used when cherry-picking.
6971 proc addnewchild {id p} {
6972 global allparents allchildren idtags nextarc
6973 global arcnos arcids arctags arcout arcend arcstart archeads growing
6974 global seeds allcommits
6976 if {![info exists allcommits]} return
6977 set allparents($id) [list $p]
6978 set allchildren($id) {}
6979 set arcnos($id) {}
6980 lappend seeds $id
6981 lappend allchildren($p) $id
6982 set a [incr nextarc]
6983 set arcstart($a) $id
6984 set archeads($a) {}
6985 set arctags($a) {}
6986 set arcids($a) [list $p]
6987 set arcend($a) $p
6988 if {![info exists arcout($p)]} {
6989 splitarc $p
6991 lappend arcnos($p) $a
6992 set arcout($id) [list $a]
6995 # This implements a cache for the topology information.
6996 # The cache saves, for each arc, the start and end of the arc,
6997 # the ids on the arc, and the outgoing arcs from the end.
6998 proc readcache {f} {
6999 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7000 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7001 global allcwait
7003 set a $nextarc
7004 set lim $cachedarcs
7005 if {$lim - $a > 500} {
7006 set lim [expr {$a + 500}]
7008 if {[catch {
7009 if {$a == $lim} {
7010 # finish reading the cache and setting up arctags, etc.
7011 set line [gets $f]
7012 if {$line ne "1"} {error "bad final version"}
7013 close $f
7014 foreach id [array names idtags] {
7015 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7016 [llength $allparents($id)] == 1} {
7017 set a [lindex $arcnos($id) 0]
7018 if {$arctags($a) eq {}} {
7019 recalcarc $a
7023 foreach id [array names idheads] {
7024 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7025 [llength $allparents($id)] == 1} {
7026 set a [lindex $arcnos($id) 0]
7027 if {$archeads($a) eq {}} {
7028 recalcarc $a
7032 foreach id [lsort -unique $possible_seeds] {
7033 if {$arcnos($id) eq {}} {
7034 lappend seeds $id
7037 set allcwait 0
7038 } else {
7039 while {[incr a] <= $lim} {
7040 set line [gets $f]
7041 if {[llength $line] != 3} {error "bad line"}
7042 set s [lindex $line 0]
7043 set arcstart($a) $s
7044 lappend arcout($s) $a
7045 if {![info exists arcnos($s)]} {
7046 lappend possible_seeds $s
7047 set arcnos($s) {}
7049 set e [lindex $line 1]
7050 if {$e eq {}} {
7051 set growing($a) 1
7052 } else {
7053 set arcend($a) $e
7054 if {![info exists arcout($e)]} {
7055 set arcout($e) {}
7058 set arcids($a) [lindex $line 2]
7059 foreach id $arcids($a) {
7060 lappend allparents($s) $id
7061 set s $id
7062 lappend arcnos($id) $a
7064 if {![info exists allparents($s)]} {
7065 set allparents($s) {}
7067 set arctags($a) {}
7068 set archeads($a) {}
7070 set nextarc [expr {$a - 1}]
7072 } err]} {
7073 dropcache $err
7074 return 0
7076 if {!$allcwait} {
7077 getallcommits
7079 return $allcwait
7082 proc getcache {f} {
7083 global nextarc cachedarcs possible_seeds
7085 if {[catch {
7086 set line [gets $f]
7087 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7088 # make sure it's an integer
7089 set cachedarcs [expr {int([lindex $line 1])}]
7090 if {$cachedarcs < 0} {error "bad number of arcs"}
7091 set nextarc 0
7092 set possible_seeds {}
7093 run readcache $f
7094 } err]} {
7095 dropcache $err
7097 return 0
7100 proc dropcache {err} {
7101 global allcwait nextarc cachedarcs seeds
7103 #puts "dropping cache ($err)"
7104 foreach v {arcnos arcout arcids arcstart arcend growing \
7105 arctags archeads allparents allchildren} {
7106 global $v
7107 catch {unset $v}
7109 set allcwait 0
7110 set nextarc 0
7111 set cachedarcs 0
7112 set seeds {}
7113 getallcommits
7116 proc writecache {f} {
7117 global cachearc cachedarcs allccache
7118 global arcstart arcend arcnos arcids arcout
7120 set a $cachearc
7121 set lim $cachedarcs
7122 if {$lim - $a > 1000} {
7123 set lim [expr {$a + 1000}]
7125 if {[catch {
7126 while {[incr a] <= $lim} {
7127 if {[info exists arcend($a)]} {
7128 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7129 } else {
7130 puts $f [list $arcstart($a) {} $arcids($a)]
7133 } err]} {
7134 catch {close $f}
7135 catch {file delete $allccache}
7136 #puts "writing cache failed ($err)"
7137 return 0
7139 set cachearc [expr {$a - 1}]
7140 if {$a > $cachedarcs} {
7141 puts $f "1"
7142 close $f
7143 return 0
7145 return 1
7148 proc savecache {} {
7149 global nextarc cachedarcs cachearc allccache
7151 if {$nextarc == $cachedarcs} return
7152 set cachearc 0
7153 set cachedarcs $nextarc
7154 catch {
7155 set f [open $allccache w]
7156 puts $f [list 1 $cachedarcs]
7157 run writecache $f
7161 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7162 # or 0 if neither is true.
7163 proc anc_or_desc {a b} {
7164 global arcout arcstart arcend arcnos cached_isanc
7166 if {$arcnos($a) eq $arcnos($b)} {
7167 # Both are on the same arc(s); either both are the same BMP,
7168 # or if one is not a BMP, the other is also not a BMP or is
7169 # the BMP at end of the arc (and it only has 1 incoming arc).
7170 # Or both can be BMPs with no incoming arcs.
7171 if {$a eq $b || $arcnos($a) eq {}} {
7172 return 0
7174 # assert {[llength $arcnos($a)] == 1}
7175 set arc [lindex $arcnos($a) 0]
7176 set i [lsearch -exact $arcids($arc) $a]
7177 set j [lsearch -exact $arcids($arc) $b]
7178 if {$i < 0 || $i > $j} {
7179 return 1
7180 } else {
7181 return -1
7185 if {![info exists arcout($a)]} {
7186 set arc [lindex $arcnos($a) 0]
7187 if {[info exists arcend($arc)]} {
7188 set aend $arcend($arc)
7189 } else {
7190 set aend {}
7192 set a $arcstart($arc)
7193 } else {
7194 set aend $a
7196 if {![info exists arcout($b)]} {
7197 set arc [lindex $arcnos($b) 0]
7198 if {[info exists arcend($arc)]} {
7199 set bend $arcend($arc)
7200 } else {
7201 set bend {}
7203 set b $arcstart($arc)
7204 } else {
7205 set bend $b
7207 if {$a eq $bend} {
7208 return 1
7210 if {$b eq $aend} {
7211 return -1
7213 if {[info exists cached_isanc($a,$bend)]} {
7214 if {$cached_isanc($a,$bend)} {
7215 return 1
7218 if {[info exists cached_isanc($b,$aend)]} {
7219 if {$cached_isanc($b,$aend)} {
7220 return -1
7222 if {[info exists cached_isanc($a,$bend)]} {
7223 return 0
7227 set todo [list $a $b]
7228 set anc($a) a
7229 set anc($b) b
7230 for {set i 0} {$i < [llength $todo]} {incr i} {
7231 set x [lindex $todo $i]
7232 if {$anc($x) eq {}} {
7233 continue
7235 foreach arc $arcnos($x) {
7236 set xd $arcstart($arc)
7237 if {$xd eq $bend} {
7238 set cached_isanc($a,$bend) 1
7239 set cached_isanc($b,$aend) 0
7240 return 1
7241 } elseif {$xd eq $aend} {
7242 set cached_isanc($b,$aend) 1
7243 set cached_isanc($a,$bend) 0
7244 return -1
7246 if {![info exists anc($xd)]} {
7247 set anc($xd) $anc($x)
7248 lappend todo $xd
7249 } elseif {$anc($xd) ne $anc($x)} {
7250 set anc($xd) {}
7254 set cached_isanc($a,$bend) 0
7255 set cached_isanc($b,$aend) 0
7256 return 0
7259 # This identifies whether $desc has an ancestor that is
7260 # a growing tip of the graph and which is not an ancestor of $anc
7261 # and returns 0 if so and 1 if not.
7262 # If we subsequently discover a tag on such a growing tip, and that
7263 # turns out to be a descendent of $anc (which it could, since we
7264 # don't necessarily see children before parents), then $desc
7265 # isn't a good choice to display as a descendent tag of
7266 # $anc (since it is the descendent of another tag which is
7267 # a descendent of $anc). Similarly, $anc isn't a good choice to
7268 # display as a ancestor tag of $desc.
7270 proc is_certain {desc anc} {
7271 global arcnos arcout arcstart arcend growing problems
7273 set certain {}
7274 if {[llength $arcnos($anc)] == 1} {
7275 # tags on the same arc are certain
7276 if {$arcnos($desc) eq $arcnos($anc)} {
7277 return 1
7279 if {![info exists arcout($anc)]} {
7280 # if $anc is partway along an arc, use the start of the arc instead
7281 set a [lindex $arcnos($anc) 0]
7282 set anc $arcstart($a)
7285 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7286 set x $desc
7287 } else {
7288 set a [lindex $arcnos($desc) 0]
7289 set x $arcend($a)
7291 if {$x == $anc} {
7292 return 1
7294 set anclist [list $x]
7295 set dl($x) 1
7296 set nnh 1
7297 set ngrowanc 0
7298 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7299 set x [lindex $anclist $i]
7300 if {$dl($x)} {
7301 incr nnh -1
7303 set done($x) 1
7304 foreach a $arcout($x) {
7305 if {[info exists growing($a)]} {
7306 if {![info exists growanc($x)] && $dl($x)} {
7307 set growanc($x) 1
7308 incr ngrowanc
7310 } else {
7311 set y $arcend($a)
7312 if {[info exists dl($y)]} {
7313 if {$dl($y)} {
7314 if {!$dl($x)} {
7315 set dl($y) 0
7316 if {![info exists done($y)]} {
7317 incr nnh -1
7319 if {[info exists growanc($x)]} {
7320 incr ngrowanc -1
7322 set xl [list $y]
7323 for {set k 0} {$k < [llength $xl]} {incr k} {
7324 set z [lindex $xl $k]
7325 foreach c $arcout($z) {
7326 if {[info exists arcend($c)]} {
7327 set v $arcend($c)
7328 if {[info exists dl($v)] && $dl($v)} {
7329 set dl($v) 0
7330 if {![info exists done($v)]} {
7331 incr nnh -1
7333 if {[info exists growanc($v)]} {
7334 incr ngrowanc -1
7336 lappend xl $v
7343 } elseif {$y eq $anc || !$dl($x)} {
7344 set dl($y) 0
7345 lappend anclist $y
7346 } else {
7347 set dl($y) 1
7348 lappend anclist $y
7349 incr nnh
7354 foreach x [array names growanc] {
7355 if {$dl($x)} {
7356 return 0
7358 return 0
7360 return 1
7363 proc validate_arctags {a} {
7364 global arctags idtags
7366 set i -1
7367 set na $arctags($a)
7368 foreach id $arctags($a) {
7369 incr i
7370 if {![info exists idtags($id)]} {
7371 set na [lreplace $na $i $i]
7372 incr i -1
7375 set arctags($a) $na
7378 proc validate_archeads {a} {
7379 global archeads idheads
7381 set i -1
7382 set na $archeads($a)
7383 foreach id $archeads($a) {
7384 incr i
7385 if {![info exists idheads($id)]} {
7386 set na [lreplace $na $i $i]
7387 incr i -1
7390 set archeads($a) $na
7393 # Return the list of IDs that have tags that are descendents of id,
7394 # ignoring IDs that are descendents of IDs already reported.
7395 proc desctags {id} {
7396 global arcnos arcstart arcids arctags idtags allparents
7397 global growing cached_dtags
7399 if {![info exists allparents($id)]} {
7400 return {}
7402 set t1 [clock clicks -milliseconds]
7403 set argid $id
7404 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7405 # part-way along an arc; check that arc first
7406 set a [lindex $arcnos($id) 0]
7407 if {$arctags($a) ne {}} {
7408 validate_arctags $a
7409 set i [lsearch -exact $arcids($a) $id]
7410 set tid {}
7411 foreach t $arctags($a) {
7412 set j [lsearch -exact $arcids($a) $t]
7413 if {$j >= $i} break
7414 set tid $t
7416 if {$tid ne {}} {
7417 return $tid
7420 set id $arcstart($a)
7421 if {[info exists idtags($id)]} {
7422 return $id
7425 if {[info exists cached_dtags($id)]} {
7426 return $cached_dtags($id)
7429 set origid $id
7430 set todo [list $id]
7431 set queued($id) 1
7432 set nc 1
7433 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7434 set id [lindex $todo $i]
7435 set done($id) 1
7436 set ta [info exists hastaggedancestor($id)]
7437 if {!$ta} {
7438 incr nc -1
7440 # ignore tags on starting node
7441 if {!$ta && $i > 0} {
7442 if {[info exists idtags($id)]} {
7443 set tagloc($id) $id
7444 set ta 1
7445 } elseif {[info exists cached_dtags($id)]} {
7446 set tagloc($id) $cached_dtags($id)
7447 set ta 1
7450 foreach a $arcnos($id) {
7451 set d $arcstart($a)
7452 if {!$ta && $arctags($a) ne {}} {
7453 validate_arctags $a
7454 if {$arctags($a) ne {}} {
7455 lappend tagloc($id) [lindex $arctags($a) end]
7458 if {$ta || $arctags($a) ne {}} {
7459 set tomark [list $d]
7460 for {set j 0} {$j < [llength $tomark]} {incr j} {
7461 set dd [lindex $tomark $j]
7462 if {![info exists hastaggedancestor($dd)]} {
7463 if {[info exists done($dd)]} {
7464 foreach b $arcnos($dd) {
7465 lappend tomark $arcstart($b)
7467 if {[info exists tagloc($dd)]} {
7468 unset tagloc($dd)
7470 } elseif {[info exists queued($dd)]} {
7471 incr nc -1
7473 set hastaggedancestor($dd) 1
7477 if {![info exists queued($d)]} {
7478 lappend todo $d
7479 set queued($d) 1
7480 if {![info exists hastaggedancestor($d)]} {
7481 incr nc
7486 set tags {}
7487 foreach id [array names tagloc] {
7488 if {![info exists hastaggedancestor($id)]} {
7489 foreach t $tagloc($id) {
7490 if {[lsearch -exact $tags $t] < 0} {
7491 lappend tags $t
7496 set t2 [clock clicks -milliseconds]
7497 set loopix $i
7499 # remove tags that are descendents of other tags
7500 for {set i 0} {$i < [llength $tags]} {incr i} {
7501 set a [lindex $tags $i]
7502 for {set j 0} {$j < $i} {incr j} {
7503 set b [lindex $tags $j]
7504 set r [anc_or_desc $a $b]
7505 if {$r == 1} {
7506 set tags [lreplace $tags $j $j]
7507 incr j -1
7508 incr i -1
7509 } elseif {$r == -1} {
7510 set tags [lreplace $tags $i $i]
7511 incr i -1
7512 break
7517 if {[array names growing] ne {}} {
7518 # graph isn't finished, need to check if any tag could get
7519 # eclipsed by another tag coming later. Simply ignore any
7520 # tags that could later get eclipsed.
7521 set ctags {}
7522 foreach t $tags {
7523 if {[is_certain $t $origid]} {
7524 lappend ctags $t
7527 if {$tags eq $ctags} {
7528 set cached_dtags($origid) $tags
7529 } else {
7530 set tags $ctags
7532 } else {
7533 set cached_dtags($origid) $tags
7535 set t3 [clock clicks -milliseconds]
7536 if {0 && $t3 - $t1 >= 100} {
7537 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7538 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7540 return $tags
7543 proc anctags {id} {
7544 global arcnos arcids arcout arcend arctags idtags allparents
7545 global growing cached_atags
7547 if {![info exists allparents($id)]} {
7548 return {}
7550 set t1 [clock clicks -milliseconds]
7551 set argid $id
7552 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7553 # part-way along an arc; check that arc first
7554 set a [lindex $arcnos($id) 0]
7555 if {$arctags($a) ne {}} {
7556 validate_arctags $a
7557 set i [lsearch -exact $arcids($a) $id]
7558 foreach t $arctags($a) {
7559 set j [lsearch -exact $arcids($a) $t]
7560 if {$j > $i} {
7561 return $t
7565 if {![info exists arcend($a)]} {
7566 return {}
7568 set id $arcend($a)
7569 if {[info exists idtags($id)]} {
7570 return $id
7573 if {[info exists cached_atags($id)]} {
7574 return $cached_atags($id)
7577 set origid $id
7578 set todo [list $id]
7579 set queued($id) 1
7580 set taglist {}
7581 set nc 1
7582 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7583 set id [lindex $todo $i]
7584 set done($id) 1
7585 set td [info exists hastaggeddescendent($id)]
7586 if {!$td} {
7587 incr nc -1
7589 # ignore tags on starting node
7590 if {!$td && $i > 0} {
7591 if {[info exists idtags($id)]} {
7592 set tagloc($id) $id
7593 set td 1
7594 } elseif {[info exists cached_atags($id)]} {
7595 set tagloc($id) $cached_atags($id)
7596 set td 1
7599 foreach a $arcout($id) {
7600 if {!$td && $arctags($a) ne {}} {
7601 validate_arctags $a
7602 if {$arctags($a) ne {}} {
7603 lappend tagloc($id) [lindex $arctags($a) 0]
7606 if {![info exists arcend($a)]} continue
7607 set d $arcend($a)
7608 if {$td || $arctags($a) ne {}} {
7609 set tomark [list $d]
7610 for {set j 0} {$j < [llength $tomark]} {incr j} {
7611 set dd [lindex $tomark $j]
7612 if {![info exists hastaggeddescendent($dd)]} {
7613 if {[info exists done($dd)]} {
7614 foreach b $arcout($dd) {
7615 if {[info exists arcend($b)]} {
7616 lappend tomark $arcend($b)
7619 if {[info exists tagloc($dd)]} {
7620 unset tagloc($dd)
7622 } elseif {[info exists queued($dd)]} {
7623 incr nc -1
7625 set hastaggeddescendent($dd) 1
7629 if {![info exists queued($d)]} {
7630 lappend todo $d
7631 set queued($d) 1
7632 if {![info exists hastaggeddescendent($d)]} {
7633 incr nc
7638 set t2 [clock clicks -milliseconds]
7639 set loopix $i
7640 set tags {}
7641 foreach id [array names tagloc] {
7642 if {![info exists hastaggeddescendent($id)]} {
7643 foreach t $tagloc($id) {
7644 if {[lsearch -exact $tags $t] < 0} {
7645 lappend tags $t
7651 # remove tags that are ancestors of other tags
7652 for {set i 0} {$i < [llength $tags]} {incr i} {
7653 set a [lindex $tags $i]
7654 for {set j 0} {$j < $i} {incr j} {
7655 set b [lindex $tags $j]
7656 set r [anc_or_desc $a $b]
7657 if {$r == -1} {
7658 set tags [lreplace $tags $j $j]
7659 incr j -1
7660 incr i -1
7661 } elseif {$r == 1} {
7662 set tags [lreplace $tags $i $i]
7663 incr i -1
7664 break
7669 if {[array names growing] ne {}} {
7670 # graph isn't finished, need to check if any tag could get
7671 # eclipsed by another tag coming later. Simply ignore any
7672 # tags that could later get eclipsed.
7673 set ctags {}
7674 foreach t $tags {
7675 if {[is_certain $origid $t]} {
7676 lappend ctags $t
7679 if {$tags eq $ctags} {
7680 set cached_atags($origid) $tags
7681 } else {
7682 set tags $ctags
7684 } else {
7685 set cached_atags($origid) $tags
7687 set t3 [clock clicks -milliseconds]
7688 if {0 && $t3 - $t1 >= 100} {
7689 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7690 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7692 return $tags
7695 # Return the list of IDs that have heads that are descendents of id,
7696 # including id itself if it has a head.
7697 proc descheads {id} {
7698 global arcnos arcstart arcids archeads idheads cached_dheads
7699 global allparents
7701 if {![info exists allparents($id)]} {
7702 return {}
7704 set aret {}
7705 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7706 # part-way along an arc; check it first
7707 set a [lindex $arcnos($id) 0]
7708 if {$archeads($a) ne {}} {
7709 validate_archeads $a
7710 set i [lsearch -exact $arcids($a) $id]
7711 foreach t $archeads($a) {
7712 set j [lsearch -exact $arcids($a) $t]
7713 if {$j > $i} break
7714 lappend aret $t
7717 set id $arcstart($a)
7719 set origid $id
7720 set todo [list $id]
7721 set seen($id) 1
7722 set ret {}
7723 for {set i 0} {$i < [llength $todo]} {incr i} {
7724 set id [lindex $todo $i]
7725 if {[info exists cached_dheads($id)]} {
7726 set ret [concat $ret $cached_dheads($id)]
7727 } else {
7728 if {[info exists idheads($id)]} {
7729 lappend ret $id
7731 foreach a $arcnos($id) {
7732 if {$archeads($a) ne {}} {
7733 validate_archeads $a
7734 if {$archeads($a) ne {}} {
7735 set ret [concat $ret $archeads($a)]
7738 set d $arcstart($a)
7739 if {![info exists seen($d)]} {
7740 lappend todo $d
7741 set seen($d) 1
7746 set ret [lsort -unique $ret]
7747 set cached_dheads($origid) $ret
7748 return [concat $ret $aret]
7751 proc addedtag {id} {
7752 global arcnos arcout cached_dtags cached_atags
7754 if {![info exists arcnos($id)]} return
7755 if {![info exists arcout($id)]} {
7756 recalcarc [lindex $arcnos($id) 0]
7758 catch {unset cached_dtags}
7759 catch {unset cached_atags}
7762 proc addedhead {hid head} {
7763 global arcnos arcout cached_dheads
7765 if {![info exists arcnos($hid)]} return
7766 if {![info exists arcout($hid)]} {
7767 recalcarc [lindex $arcnos($hid) 0]
7769 catch {unset cached_dheads}
7772 proc removedhead {hid head} {
7773 global cached_dheads
7775 catch {unset cached_dheads}
7778 proc movedhead {hid head} {
7779 global arcnos arcout cached_dheads
7781 if {![info exists arcnos($hid)]} return
7782 if {![info exists arcout($hid)]} {
7783 recalcarc [lindex $arcnos($hid) 0]
7785 catch {unset cached_dheads}
7788 proc changedrefs {} {
7789 global cached_dheads cached_dtags cached_atags
7790 global arctags archeads arcnos arcout idheads idtags
7792 foreach id [concat [array names idheads] [array names idtags]] {
7793 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7794 set a [lindex $arcnos($id) 0]
7795 if {![info exists donearc($a)]} {
7796 recalcarc $a
7797 set donearc($a) 1
7801 catch {unset cached_dtags}
7802 catch {unset cached_atags}
7803 catch {unset cached_dheads}
7806 proc rereadrefs {} {
7807 global idtags idheads idotherrefs mainhead
7809 set refids [concat [array names idtags] \
7810 [array names idheads] [array names idotherrefs]]
7811 foreach id $refids {
7812 if {![info exists ref($id)]} {
7813 set ref($id) [listrefs $id]
7816 set oldmainhead $mainhead
7817 readrefs
7818 changedrefs
7819 set refids [lsort -unique [concat $refids [array names idtags] \
7820 [array names idheads] [array names idotherrefs]]]
7821 foreach id $refids {
7822 set v [listrefs $id]
7823 if {![info exists ref($id)] || $ref($id) != $v ||
7824 ($id eq $oldmainhead && $id ne $mainhead) ||
7825 ($id eq $mainhead && $id ne $oldmainhead)} {
7826 redrawtags $id
7829 run refill_reflist
7832 proc listrefs {id} {
7833 global idtags idheads idotherrefs
7835 set x {}
7836 if {[info exists idtags($id)]} {
7837 set x $idtags($id)
7839 set y {}
7840 if {[info exists idheads($id)]} {
7841 set y $idheads($id)
7843 set z {}
7844 if {[info exists idotherrefs($id)]} {
7845 set z $idotherrefs($id)
7847 return [list $x $y $z]
7850 proc showtag {tag isnew} {
7851 global ctext tagcontents tagids linknum tagobjid
7853 if {$isnew} {
7854 addtohistory [list showtag $tag 0]
7856 $ctext conf -state normal
7857 clear_ctext
7858 settabs 0
7859 set linknum 0
7860 if {![info exists tagcontents($tag)]} {
7861 catch {
7862 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7865 if {[info exists tagcontents($tag)]} {
7866 set text $tagcontents($tag)
7867 } else {
7868 set text "Tag: $tag\nId: $tagids($tag)"
7870 appendwithlinks $text {}
7871 $ctext conf -state disabled
7872 init_flist {}
7875 proc doquit {} {
7876 global stopped
7877 set stopped 100
7878 savestuff .
7879 destroy .
7882 proc mkfontdisp {font top which} {
7883 global fontattr fontpref $font
7885 set fontpref($font) [set $font]
7886 button $top.${font}but -text $which -font optionfont \
7887 -command [list choosefont $font $which]
7888 label $top.$font -relief flat -font $font \
7889 -text $fontattr($font,family) -justify left
7890 grid x $top.${font}but $top.$font -sticky w
7893 proc choosefont {font which} {
7894 global fontparam fontlist fonttop fontattr
7896 set fontparam(which) $which
7897 set fontparam(font) $font
7898 set fontparam(family) [font actual $font -family]
7899 set fontparam(size) $fontattr($font,size)
7900 set fontparam(weight) $fontattr($font,weight)
7901 set fontparam(slant) $fontattr($font,slant)
7902 set top .gitkfont
7903 set fonttop $top
7904 if {![winfo exists $top]} {
7905 font create sample
7906 eval font config sample [font actual $font]
7907 toplevel $top
7908 wm title $top "Gitk font chooser"
7909 label $top.l -textvariable fontparam(which) -font uifont
7910 pack $top.l -side top
7911 set fontlist [lsort [font families]]
7912 frame $top.f
7913 listbox $top.f.fam -listvariable fontlist \
7914 -yscrollcommand [list $top.f.sb set]
7915 bind $top.f.fam <<ListboxSelect>> selfontfam
7916 scrollbar $top.f.sb -command [list $top.f.fam yview]
7917 pack $top.f.sb -side right -fill y
7918 pack $top.f.fam -side left -fill both -expand 1
7919 pack $top.f -side top -fill both -expand 1
7920 frame $top.g
7921 spinbox $top.g.size -from 4 -to 40 -width 4 \
7922 -textvariable fontparam(size) \
7923 -validatecommand {string is integer -strict %s}
7924 checkbutton $top.g.bold -padx 5 \
7925 -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
7926 -variable fontparam(weight) -onvalue bold -offvalue normal
7927 checkbutton $top.g.ital -padx 5 \
7928 -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0 \
7929 -variable fontparam(slant) -onvalue italic -offvalue roman
7930 pack $top.g.size $top.g.bold $top.g.ital -side left
7931 pack $top.g -side top
7932 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7933 -background white
7934 $top.c create text 100 25 -anchor center -text $which -font sample \
7935 -fill black -tags text
7936 bind $top.c <Configure> [list centertext $top.c]
7937 pack $top.c -side top -fill x
7938 frame $top.buts
7939 button $top.buts.ok -text "OK" -command fontok -default active \
7940 -font uifont
7941 button $top.buts.can -text "Cancel" -command fontcan -default normal \
7942 -font uifont
7943 grid $top.buts.ok $top.buts.can
7944 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7945 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7946 pack $top.buts -side bottom -fill x
7947 trace add variable fontparam write chg_fontparam
7948 } else {
7949 raise $top
7950 $top.c itemconf text -text $which
7952 set i [lsearch -exact $fontlist $fontparam(family)]
7953 if {$i >= 0} {
7954 $top.f.fam selection set $i
7955 $top.f.fam see $i
7959 proc centertext {w} {
7960 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7963 proc fontok {} {
7964 global fontparam fontpref prefstop
7966 set f $fontparam(font)
7967 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7968 if {$fontparam(weight) eq "bold"} {
7969 lappend fontpref($f) "bold"
7971 if {$fontparam(slant) eq "italic"} {
7972 lappend fontpref($f) "italic"
7974 set w $prefstop.$f
7975 $w conf -text $fontparam(family) -font $fontpref($f)
7977 fontcan
7980 proc fontcan {} {
7981 global fonttop fontparam
7983 if {[info exists fonttop]} {
7984 catch {destroy $fonttop}
7985 catch {font delete sample}
7986 unset fonttop
7987 unset fontparam
7991 proc selfontfam {} {
7992 global fonttop fontparam
7994 set i [$fonttop.f.fam curselection]
7995 if {$i ne {}} {
7996 set fontparam(family) [$fonttop.f.fam get $i]
8000 proc chg_fontparam {v sub op} {
8001 global fontparam
8003 font config sample -$sub $fontparam($sub)
8006 proc doprefs {} {
8007 global maxwidth maxgraphpct
8008 global oldprefs prefstop showneartags showlocalchanges
8009 global bgcolor fgcolor ctext diffcolors selectbgcolor
8010 global uifont tabstop
8012 set top .gitkprefs
8013 set prefstop $top
8014 if {[winfo exists $top]} {
8015 raise $top
8016 return
8018 foreach v {maxwidth maxgraphpct showneartags showlocalchanges} {
8019 set oldprefs($v) [set $v]
8021 toplevel $top
8022 wm title $top "Gitk preferences"
8023 label $top.ldisp -text "Commit list display options"
8024 $top.ldisp configure -font uifont
8025 grid $top.ldisp - -sticky w -pady 10
8026 label $top.spacer -text " "
8027 label $top.maxwidthl -text "Maximum graph width (lines)" \
8028 -font optionfont
8029 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8030 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8031 label $top.maxpctl -text "Maximum graph width (% of pane)" \
8032 -font optionfont
8033 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8034 grid x $top.maxpctl $top.maxpct -sticky w
8035 frame $top.showlocal
8036 label $top.showlocal.l -text "Show local changes" -font optionfont
8037 checkbutton $top.showlocal.b -variable showlocalchanges
8038 pack $top.showlocal.b $top.showlocal.l -side left
8039 grid x $top.showlocal -sticky w
8041 label $top.ddisp -text "Diff display options"
8042 $top.ddisp configure -font uifont
8043 grid $top.ddisp - -sticky w -pady 10
8044 frame $top.ntag
8045 label $top.ntag.l -text "Display nearby tags" -font optionfont
8046 checkbutton $top.ntag.b -variable showneartags
8047 pack $top.ntag.b $top.ntag.l -side left
8048 grid x $top.ntag -sticky w
8049 label $top.tabstopl -text "tabstop" -font optionfont
8050 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8051 grid x $top.tabstopl $top.tabstop -sticky w
8053 label $top.cdisp -text "Colors: press to choose"
8054 $top.cdisp configure -font uifont
8055 grid $top.cdisp - -sticky w -pady 10
8056 label $top.bg -padx 40 -relief sunk -background $bgcolor
8057 button $top.bgbut -text "Background" -font optionfont \
8058 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8059 grid x $top.bgbut $top.bg -sticky w
8060 label $top.fg -padx 40 -relief sunk -background $fgcolor
8061 button $top.fgbut -text "Foreground" -font optionfont \
8062 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8063 grid x $top.fgbut $top.fg -sticky w
8064 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8065 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8066 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8067 [list $ctext tag conf d0 -foreground]]
8068 grid x $top.diffoldbut $top.diffold -sticky w
8069 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8070 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8071 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8072 [list $ctext tag conf d1 -foreground]]
8073 grid x $top.diffnewbut $top.diffnew -sticky w
8074 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8075 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8076 -command [list choosecolor diffcolors 2 $top.hunksep \
8077 "diff hunk header" \
8078 [list $ctext tag conf hunksep -foreground]]
8079 grid x $top.hunksepbut $top.hunksep -sticky w
8080 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8081 button $top.selbgbut -text "Select bg" -font optionfont \
8082 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8083 grid x $top.selbgbut $top.selbgsep -sticky w
8085 label $top.cfont -text "Fonts: press to choose"
8086 $top.cfont configure -font uifont
8087 grid $top.cfont - -sticky w -pady 10
8088 mkfontdisp mainfont $top "Main font"
8089 mkfontdisp textfont $top "Diff display font"
8090 mkfontdisp uifont $top "User interface font"
8092 frame $top.buts
8093 button $top.buts.ok -text "OK" -command prefsok -default active
8094 $top.buts.ok configure -font uifont
8095 button $top.buts.can -text "Cancel" -command prefscan -default normal
8096 $top.buts.can configure -font uifont
8097 grid $top.buts.ok $top.buts.can
8098 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8099 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8100 grid $top.buts - - -pady 10 -sticky ew
8101 bind $top <Visibility> "focus $top.buts.ok"
8104 proc choosecolor {v vi w x cmd} {
8105 global $v
8107 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8108 -title "Gitk: choose color for $x"]
8109 if {$c eq {}} return
8110 $w conf -background $c
8111 lset $v $vi $c
8112 eval $cmd $c
8115 proc setselbg {c} {
8116 global bglist cflist
8117 foreach w $bglist {
8118 $w configure -selectbackground $c
8120 $cflist tag configure highlight \
8121 -background [$cflist cget -selectbackground]
8122 allcanvs itemconf secsel -fill $c
8125 proc setbg {c} {
8126 global bglist
8128 foreach w $bglist {
8129 $w conf -background $c
8133 proc setfg {c} {
8134 global fglist canv
8136 foreach w $fglist {
8137 $w conf -foreground $c
8139 allcanvs itemconf text -fill $c
8140 $canv itemconf circle -outline $c
8143 proc prefscan {} {
8144 global maxwidth maxgraphpct
8145 global oldprefs prefstop showneartags showlocalchanges
8147 foreach v {maxwidth maxgraphpct showneartags showlocalchanges} {
8148 set $v $oldprefs($v)
8150 catch {destroy $prefstop}
8151 unset prefstop
8152 fontcan
8155 proc prefsok {} {
8156 global maxwidth maxgraphpct
8157 global oldprefs prefstop showneartags showlocalchanges
8158 global fontpref mainfont textfont uifont
8160 catch {destroy $prefstop}
8161 unset prefstop
8162 fontcan
8163 set fontchanged 0
8164 if {$mainfont ne $fontpref(mainfont)} {
8165 set mainfont $fontpref(mainfont)
8166 parsefont mainfont $mainfont
8167 eval font configure mainfont [fontflags mainfont]
8168 eval font configure mainfontbold [fontflags mainfont 1]
8169 setcoords
8170 set fontchanged 1
8172 if {$textfont ne $fontpref(textfont)} {
8173 set textfont $fontpref(textfont)
8174 parsefont textfont $textfont
8175 eval font configure textfont [fontflags textfont]
8176 eval font configure textfontbold [fontflags textfont 1]
8178 if {$uifont ne $fontpref(uifont)} {
8179 set uifont $fontpref(uifont)
8180 parsefont uifont $uifont
8181 eval font configure uifont [fontflags uifont]
8183 settabs
8184 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8185 if {$showlocalchanges} {
8186 doshowlocalchanges
8187 } else {
8188 dohidelocalchanges
8191 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8192 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8193 redisplay
8194 } elseif {$showneartags != $oldprefs(showneartags)} {
8195 reselectline
8199 proc formatdate {d} {
8200 global datetimeformat
8201 if {$d ne {}} {
8202 set d [clock format $d -format $datetimeformat]
8204 return $d
8207 # This list of encoding names and aliases is distilled from
8208 # http://www.iana.org/assignments/character-sets.
8209 # Not all of them are supported by Tcl.
8210 set encoding_aliases {
8211 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8212 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8213 { ISO-10646-UTF-1 csISO10646UTF1 }
8214 { ISO_646.basic:1983 ref csISO646basic1983 }
8215 { INVARIANT csINVARIANT }
8216 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8217 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8218 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8219 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8220 { NATS-DANO iso-ir-9-1 csNATSDANO }
8221 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8222 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8223 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8224 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8225 { ISO-2022-KR csISO2022KR }
8226 { EUC-KR csEUCKR }
8227 { ISO-2022-JP csISO2022JP }
8228 { ISO-2022-JP-2 csISO2022JP2 }
8229 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8230 csISO13JISC6220jp }
8231 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8232 { IT iso-ir-15 ISO646-IT csISO15Italian }
8233 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8234 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8235 { greek7-old iso-ir-18 csISO18Greek7Old }
8236 { latin-greek iso-ir-19 csISO19LatinGreek }
8237 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8238 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8239 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8240 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8241 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8242 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8243 { INIS iso-ir-49 csISO49INIS }
8244 { INIS-8 iso-ir-50 csISO50INIS8 }
8245 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8246 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8247 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8248 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8249 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8250 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8251 csISO60Norwegian1 }
8252 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8253 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8254 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8255 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8256 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8257 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8258 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8259 { greek7 iso-ir-88 csISO88Greek7 }
8260 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8261 { iso-ir-90 csISO90 }
8262 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8263 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8264 csISO92JISC62991984b }
8265 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8266 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8267 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8268 csISO95JIS62291984handadd }
8269 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8270 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8271 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8272 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8273 CP819 csISOLatin1 }
8274 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8275 { T.61-7bit iso-ir-102 csISO102T617bit }
8276 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8277 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8278 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8279 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8280 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8281 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8282 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8283 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8284 arabic csISOLatinArabic }
8285 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8286 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8287 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8288 greek greek8 csISOLatinGreek }
8289 { T.101-G2 iso-ir-128 csISO128T101G2 }
8290 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8291 csISOLatinHebrew }
8292 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8293 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8294 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8295 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8296 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8297 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8298 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8299 csISOLatinCyrillic }
8300 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8301 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8302 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8303 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8304 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8305 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8306 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8307 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8308 { ISO_10367-box iso-ir-155 csISO10367Box }
8309 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8310 { latin-lap lap iso-ir-158 csISO158Lap }
8311 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8312 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8313 { us-dk csUSDK }
8314 { dk-us csDKUS }
8315 { JIS_X0201 X0201 csHalfWidthKatakana }
8316 { KSC5636 ISO646-KR csKSC5636 }
8317 { ISO-10646-UCS-2 csUnicode }
8318 { ISO-10646-UCS-4 csUCS4 }
8319 { DEC-MCS dec csDECMCS }
8320 { hp-roman8 roman8 r8 csHPRoman8 }
8321 { macintosh mac csMacintosh }
8322 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8323 csIBM037 }
8324 { IBM038 EBCDIC-INT cp038 csIBM038 }
8325 { IBM273 CP273 csIBM273 }
8326 { IBM274 EBCDIC-BE CP274 csIBM274 }
8327 { IBM275 EBCDIC-BR cp275 csIBM275 }
8328 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8329 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8330 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8331 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8332 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8333 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8334 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8335 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8336 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8337 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8338 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8339 { IBM437 cp437 437 csPC8CodePage437 }
8340 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8341 { IBM775 cp775 csPC775Baltic }
8342 { IBM850 cp850 850 csPC850Multilingual }
8343 { IBM851 cp851 851 csIBM851 }
8344 { IBM852 cp852 852 csPCp852 }
8345 { IBM855 cp855 855 csIBM855 }
8346 { IBM857 cp857 857 csIBM857 }
8347 { IBM860 cp860 860 csIBM860 }
8348 { IBM861 cp861 861 cp-is csIBM861 }
8349 { IBM862 cp862 862 csPC862LatinHebrew }
8350 { IBM863 cp863 863 csIBM863 }
8351 { IBM864 cp864 csIBM864 }
8352 { IBM865 cp865 865 csIBM865 }
8353 { IBM866 cp866 866 csIBM866 }
8354 { IBM868 CP868 cp-ar csIBM868 }
8355 { IBM869 cp869 869 cp-gr csIBM869 }
8356 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8357 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8358 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8359 { IBM891 cp891 csIBM891 }
8360 { IBM903 cp903 csIBM903 }
8361 { IBM904 cp904 904 csIBBM904 }
8362 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8363 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8364 { IBM1026 CP1026 csIBM1026 }
8365 { EBCDIC-AT-DE csIBMEBCDICATDE }
8366 { EBCDIC-AT-DE-A csEBCDICATDEA }
8367 { EBCDIC-CA-FR csEBCDICCAFR }
8368 { EBCDIC-DK-NO csEBCDICDKNO }
8369 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8370 { EBCDIC-FI-SE csEBCDICFISE }
8371 { EBCDIC-FI-SE-A csEBCDICFISEA }
8372 { EBCDIC-FR csEBCDICFR }
8373 { EBCDIC-IT csEBCDICIT }
8374 { EBCDIC-PT csEBCDICPT }
8375 { EBCDIC-ES csEBCDICES }
8376 { EBCDIC-ES-A csEBCDICESA }
8377 { EBCDIC-ES-S csEBCDICESS }
8378 { EBCDIC-UK csEBCDICUK }
8379 { EBCDIC-US csEBCDICUS }
8380 { UNKNOWN-8BIT csUnknown8BiT }
8381 { MNEMONIC csMnemonic }
8382 { MNEM csMnem }
8383 { VISCII csVISCII }
8384 { VIQR csVIQR }
8385 { KOI8-R csKOI8R }
8386 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8387 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8388 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8389 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8390 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8391 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8392 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8393 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8394 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8395 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8396 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8397 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8398 { IBM1047 IBM-1047 }
8399 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8400 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8401 { UNICODE-1-1 csUnicode11 }
8402 { CESU-8 csCESU-8 }
8403 { BOCU-1 csBOCU-1 }
8404 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8405 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8406 l8 }
8407 { ISO-8859-15 ISO_8859-15 Latin-9 }
8408 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8409 { GBK CP936 MS936 windows-936 }
8410 { JIS_Encoding csJISEncoding }
8411 { Shift_JIS MS_Kanji csShiftJIS }
8412 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8413 EUC-JP }
8414 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8415 { ISO-10646-UCS-Basic csUnicodeASCII }
8416 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8417 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8418 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8419 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8420 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8421 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8422 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8423 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8424 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8425 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8426 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8427 { Ventura-US csVenturaUS }
8428 { Ventura-International csVenturaInternational }
8429 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8430 { PC8-Turkish csPC8Turkish }
8431 { IBM-Symbols csIBMSymbols }
8432 { IBM-Thai csIBMThai }
8433 { HP-Legal csHPLegal }
8434 { HP-Pi-font csHPPiFont }
8435 { HP-Math8 csHPMath8 }
8436 { Adobe-Symbol-Encoding csHPPSMath }
8437 { HP-DeskTop csHPDesktop }
8438 { Ventura-Math csVenturaMath }
8439 { Microsoft-Publishing csMicrosoftPublishing }
8440 { Windows-31J csWindows31J }
8441 { GB2312 csGB2312 }
8442 { Big5 csBig5 }
8445 proc tcl_encoding {enc} {
8446 global encoding_aliases
8447 set names [encoding names]
8448 set lcnames [string tolower $names]
8449 set enc [string tolower $enc]
8450 set i [lsearch -exact $lcnames $enc]
8451 if {$i < 0} {
8452 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8453 if {[regsub {^iso[-_]} $enc iso encx]} {
8454 set i [lsearch -exact $lcnames $encx]
8457 if {$i < 0} {
8458 foreach l $encoding_aliases {
8459 set ll [string tolower $l]
8460 if {[lsearch -exact $ll $enc] < 0} continue
8461 # look through the aliases for one that tcl knows about
8462 foreach e $ll {
8463 set i [lsearch -exact $lcnames $e]
8464 if {$i < 0} {
8465 if {[regsub {^iso[-_]} $e iso ex]} {
8466 set i [lsearch -exact $lcnames $ex]
8469 if {$i >= 0} break
8471 break
8474 if {$i >= 0} {
8475 return [lindex $names $i]
8477 return {}
8480 # defaults...
8481 set datemode 0
8482 set wrcomcmd "git diff-tree --stdin -p --pretty"
8484 set gitencoding {}
8485 catch {
8486 set gitencoding [exec git config --get i18n.commitencoding]
8488 if {$gitencoding == ""} {
8489 set gitencoding "utf-8"
8491 set tclencoding [tcl_encoding $gitencoding]
8492 if {$tclencoding == {}} {
8493 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8496 set mainfont {Helvetica 9}
8497 set textfont {Courier 9}
8498 set uifont {Helvetica 9 bold}
8499 set tabstop 8
8500 set findmergefiles 0
8501 set maxgraphpct 50
8502 set maxwidth 16
8503 set revlistorder 0
8504 set fastdate 0
8505 set uparrowlen 5
8506 set downarrowlen 5
8507 set mingaplen 100
8508 set cmitmode "patch"
8509 set wrapcomment "none"
8510 set showneartags 1
8511 set maxrefs 20
8512 set maxlinelen 200
8513 set showlocalchanges 1
8514 set datetimeformat "%Y-%m-%d %H:%M:%S"
8516 set colors {green red blue magenta darkgrey brown orange}
8517 set bgcolor white
8518 set fgcolor black
8519 set diffcolors {red "#00a000" blue}
8520 set diffcontext 3
8521 set selectbgcolor gray85
8523 catch {source ~/.gitk}
8525 font create optionfont -family sans-serif -size -12
8527 parsefont mainfont $mainfont
8528 eval font create mainfont [fontflags mainfont]
8529 eval font create mainfontbold [fontflags mainfont 1]
8531 parsefont textfont $textfont
8532 eval font create textfont [fontflags textfont]
8533 eval font create textfontbold [fontflags textfont 1]
8535 parsefont uifont $uifont
8536 eval font create uifont [fontflags uifont]
8538 # check that we can find a .git directory somewhere...
8539 if {[catch {set gitdir [gitdir]}]} {
8540 show_error {} . "Cannot find a git repository here."
8541 exit 1
8543 if {![file isdirectory $gitdir]} {
8544 show_error {} . "Cannot find the git directory \"$gitdir\"."
8545 exit 1
8548 set revtreeargs {}
8549 set cmdline_files {}
8550 set i 0
8551 foreach arg $argv {
8552 switch -- $arg {
8553 "" { }
8554 "-d" { set datemode 1 }
8555 "--" {
8556 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8557 break
8559 default {
8560 lappend revtreeargs $arg
8563 incr i
8566 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8567 # no -- on command line, but some arguments (other than -d)
8568 if {[catch {
8569 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8570 set cmdline_files [split $f "\n"]
8571 set n [llength $cmdline_files]
8572 set revtreeargs [lrange $revtreeargs 0 end-$n]
8573 # Unfortunately git rev-parse doesn't produce an error when
8574 # something is both a revision and a filename. To be consistent
8575 # with git log and git rev-list, check revtreeargs for filenames.
8576 foreach arg $revtreeargs {
8577 if {[file exists $arg]} {
8578 show_error {} . "Ambiguous argument '$arg': both revision\
8579 and filename"
8580 exit 1
8583 } err]} {
8584 # unfortunately we get both stdout and stderr in $err,
8585 # so look for "fatal:".
8586 set i [string first "fatal:" $err]
8587 if {$i > 0} {
8588 set err [string range $err [expr {$i + 6}] end]
8590 show_error {} . "Bad arguments to gitk:\n$err"
8591 exit 1
8595 set nullid "0000000000000000000000000000000000000000"
8596 set nullid2 "0000000000000000000000000000000000000001"
8598 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8600 set runq {}
8601 set history {}
8602 set historyindex 0
8603 set fh_serial 0
8604 set nhl_names {}
8605 set highlight_paths {}
8606 set findpattern {}
8607 set searchdirn -forwards
8608 set boldrows {}
8609 set boldnamerows {}
8610 set diffelide {0 0}
8611 set markingmatches 0
8612 set linkentercount 0
8613 set need_redisplay 0
8614 set nrows_drawn 0
8615 set firsttabstop 0
8617 set nextviewnum 1
8618 set curview 0
8619 set selectedview 0
8620 set selectedhlview None
8621 set highlight_related None
8622 set highlight_files {}
8623 set viewfiles(0) {}
8624 set viewperm(0) 0
8625 set viewargs(0) {}
8627 set cmdlineok 0
8628 set stopped 0
8629 set stuffsaved 0
8630 set patchnum 0
8631 set localirow -1
8632 set localfrow -1
8633 set lserial 0
8634 setcoords
8635 makewindow
8636 # wait for the window to become visible
8637 tkwait visibility .
8638 wm title . "[file tail $argv0]: [file tail [pwd]]"
8639 readrefs
8641 if {$cmdline_files ne {} || $revtreeargs ne {}} {
8642 # create a view for the files/dirs specified on the command line
8643 set curview 1
8644 set selectedview 1
8645 set nextviewnum 2
8646 set viewname(1) "Command line"
8647 set viewfiles(1) $cmdline_files
8648 set viewargs(1) $revtreeargs
8649 set viewperm(1) 0
8650 addviewmenu 1
8651 .bar.view entryconf Edit* -state normal
8652 .bar.view entryconf Delete* -state normal
8655 if {[info exists permviews]} {
8656 foreach v $permviews {
8657 set n $nextviewnum
8658 incr nextviewnum
8659 set viewname($n) [lindex $v 0]
8660 set viewfiles($n) [lindex $v 1]
8661 set viewargs($n) [lindex $v 2]
8662 set viewperm($n) 1
8663 addviewmenu $n
8666 getcommits