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