2 # Tcl ignores the next line -*- tcl -*- \
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.
12 if {[info exists env
(GIT_DIR
)]} {
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.
28 if {[info exists isonrunq
($script)]} return
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} {
43 fileevent
$fd readable
{}
47 lappend runq
[list
$fd $script]
53 set tstart
[clock clicks
-milliseconds]
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]
68 fileevent
$fd readable
[list filereadable
$fd $script]
70 } elseif
{$fd eq
{}} {
71 unset isonrunq
($script)
74 if {$t1 - $tstart >= 80} break
81 # Start off a git rev-list process and arrange to read its output
82 proc start_rev_list
{view
} {
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
{}} {
96 set str
[exec sh
-c $viewargscmd($view)]
98 error_popup
"Error executing --argscmd command: $err"
101 set args
[concat
$args [split $str "\n"]]
103 set order
"--topo-order"
105 set order
"--date-order"
108 set fd
[open
[concat | git log
--no-color -z --pretty=raw
$order --parents \
109 --boundary $args "--" $viewfiles($view)] r
]
111 error_popup
"[mc "Error executing git rev-list
:"] $err"
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} {
127 set progresscoords
{0 0}
132 proc stop_rev_list
{} {
133 global commfd curview
135 if {![info exists commfd
($curview)]} return
136 set fd
$commfd($curview)
142 unset commfd
($curview)
146 global phase canv curview
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
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]} {
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
196 lappend vparentlist
($view) {}
197 lappend vdisporder
($view) $id
198 lappend vcmitlisted
($view) 0
201 set viewcomplete
($view) 1
202 global viewname progresscoords
205 set progresscoords
{0 0}
207 # set it blocking so we wait for the process to terminate
208 fconfigure
$fd -blocking 1
209 if {[catch
{close
$fd} err
]} {
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"} {
219 " (Note: arguments to gitk are passed to git rev-list\
220 to allow selection of commits to be displayed.)"
223 set err
"Error reading commits$fv: $err"
227 if {$view == $curview} {
228 run chewcommits
$view
235 set i
[string first
"\0" $stuff $start]
237 append leftover
($view) [string range
$stuff $start end
]
241 set cmit
$leftover($view)
242 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
243 set leftover
($view) {}
245 set cmit
[string range
$stuff $start [expr {$i - 1}]]
247 set start
[expr {$i + 1}]
248 set j
[string first
"\n" $cmit]
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] {
260 set ids
[string range
$ids 1 end
]
264 if {[string length
$id] != 40} {
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}"
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
284 set otok $ordertok($view,$id)
285 unset idpending($view,$id)
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
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
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
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)
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]
345 set r [expr {$r + $inc}]
351 set l [expr {$r - 0.2}]
354 set l [expr {$l - $inc}]
359 set r [expr {$l + 0.2}]
361 set progresscoords [list $l $r]
368 proc chewcommits {view} {
369 global curview hlview viewcomplete
370 global selectedline pending_select
372 if {$view == $curview} {
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]
382 if {$commitidx($curview) > 0} {
383 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
384 #puts "overall $ms ms for $numcommits commits"
386 show_status [mc "No commits selected"]
392 if {[info exists hlview] && $view == $hlview} {
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
408 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
415 foreach id $displayorder {
416 catch {unset children($n,$id)}
417 catch {unset commitrow($n,$id)}
418 catch {unset ordertok($n,$id)}
420 foreach vid [array names idpending "$n,*"] {
421 unset idpending($vid)
424 catch {unset selectedline}
425 catch {unset thickerline}
426 catch {unset viewdata($n)}
435 proc parsecommit {id contents listed} {
436 global commitinfo cdate
445 set hdrend [string first "\n\n" $contents]
447 # should never happen...
448 set hdrend [string length $contents]
450 set header [string range $contents 0 [expr {$hdrend - 1}]]
451 set comment [string range $contents [expr {$hdrend + 2}] end]
452 foreach line [split $header "\n"] {
453 set tag [lindex $line 0]
454 if {$tag == "author"} {
455 set audate [lindex $line end-1]
456 set auname [lrange $line 1 end-2]
457 } elseif {$tag == "committer"} {
458 set comdate [lindex $line end-1]
459 set comname [lrange $line 1 end-2]
463 # take the first non-blank line of the comment as the headline
464 set headline [string trimleft $comment]
465 set i [string first "\n" $headline]
467 set headline [string range $headline 0 $i]
469 set headline [string trimright $headline]
470 set i [string first "\r" $headline]
472 set headline [string trimright [string range $headline 0 $i]]
475 # git rev-list indents the comment by 4 spaces;
476 # if we got this via git cat-file, add the indentation
478 foreach line [split $comment "\n"] {
479 append newcomment " "
480 append newcomment $line
481 append newcomment "\n"
483 set comment $newcomment
485 if {$comdate != {}} {
486 set cdate($id) $comdate
488 set commitinfo($id) [list $headline $auname $audate \
489 $comname $comdate $comment]
492 proc getcommit {id} {
493 global commitdata commitinfo
495 if {[info exists commitdata($id)]} {
496 parsecommit $id $commitdata($id) 1
499 if {![info exists commitinfo($id)]} {
500 set commitinfo($id) [list [mc "No commit information available"]]
507 global tagids idtags headids idheads tagobjid
508 global otherrefids idotherrefs mainhead mainheadid
510 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
513 set refd [open [list | git show-ref -d] r]
514 while {[gets $refd line] >= 0} {
515 if {[string index $line 40] ne " "} continue
516 set id [string range $line 0 39]
517 set ref [string range $line 41 end]
518 if {![string match "refs/*" $ref]} continue
519 set name [string range $ref 5 end]
520 if {[string match "remotes/*" $name]} {
521 if {![string match "*/HEAD" $name]} {
522 set headids($name) $id
523 lappend idheads($id) $name
525 } elseif {[string match "heads/*" $name]} {
526 set name [string range $name 6 end]
527 set headids($name) $id
528 lappend idheads($id) $name
529 } elseif {[string match "tags/*" $name]} {
530 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
531 # which is what we want since the former is the commit ID
532 set name [string range $name 5 end]
533 if {[string match "*^{}" $name]} {
534 set name [string range $name 0 end-3]
536 set tagobjid($name) $id
538 set tagids($name) $id
539 lappend idtags($id) $name
541 set otherrefids($name) $id
542 lappend idotherrefs($id) $name
549 set thehead [exec git symbolic-ref HEAD]
550 if {[string match "refs/heads/*" $thehead]} {
551 set mainhead [string range $thehead 11 end]
552 if {[info exists headids($mainhead)]} {
553 set mainheadid $headids($mainhead)
559 # skip over fake commits
560 proc first_real_row {} {
561 global nullid nullid2 displayorder numcommits
563 for {set row 0} {$row < $numcommits} {incr row} {
564 set id [lindex $displayorder $row]
565 if {$id ne $nullid && $id ne $nullid2} {
572 # update things for a head moved to a child of its previous location
573 proc movehead {id name} {
574 global headids idheads
576 removehead $headids($name) $name
577 set headids($name) $id
578 lappend idheads($id) $name
581 # update things when a head has been removed
582 proc removehead {id name} {
583 global headids idheads
585 if {$idheads($id) eq $name} {
588 set i [lsearch -exact $idheads($id) $name]
590 set idheads($id) [lreplace $idheads($id) $i $i]
596 proc show_error {w top msg} {
597 message $w.m -text $msg -justify center -aspect 400
598 pack $w.m -side top -fill x -padx 20 -pady 20
599 button $w.ok -text [mc OK] -command "destroy $top"
600 pack $w.ok -side bottom -fill x
601 bind $top <Visibility> "grab $top; focus $top"
602 bind $top <Key-Return> "destroy $top"
606 proc error_popup msg {
610 show_error $w $w $msg
613 proc confirm_popup msg {
619 message $w.m -text $msg -justify center -aspect 400
620 pack $w.m -side top -fill x -padx 20 -pady 20
621 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
622 pack $w.ok -side left -fill x
623 button $w.cancel -text [mc Cancel] -command "destroy $w"
624 pack $w.cancel -side right -fill x
625 bind $w <Visibility> "grab $w; focus $w"
631 option add *Panedwindow.showHandle 1 startupFile
632 option add *Panedwindow.sashRelief raised startupFile
633 option add *Button.font uifont startupFile
634 option add *Checkbutton.font uifont startupFile
635 option add *Radiobutton.font uifont startupFile
636 option add *Menu.font uifont startupFile
637 option add *Menubutton.font uifont startupFile
638 option add *Label.font uifont startupFile
639 option add *Message.font uifont startupFile
640 option add *Entry.font uifont startupFile
644 global canv canv2 canv3 linespc charspc ctext cflist
646 global findtype findtypemenu findloc findstring fstring geometry
647 global entries sha1entry sha1string sha1but
648 global diffcontextstring diffcontext
650 global maincursor textcursor curtextcursor
651 global rowctxmenu fakerowmenu mergemax wrapcomment
652 global highlight_files gdttype
653 global searchstring sstring
654 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
655 global headctxmenu progresscanv progressitem progresscoords statusw
656 global fprogitem fprogcoord lastprogupdate progupdatepending
657 global rprogitem rprogcoord
661 .bar add cascade -label [mc "File"] -menu .bar.file
663 .bar.file add command -label [mc "Update"] -command updatecommits
664 .bar.file add command -label [mc "Reread references"] -command rereadrefs
665 .bar.file add command -label [mc "List references"] -command showrefs
666 .bar.file add command -label [mc "Quit"] -command doquit
668 .bar add cascade -label [mc "Edit"] -menu .bar.edit
669 .bar.edit add command -label [mc "Preferences"] -command doprefs
672 .bar add cascade -label [mc "View"] -menu .bar.view
673 .bar.view add command -label [mc "New view..."] -command {newview 0}
674 .bar.view add command -label [mc "Edit view..."] -command editview \
676 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
677 .bar.view add separator
678 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
679 -variable selectedview -value 0
682 .bar add cascade -label [mc "Help"] -menu .bar.help
683 .bar.help add command -label [mc "About gitk"] -command about
684 .bar.help add command -label [mc "Key bindings"] -command keys
686 . configure -menu .bar
688 # the gui has upper and lower half, parts of a paned window.
689 panedwindow .ctop -orient vertical
691 # possibly use assumed geometry
692 if {![info exists geometry(pwsash0)]} {
693 set geometry(topheight) [expr {15 * $linespc}]
694 set geometry(topwidth) [expr {80 * $charspc}]
695 set geometry(botheight) [expr {15 * $linespc}]
696 set geometry(botwidth) [expr {50 * $charspc}]
697 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
698 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
701 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
702 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
704 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
706 # create three canvases
707 set cscroll .tf.histframe.csb
708 set canv .tf.histframe.pwclist.canv
710 -selectbackground $selectbgcolor \
711 -background $bgcolor -bd 0 \
712 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
713 .tf.histframe.pwclist add $canv
714 set canv2 .tf.histframe.pwclist.canv2
716 -selectbackground $selectbgcolor \
717 -background $bgcolor -bd 0 -yscrollincr $linespc
718 .tf.histframe.pwclist add $canv2
719 set canv3 .tf.histframe.pwclist.canv3
721 -selectbackground $selectbgcolor \
722 -background $bgcolor -bd 0 -yscrollincr $linespc
723 .tf.histframe.pwclist add $canv3
724 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
725 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
727 # a scroll bar to rule them
728 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
729 pack $cscroll -side right -fill y
730 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
731 lappend bglist $canv $canv2 $canv3
732 pack .tf.histframe.pwclist -fill both -expand 1 -side left
734 # we have two button bars at bottom of top frame. Bar 1
736 frame .tf.lbar -height 15
738 set sha1entry .tf.bar.sha1
739 set entries $sha1entry
740 set sha1but .tf.bar.sha1label
741 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
742 -command gotocommit -width 8
743 $sha1but conf -disabledforeground [$sha1but cget -foreground]
744 pack .tf.bar.sha1label -side left
745 entry $sha1entry -width 40 -font textfont -textvariable sha1string
746 trace add variable sha1string write sha1change
747 pack $sha1entry -side left -pady 2
749 image create bitmap bm-left -data {
750 #define left_width 16
751 #define left_height 16
752 static unsigned char left_bits[] = {
753 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
754 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
755 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
757 image create bitmap bm-right -data {
758 #define right_width 16
759 #define right_height 16
760 static unsigned char right_bits[] = {
761 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
762 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
763 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
765 button .tf.bar.leftbut -image bm-left -command goback \
766 -state disabled -width 26
767 pack .tf.bar.leftbut -side left -fill y
768 button .tf.bar.rightbut -image bm-right -command goforw \
769 -state disabled -width 26
770 pack .tf.bar.rightbut -side left -fill y
772 # Status label and progress bar
773 set statusw .tf.bar.status
774 label $statusw -width 15 -relief sunken
775 pack $statusw -side left -padx 5
776 set h [expr {[font metrics uifont -linespace] + 2}]
777 set progresscanv .tf.bar.progress
778 canvas $progresscanv -relief sunken -height $h -borderwidth 2
779 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
780 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
781 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
782 pack $progresscanv -side right -expand 1 -fill x
783 set progresscoords {0 0}
786 bind $progresscanv <Configure> adjustprogress
787 set lastprogupdate [clock clicks -milliseconds]
788 set progupdatepending 0
790 # build up the bottom bar of upper window
791 label .tf.lbar.flabel -text "[mc "Find"] "
792 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
793 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
794 label .tf.lbar.flab2 -text " [mc "commit"] "
795 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
797 set gdttype [mc "containing:"]
798 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
800 [mc "touching paths:"] \
801 [mc "adding/removing string:"]]
802 trace add variable gdttype write gdttype_change
803 pack .tf.lbar.gdttype -side left -fill y
806 set fstring .tf.lbar.findstring
807 lappend entries $fstring
808 entry $fstring -width 30 -font textfont -textvariable findstring
809 trace add variable findstring write find_change
810 set findtype [mc "Exact"]
811 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
812 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
813 trace add variable findtype write findcom_change
814 set findloc [mc "All fields"]
815 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
816 [mc "Comments"] [mc "Author"] [mc "Committer"]
817 trace add variable findloc write find_change
818 pack .tf.lbar.findloc -side right
819 pack .tf.lbar.findtype -side right
820 pack $fstring -side left -expand 1 -fill x
822 # Finish putting the upper half of the viewer together
823 pack .tf.lbar -in .tf -side bottom -fill x
824 pack .tf.bar -in .tf -side bottom -fill x
825 pack .tf.histframe -fill both -side top -expand 1
827 .ctop paneconfigure .tf -height $geometry(topheight)
828 .ctop paneconfigure .tf -width $geometry(topwidth)
830 # now build up the bottom
831 panedwindow .pwbottom -orient horizontal
833 # lower left, a text box over search bar, scroll bar to the right
834 # if we know window height, then that will set the lower text height, otherwise
835 # we set lower text height which will drive window height
836 if {[info exists geometry(main)]} {
837 frame .bleft -width $geometry(botwidth)
839 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
845 button .bleft.top.search -text [mc "Search"] -command dosearch
846 pack .bleft.top.search -side left -padx 5
847 set sstring .bleft.top.sstring
848 entry $sstring -width 20 -font textfont -textvariable searchstring
849 lappend entries $sstring
850 trace add variable searchstring write incrsearch
851 pack $sstring -side left -expand 1 -fill x
852 radiobutton .bleft.mid.diff -text [mc "Diff"] \
853 -command changediffdisp -variable diffelide -value {0 0}
854 radiobutton .bleft.mid.old -text [mc "Old version"] \
855 -command changediffdisp -variable diffelide -value {0 1}
856 radiobutton .bleft.mid.new -text [mc "New version"] \
857 -command changediffdisp -variable diffelide -value {1 0}
858 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
859 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
860 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
861 -from 1 -increment 1 -to 10000000 \
862 -validate all -validatecommand "diffcontextvalidate %P" \
863 -textvariable diffcontextstring
864 .bleft.mid.diffcontext set $diffcontext
865 trace add variable diffcontextstring write diffcontextchange
866 lappend entries .bleft.mid.diffcontext
867 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
868 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
869 -command changeignorespace -variable ignorespace
870 pack .bleft.mid.ignspace -side left -padx 5
871 set ctext .bleft.bottom.ctext
872 text $ctext -background $bgcolor -foreground $fgcolor \
873 -state disabled -font textfont \
874 -yscrollcommand scrolltext -wrap none \
875 -xscrollcommand ".bleft.bottom.sbhorizontal set"
877 $ctext conf -tabstyle wordprocessor
879 scrollbar .bleft.bottom.sb -command "$ctext yview"
880 scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h \
882 pack .bleft.top -side top -fill x
883 pack .bleft.mid -side top -fill x
884 grid $ctext .bleft.bottom.sb -sticky nsew
885 grid .bleft.bottom.sbhorizontal -sticky ew
886 grid columnconfigure .bleft.bottom 0 -weight 1
887 grid rowconfigure .bleft.bottom 0 -weight 1
888 grid rowconfigure .bleft.bottom 1 -weight 0
889 pack .bleft.bottom -side top -fill both -expand 1
890 lappend bglist $ctext
891 lappend fglist $ctext
893 $ctext tag conf comment -wrap $wrapcomment
894 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
895 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
896 $ctext tag conf d0 -fore [lindex $diffcolors 0]
897 $ctext tag conf d1 -fore [lindex $diffcolors 1]
898 $ctext tag conf m0 -fore red
899 $ctext tag conf m1 -fore blue
900 $ctext tag conf m2 -fore green
901 $ctext tag conf m3 -fore purple
902 $ctext tag conf m4 -fore brown
903 $ctext tag conf m5 -fore "#009090"
904 $ctext tag conf m6 -fore magenta
905 $ctext tag conf m7 -fore "#808000"
906 $ctext tag conf m8 -fore "#009000"
907 $ctext tag conf m9 -fore "#ff0080"
908 $ctext tag conf m10 -fore cyan
909 $ctext tag conf m11 -fore "#b07070"
910 $ctext tag conf m12 -fore "#70b0f0"
911 $ctext tag conf m13 -fore "#70f0b0"
912 $ctext tag conf m14 -fore "#f0b070"
913 $ctext tag conf m15 -fore "#ff70b0"
914 $ctext tag conf mmax -fore darkgrey
916 $ctext tag conf mresult -font textfontbold
917 $ctext tag conf msep -font textfontbold
918 $ctext tag conf found -back yellow
921 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
926 radiobutton .bright.mode.patch -text [mc "Patch"] \
927 -command reselectline -variable cmitmode -value "patch"
928 radiobutton .bright.mode.tree -text [mc "Tree"] \
929 -command reselectline -variable cmitmode -value "tree"
930 grid .bright.mode.patch .bright.mode.tree -sticky ew
931 pack .bright.mode -side top -fill x
932 set cflist .bright.cfiles
933 set indent [font measure mainfont "nn"]
935 -selectbackground $selectbgcolor \
936 -background $bgcolor -foreground $fgcolor \
938 -tabs [list $indent [expr {2 * $indent}]] \
939 -yscrollcommand ".bright.sb set" \
940 -cursor [. cget -cursor] \
941 -spacing1 1 -spacing3 1
942 lappend bglist $cflist
943 lappend fglist $cflist
944 scrollbar .bright.sb -command "$cflist yview"
945 pack .bright.sb -side right -fill y
946 pack $cflist -side left -fill both -expand 1
947 $cflist tag configure highlight \
948 -background [$cflist cget -selectbackground]
949 $cflist tag configure bold -font mainfontbold
951 .pwbottom add .bright
954 # restore window width & height if known
955 if {[info exists geometry(main)]} {
956 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
957 if {$w > [winfo screenwidth .]} {
958 set w [winfo screenwidth .]
960 if {$h > [winfo screenheight .]} {
961 set h [winfo screenheight .]
963 wm geometry . "${w}x$h"
967 if {[tk windowingsystem] eq {aqua}} {
973 bind .pwbottom <Configure> {resizecdetpanes %W %w}
974 pack .ctop -fill both -expand 1
975 bindall <1> {selcanvline %W %x %y}
976 #bindall <B1-Motion> {selcanvline %W %x %y}
977 if {[tk windowingsystem] == "win32"} {
978 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
979 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
981 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
982 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
983 if {[tk windowingsystem] eq "aqua"} {
984 bindall <MouseWheel> {
985 set delta [expr {- (%D)}]
986 allcanvs yview scroll $delta units
990 bindall <2> "canvscan mark %W %x %y"
991 bindall <B2-Motion> "canvscan dragto %W %x %y"
992 bindkey <Home> selfirstline
993 bindkey <End> sellastline
994 bind . <Key-Up> "selnextline -1"
995 bind . <Key-Down> "selnextline 1"
996 bind . <Shift-Key-Up> "dofind -1 0"
997 bind . <Shift-Key-Down> "dofind 1 0"
998 bindkey <Key-Right> "goforw"
999 bindkey <Key-Left> "goback"
1000 bind . <Key-Prior> "selnextpage -1"
1001 bind . <Key-Next> "selnextpage 1"
1002 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
1003 bind . <$M1B-End> "allcanvs yview moveto 1.0"
1004 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
1005 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
1006 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
1007 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
1008 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
1009 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
1010 bindkey <Key-space> "$ctext yview scroll 1 pages"
1011 bindkey p "selnextline -1"
1012 bindkey n "selnextline 1"
1015 bindkey i "selnextline -1"
1016 bindkey k "selnextline 1"
1019 bindkey b "$ctext yview scroll -1 pages"
1020 bindkey d "$ctext yview scroll 18 units"
1021 bindkey u "$ctext yview scroll -18 units"
1022 bindkey / {dofind 1 1}
1023 bindkey <Key-Return> {dofind 1 1}
1024 bindkey ? {dofind -1 1}
1026 bindkey <F5> updatecommits
1027 bind . <$M1B-q> doquit
1028 bind . <$M1B-f> {dofind 1 1}
1029 bind . <$M1B-g> {dofind 1 0}
1030 bind . <$M1B-r> dosearchback
1031 bind . <$M1B-s> dosearch
1032 bind . <$M1B-equal> {incrfont 1}
1033 bind . <$M1B-plus> {incrfont 1}
1034 bind . <$M1B-KP_Add> {incrfont 1}
1035 bind . <$M1B-minus> {incrfont -1}
1036 bind . <$M1B-KP_Subtract> {incrfont -1}
1037 wm protocol . WM_DELETE_WINDOW doquit
1038 bind . <Button-1> "click %W"
1039 bind $fstring <Key-Return> {dofind 1 1}
1040 bind $sha1entry <Key-Return> gotocommit
1041 bind $sha1entry <<PasteSelection>> clearsha1
1042 bind $cflist <1> {sel_flist %W %x %y; break}
1043 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1044 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1045 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1047 set maincursor [. cget -cursor]
1048 set textcursor [$ctext cget -cursor]
1049 set curtextcursor $textcursor
1051 set rowctxmenu .rowctxmenu
1052 menu $rowctxmenu -tearoff 0
1053 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1054 -command {diffvssel 0}
1055 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1056 -command {diffvssel 1}
1057 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1058 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1059 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1060 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1061 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1063 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1066 set fakerowmenu .fakerowmenu
1067 menu $fakerowmenu -tearoff 0
1068 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1069 -command {diffvssel 0}
1070 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1071 -command {diffvssel 1}
1072 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1073 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1074 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1075 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1077 set headctxmenu .headctxmenu
1078 menu $headctxmenu -tearoff 0
1079 $headctxmenu add command -label [mc "Check out this branch"] \
1081 $headctxmenu add command -label [mc "Remove this branch"] \
1085 set flist_menu .flistctxmenu
1086 menu $flist_menu -tearoff 0
1087 $flist_menu add command -label [mc "Highlight this too"] \
1088 -command {flist_hl 0}
1089 $flist_menu add command -label [mc "Highlight this only"] \
1090 -command {flist_hl 1}
1093 # Windows sends all mouse wheel events to the current focused window, not
1094 # the one where the mouse hovers, so bind those events here and redirect
1095 # to the correct window
1096 proc windows_mousewheel_redirector {W X Y D} {
1097 global canv canv2 canv3
1098 set w [winfo containing -displayof $W $X $Y]
1100 set u [expr {$D < 0 ? 5 : -5}]
1101 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1102 allcanvs yview scroll $u units
1105 $w yview scroll $u units
1111 # mouse-2 makes all windows scan vertically, but only the one
1112 # the cursor is in scans horizontally
1113 proc canvscan {op w x y} {
1114 global canv canv2 canv3
1115 foreach c [list $canv $canv2 $canv3] {
1124 proc scrollcanv {cscroll f0 f1} {
1125 $cscroll set $f0 $f1
1130 # when we make a key binding for the toplevel, make sure
1131 # it doesn't get triggered when that key is pressed
in the
1132 # find string entry widget.
1133 proc bindkey
{ev
script} {
1136 set escript
[bind Entry
$ev]
1137 if {$escript == {}} {
1138 set escript
[bind Entry
<Key
>]
1140 foreach e
$entries {
1141 bind $e $ev "$escript; break"
1145 # set the focus back to the toplevel for any click outside
1148 global ctext entries
1149 foreach e
[concat
$entries $ctext] {
1150 if {$w == $e} return
1155 # Adjust the progress bar for a change in requested extent or canvas size
1156 proc adjustprogress
{} {
1157 global progresscanv progressitem progresscoords
1158 global fprogitem fprogcoord lastprogupdate progupdatepending
1159 global rprogitem rprogcoord
1161 set w
[expr {[winfo width
$progresscanv] - 4}]
1162 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1163 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1164 set h
[winfo height
$progresscanv]
1165 $progresscanv coords
$progressitem $x0 0 $x1 $h
1166 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1167 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1168 set now
[clock clicks
-milliseconds]
1169 if {$now >= $lastprogupdate + 100} {
1170 set progupdatepending
0
1172 } elseif
{!$progupdatepending} {
1173 set progupdatepending
1
1174 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1178 proc doprogupdate
{} {
1179 global lastprogupdate progupdatepending
1181 if {$progupdatepending} {
1182 set progupdatepending
0
1183 set lastprogupdate
[clock clicks
-milliseconds]
1188 proc savestuff
{w
} {
1189 global canv canv2 canv3 mainfont textfont uifont tabstop
1190 global stuffsaved findmergefiles maxgraphpct
1191 global maxwidth showneartags showlocalchanges
1192 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
1193 global cmitmode wrapcomment datetimeformat limitdiffs
1194 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1197 if {$stuffsaved} return
1198 if {![winfo viewable .
]} return
1200 set f
[open
"~/.gitk-new" w
]
1201 puts
$f [list
set mainfont
$mainfont]
1202 puts
$f [list
set textfont
$textfont]
1203 puts
$f [list
set uifont
$uifont]
1204 puts
$f [list
set tabstop
$tabstop]
1205 puts
$f [list
set findmergefiles
$findmergefiles]
1206 puts
$f [list
set maxgraphpct
$maxgraphpct]
1207 puts
$f [list
set maxwidth
$maxwidth]
1208 puts
$f [list
set cmitmode
$cmitmode]
1209 puts
$f [list
set wrapcomment
$wrapcomment]
1210 puts
$f [list
set autoselect
$autoselect]
1211 puts
$f [list
set showneartags
$showneartags]
1212 puts
$f [list
set showlocalchanges
$showlocalchanges]
1213 puts
$f [list
set datetimeformat
$datetimeformat]
1214 puts
$f [list
set limitdiffs
$limitdiffs]
1215 puts
$f [list
set bgcolor
$bgcolor]
1216 puts
$f [list
set fgcolor
$fgcolor]
1217 puts
$f [list
set colors
$colors]
1218 puts
$f [list
set diffcolors
$diffcolors]
1219 puts
$f [list
set diffcontext
$diffcontext]
1220 puts
$f [list
set selectbgcolor
$selectbgcolor]
1222 puts
$f "set geometry(main) [wm geometry .]"
1223 puts
$f "set geometry(topwidth) [winfo width .tf]"
1224 puts
$f "set geometry(topheight) [winfo height .tf]"
1225 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1226 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1227 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1228 puts
$f "set geometry(botheight) [winfo height .bleft]"
1230 puts
-nonewline $f "set permviews {"
1231 for {set v
0} {$v < $nextviewnum} {incr v
} {
1232 if {$viewperm($v)} {
1233 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
1238 file rename
-force "~/.gitk-new" "~/.gitk"
1243 proc resizeclistpanes
{win w
} {
1245 if {[info exists oldwidth
($win)]} {
1246 set s0
[$win sash coord
0]
1247 set s1
[$win sash coord
1]
1249 set sash0
[expr {int
($w/2 - 2)}]
1250 set sash1
[expr {int
($w*5/6 - 2)}]
1252 set factor [expr {1.0 * $w / $oldwidth($win)}]
1253 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1254 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1258 if {$sash1 < $sash0 + 20} {
1259 set sash1
[expr {$sash0 + 20}]
1261 if {$sash1 > $w - 10} {
1262 set sash1
[expr {$w - 10}]
1263 if {$sash0 > $sash1 - 20} {
1264 set sash0
[expr {$sash1 - 20}]
1268 $win sash place
0 $sash0 [lindex
$s0 1]
1269 $win sash place
1 $sash1 [lindex
$s1 1]
1271 set oldwidth
($win) $w
1274 proc resizecdetpanes
{win w
} {
1276 if {[info exists oldwidth
($win)]} {
1277 set s0
[$win sash coord
0]
1279 set sash0
[expr {int
($w*3/4 - 2)}]
1281 set factor [expr {1.0 * $w / $oldwidth($win)}]
1282 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1286 if {$sash0 > $w - 15} {
1287 set sash0
[expr {$w - 15}]
1290 $win sash place
0 $sash0 [lindex
$s0 1]
1292 set oldwidth
($win) $w
1295 proc allcanvs args
{
1296 global canv canv2 canv3
1302 proc bindall
{event action
} {
1303 global canv canv2 canv3
1304 bind $canv $event $action
1305 bind $canv2 $event $action
1306 bind $canv3 $event $action
1312 if {[winfo exists
$w]} {
1317 wm title
$w [mc
"About gitk"]
1318 message
$w.m
-text [mc
"
1319 Gitk - a commit viewer for git
1321 Copyright © 2005-2006 Paul Mackerras
1323 Use and redistribute under the terms of the GNU General Public License"] \
1324 -justify center
-aspect 400 -border 2 -bg white
-relief groove
1325 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
1326 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1327 pack
$w.ok
-side bottom
1328 bind $w <Visibility
> "focus $w.ok"
1329 bind $w <Key-Escape
> "destroy $w"
1330 bind $w <Key-Return
> "destroy $w"
1335 if {[winfo exists
$w]} {
1339 if {[tk windowingsystem
] eq
{aqua
}} {
1345 wm title
$w [mc
"Gitk key bindings"]
1346 message
$w.m
-text "
1347 [mc "Gitk key bindings
:"]
1349 [mc "<%s-Q
> Quit
" $M1T]
1350 [mc "<Home
> Move to first commit
"]
1351 [mc "<End
> Move to last commit
"]
1352 [mc "<Up
>, p
, i Move up one commit
"]
1353 [mc "<Down
>, n
, k Move down one commit
"]
1354 [mc "<Left
>, z
, j Go back
in history list
"]
1355 [mc "<Right
>, x
, l Go forward
in history list
"]
1356 [mc "<PageUp
> Move up one page
in commit list
"]
1357 [mc "<PageDown
> Move down one page
in commit list
"]
1358 [mc "<%s-Home
> Scroll to top of commit list
" $M1T]
1359 [mc "<%s-End
> Scroll to bottom of commit list
" $M1T]
1360 [mc "<%s-Up
> Scroll commit list up one line
" $M1T]
1361 [mc "<%s-Down
> Scroll commit list down one line
" $M1T]
1362 [mc "<%s-PageUp
> Scroll commit list up one page
" $M1T]
1363 [mc "<%s-PageDown
> Scroll commit list down one page
" $M1T]
1364 [mc "<Shift-Up
> Find backwards
(upwards
, later commits
)"]
1365 [mc "<Shift-Down
> Find forwards
(downwards
, earlier commits
)"]
1366 [mc "<Delete
>, b Scroll
diff view up one page
"]
1367 [mc "<Backspace
> Scroll
diff view up one page
"]
1368 [mc "<Space
> Scroll
diff view down one page
"]
1369 [mc "u Scroll
diff view up
18 lines
"]
1370 [mc "d Scroll
diff view down
18 lines
"]
1371 [mc "<%s-F
> Find
" $M1T]
1372 [mc "<%s-G
> Move to next
find hit
" $M1T]
1373 [mc "<Return
> Move to next
find hit
"]
1374 [mc "/ Move to next
find hit
, or redo
find"]
1375 [mc "? Move to previous
find hit
"]
1376 [mc "f Scroll
diff view to next
file"]
1377 [mc "<%s-S
> Search
for next hit
in diff view
" $M1T]
1378 [mc "<%s-R
> Search
for previous hit
in diff view
" $M1T]
1379 [mc "<%s-KP
+> Increase font size
" $M1T]
1380 [mc "<%s-plus
> Increase font size
" $M1T]
1381 [mc "<%s-KP-
> Decrease font size
" $M1T]
1382 [mc "<%s-minus
> Decrease font size
" $M1T]
1385 -justify left
-bg white
-border 2 -relief groove
1386 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
1387 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1388 pack
$w.ok
-side bottom
1389 bind $w <Visibility
> "focus $w.ok"
1390 bind $w <Key-Escape
> "destroy $w"
1391 bind $w <Key-Return
> "destroy $w"
1394 # Procedures for manipulating the file list window at the
1395 # bottom right of the overall window.
1397 proc treeview
{w l openlevs
} {
1398 global treecontents treediropen treeheight treeparent treeindex
1408 set treecontents
() {}
1409 $w conf
-state normal
1411 while {[string range
$f 0 $prefixend] ne
$prefix} {
1412 if {$lev <= $openlevs} {
1413 $w mark
set e
:$treeindex($prefix) "end -1c"
1414 $w mark gravity e
:$treeindex($prefix) left
1416 set treeheight
($prefix) $ht
1417 incr ht
[lindex
$htstack end
]
1418 set htstack
[lreplace
$htstack end end
]
1419 set prefixend
[lindex
$prefendstack end
]
1420 set prefendstack
[lreplace
$prefendstack end end
]
1421 set prefix
[string range
$prefix 0 $prefixend]
1424 set tail [string range
$f [expr {$prefixend+1}] end
]
1425 while {[set slash
[string first
"/" $tail]] >= 0} {
1428 lappend prefendstack
$prefixend
1429 incr prefixend
[expr {$slash + 1}]
1430 set d
[string range
$tail 0 $slash]
1431 lappend treecontents
($prefix) $d
1432 set oldprefix
$prefix
1434 set treecontents
($prefix) {}
1435 set treeindex
($prefix) [incr ix
]
1436 set treeparent
($prefix) $oldprefix
1437 set tail [string range
$tail [expr {$slash+1}] end
]
1438 if {$lev <= $openlevs} {
1440 set treediropen
($prefix) [expr {$lev < $openlevs}]
1441 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
1442 $w mark
set d
:$ix "end -1c"
1443 $w mark gravity d
:$ix left
1445 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1447 $w image create end
-align center
-image $bm -padx 1 \
1449 $w insert end
$d [highlight_tag
$prefix]
1450 $w mark
set s
:$ix "end -1c"
1451 $w mark gravity s
:$ix left
1456 if {$lev <= $openlevs} {
1459 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1461 $w insert end
$tail [highlight_tag
$f]
1463 lappend treecontents
($prefix) $tail
1466 while {$htstack ne
{}} {
1467 set treeheight
($prefix) $ht
1468 incr ht
[lindex
$htstack end
]
1469 set htstack
[lreplace
$htstack end end
]
1470 set prefixend
[lindex
$prefendstack end
]
1471 set prefendstack
[lreplace
$prefendstack end end
]
1472 set prefix
[string range
$prefix 0 $prefixend]
1474 $w conf
-state disabled
1477 proc linetoelt
{l
} {
1478 global treeheight treecontents
1483 foreach e
$treecontents($prefix) {
1488 if {[string index
$e end
] eq
"/"} {
1489 set n
$treeheight($prefix$e)
1501 proc highlight_tree
{y prefix
} {
1502 global treeheight treecontents cflist
1504 foreach e
$treecontents($prefix) {
1506 if {[highlight_tag
$path] ne
{}} {
1507 $cflist tag add bold
$y.0 "$y.0 lineend"
1510 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
1511 set y
[highlight_tree
$y $path]
1517 proc treeclosedir
{w dir
} {
1518 global treediropen treeheight treeparent treeindex
1520 set ix
$treeindex($dir)
1521 $w conf
-state normal
1522 $w delete s
:$ix e
:$ix
1523 set treediropen
($dir) 0
1524 $w image configure a
:$ix -image tri-rt
1525 $w conf
-state disabled
1526 set n
[expr {1 - $treeheight($dir)}]
1527 while {$dir ne
{}} {
1528 incr treeheight
($dir) $n
1529 set dir
$treeparent($dir)
1533 proc treeopendir
{w dir
} {
1534 global treediropen treeheight treeparent treecontents treeindex
1536 set ix
$treeindex($dir)
1537 $w conf
-state normal
1538 $w image configure a
:$ix -image tri-dn
1539 $w mark
set e
:$ix s
:$ix
1540 $w mark gravity e
:$ix right
1543 set n
[llength
$treecontents($dir)]
1544 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
1547 incr treeheight
($x) $n
1549 foreach e
$treecontents($dir) {
1551 if {[string index
$e end
] eq
"/"} {
1552 set iy
$treeindex($de)
1553 $w mark
set d
:$iy e
:$ix
1554 $w mark gravity d
:$iy left
1555 $w insert e
:$ix $str
1556 set treediropen
($de) 0
1557 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
1559 $w insert e
:$ix $e [highlight_tag
$de]
1560 $w mark
set s
:$iy e
:$ix
1561 $w mark gravity s
:$iy left
1562 set treeheight
($de) 1
1564 $w insert e
:$ix $str
1565 $w insert e
:$ix $e [highlight_tag
$de]
1568 $w mark gravity e
:$ix left
1569 $w conf
-state disabled
1570 set treediropen
($dir) 1
1571 set top
[lindex
[split [$w index @
0,0] .
] 0]
1572 set ht
[$w cget
-height]
1573 set l
[lindex
[split [$w index s
:$ix] .
] 0]
1576 } elseif
{$l + $n + 1 > $top + $ht} {
1577 set top
[expr {$l + $n + 2 - $ht}]
1585 proc treeclick
{w x y
} {
1586 global treediropen cmitmode ctext cflist cflist_top
1588 if {$cmitmode ne
"tree"} return
1589 if {![info exists cflist_top
]} return
1590 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1591 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1592 $cflist tag add highlight
$l.0 "$l.0 lineend"
1598 set e
[linetoelt
$l]
1599 if {[string index
$e end
] ne
"/"} {
1601 } elseif
{$treediropen($e)} {
1608 proc setfilelist
{id
} {
1609 global treefilelist cflist
1611 treeview
$cflist $treefilelist($id) 0
1614 image create bitmap tri-rt
-background black
-foreground blue
-data {
1615 #define tri-rt_width 13
1616 #define tri-rt_height 13
1617 static unsigned char tri-rt_bits
[] = {
1618 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1619 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1622 #define tri-rt-mask_width 13
1623 #define tri-rt-mask_height 13
1624 static unsigned char tri-rt-mask_bits
[] = {
1625 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1626 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1629 image create bitmap tri-dn
-background black
-foreground blue
-data {
1630 #define tri-dn_width 13
1631 #define tri-dn_height 13
1632 static unsigned char tri-dn_bits
[] = {
1633 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1634 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1637 #define tri-dn-mask_width 13
1638 #define tri-dn-mask_height 13
1639 static unsigned char tri-dn-mask_bits
[] = {
1640 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1641 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1645 image create bitmap reficon-T
-background black
-foreground yellow
-data {
1646 #define tagicon_width 13
1647 #define tagicon_height 9
1648 static unsigned char tagicon_bits
[] = {
1649 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1650 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1652 #define tagicon-mask_width 13
1653 #define tagicon-mask_height 9
1654 static unsigned char tagicon-mask_bits
[] = {
1655 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1656 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1659 #define headicon_width 13
1660 #define headicon_height 9
1661 static unsigned char headicon_bits
[] = {
1662 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1663 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1666 #define headicon-mask_width 13
1667 #define headicon-mask_height 9
1668 static unsigned char headicon-mask_bits
[] = {
1669 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1670 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1672 image create bitmap reficon-H
-background black
-foreground green \
1673 -data $rectdata -maskdata $rectmask
1674 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
1675 -data $rectdata -maskdata $rectmask
1677 proc init_flist
{first
} {
1678 global cflist cflist_top selectedline difffilestart
1680 $cflist conf
-state normal
1681 $cflist delete
0.0 end
1683 $cflist insert end
$first
1685 $cflist tag add highlight
1.0 "1.0 lineend"
1687 catch
{unset cflist_top
}
1689 $cflist conf
-state disabled
1690 set difffilestart
{}
1693 proc highlight_tag
{f
} {
1694 global highlight_paths
1696 foreach p
$highlight_paths {
1697 if {[string match
$p $f]} {
1704 proc highlight_filelist
{} {
1705 global cmitmode cflist
1707 $cflist conf
-state normal
1708 if {$cmitmode ne
"tree"} {
1709 set end
[lindex
[split [$cflist index end
] .
] 0]
1710 for {set l
2} {$l < $end} {incr l
} {
1711 set line
[$cflist get
$l.0 "$l.0 lineend"]
1712 if {[highlight_tag
$line] ne
{}} {
1713 $cflist tag add bold
$l.0 "$l.0 lineend"
1719 $cflist conf
-state disabled
1722 proc unhighlight_filelist
{} {
1725 $cflist conf
-state normal
1726 $cflist tag remove bold
1.0 end
1727 $cflist conf
-state disabled
1730 proc add_flist
{fl
} {
1733 $cflist conf
-state normal
1735 $cflist insert end
"\n"
1736 $cflist insert end
$f [highlight_tag
$f]
1738 $cflist conf
-state disabled
1741 proc sel_flist
{w x y
} {
1742 global ctext difffilestart cflist cflist_top cmitmode
1744 if {$cmitmode eq
"tree"} return
1745 if {![info exists cflist_top
]} return
1746 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1747 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1748 $cflist tag add highlight
$l.0 "$l.0 lineend"
1753 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
1757 proc pop_flist_menu
{w X Y x y
} {
1758 global ctext cflist cmitmode flist_menu flist_menu_file
1759 global treediffs diffids
1762 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1764 if {$cmitmode eq
"tree"} {
1765 set e
[linetoelt
$l]
1766 if {[string index
$e end
] eq
"/"} return
1768 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
1770 set flist_menu_file
$e
1771 tk_popup
$flist_menu $X $Y
1774 proc flist_hl
{only
} {
1775 global flist_menu_file findstring gdttype
1777 set x
[shellquote
$flist_menu_file]
1778 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
1781 append findstring
" " $x
1783 set gdttype
[mc
"touching paths:"]
1786 # Functions for adding and removing shell-type quoting
1788 proc shellquote
{str
} {
1789 if {![string match
"*\['\"\\ \t]*" $str]} {
1792 if {![string match
"*\['\"\\]*" $str]} {
1795 if {![string match
"*'*" $str]} {
1798 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1801 proc shellarglist
{l
} {
1807 append str
[shellquote
$a]
1812 proc shelldequote
{str
} {
1817 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
1818 append ret
[string range
$str $used end
]
1819 set used
[string length
$str]
1822 set first
[lindex
$first 0]
1823 set ch
[string index
$str $first]
1824 if {$first > $used} {
1825 append ret
[string range
$str $used [expr {$first - 1}]]
1828 if {$ch eq
" " ||
$ch eq
"\t"} break
1831 set first
[string first
"'" $str $used]
1833 error
"unmatched single-quote"
1835 append ret
[string range
$str $used [expr {$first - 1}]]
1840 if {$used >= [string length
$str]} {
1841 error
"trailing backslash"
1843 append ret
[string index
$str $used]
1848 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
1849 error
"unmatched double-quote"
1851 set first
[lindex
$first 0]
1852 set ch
[string index
$str $first]
1853 if {$first > $used} {
1854 append ret
[string range
$str $used [expr {$first - 1}]]
1857 if {$ch eq
"\""} break
1859 append ret
[string index
$str $used]
1863 return [list
$used $ret]
1866 proc shellsplit
{str
} {
1869 set str
[string trimleft
$str]
1870 if {$str eq
{}} break
1871 set dq
[shelldequote
$str]
1872 set n
[lindex
$dq 0]
1873 set word
[lindex
$dq 1]
1874 set str
[string range
$str $n end
]
1880 # Code to implement multiple views
1882 proc newview
{ishighlight
} {
1883 global nextviewnum newviewname newviewperm newishighlight
1884 global newviewargs revtreeargs viewargscmd newviewargscmd curview
1886 set newishighlight
$ishighlight
1888 if {[winfo exists
$top]} {
1892 set newviewname
($nextviewnum) "[mc "View
"] $nextviewnum"
1893 set newviewperm
($nextviewnum) 0
1894 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
1895 set newviewargscmd
($nextviewnum) $viewargscmd($curview)
1896 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
1901 global viewname viewperm newviewname newviewperm
1902 global viewargs newviewargs viewargscmd newviewargscmd
1904 set top .gitkvedit-
$curview
1905 if {[winfo exists
$top]} {
1909 set newviewname
($curview) $viewname($curview)
1910 set newviewperm
($curview) $viewperm($curview)
1911 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
1912 set newviewargscmd
($curview) $viewargscmd($curview)
1913 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
1916 proc vieweditor
{top n title
} {
1917 global newviewname newviewperm viewfiles bgcolor
1920 wm title
$top $title
1921 label
$top.
nl -text [mc
"Name"]
1922 entry
$top.name
-width 20 -textvariable newviewname
($n)
1923 grid
$top.
nl $top.name
-sticky w
-pady 5
1924 checkbutton
$top.perm
-text [mc
"Remember this view"] \
1925 -variable newviewperm
($n)
1926 grid
$top.perm
- -pady 5 -sticky w
1927 message
$top.al
-aspect 1000 \
1928 -text [mc
"Commits to include (arguments to git rev-list):"]
1929 grid
$top.al
- -sticky w
-pady 5
1930 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
1931 -background $bgcolor
1932 grid
$top.args
- -sticky ew
-padx 5
1934 message
$top.ac
-aspect 1000 \
1935 -text [mc
"Command to generate more commits to include:"]
1936 grid
$top.ac
- -sticky w
-pady 5
1937 entry
$top.argscmd
-width 50 -textvariable newviewargscmd
($n) \
1939 grid
$top.argscmd
- -sticky ew
-padx 5
1941 message
$top.l
-aspect 1000 \
1942 -text [mc
"Enter files and directories to include, one per line:"]
1943 grid
$top.l
- -sticky w
1944 text
$top.t
-width 40 -height 10 -background $bgcolor -font uifont
1945 if {[info exists viewfiles
($n)]} {
1946 foreach f
$viewfiles($n) {
1947 $top.t insert end
$f
1948 $top.t insert end
"\n"
1950 $top.t delete
{end
- 1c
} end
1951 $top.t mark
set insert
0.0
1953 grid
$top.t
- -sticky ew
-padx 5
1955 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n]
1956 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top]
1957 grid
$top.buts.ok
$top.buts.can
1958 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
1959 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
1960 grid
$top.buts
- -pady 10 -sticky ew
1964 proc doviewmenu
{m first cmd op argv
} {
1965 set nmenu
[$m index end
]
1966 for {set i
$first} {$i <= $nmenu} {incr i
} {
1967 if {[$m entrycget
$i -command] eq
$cmd} {
1968 eval $m $op $i $argv
1974 proc allviewmenus
{n op args
} {
1977 doviewmenu .bar.view
5 [list showview
$n] $op $args
1978 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1981 proc newviewok
{top n
} {
1982 global nextviewnum newviewperm newviewname newishighlight
1983 global viewname viewfiles viewperm selectedview curview
1984 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
1987 set newargs
[shellsplit
$newviewargs($n)]
1989 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
1995 foreach f
[split [$top.t get
0.0 end
] "\n"] {
1996 set ft
[string trim
$f]
2001 if {![info exists viewfiles
($n)]} {
2002 # creating a new view
2004 set viewname
($n) $newviewname($n)
2005 set viewperm
($n) $newviewperm($n)
2006 set viewfiles
($n) $files
2007 set viewargs
($n) $newargs
2008 set viewargscmd
($n) $newviewargscmd($n)
2010 if {!$newishighlight} {
2013 run addvhighlight
$n
2016 # editing an existing view
2017 set viewperm
($n) $newviewperm($n)
2018 if {$newviewname($n) ne
$viewname($n)} {
2019 set viewname
($n) $newviewname($n)
2020 doviewmenu .bar.view
5 [list showview
$n] \
2021 entryconf
[list
-label $viewname($n)]
2022 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2023 # entryconf [list -label $viewname($n) -value $viewname($n)]
2025 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n) || \
2026 $newviewargscmd($n) ne
$viewargscmd($n)} {
2027 set viewfiles
($n) $files
2028 set viewargs
($n) $newargs
2029 set viewargscmd
($n) $newviewargscmd($n)
2030 if {$curview == $n} {
2035 catch
{destroy
$top}
2039 global curview viewdata viewperm hlview selectedhlview
2041 if {$curview == 0} return
2042 if {[info exists hlview
] && $hlview == $curview} {
2043 set selectedhlview
[mc
"None"]
2046 allviewmenus
$curview delete
2047 set viewdata
($curview) {}
2048 set viewperm
($curview) 0
2052 proc addviewmenu
{n
} {
2053 global viewname viewhlmenu
2055 .bar.view add radiobutton
-label $viewname($n) \
2056 -command [list showview
$n] -variable selectedview
-value $n
2057 #$viewhlmenu add radiobutton -label $viewname($n) \
2058 # -command [list addvhighlight $n] -variable selectedhlview
2061 proc flatten
{var
} {
2065 foreach i
[array names
$var] {
2066 lappend ret
$i [set $var\
($i\
)]
2071 proc unflatten
{var l
} {
2081 global curview viewdata viewfiles
2082 global displayorder parentlist rowidlist rowisopt rowfinal
2083 global colormap rowtextx commitrow nextcolor canvxmax
2084 global numcommits commitlisted
2085 global selectedline currentid canv canvy0
2087 global pending_select phase
2090 global selectedview selectfirst
2091 global vparentlist vdisporder vcmitlisted
2092 global hlview selectedhlview commitinterest
2094 if {$n == $curview} return
2096 if {[info exists selectedline
]} {
2097 set selid
$currentid
2098 set y
[yc
$selectedline]
2099 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2100 set span
[$canv yview
]
2101 set ytop
[expr {[lindex
$span 0] * $ymax}]
2102 set ybot
[expr {[lindex
$span 1] * $ymax}]
2103 if {$ytop < $y && $y < $ybot} {
2104 set yscreen
[expr {$y - $ytop}]
2106 set yscreen
[expr {($ybot - $ytop) / 2}]
2108 } elseif
{[info exists pending_select
]} {
2109 set selid
$pending_select
2110 unset pending_select
2114 if {$curview >= 0} {
2115 set vparentlist
($curview) $parentlist
2116 set vdisporder
($curview) $displayorder
2117 set vcmitlisted
($curview) $commitlisted
2119 ![info exists viewdata
($curview)] ||
2120 [lindex
$viewdata($curview) 0] ne
{}} {
2121 set viewdata
($curview) \
2122 [list
$phase $rowidlist $rowisopt $rowfinal]
2125 catch
{unset treediffs
}
2127 if {[info exists hlview
] && $hlview == $n} {
2129 set selectedhlview
[mc
"None"]
2131 catch
{unset commitinterest
}
2135 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2136 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2139 if {![info exists viewdata
($n)]} {
2141 set pending_select
$selid
2148 set phase
[lindex
$v 0]
2149 set displayorder
$vdisporder($n)
2150 set parentlist
$vparentlist($n)
2151 set commitlisted
$vcmitlisted($n)
2152 set rowidlist
[lindex
$v 1]
2153 set rowisopt
[lindex
$v 2]
2154 set rowfinal
[lindex
$v 3]
2155 set numcommits
$commitidx($n)
2157 catch
{unset colormap
}
2158 catch
{unset rowtextx
}
2160 set canvxmax
[$canv cget
-width]
2167 if {$selid ne
{} && [info exists commitrow
($n,$selid)]} {
2168 set row
$commitrow($n,$selid)
2169 # try to get the selected row in the same position on the screen
2170 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2171 set ytop
[expr {[yc
$row] - $yscreen}]
2175 set yf
[expr {$ytop * 1.0 / $ymax}]
2177 allcanvs yview moveto
$yf
2181 } elseif
{$selid ne
{}} {
2182 set pending_select
$selid
2184 set row
[first_real_row
]
2185 if {$row < $numcommits} {
2192 if {$phase eq
"getcommits"} {
2193 show_status
[mc
"Reading commits..."]
2196 } elseif
{$numcommits == 0} {
2197 show_status
[mc
"No commits selected"]
2201 # Stuff relating to the highlighting facility
2203 proc ishighlighted
{row
} {
2204 global vhighlights fhighlights nhighlights rhighlights
2206 if {[info exists nhighlights
($row)] && $nhighlights($row) > 0} {
2207 return $nhighlights($row)
2209 if {[info exists vhighlights
($row)] && $vhighlights($row) > 0} {
2210 return $vhighlights($row)
2212 if {[info exists fhighlights
($row)] && $fhighlights($row) > 0} {
2213 return $fhighlights($row)
2215 if {[info exists rhighlights
($row)] && $rhighlights($row) > 0} {
2216 return $rhighlights($row)
2221 proc bolden
{row font
} {
2222 global canv linehtag selectedline boldrows
2224 lappend boldrows
$row
2225 $canv itemconf
$linehtag($row) -font $font
2226 if {[info exists selectedline
] && $row == $selectedline} {
2228 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2229 -outline {{}} -tags secsel \
2230 -fill [$canv cget
-selectbackground]]
2235 proc bolden_name
{row font
} {
2236 global canv2 linentag selectedline boldnamerows
2238 lappend boldnamerows
$row
2239 $canv2 itemconf
$linentag($row) -font $font
2240 if {[info exists selectedline
] && $row == $selectedline} {
2241 $canv2 delete secsel
2242 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2243 -outline {{}} -tags secsel \
2244 -fill [$canv2 cget
-selectbackground]]
2253 foreach row
$boldrows {
2254 if {![ishighlighted
$row]} {
2255 bolden
$row mainfont
2257 lappend stillbold
$row
2260 set boldrows
$stillbold
2263 proc addvhighlight
{n
} {
2264 global hlview curview viewdata vhl_done vhighlights commitidx
2266 if {[info exists hlview
]} {
2270 if {$n != $curview && ![info exists viewdata
($n)]} {
2271 set viewdata
($n) [list getcommits
{{}} 0 0 0]
2272 set vparentlist
($n) {}
2273 set vdisporder
($n) {}
2274 set vcmitlisted
($n) {}
2277 set vhl_done
$commitidx($hlview)
2278 if {$vhl_done > 0} {
2283 proc delvhighlight
{} {
2284 global hlview vhighlights
2286 if {![info exists hlview
]} return
2288 catch
{unset vhighlights
}
2292 proc vhighlightmore
{} {
2293 global hlview vhl_done commitidx vhighlights
2294 global displayorder vdisporder curview
2296 set max
$commitidx($hlview)
2297 if {$hlview == $curview} {
2298 set disp
$displayorder
2300 set disp
$vdisporder($hlview)
2302 set vr
[visiblerows
]
2303 set r0
[lindex
$vr 0]
2304 set r1
[lindex
$vr 1]
2305 for {set i
$vhl_done} {$i < $max} {incr i
} {
2306 set id
[lindex
$disp $i]
2307 if {[info exists commitrow
($curview,$id)]} {
2308 set row
$commitrow($curview,$id)
2309 if {$r0 <= $row && $row <= $r1} {
2310 if {![highlighted
$row]} {
2311 bolden
$row mainfontbold
2313 set vhighlights
($row) 1
2320 proc askvhighlight
{row id
} {
2321 global hlview vhighlights commitrow iddrawn
2323 if {[info exists commitrow
($hlview,$id)]} {
2324 if {[info exists iddrawn
($id)] && ![ishighlighted
$row]} {
2325 bolden
$row mainfontbold
2327 set vhighlights
($row) 1
2329 set vhighlights
($row) 0
2333 proc hfiles_change
{} {
2334 global highlight_files filehighlight fhighlights fh_serial
2335 global highlight_paths gdttype
2337 if {[info exists filehighlight
]} {
2338 # delete previous highlights
2339 catch
{close
$filehighlight}
2341 catch
{unset fhighlights
}
2343 unhighlight_filelist
2345 set highlight_paths
{}
2346 after cancel do_file_hl
$fh_serial
2348 if {$highlight_files ne
{}} {
2349 after
300 do_file_hl
$fh_serial
2353 proc gdttype_change
{name ix op
} {
2354 global gdttype highlight_files findstring findpattern
2357 if {$findstring ne
{}} {
2358 if {$gdttype eq
[mc
"containing:"]} {
2359 if {$highlight_files ne
{}} {
2360 set highlight_files
{}
2365 if {$findpattern ne
{}} {
2369 set highlight_files
$findstring
2374 # enable/disable findtype/findloc menus too
2377 proc find_change
{name ix op
} {
2378 global gdttype findstring highlight_files
2381 if {$gdttype eq
[mc
"containing:"]} {
2384 if {$highlight_files ne
$findstring} {
2385 set highlight_files
$findstring
2392 proc findcom_change args
{
2393 global nhighlights boldnamerows
2394 global findpattern findtype findstring gdttype
2397 # delete previous highlights, if any
2398 foreach row
$boldnamerows {
2399 bolden_name
$row mainfont
2402 catch
{unset nhighlights
}
2405 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
2407 } elseif
{$findtype eq
[mc
"Regexp"]} {
2408 set findpattern
$findstring
2410 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2412 set findpattern
"*$e*"
2416 proc makepatterns
{l
} {
2419 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2420 if {[string index
$ee end
] eq
"/"} {
2430 proc do_file_hl
{serial
} {
2431 global highlight_files filehighlight highlight_paths gdttype fhl_list
2433 if {$gdttype eq
[mc
"touching paths:"]} {
2434 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
2435 set highlight_paths
[makepatterns
$paths]
2437 set gdtargs
[concat
-- $paths]
2438 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
2439 set gdtargs
[list
"-S$highlight_files"]
2441 # must be "containing:", i.e. we're searching commit info
2444 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
2445 set filehighlight
[open
$cmd r
+]
2446 fconfigure
$filehighlight -blocking 0
2447 filerun
$filehighlight readfhighlight
2453 proc flushhighlights
{} {
2454 global filehighlight fhl_list
2456 if {[info exists filehighlight
]} {
2458 puts
$filehighlight ""
2459 flush
$filehighlight
2463 proc askfilehighlight
{row id
} {
2464 global filehighlight fhighlights fhl_list
2466 lappend fhl_list
$id
2467 set fhighlights
($row) -1
2468 puts
$filehighlight $id
2471 proc readfhighlight
{} {
2472 global filehighlight fhighlights commitrow curview iddrawn
2473 global fhl_list find_dirn
2475 if {![info exists filehighlight
]} {
2479 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
2480 set line
[string trim
$line]
2481 set i
[lsearch
-exact $fhl_list $line]
2482 if {$i < 0} continue
2483 for {set j
0} {$j < $i} {incr j
} {
2484 set id
[lindex
$fhl_list $j]
2485 if {[info exists commitrow
($curview,$id)]} {
2486 set fhighlights
($commitrow($curview,$id)) 0
2489 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
2490 if {$line eq
{}} continue
2491 if {![info exists commitrow
($curview,$line)]} continue
2492 set row
$commitrow($curview,$line)
2493 if {[info exists iddrawn
($line)] && ![ishighlighted
$row]} {
2494 bolden
$row mainfontbold
2496 set fhighlights
($row) 1
2498 if {[eof
$filehighlight]} {
2500 puts
"oops, git diff-tree died"
2501 catch
{close
$filehighlight}
2505 if {[info exists find_dirn
]} {
2511 proc doesmatch
{f
} {
2512 global findtype findpattern
2514 if {$findtype eq
[mc
"Regexp"]} {
2515 return [regexp
$findpattern $f]
2516 } elseif
{$findtype eq
[mc
"IgnCase"]} {
2517 return [string match
-nocase $findpattern $f]
2519 return [string match
$findpattern $f]
2523 proc askfindhighlight
{row id
} {
2524 global nhighlights commitinfo iddrawn
2526 global markingmatches
2528 if {![info exists commitinfo
($id)]} {
2531 set info
$commitinfo($id)
2533 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
2534 foreach f
$info ty
$fldtypes {
2535 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
2537 if {$ty eq
[mc
"Author"]} {
2544 if {$isbold && [info exists iddrawn
($id)]} {
2545 if {![ishighlighted
$row]} {
2546 bolden
$row mainfontbold
2548 bolden_name
$row mainfontbold
2551 if {$markingmatches} {
2552 markrowmatches
$row $id
2555 set nhighlights
($row) $isbold
2558 proc markrowmatches
{row id
} {
2559 global canv canv2 linehtag linentag commitinfo findloc
2561 set headline
[lindex
$commitinfo($id) 0]
2562 set author
[lindex
$commitinfo($id) 1]
2563 $canv delete match
$row
2564 $canv2 delete match
$row
2565 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
2566 set m
[findmatches
$headline]
2568 markmatches
$canv $row $headline $linehtag($row) $m \
2569 [$canv itemcget
$linehtag($row) -font] $row
2572 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
2573 set m
[findmatches
$author]
2575 markmatches
$canv2 $row $author $linentag($row) $m \
2576 [$canv2 itemcget
$linentag($row) -font] $row
2581 proc vrel_change
{name ix op
} {
2582 global highlight_related
2585 if {$highlight_related ne
[mc
"None"]} {
2590 # prepare for testing whether commits are descendents or ancestors of a
2591 proc rhighlight_sel
{a
} {
2592 global descendent desc_todo ancestor anc_todo
2593 global highlight_related rhighlights
2595 catch
{unset descendent
}
2596 set desc_todo
[list
$a]
2597 catch
{unset ancestor
}
2598 set anc_todo
[list
$a]
2599 if {$highlight_related ne
[mc
"None"]} {
2605 proc rhighlight_none
{} {
2608 catch
{unset rhighlights
}
2612 proc is_descendent
{a
} {
2613 global curview children commitrow descendent desc_todo
2616 set la
$commitrow($v,$a)
2620 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2621 set do [lindex
$todo $i]
2622 if {$commitrow($v,$do) < $la} {
2623 lappend leftover
$do
2626 foreach nk
$children($v,$do) {
2627 if {![info exists descendent
($nk)]} {
2628 set descendent
($nk) 1
2636 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2640 set descendent
($a) 0
2641 set desc_todo
$leftover
2644 proc is_ancestor
{a
} {
2645 global curview parentlist commitrow ancestor anc_todo
2648 set la
$commitrow($v,$a)
2652 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2653 set do [lindex
$todo $i]
2654 if {![info exists commitrow
($v,$do)] ||
$commitrow($v,$do) > $la} {
2655 lappend leftover
$do
2658 foreach np
[lindex
$parentlist $commitrow($v,$do)] {
2659 if {![info exists ancestor
($np)]} {
2668 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2673 set anc_todo
$leftover
2676 proc askrelhighlight
{row id
} {
2677 global descendent highlight_related iddrawn rhighlights
2678 global selectedline ancestor
2680 if {![info exists selectedline
]} return
2682 if {$highlight_related eq
[mc
"Descendant"] ||
2683 $highlight_related eq
[mc
"Not descendant"]} {
2684 if {![info exists descendent
($id)]} {
2687 if {$descendent($id) == ($highlight_related eq
[mc
"Descendant"])} {
2690 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
2691 $highlight_related eq
[mc
"Not ancestor"]} {
2692 if {![info exists ancestor
($id)]} {
2695 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
2699 if {[info exists iddrawn
($id)]} {
2700 if {$isbold && ![ishighlighted
$row]} {
2701 bolden
$row mainfontbold
2704 set rhighlights
($row) $isbold
2707 # Graph layout functions
2709 proc shortids
{ids
} {
2712 if {[llength
$id] > 1} {
2713 lappend res
[shortids
$id]
2714 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
2715 lappend res
[string range
$id 0 7]
2726 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
2727 if {($n & $mask) != 0} {
2728 set ret
[concat
$ret $o]
2730 set o
[concat
$o $o]
2735 # Work out where id should go in idlist so that order-token
2736 # values increase from left to right
2737 proc idcol
{idlist id
{i
0}} {
2738 global ordertok curview
2740 set t
$ordertok($curview,$id)
2741 if {$i >= [llength
$idlist] ||
2742 $t < $ordertok($curview,[lindex
$idlist $i])} {
2743 if {$i > [llength
$idlist]} {
2744 set i
[llength
$idlist]
2746 while {[incr i
-1] >= 0 &&
2747 $t < $ordertok($curview,[lindex
$idlist $i])} {}
2750 if {$t > $ordertok($curview,[lindex
$idlist $i])} {
2751 while {[incr i
] < [llength
$idlist] &&
2752 $t >= $ordertok($curview,[lindex
$idlist $i])} {}
2758 proc initlayout
{} {
2759 global rowidlist rowisopt rowfinal displayorder commitlisted
2760 global numcommits canvxmax canv
2763 global colormap rowtextx
2774 set canvxmax
[$canv cget
-width]
2775 catch
{unset colormap
}
2776 catch
{unset rowtextx
}
2780 proc setcanvscroll
{} {
2781 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2783 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2784 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
2785 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
2786 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
2789 proc visiblerows
{} {
2790 global canv numcommits linespc
2792 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2793 if {$ymax eq
{} ||
$ymax == 0} return
2795 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
2796 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
2800 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
2801 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
2802 if {$r1 >= $numcommits} {
2803 set r1
[expr {$numcommits - 1}]
2805 return [list
$r0 $r1]
2808 proc layoutmore
{} {
2809 global commitidx viewcomplete numcommits
2810 global uparrowlen downarrowlen mingaplen curview
2812 set show
$commitidx($curview)
2813 if {$show > $numcommits ||
$viewcomplete($curview)} {
2814 showstuff
$show $viewcomplete($curview)
2818 proc showstuff
{canshow last
} {
2819 global numcommits commitrow pending_select selectedline curview
2820 global mainheadid displayorder selectfirst
2821 global lastscrollset commitinterest
2823 if {$numcommits == 0} {
2825 set phase
"incrdraw"
2829 set prev
$numcommits
2830 set numcommits
$canshow
2831 set t
[clock clicks
-milliseconds]
2832 if {$prev < 100 ||
$last ||
$t - $lastscrollset > 500} {
2833 set lastscrollset
$t
2836 set rows
[visiblerows
]
2837 set r1
[lindex
$rows 1]
2838 if {$r1 >= $canshow} {
2839 set r1
[expr {$canshow - 1}]
2844 if {[info exists pending_select
] &&
2845 [info exists commitrow
($curview,$pending_select)] &&
2846 $commitrow($curview,$pending_select) < $numcommits} {
2847 selectline
$commitrow($curview,$pending_select) 1
2850 if {[info exists selectedline
] ||
[info exists pending_select
]} {
2853 set l
[first_real_row
]
2860 proc doshowlocalchanges
{} {
2861 global curview mainheadid phase commitrow
2863 if {[info exists commitrow
($curview,$mainheadid)] &&
2864 ($phase eq
{} ||
$commitrow($curview,$mainheadid) < $numcommits - 1)} {
2866 } elseif
{$phase ne
{}} {
2867 lappend commitinterest
($mainheadid) {}
2871 proc dohidelocalchanges
{} {
2872 global localfrow localirow lserial
2874 if {$localfrow >= 0} {
2875 removerow
$localfrow
2877 if {$localirow > 0} {
2881 if {$localirow >= 0} {
2882 removerow
$localirow
2888 # spawn off a process to do git diff-index --cached HEAD
2889 proc dodiffindex
{} {
2890 global localirow localfrow lserial showlocalchanges
2893 if {!$showlocalchanges ||
!$isworktree} return
2897 set fd
[open
"|git diff-index --cached HEAD" r
]
2898 fconfigure
$fd -blocking 0
2899 filerun
$fd [list readdiffindex
$fd $lserial]
2902 proc readdiffindex
{fd serial
} {
2903 global localirow commitrow mainheadid nullid2 curview
2904 global commitinfo commitdata lserial
2907 if {[gets
$fd line
] < 0} {
2913 # we only need to see one line and we don't really care what it says...
2916 # now see if there are any local changes not checked in to the index
2917 if {$serial == $lserial} {
2918 set fd
[open
"|git diff-files" r
]
2919 fconfigure
$fd -blocking 0
2920 filerun
$fd [list readdifffiles
$fd $serial]
2923 if {$isdiff && $serial == $lserial && $localirow == -1} {
2924 # add the line for the changes in the index to the graph
2925 set localirow
$commitrow($curview,$mainheadid)
2926 set hl
[mc
"Local changes checked in to index but not committed"]
2927 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
2928 set commitdata
($nullid2) "\n $hl\n"
2929 insertrow
$localirow $nullid2
2934 proc readdifffiles
{fd serial
} {
2935 global localirow localfrow commitrow mainheadid nullid curview
2936 global commitinfo commitdata lserial
2939 if {[gets
$fd line
] < 0} {
2945 # we only need to see one line and we don't really care what it says...
2948 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2949 # add the line for the local diff to the graph
2950 if {$localirow >= 0} {
2951 set localfrow
$localirow
2954 set localfrow
$commitrow($curview,$mainheadid)
2956 set hl
[mc
"Local uncommitted changes, not checked in to index"]
2957 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
2958 set commitdata
($nullid) "\n $hl\n"
2959 insertrow
$localfrow $nullid
2964 proc nextuse
{id row
} {
2965 global commitrow curview children
2967 if {[info exists children
($curview,$id)]} {
2968 foreach kid
$children($curview,$id) {
2969 if {![info exists commitrow
($curview,$kid)]} {
2972 if {$commitrow($curview,$kid) > $row} {
2973 return $commitrow($curview,$kid)
2977 if {[info exists commitrow
($curview,$id)]} {
2978 return $commitrow($curview,$id)
2983 proc prevuse
{id row
} {
2984 global commitrow curview children
2987 if {[info exists children
($curview,$id)]} {
2988 foreach kid
$children($curview,$id) {
2989 if {![info exists commitrow
($curview,$kid)]} break
2990 if {$commitrow($curview,$kid) < $row} {
2991 set ret
$commitrow($curview,$kid)
2998 proc make_idlist
{row
} {
2999 global displayorder parentlist uparrowlen downarrowlen mingaplen
3000 global commitidx curview ordertok children commitrow
3002 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
3006 set ra
[expr {$row - $downarrowlen}]
3010 set rb
[expr {$row + $uparrowlen}]
3011 if {$rb > $commitidx($curview)} {
3012 set rb
$commitidx($curview)
3015 for {} {$r < $ra} {incr r
} {
3016 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3017 foreach p
[lindex
$parentlist $r] {
3018 if {$p eq
$nextid} continue
3019 set rn
[nextuse
$p $r]
3021 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3022 lappend ids
[list
$ordertok($curview,$p) $p]
3026 for {} {$r < $row} {incr r
} {
3027 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3028 foreach p
[lindex
$parentlist $r] {
3029 if {$p eq
$nextid} continue
3030 set rn
[nextuse
$p $r]
3031 if {$rn < 0 ||
$rn >= $row} {
3032 lappend ids
[list
$ordertok($curview,$p) $p]
3036 set id
[lindex
$displayorder $row]
3037 lappend ids
[list
$ordertok($curview,$id) $id]
3039 foreach p
[lindex
$parentlist $r] {
3040 set firstkid
[lindex
$children($curview,$p) 0]
3041 if {$commitrow($curview,$firstkid) < $row} {
3042 lappend ids
[list
$ordertok($curview,$p) $p]
3046 set id
[lindex
$displayorder $r]
3048 set firstkid
[lindex
$children($curview,$id) 0]
3049 if {$firstkid ne
{} && $commitrow($curview,$firstkid) < $row} {
3050 lappend ids
[list
$ordertok($curview,$id) $id]
3055 foreach idx
[lsort
-unique $ids] {
3056 lappend idlist
[lindex
$idx 1]
3061 proc rowsequal
{a b
} {
3062 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3063 set a
[lreplace
$a $i $i]
3065 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3066 set b
[lreplace
$b $i $i]
3068 return [expr {$a eq
$b}]
3071 proc makeupline
{id row rend
col} {
3072 global rowidlist uparrowlen downarrowlen mingaplen
3074 for {set r
$rend} {1} {set r
$rstart} {
3075 set rstart
[prevuse
$id $r]
3076 if {$rstart < 0} return
3077 if {$rstart < $row} break
3079 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3080 set rstart
[expr {$rend - $uparrowlen - 1}]
3082 for {set r
$rstart} {[incr r
] <= $row} {} {
3083 set idlist
[lindex
$rowidlist $r]
3084 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3085 set col [idcol
$idlist $id $col]
3086 lset rowidlist
$r [linsert
$idlist $col $id]
3092 proc layoutrows
{row endrow
} {
3093 global rowidlist rowisopt rowfinal displayorder
3094 global uparrowlen downarrowlen maxwidth mingaplen
3095 global children parentlist
3096 global commitidx viewcomplete curview commitrow
3100 set rm1
[expr {$row - 1}]
3101 foreach id
[lindex
$rowidlist $rm1] {
3106 set final
[lindex
$rowfinal $rm1]
3108 for {} {$row < $endrow} {incr row
} {
3109 set rm1
[expr {$row - 1}]
3110 if {$rm1 < 0 ||
$idlist eq
{}} {
3111 set idlist
[make_idlist
$row]
3114 set id
[lindex
$displayorder $rm1]
3115 set col [lsearch
-exact $idlist $id]
3116 set idlist
[lreplace
$idlist $col $col]
3117 foreach p
[lindex
$parentlist $rm1] {
3118 if {[lsearch
-exact $idlist $p] < 0} {
3119 set col [idcol
$idlist $p $col]
3120 set idlist
[linsert
$idlist $col $p]
3121 # if not the first child, we have to insert a line going up
3122 if {$id ne
[lindex
$children($curview,$p) 0]} {
3123 makeupline
$p $rm1 $row $col
3127 set id
[lindex
$displayorder $row]
3128 if {$row > $downarrowlen} {
3129 set termrow
[expr {$row - $downarrowlen - 1}]
3130 foreach p
[lindex
$parentlist $termrow] {
3131 set i
[lsearch
-exact $idlist $p]
3132 if {$i < 0} continue
3133 set nr
[nextuse
$p $termrow]
3134 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3135 set idlist
[lreplace
$idlist $i $i]
3139 set col [lsearch
-exact $idlist $id]
3141 set col [idcol
$idlist $id]
3142 set idlist
[linsert
$idlist $col $id]
3143 if {$children($curview,$id) ne
{}} {
3144 makeupline
$id $rm1 $row $col
3147 set r
[expr {$row + $uparrowlen - 1}]
3148 if {$r < $commitidx($curview)} {
3150 foreach p
[lindex
$parentlist $r] {
3151 if {[lsearch
-exact $idlist $p] >= 0} continue
3152 set fk
[lindex
$children($curview,$p) 0]
3153 if {$commitrow($curview,$fk) < $row} {
3154 set x
[idcol
$idlist $p $x]
3155 set idlist
[linsert
$idlist $x $p]
3158 if {[incr r
] < $commitidx($curview)} {
3159 set p
[lindex
$displayorder $r]
3160 if {[lsearch
-exact $idlist $p] < 0} {
3161 set fk
[lindex
$children($curview,$p) 0]
3162 if {$fk ne
{} && $commitrow($curview,$fk) < $row} {
3163 set x
[idcol
$idlist $p $x]
3164 set idlist
[linsert
$idlist $x $p]
3170 if {$final && !$viewcomplete($curview) &&
3171 $row + $uparrowlen + $mingaplen + $downarrowlen
3172 >= $commitidx($curview)} {
3175 set l
[llength
$rowidlist]
3177 lappend rowidlist
$idlist
3179 lappend rowfinal
$final
3180 } elseif
{$row < $l} {
3181 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3182 lset rowidlist
$row $idlist
3185 lset rowfinal
$row $final
3187 set pad
[ntimes
[expr {$row - $l}] {}]
3188 set rowidlist
[concat
$rowidlist $pad]
3189 lappend rowidlist
$idlist
3190 set rowfinal
[concat
$rowfinal $pad]
3191 lappend rowfinal
$final
3192 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3198 proc changedrow
{row
} {
3199 global displayorder iddrawn rowisopt need_redisplay
3201 set l
[llength
$rowisopt]
3203 lset rowisopt
$row 0
3204 if {$row + 1 < $l} {
3205 lset rowisopt
[expr {$row + 1}] 0
3206 if {$row + 2 < $l} {
3207 lset rowisopt
[expr {$row + 2}] 0
3211 set id
[lindex
$displayorder $row]
3212 if {[info exists iddrawn
($id)]} {
3213 set need_redisplay
1
3217 proc insert_pad
{row
col npad
} {
3220 set pad
[ntimes
$npad {}]
3221 set idlist
[lindex
$rowidlist $row]
3222 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3223 set aft
[lrange
$idlist $col end
]
3224 set i
[lsearch
-exact $aft {}]
3226 set aft
[lreplace
$aft $i $i]
3228 lset rowidlist
$row [concat
$bef $pad $aft]
3232 proc optimize_rows
{row
col endrow
} {
3233 global rowidlist rowisopt displayorder curview children
3238 for {} {$row < $endrow} {incr row
; set col 0} {
3239 if {[lindex
$rowisopt $row]} continue
3241 set y0
[expr {$row - 1}]
3242 set ym
[expr {$row - 2}]
3243 set idlist
[lindex
$rowidlist $row]
3244 set previdlist
[lindex
$rowidlist $y0]
3245 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3247 set pprevidlist
[lindex
$rowidlist $ym]
3248 if {$pprevidlist eq
{}} continue
3254 for {} {$col < [llength
$idlist]} {incr
col} {
3255 set id
[lindex
$idlist $col]
3256 if {[lindex
$previdlist $col] eq
$id} continue
3261 set x0
[lsearch
-exact $previdlist $id]
3262 if {$x0 < 0} continue
3263 set z
[expr {$x0 - $col}]
3267 set xm
[lsearch
-exact $pprevidlist $id]
3269 set z0
[expr {$xm - $x0}]
3273 # if row y0 is the first child of $id then it's not an arrow
3274 if {[lindex
$children($curview,$id) 0] ne
3275 [lindex
$displayorder $y0]} {
3279 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3280 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3283 # Looking at lines from this row to the previous row,
3284 # make them go straight up if they end in an arrow on
3285 # the previous row; otherwise make them go straight up
3287 if {$z < -1 ||
($z < 0 && $isarrow)} {
3288 # Line currently goes left too much;
3289 # insert pads in the previous row, then optimize it
3290 set npad
[expr {-1 - $z + $isarrow}]
3291 insert_pad
$y0 $x0 $npad
3293 optimize_rows
$y0 $x0 $row
3295 set previdlist
[lindex
$rowidlist $y0]
3296 set x0
[lsearch
-exact $previdlist $id]
3297 set z
[expr {$x0 - $col}]
3299 set pprevidlist
[lindex
$rowidlist $ym]
3300 set xm
[lsearch
-exact $pprevidlist $id]
3301 set z0
[expr {$xm - $x0}]
3303 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3304 # Line currently goes right too much;
3305 # insert pads in this line
3306 set npad
[expr {$z - 1 + $isarrow}]
3307 insert_pad
$row $col $npad
3308 set idlist
[lindex
$rowidlist $row]
3310 set z
[expr {$x0 - $col}]
3313 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3314 # this line links to its first child on row $row-2
3315 set id
[lindex
$displayorder $ym]
3316 set xc
[lsearch
-exact $pprevidlist $id]
3318 set z0
[expr {$xc - $x0}]
3321 # avoid lines jigging left then immediately right
3322 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3323 insert_pad
$y0 $x0 1
3325 optimize_rows
$y0 $x0 $row
3326 set previdlist
[lindex
$rowidlist $y0]
3330 # Find the first column that doesn't have a line going right
3331 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
3332 set id
[lindex
$idlist $col]
3333 if {$id eq
{}} break
3334 set x0
[lsearch
-exact $previdlist $id]
3336 # check if this is the link to the first child
3337 set kid
[lindex
$displayorder $y0]
3338 if {[lindex
$children($curview,$id) 0] eq
$kid} {
3339 # it is, work out offset to child
3340 set x0
[lsearch
-exact $previdlist $kid]
3343 if {$x0 <= $col} break
3345 # Insert a pad at that column as long as it has a line and
3346 # isn't the last column
3347 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
3348 set idlist
[linsert
$idlist $col {}]
3349 lset rowidlist
$row $idlist
3357 global canvx0 linespc
3358 return [expr {$canvx0 + $col * $linespc}]
3362 global canvy0 linespc
3363 return [expr {$canvy0 + $row * $linespc}]
3366 proc linewidth
{id
} {
3367 global thickerline lthickness
3370 if {[info exists thickerline
] && $id eq
$thickerline} {
3371 set wid
[expr {2 * $lthickness}]
3376 proc rowranges
{id
} {
3377 global commitrow curview children uparrowlen downarrowlen
3380 set kids
$children($curview,$id)
3386 foreach child
$kids {
3387 if {![info exists commitrow
($curview,$child)]} break
3388 set row
$commitrow($curview,$child)
3389 if {![info exists prev
]} {
3390 lappend ret
[expr {$row + 1}]
3392 if {$row <= $prevrow} {
3393 puts
"oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3395 # see if the line extends the whole way from prevrow to row
3396 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3397 [lsearch
-exact [lindex
$rowidlist \
3398 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
3399 # it doesn't, see where it ends
3400 set r
[expr {$prevrow + $downarrowlen}]
3401 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3402 while {[incr r
-1] > $prevrow &&
3403 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3405 while {[incr r
] <= $row &&
3406 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3410 # see where it starts up again
3411 set r
[expr {$row - $uparrowlen}]
3412 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3413 while {[incr r
] < $row &&
3414 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3416 while {[incr r
-1] >= $prevrow &&
3417 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3423 if {$child eq
$id} {
3432 proc drawlineseg
{id row endrow arrowlow
} {
3433 global rowidlist displayorder iddrawn linesegs
3434 global canv colormap linespc curview maxlinelen parentlist
3436 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
3437 set le
[expr {$row + 1}]
3440 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
3446 set x
[lindex
$displayorder $le]
3451 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
3452 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
3468 if {[info exists linesegs
($id)]} {
3469 set lines
$linesegs($id)
3471 set r0
[lindex
$li 0]
3473 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
3483 set li
[lindex
$lines [expr {$i-1}]]
3484 set r1
[lindex
$li 1]
3485 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
3490 set x
[lindex
$cols [expr {$le - $row}]]
3491 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
3492 set dir
[expr {$xp - $x}]
3494 set ith
[lindex
$lines $i 2]
3495 set coords
[$canv coords
$ith]
3496 set ah
[$canv itemcget
$ith -arrow]
3497 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
3498 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
3499 if {$x2 ne
{} && $x - $x2 == $dir} {
3500 set coords
[lrange
$coords 0 end-2
]
3503 set coords
[list
[xc
$le $x] [yc
$le]]
3506 set itl
[lindex
$lines [expr {$i-1}] 2]
3507 set al
[$canv itemcget
$itl -arrow]
3508 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
3509 } elseif
{$arrowlow} {
3510 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
3511 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
3515 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
3516 for {set y
$le} {[incr y
-1] > $row} {} {
3518 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
3519 set ndir
[expr {$xp - $x}]
3520 if {$dir != $ndir ||
$xp < 0} {
3521 lappend coords
[xc
$y $x] [yc
$y]
3527 # join parent line to first child
3528 set ch
[lindex
$displayorder $row]
3529 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
3531 puts
"oops: drawlineseg: child $ch not on row $row"
3532 } elseif
{$xc != $x} {
3533 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
3534 set d
[expr {int
(0.5 * $linespc)}]
3537 set x2
[expr {$x1 - $d}]
3539 set x2
[expr {$x1 + $d}]
3542 set y1
[expr {$y2 + $d}]
3543 lappend coords
$x1 $y1 $x2 $y2
3544 } elseif
{$xc < $x - 1} {
3545 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
3546 } elseif
{$xc > $x + 1} {
3547 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
3551 lappend coords
[xc
$row $x] [yc
$row]
3553 set xn
[xc
$row $xp]
3555 lappend coords
$xn $yn
3559 set t
[$canv create line
$coords -width [linewidth
$id] \
3560 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
3563 set lines
[linsert
$lines $i [list
$row $le $t]]
3565 $canv coords
$ith $coords
3566 if {$arrow ne
$ah} {
3567 $canv itemconf
$ith -arrow $arrow
3569 lset lines
$i 0 $row
3572 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
3573 set ndir
[expr {$xo - $xp}]
3574 set clow
[$canv coords
$itl]
3575 if {$dir == $ndir} {
3576 set clow
[lrange
$clow 2 end
]
3578 set coords
[concat
$coords $clow]
3580 lset lines
[expr {$i-1}] 1 $le
3582 # coalesce two pieces
3584 set b
[lindex
$lines [expr {$i-1}] 0]
3585 set e
[lindex
$lines $i 1]
3586 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
3588 $canv coords
$itl $coords
3589 if {$arrow ne
$al} {
3590 $canv itemconf
$itl -arrow $arrow
3594 set linesegs
($id) $lines
3598 proc drawparentlinks
{id row
} {
3599 global rowidlist canv colormap curview parentlist
3600 global idpos linespc
3602 set rowids
[lindex
$rowidlist $row]
3603 set col [lsearch
-exact $rowids $id]
3604 if {$col < 0} return
3605 set olds
[lindex
$parentlist $row]
3606 set row2
[expr {$row + 1}]
3607 set x
[xc
$row $col]
3610 set d
[expr {int
(0.5 * $linespc)}]
3611 set ymid
[expr {$y + $d}]
3612 set ids
[lindex
$rowidlist $row2]
3613 # rmx = right-most X coord used
3616 set i
[lsearch
-exact $ids $p]
3618 puts
"oops, parent $p of $id not in list"
3621 set x2
[xc
$row2 $i]
3625 set j
[lsearch
-exact $rowids $p]
3627 # drawlineseg will do this one for us
3631 # should handle duplicated parents here...
3632 set coords
[list
$x $y]
3634 # if attaching to a vertical segment, draw a smaller
3635 # slant for visual distinctness
3638 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
3640 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
3642 } elseif
{$i < $col && $i < $j} {
3643 # segment slants towards us already
3644 lappend coords
[xc
$row $j] $y
3646 if {$i < $col - 1} {
3647 lappend coords
[expr {$x2 + $linespc}] $y
3648 } elseif
{$i > $col + 1} {
3649 lappend coords
[expr {$x2 - $linespc}] $y
3651 lappend coords
$x2 $y2
3654 lappend coords
$x2 $y2
3656 set t
[$canv create line
$coords -width [linewidth
$p] \
3657 -fill $colormap($p) -tags lines.
$p]
3661 if {$rmx > [lindex
$idpos($id) 1]} {
3662 lset idpos
($id) 1 $rmx
3667 proc drawlines
{id
} {
3670 $canv itemconf lines.
$id -width [linewidth
$id]
3673 proc drawcmittext
{id row
col} {
3674 global linespc canv canv2 canv3 canvy0 fgcolor curview
3675 global commitlisted commitinfo rowidlist parentlist
3676 global rowtextx idpos idtags idheads idotherrefs
3677 global linehtag linentag linedtag selectedline
3678 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3680 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
3681 set listed
[lindex
$commitlisted $row]
3682 if {$id eq
$nullid} {
3684 } elseif
{$id eq
$nullid2} {
3687 set ofill
[expr {$listed != 0 ?
$listed == 2 ?
"gray" : "blue" : "white"}]
3689 set x
[xc
$row $col]
3691 set orad
[expr {$linespc / 3}]
3693 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
3694 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3695 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3696 } elseif
{$listed == 3} {
3697 # triangle pointing left for left-side commits
3698 set t
[$canv create polygon \
3699 [expr {$x - $orad}] $y \
3700 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3701 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3702 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3704 # triangle pointing right for right-side commits
3705 set t
[$canv create polygon \
3706 [expr {$x + $orad - 1}] $y \
3707 [expr {$x - $orad}] [expr {$y - $orad}] \
3708 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3709 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3712 $canv bind $t <1> {selcanvline
{} %x
%y
}
3713 set rmx
[llength
[lindex
$rowidlist $row]]
3714 set olds
[lindex
$parentlist $row]
3716 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
3718 set i
[lsearch
-exact $nextids $p]
3724 set xt
[xc
$row $rmx]
3725 set rowtextx
($row) $xt
3726 set idpos
($id) [list
$x $xt $y]
3727 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
3728 ||
[info exists idotherrefs
($id)]} {
3729 set xt
[drawtags
$id $x $xt $y]
3731 set headline
[lindex
$commitinfo($id) 0]
3732 set name
[lindex
$commitinfo($id) 1]
3733 set date [lindex
$commitinfo($id) 2]
3734 set date [formatdate
$date]
3737 set isbold
[ishighlighted
$row]
3739 lappend boldrows
$row
3740 set font mainfontbold
3742 lappend boldnamerows
$row
3743 set nfont mainfontbold
3746 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
3747 -text $headline -font $font -tags text
]
3748 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
3749 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
3750 -text $name -font $nfont -tags text
]
3751 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
3752 -text $date -font mainfont
-tags text
]
3753 if {[info exists selectedline
] && $selectedline == $row} {
3756 set xr
[expr {$xt + [font measure
$font $headline]}]
3757 if {$xr > $canvxmax} {
3763 proc drawcmitrow
{row
} {
3764 global displayorder rowidlist nrows_drawn
3765 global iddrawn markingmatches
3766 global commitinfo parentlist numcommits
3767 global filehighlight fhighlights findpattern nhighlights
3768 global hlview vhighlights
3769 global highlight_related rhighlights
3771 if {$row >= $numcommits} return
3773 set id
[lindex
$displayorder $row]
3774 if {[info exists hlview
] && ![info exists vhighlights
($row)]} {
3775 askvhighlight
$row $id
3777 if {[info exists filehighlight
] && ![info exists fhighlights
($row)]} {
3778 askfilehighlight
$row $id
3780 if {$findpattern ne
{} && ![info exists nhighlights
($row)]} {
3781 askfindhighlight
$row $id
3783 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($row)]} {
3784 askrelhighlight
$row $id
3786 if {![info exists iddrawn
($id)]} {
3787 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
3789 puts
"oops, row $row id $id not in list"
3792 if {![info exists commitinfo
($id)]} {
3796 drawcmittext
$id $row $col
3800 if {$markingmatches} {
3801 markrowmatches
$row $id
3805 proc drawcommits
{row
{endrow
{}}} {
3806 global numcommits iddrawn displayorder curview need_redisplay
3807 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3812 if {$endrow eq
{}} {
3815 if {$endrow >= $numcommits} {
3816 set endrow
[expr {$numcommits - 1}]
3819 set rl1
[expr {$row - $downarrowlen - 3}]
3823 set ro1
[expr {$row - 3}]
3827 set r2
[expr {$endrow + $uparrowlen + 3}]
3828 if {$r2 > $numcommits} {
3831 for {set r
$rl1} {$r < $r2} {incr r
} {
3832 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
3836 set rl1
[expr {$r + 1}]
3842 optimize_rows
$ro1 0 $r2
3843 if {$need_redisplay ||
$nrows_drawn > 2000} {
3848 # make the lines join to already-drawn rows either side
3849 set r
[expr {$row - 1}]
3850 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
3853 set er
[expr {$endrow + 1}]
3854 if {$er >= $numcommits ||
3855 ![info exists iddrawn
([lindex
$displayorder $er])]} {
3858 for {} {$r <= $er} {incr r
} {
3859 set id
[lindex
$displayorder $r]
3860 set wasdrawn
[info exists iddrawn
($id)]
3862 if {$r == $er} break
3863 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3864 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
3865 drawparentlinks
$id $r
3867 set rowids
[lindex
$rowidlist $r]
3868 foreach lid
$rowids {
3869 if {$lid eq
{}} continue
3870 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
3872 # see if this is the first child of any of its parents
3873 foreach p
[lindex
$parentlist $r] {
3874 if {[lsearch
-exact $rowids $p] < 0} {
3875 # make this line extend up to the child
3876 set lineend
($p) [drawlineseg
$p $r $er 0]
3880 set lineend
($lid) [drawlineseg
$lid $r $er 1]
3886 proc drawfrac
{f0 f1
} {
3889 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3890 if {$ymax eq
{} ||
$ymax == 0} return
3891 set y0
[expr {int
($f0 * $ymax)}]
3892 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
3893 set y1
[expr {int
($f1 * $ymax)}]
3894 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
3895 drawcommits
$row $endrow
3898 proc drawvisible
{} {
3900 eval drawfrac
[$canv yview
]
3903 proc clear_display
{} {
3904 global iddrawn linesegs need_redisplay nrows_drawn
3905 global vhighlights fhighlights nhighlights rhighlights
3908 catch
{unset iddrawn
}
3909 catch
{unset linesegs
}
3910 catch
{unset vhighlights
}
3911 catch
{unset fhighlights
}
3912 catch
{unset nhighlights
}
3913 catch
{unset rhighlights
}
3914 set need_redisplay
0
3918 proc findcrossings
{id
} {
3919 global rowidlist parentlist numcommits displayorder
3923 foreach
{s e
} [rowranges
$id] {
3924 if {$e >= $numcommits} {
3925 set e
[expr {$numcommits - 1}]
3927 if {$e <= $s} continue
3928 for {set row
$e} {[incr row
-1] >= $s} {} {
3929 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
3931 set olds
[lindex
$parentlist $row]
3932 set kid
[lindex
$displayorder $row]
3933 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
3934 if {$kidx < 0} continue
3935 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
3937 set px
[lsearch
-exact $nextrow $p]
3938 if {$px < 0} continue
3939 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
3940 if {[lsearch
-exact $ccross $p] >= 0} continue
3941 if {$x == $px + ($kidx < $px?
-1: 1)} {
3943 } elseif
{[lsearch
-exact $cross $p] < 0} {
3950 return [concat
$ccross {{}} $cross]
3953 proc assigncolor
{id
} {
3954 global colormap colors nextcolor
3955 global commitrow parentlist children children curview
3957 if {[info exists colormap
($id)]} return
3958 set ncolors
[llength
$colors]
3959 if {[info exists children
($curview,$id)]} {
3960 set kids
$children($curview,$id)
3964 if {[llength
$kids] == 1} {
3965 set child
[lindex
$kids 0]
3966 if {[info exists colormap
($child)]
3967 && [llength
[lindex
$parentlist $commitrow($curview,$child)]] == 1} {
3968 set colormap
($id) $colormap($child)
3974 foreach x
[findcrossings
$id] {
3976 # delimiter between corner crossings and other crossings
3977 if {[llength
$badcolors] >= $ncolors - 1} break
3978 set origbad
$badcolors
3980 if {[info exists colormap
($x)]
3981 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
3982 lappend badcolors
$colormap($x)
3985 if {[llength
$badcolors] >= $ncolors} {
3986 set badcolors
$origbad
3988 set origbad
$badcolors
3989 if {[llength
$badcolors] < $ncolors - 1} {
3990 foreach child
$kids {
3991 if {[info exists colormap
($child)]
3992 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
3993 lappend badcolors
$colormap($child)
3995 foreach p
[lindex
$parentlist $commitrow($curview,$child)] {
3996 if {[info exists colormap
($p)]
3997 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
3998 lappend badcolors
$colormap($p)
4002 if {[llength
$badcolors] >= $ncolors} {
4003 set badcolors
$origbad
4006 for {set i
0} {$i <= $ncolors} {incr i
} {
4007 set c
[lindex
$colors $nextcolor]
4008 if {[incr nextcolor
] >= $ncolors} {
4011 if {[lsearch
-exact $badcolors $c]} break
4013 set colormap
($id) $c
4016 proc bindline
{t id
} {
4019 $canv bind $t <Enter
> "lineenter %x %y $id"
4020 $canv bind $t <Motion
> "linemotion %x %y $id"
4021 $canv bind $t <Leave
> "lineleave $id"
4022 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4025 proc drawtags
{id x xt y1
} {
4026 global idtags idheads idotherrefs mainhead
4027 global linespc lthickness
4028 global canv commitrow rowtextx curview fgcolor bgcolor
4033 if {[info exists idtags
($id)]} {
4034 set marks
$idtags($id)
4035 set ntags
[llength
$marks]
4037 if {[info exists idheads
($id)]} {
4038 set marks
[concat
$marks $idheads($id)]
4039 set nheads
[llength
$idheads($id)]
4041 if {[info exists idotherrefs
($id)]} {
4042 set marks
[concat
$marks $idotherrefs($id)]
4048 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4049 set yt
[expr {$y1 - 0.5 * $linespc}]
4050 set yb
[expr {$yt + $linespc - 1}]
4054 foreach tag
$marks {
4056 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4057 set wid
[font measure mainfontbold
$tag]
4059 set wid
[font measure mainfont
$tag]
4063 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4065 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4066 -width $lthickness -fill black
-tags tag.
$id]
4068 foreach tag
$marks x
$xvals wid
$wvals {
4069 set xl
[expr {$x + $delta}]
4070 set xr
[expr {$x + $delta + $wid + $lthickness}]
4072 if {[incr ntags
-1] >= 0} {
4074 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4075 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4076 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4077 $canv bind $t <1> [list showtag
$tag 1]
4078 set rowtextx
($commitrow($curview,$id)) [expr {$xr + $linespc}]
4080 # draw a head or other ref
4081 if {[incr nheads
-1] >= 0} {
4083 if {$tag eq
$mainhead} {
4084 set font mainfontbold
4089 set xl
[expr {$xl - $delta/2}]
4090 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4091 -width 1 -outline black
-fill $col -tags tag.
$id
4092 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4093 set rwid
[font measure mainfont
$remoteprefix]
4094 set xi
[expr {$x + 1}]
4095 set yti
[expr {$yt + 1}]
4096 set xri
[expr {$x + $rwid}]
4097 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4098 -width 0 -fill "#ffddaa" -tags tag.
$id
4101 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4102 -font $font -tags [list tag.
$id text
]]
4104 $canv bind $t <1> [list showtag
$tag 1]
4105 } elseif
{$nheads >= 0} {
4106 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4112 proc xcoord
{i level
ln} {
4113 global canvx0 xspc1 xspc2
4115 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4116 if {$i > 0 && $i == $level} {
4117 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4118 } elseif
{$i > $level} {
4119 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4124 proc show_status
{msg
} {
4128 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4129 -tags text
-fill $fgcolor
4132 # Insert a new commit as the child of the commit on row $row.
4133 # The new commit will be displayed on row $row and the commits
4134 # on that row and below will move down one row.
4135 proc insertrow
{row newcmit
} {
4136 global displayorder parentlist commitlisted children
4137 global commitrow curview rowidlist rowisopt rowfinal numcommits
4139 global selectedline commitidx ordertok
4141 if {$row >= $numcommits} {
4142 puts
"oops, inserting new row $row but only have $numcommits rows"
4145 set p
[lindex
$displayorder $row]
4146 set displayorder
[linsert
$displayorder $row $newcmit]
4147 set parentlist
[linsert
$parentlist $row $p]
4148 set kids
$children($curview,$p)
4149 lappend kids
$newcmit
4150 set children
($curview,$p) $kids
4151 set children
($curview,$newcmit) {}
4152 set commitlisted
[linsert
$commitlisted $row 1]
4153 set l
[llength
$displayorder]
4154 for {set r
$row} {$r < $l} {incr r
} {
4155 set id
[lindex
$displayorder $r]
4156 set commitrow
($curview,$id) $r
4158 incr commitidx
($curview)
4159 set ordertok
($curview,$newcmit) $ordertok($curview,$p)
4161 if {$row < [llength
$rowidlist]} {
4162 set idlist
[lindex
$rowidlist $row]
4163 if {$idlist ne
{}} {
4164 if {[llength
$kids] == 1} {
4165 set col [lsearch
-exact $idlist $p]
4166 lset idlist
$col $newcmit
4168 set col [llength
$idlist]
4169 lappend idlist
$newcmit
4172 set rowidlist
[linsert
$rowidlist $row $idlist]
4173 set rowisopt
[linsert
$rowisopt $row 0]
4174 set rowfinal
[linsert
$rowfinal $row [lindex
$rowfinal $row]]
4179 if {[info exists selectedline
] && $selectedline >= $row} {
4185 # Remove a commit that was inserted with insertrow on row $row.
4186 proc removerow
{row
} {
4187 global displayorder parentlist commitlisted children
4188 global commitrow curview rowidlist rowisopt rowfinal numcommits
4190 global linesegends selectedline commitidx
4192 if {$row >= $numcommits} {
4193 puts
"oops, removing row $row but only have $numcommits rows"
4196 set rp1
[expr {$row + 1}]
4197 set id
[lindex
$displayorder $row]
4198 set p
[lindex
$parentlist $row]
4199 set displayorder
[lreplace
$displayorder $row $row]
4200 set parentlist
[lreplace
$parentlist $row $row]
4201 set commitlisted
[lreplace
$commitlisted $row $row]
4202 set kids
$children($curview,$p)
4203 set i
[lsearch
-exact $kids $id]
4205 set kids
[lreplace
$kids $i $i]
4206 set children
($curview,$p) $kids
4208 set l
[llength
$displayorder]
4209 for {set r
$row} {$r < $l} {incr r
} {
4210 set id
[lindex
$displayorder $r]
4211 set commitrow
($curview,$id) $r
4213 incr commitidx
($curview) -1
4215 if {$row < [llength
$rowidlist]} {
4216 set rowidlist
[lreplace
$rowidlist $row $row]
4217 set rowisopt
[lreplace
$rowisopt $row $row]
4218 set rowfinal
[lreplace
$rowfinal $row $row]
4223 if {[info exists selectedline
] && $selectedline > $row} {
4224 incr selectedline
-1
4229 # Don't change the text pane cursor if it is currently the hand cursor,
4230 # showing that we are over a sha1 ID link.
4231 proc settextcursor
{c
} {
4232 global ctext curtextcursor
4234 if {[$ctext cget
-cursor] == $curtextcursor} {
4235 $ctext config
-cursor $c
4237 set curtextcursor
$c
4240 proc nowbusy
{what
{name
{}}} {
4241 global isbusy busyname statusw
4243 if {[array names isbusy
] eq
{}} {
4244 . config
-cursor watch
4248 set busyname
($what) $name
4250 $statusw conf
-text $name
4254 proc notbusy
{what
} {
4255 global isbusy maincursor textcursor busyname statusw
4259 if {$busyname($what) ne
{} &&
4260 [$statusw cget
-text] eq
$busyname($what)} {
4261 $statusw conf
-text {}
4264 if {[array names isbusy
] eq
{}} {
4265 . config
-cursor $maincursor
4266 settextcursor
$textcursor
4270 proc findmatches
{f
} {
4271 global findtype findstring
4272 if {$findtype == [mc
"Regexp"]} {
4273 set matches
[regexp
-indices -all -inline $findstring $f]
4276 if {$findtype == [mc
"IgnCase"]} {
4277 set f
[string tolower
$f]
4278 set fs
[string tolower
$fs]
4282 set l
[string length
$fs]
4283 while {[set j
[string first
$fs $f $i]] >= 0} {
4284 lappend matches
[list
$j [expr {$j+$l-1}]]
4285 set i
[expr {$j + $l}]
4291 proc dofind
{{dirn
1} {wrap
1}} {
4292 global findstring findstartline findcurline selectedline numcommits
4293 global gdttype filehighlight fh_serial find_dirn findallowwrap
4295 if {[info exists find_dirn
]} {
4296 if {$find_dirn == $dirn} return
4300 if {$findstring eq
{} ||
$numcommits == 0} return
4301 if {![info exists selectedline
]} {
4302 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4304 set findstartline
$selectedline
4306 set findcurline
$findstartline
4307 nowbusy finding
[mc
"Searching"]
4308 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4309 after cancel do_file_hl
$fh_serial
4310 do_file_hl
$fh_serial
4313 set findallowwrap
$wrap
4317 proc stopfinding
{} {
4318 global find_dirn findcurline fprogcoord
4320 if {[info exists find_dirn
]} {
4330 global commitdata commitinfo numcommits findpattern findloc
4331 global findstartline findcurline displayorder
4332 global find_dirn gdttype fhighlights fprogcoord
4333 global findallowwrap
4335 if {![info exists find_dirn
]} {
4338 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4341 if {$find_dirn > 0} {
4343 if {$l >= $numcommits} {
4346 if {$l <= $findstartline} {
4347 set lim
[expr {$findstartline + 1}]
4350 set moretodo
$findallowwrap
4357 if {$l >= $findstartline} {
4358 set lim
[expr {$findstartline - 1}]
4361 set moretodo
$findallowwrap
4364 set n
[expr {($lim - $l) * $find_dirn}]
4371 if {$gdttype eq
[mc
"containing:"]} {
4372 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4373 set id
[lindex
$displayorder $l]
4374 # shouldn't happen unless git log doesn't give all the commits...
4375 if {![info exists commitdata
($id)]} continue
4376 if {![doesmatch
$commitdata($id)]} continue
4377 if {![info exists commitinfo
($id)]} {
4380 set info
$commitinfo($id)
4381 foreach f
$info ty
$fldtypes {
4382 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
4391 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4392 set id
[lindex
$displayorder $l]
4393 if {![info exists fhighlights
($l)]} {
4394 askfilehighlight
$l $id
4397 set findcurline
[expr {$l - $find_dirn}]
4399 } elseif
{$fhighlights($l)} {
4405 if {$found ||
($domore && !$moretodo)} {
4421 set findcurline
[expr {$l - $find_dirn}]
4423 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
4427 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
4432 proc findselectline
{l
} {
4433 global findloc commentend ctext findcurline markingmatches gdttype
4435 set markingmatches
1
4438 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
4439 # highlight the matches in the comments
4440 set f
[$ctext get
1.0 $commentend]
4441 set matches
[findmatches
$f]
4442 foreach match
$matches {
4443 set start
[lindex
$match 0]
4444 set end
[expr {[lindex
$match 1] + 1}]
4445 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
4451 # mark the bits of a headline or author that match a find string
4452 proc markmatches
{canv l str tag matches font row
} {
4455 set bbox
[$canv bbox
$tag]
4456 set x0
[lindex
$bbox 0]
4457 set y0
[lindex
$bbox 1]
4458 set y1
[lindex
$bbox 3]
4459 foreach match
$matches {
4460 set start
[lindex
$match 0]
4461 set end
[lindex
$match 1]
4462 if {$start > $end} continue
4463 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
4464 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
4465 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
4466 [expr {$x0+$xlen+2}] $y1 \
4467 -outline {} -tags [list match
$l matches
] -fill yellow
]
4469 if {[info exists selectedline
] && $row == $selectedline} {
4470 $canv raise
$t secsel
4475 proc unmarkmatches
{} {
4476 global markingmatches
4478 allcanvs delete matches
4479 set markingmatches
0
4483 proc selcanvline
{w x y
} {
4484 global canv canvy0 ctext linespc
4486 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4487 if {$ymax == {}} return
4488 set yfrac
[lindex
[$canv yview
] 0]
4489 set y
[expr {$y + $yfrac * $ymax}]
4490 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
4495 if {![info exists rowtextx
($l)] ||
$x < $rowtextx($l)} return
4501 proc commit_descriptor
{p
} {
4503 if {![info exists commitinfo
($p)]} {
4507 if {[llength
$commitinfo($p)] > 1} {
4508 set l
[lindex
$commitinfo($p) 0]
4513 # append some text to the ctext widget, and make any SHA1 ID
4514 # that we know about be a clickable link.
4515 proc appendwithlinks
{text tags
} {
4516 global ctext commitrow linknum curview pendinglinks
4518 set start
[$ctext index
"end - 1c"]
4519 $ctext insert end
$text $tags
4520 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
4524 set linkid
[string range
$text $s $e]
4526 $ctext tag delete link
$linknum
4527 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
4528 setlink
$linkid link
$linknum
4533 proc setlink
{id lk
} {
4534 global curview commitrow ctext pendinglinks commitinterest
4536 if {[info exists commitrow
($curview,$id)]} {
4537 $ctext tag conf
$lk -foreground blue
-underline 1
4538 $ctext tag
bind $lk <1> [list selectline
$commitrow($curview,$id) 1]
4539 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
4540 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
4542 lappend pendinglinks
($id) $lk
4543 lappend commitinterest
($id) {makelink
%I
}
4547 proc makelink
{id
} {
4550 if {![info exists pendinglinks
($id)]} return
4551 foreach lk
$pendinglinks($id) {
4554 unset pendinglinks
($id)
4557 proc linkcursor
{w inc
} {
4558 global linkentercount curtextcursor
4560 if {[incr linkentercount
$inc] > 0} {
4561 $w configure
-cursor hand2
4563 $w configure
-cursor $curtextcursor
4564 if {$linkentercount < 0} {
4565 set linkentercount
0
4570 proc viewnextline
{dir
} {
4574 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4575 set wnow
[$canv yview
]
4576 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4577 set newtop
[expr {$wtop + $dir * $linespc}]
4580 } elseif
{$newtop > $ymax} {
4583 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4586 # add a list of tag or branch names at position pos
4587 # returns the number of names inserted
4588 proc appendrefs
{pos ids var
} {
4589 global ctext commitrow linknum curview
$var maxrefs
4591 if {[catch
{$ctext index
$pos}]} {
4594 $ctext conf
-state normal
4595 $ctext delete
$pos "$pos lineend"
4598 foreach tag
[set $var\
($id\
)] {
4599 lappend tags
[list
$tag $id]
4602 if {[llength
$tags] > $maxrefs} {
4603 $ctext insert
$pos "many ([llength $tags])"
4605 set tags
[lsort
-index 0 -decreasing $tags]
4608 set id
[lindex
$ti 1]
4611 $ctext tag delete
$lk
4612 $ctext insert
$pos $sep
4613 $ctext insert
$pos [lindex
$ti 0] $lk
4618 $ctext conf
-state disabled
4619 return [llength
$tags]
4622 # called when we have finished computing the nearby tags
4623 proc dispneartags
{delay
} {
4624 global selectedline currentid showneartags tagphase
4626 if {![info exists selectedline
] ||
!$showneartags} return
4627 after cancel dispnexttag
4629 after
200 dispnexttag
4632 after idle dispnexttag
4637 proc dispnexttag
{} {
4638 global selectedline currentid showneartags tagphase ctext
4640 if {![info exists selectedline
] ||
!$showneartags} return
4641 switch
-- $tagphase {
4643 set dtags
[desctags
$currentid]
4645 appendrefs precedes
$dtags idtags
4649 set atags
[anctags
$currentid]
4651 appendrefs follows
$atags idtags
4655 set dheads
[descheads
$currentid]
4656 if {$dheads ne
{}} {
4657 if {[appendrefs branch
$dheads idheads
] > 1
4658 && [$ctext get
"branch -3c"] eq
"h"} {
4659 # turn "Branch" into "Branches"
4660 $ctext conf
-state normal
4661 $ctext insert
"branch -2c" "es"
4662 $ctext conf
-state disabled
4667 if {[incr tagphase
] <= 2} {
4668 after idle dispnexttag
4672 proc make_secsel
{l
} {
4673 global linehtag linentag linedtag canv canv2 canv3
4675 if {![info exists linehtag
($l)]} return
4677 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
4678 -tags secsel
-fill [$canv cget
-selectbackground]]
4680 $canv2 delete secsel
4681 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
4682 -tags secsel
-fill [$canv2 cget
-selectbackground]]
4684 $canv3 delete secsel
4685 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
4686 -tags secsel
-fill [$canv3 cget
-selectbackground]]
4690 proc selectline
{l isnew
} {
4691 global canv ctext commitinfo selectedline
4693 global canvy0 linespc parentlist children curview
4694 global currentid sha1entry
4695 global commentend idtags linknum
4696 global mergemax numcommits pending_select
4697 global cmitmode showneartags allcommits
4700 catch
{unset pending_select
}
4705 if {$l < 0 ||
$l >= $numcommits} return
4706 set y
[expr {$canvy0 + $l * $linespc}]
4707 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4708 set ytop
[expr {$y - $linespc - 1}]
4709 set ybot
[expr {$y + $linespc + 1}]
4710 set wnow
[$canv yview
]
4711 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4712 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
4713 set wh
[expr {$wbot - $wtop}]
4715 if {$ytop < $wtop} {
4716 if {$ybot < $wtop} {
4717 set newtop
[expr {$y - $wh / 2.0}]
4720 if {$newtop > $wtop - $linespc} {
4721 set newtop
[expr {$wtop - $linespc}]
4724 } elseif
{$ybot > $wbot} {
4725 if {$ytop > $wbot} {
4726 set newtop
[expr {$y - $wh / 2.0}]
4728 set newtop
[expr {$ybot - $wh}]
4729 if {$newtop < $wtop + $linespc} {
4730 set newtop
[expr {$wtop + $linespc}]
4734 if {$newtop != $wtop} {
4738 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4745 addtohistory
[list selectline
$l 0]
4750 set id
[lindex
$displayorder $l]
4752 $sha1entry delete
0 end
4753 $sha1entry insert
0 $id
4755 $sha1entry selection from
0
4756 $sha1entry selection to end
4760 $ctext conf
-state normal
4763 set info
$commitinfo($id)
4764 set date [formatdate
[lindex
$info 2]]
4765 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
4766 set date [formatdate
[lindex
$info 4]]
4767 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
4768 if {[info exists idtags
($id)]} {
4769 $ctext insert end
[mc
"Tags:"]
4770 foreach tag
$idtags($id) {
4771 $ctext insert end
" $tag"
4773 $ctext insert end
"\n"
4777 set olds
[lindex
$parentlist $l]
4778 if {[llength
$olds] > 1} {
4781 if {$np >= $mergemax} {
4786 $ctext insert end
"[mc "Parent
"]: " $tag
4787 appendwithlinks
[commit_descriptor
$p] {}
4792 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
4796 foreach c
$children($curview,$id) {
4797 append headers
"[mc "Child
"]: [commit_descriptor $c]"
4800 # make anything that looks like a SHA1 ID be a clickable link
4801 appendwithlinks
$headers {}
4802 if {$showneartags} {
4803 if {![info exists allcommits
]} {
4806 $ctext insert end
"[mc "Branch
"]: "
4807 $ctext mark
set branch
"end -1c"
4808 $ctext mark gravity branch left
4809 $ctext insert end
"\n[mc "Follows
"]: "
4810 $ctext mark
set follows
"end -1c"
4811 $ctext mark gravity follows left
4812 $ctext insert end
"\n[mc "Precedes
"]: "
4813 $ctext mark
set precedes
"end -1c"
4814 $ctext mark gravity precedes left
4815 $ctext insert end
"\n"
4818 $ctext insert end
"\n"
4819 set comment
[lindex
$info 5]
4820 if {[string first
"\r" $comment] >= 0} {
4821 set comment
[string map
{"\r" "\n "} $comment]
4823 appendwithlinks
$comment {comment
}
4825 $ctext tag remove found
1.0 end
4826 $ctext conf
-state disabled
4827 set commentend
[$ctext index
"end - 1c"]
4829 init_flist
[mc
"Comments"]
4830 if {$cmitmode eq
"tree"} {
4832 } elseif
{[llength
$olds] <= 1} {
4839 proc selfirstline
{} {
4844 proc sellastline
{} {
4847 set l
[expr {$numcommits - 1}]
4851 proc selnextline
{dir
} {
4854 if {![info exists selectedline
]} return
4855 set l
[expr {$selectedline + $dir}]
4860 proc selnextpage
{dir
} {
4861 global canv linespc selectedline numcommits
4863 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
4867 allcanvs yview scroll
[expr {$dir * $lpp}] units
4869 if {![info exists selectedline
]} return
4870 set l
[expr {$selectedline + $dir * $lpp}]
4873 } elseif
{$l >= $numcommits} {
4874 set l
[expr $numcommits - 1]
4880 proc unselectline
{} {
4881 global selectedline currentid
4883 catch
{unset selectedline
}
4884 catch
{unset currentid
}
4885 allcanvs delete secsel
4889 proc reselectline
{} {
4892 if {[info exists selectedline
]} {
4893 selectline
$selectedline 0
4897 proc addtohistory
{cmd
} {
4898 global
history historyindex curview
4900 set elt
[list
$curview $cmd]
4901 if {$historyindex > 0
4902 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
4906 if {$historyindex < [llength
$history]} {
4907 set history [lreplace
$history $historyindex end
$elt]
4909 lappend
history $elt
4912 if {$historyindex > 1} {
4913 .tf.bar.leftbut conf
-state normal
4915 .tf.bar.leftbut conf
-state disabled
4917 .tf.bar.rightbut conf
-state disabled
4923 set view
[lindex
$elt 0]
4924 set cmd
[lindex
$elt 1]
4925 if {$curview != $view} {
4932 global
history historyindex
4935 if {$historyindex > 1} {
4936 incr historyindex
-1
4937 godo
[lindex
$history [expr {$historyindex - 1}]]
4938 .tf.bar.rightbut conf
-state normal
4940 if {$historyindex <= 1} {
4941 .tf.bar.leftbut conf
-state disabled
4946 global
history historyindex
4949 if {$historyindex < [llength
$history]} {
4950 set cmd
[lindex
$history $historyindex]
4953 .tf.bar.leftbut conf
-state normal
4955 if {$historyindex >= [llength
$history]} {
4956 .tf.bar.rightbut conf
-state disabled
4961 global treefilelist treeidlist diffids diffmergeid treepending
4962 global nullid nullid2
4965 catch
{unset diffmergeid
}
4966 if {![info exists treefilelist
($id)]} {
4967 if {![info exists treepending
]} {
4968 if {$id eq
$nullid} {
4969 set cmd
[list | git ls-files
]
4970 } elseif
{$id eq
$nullid2} {
4971 set cmd
[list | git ls-files
--stage -t]
4973 set cmd
[list | git ls-tree
-r $id]
4975 if {[catch
{set gtf
[open
$cmd r
]}]} {
4979 set treefilelist
($id) {}
4980 set treeidlist
($id) {}
4981 fconfigure
$gtf -blocking 0
4982 filerun
$gtf [list gettreeline
$gtf $id]
4989 proc gettreeline
{gtf id
} {
4990 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4993 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
4994 if {$diffids eq
$nullid} {
4997 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
4998 set i
[string first
"\t" $line]
4999 if {$i < 0} continue
5000 set sha1
[lindex
$line 2]
5001 set fname
[string range
$line [expr {$i+1}] end
]
5002 if {[string index
$fname 0] eq
"\""} {
5003 set fname
[lindex
$fname 0]
5005 lappend treeidlist
($id) $sha1
5007 lappend treefilelist
($id) $fname
5010 return [expr {$nl >= 1000?
2: 1}]
5014 if {$cmitmode ne
"tree"} {
5015 if {![info exists diffmergeid
]} {
5016 gettreediffs
$diffids
5018 } elseif
{$id ne
$diffids} {
5027 global treefilelist treeidlist diffids nullid nullid2
5028 global ctext commentend
5030 set i
[lsearch
-exact $treefilelist($diffids) $f]
5032 puts
"oops, $f not in list for id $diffids"
5035 if {$diffids eq
$nullid} {
5036 if {[catch
{set bf
[open
$f r
]} err
]} {
5037 puts
"oops, can't read $f: $err"
5041 set blob
[lindex
$treeidlist($diffids) $i]
5042 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5043 puts
"oops, error reading blob $blob: $err"
5047 fconfigure
$bf -blocking 0
5048 filerun
$bf [list getblobline
$bf $diffids]
5049 $ctext config
-state normal
5050 clear_ctext
$commentend
5051 $ctext insert end
"\n"
5052 $ctext insert end
"$f\n" filesep
5053 $ctext config
-state disabled
5054 $ctext yview
$commentend
5058 proc getblobline
{bf id
} {
5059 global diffids cmitmode ctext
5061 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5065 $ctext config
-state normal
5067 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5068 $ctext insert end
"$line\n"
5071 # delete last newline
5072 $ctext delete
"end - 2c" "end - 1c"
5076 $ctext config
-state disabled
5077 return [expr {$nl >= 1000?
2: 1}]
5080 proc mergediff
{id l
} {
5081 global diffmergeid mdifffd
5085 global limitdiffs viewfiles curview
5089 # this doesn't seem to actually affect anything...
5090 set cmd
[concat | git diff-tree
--no-commit-id --cc -U$diffcontext $id]
5091 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5092 set cmd
[concat
$cmd -- $viewfiles($curview)]
5094 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5095 error_popup
"[mc "Error getting merge diffs
:"] $err"
5098 fconfigure
$mdf -blocking 0
5099 set mdifffd
($id) $mdf
5100 set np
[llength
[lindex
$parentlist $l]]
5102 filerun
$mdf [list getmergediffline
$mdf $id $np]
5105 proc getmergediffline
{mdf id np
} {
5106 global diffmergeid ctext cflist mergemax
5107 global difffilestart mdifffd
5109 $ctext conf
-state normal
5111 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5112 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5113 ||
$mdf != $mdifffd($id)} {
5117 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5118 # start of a new file
5119 $ctext insert end
"\n"
5120 set here
[$ctext index
"end - 1c"]
5121 lappend difffilestart
$here
5122 add_flist
[list
$fname]
5123 set l
[expr {(78 - [string length
$fname]) / 2}]
5124 set pad
[string range
"----------------------------------------" 1 $l]
5125 $ctext insert end
"$pad $fname $pad\n" filesep
5126 } elseif
{[regexp
{^@@
} $line]} {
5127 $ctext insert end
"$line\n" hunksep
5128 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5131 # parse the prefix - one ' ', '-' or '+' for each parent
5136 for {set j
0} {$j < $np} {incr j
} {
5137 set c
[string range
$line $j $j]
5140 } elseif
{$c == "-"} {
5142 } elseif
{$c == "+"} {
5151 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5152 # line doesn't appear in result, parents in $minuses have the line
5153 set num
[lindex
$minuses 0]
5154 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5155 # line appears in result, parents in $pluses don't have the line
5156 lappend tags mresult
5157 set num
[lindex
$spaces 0]
5160 if {$num >= $mergemax} {
5165 $ctext insert end
"$line\n" $tags
5168 $ctext conf
-state disabled
5173 return [expr {$nr >= 1000?
2: 1}]
5176 proc startdiff
{ids
} {
5177 global treediffs diffids treepending diffmergeid nullid nullid2
5181 catch
{unset diffmergeid
}
5182 if {![info exists treediffs
($ids)] ||
5183 [lsearch
-exact $ids $nullid] >= 0 ||
5184 [lsearch
-exact $ids $nullid2] >= 0} {
5185 if {![info exists treepending
]} {
5193 proc path_filter
{filter name
} {
5195 set l
[string length
$p]
5196 if {[string index
$p end
] eq
"/"} {
5197 if {[string compare
-length $l $p $name] == 0} {
5201 if {[string compare
-length $l $p $name] == 0 &&
5202 ([string length
$name] == $l ||
5203 [string index
$name $l] eq
"/")} {
5211 proc addtocflist
{ids
} {
5214 add_flist
$treediffs($ids)
5218 proc diffcmd
{ids flags
} {
5219 global nullid nullid2
5221 set i
[lsearch
-exact $ids $nullid]
5222 set j
[lsearch
-exact $ids $nullid2]
5224 if {[llength
$ids] > 1 && $j < 0} {
5225 # comparing working directory with some specific revision
5226 set cmd
[concat | git diff-index
$flags]
5228 lappend cmd
-R [lindex
$ids 1]
5230 lappend cmd
[lindex
$ids 0]
5233 # comparing working directory with index
5234 set cmd
[concat | git diff-files
$flags]
5239 } elseif
{$j >= 0} {
5240 set cmd
[concat | git diff-index
--cached $flags]
5241 if {[llength
$ids] > 1} {
5242 # comparing index with specific revision
5244 lappend cmd
-R [lindex
$ids 1]
5246 lappend cmd
[lindex
$ids 0]
5249 # comparing index with HEAD
5253 set cmd
[concat | git diff-tree
-r $flags $ids]
5258 proc gettreediffs
{ids
} {
5259 global treediff treepending
5261 set treepending
$ids
5263 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5264 fconfigure
$gdtf -blocking 0
5265 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5268 proc gettreediffline
{gdtf ids
} {
5269 global treediff treediffs treepending diffids diffmergeid
5270 global cmitmode viewfiles curview limitdiffs
5273 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5274 set i
[string first
"\t" $line]
5276 set file [string range
$line [expr {$i+1}] end
]
5277 if {[string index
$file 0] eq
"\""} {
5278 set file [lindex
$file 0]
5280 lappend treediff
$file
5284 return [expr {$nr >= 1000?
2: 1}]
5287 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5289 foreach f
$treediff {
5290 if {[path_filter
$viewfiles($curview) $f]} {
5294 set treediffs
($ids) $flist
5296 set treediffs
($ids) $treediff
5299 if {$cmitmode eq
"tree"} {
5301 } elseif
{$ids != $diffids} {
5302 if {![info exists diffmergeid
]} {
5303 gettreediffs
$diffids
5311 # empty string or positive integer
5312 proc diffcontextvalidate
{v
} {
5313 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5316 proc diffcontextchange
{n1 n2 op
} {
5317 global diffcontextstring diffcontext
5319 if {[string is integer
-strict $diffcontextstring]} {
5320 if {$diffcontextstring > 0} {
5321 set diffcontext
$diffcontextstring
5327 proc changeignorespace
{} {
5331 proc getblobdiffs
{ids
} {
5332 global blobdifffd diffids env
5333 global diffinhdr treediffs
5336 global limitdiffs viewfiles curview
5338 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5342 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5343 set cmd
[concat
$cmd -- $viewfiles($curview)]
5345 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5346 puts
"error getting diffs: $err"
5350 fconfigure
$bdf -blocking 0
5351 set blobdifffd
($ids) $bdf
5352 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5355 proc setinlist
{var i val
} {
5358 while {[llength
[set $var]] < $i} {
5361 if {[llength
[set $var]] == $i} {
5368 proc makediffhdr
{fname ids
} {
5369 global ctext curdiffstart treediffs
5371 set i
[lsearch
-exact $treediffs($ids) $fname]
5373 setinlist difffilestart
$i $curdiffstart
5375 set l
[expr {(78 - [string length
$fname]) / 2}]
5376 set pad
[string range
"----------------------------------------" 1 $l]
5377 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
5380 proc getblobdiffline
{bdf ids
} {
5381 global diffids blobdifffd ctext curdiffstart
5382 global diffnexthead diffnextnote difffilestart
5383 global diffinhdr treediffs
5386 $ctext conf
-state normal
5387 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
5388 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
5392 if {![string compare
-length 11 "diff --git " $line]} {
5393 # trim off "diff --git "
5394 set line
[string range
$line 11 end
]
5396 # start of a new file
5397 $ctext insert end
"\n"
5398 set curdiffstart
[$ctext index
"end - 1c"]
5399 $ctext insert end
"\n" filesep
5400 # If the name hasn't changed the length will be odd,
5401 # the middle char will be a space, and the two bits either
5402 # side will be a/name and b/name, or "a/name" and "b/name".
5403 # If the name has changed we'll get "rename from" and
5404 # "rename to" or "copy from" and "copy to" lines following this,
5405 # and we'll use them to get the filenames.
5406 # This complexity is necessary because spaces in the filename(s)
5407 # don't get escaped.
5408 set l
[string length
$line]
5409 set i
[expr {$l / 2}]
5410 if {!(($l & 1) && [string index
$line $i] eq
" " &&
5411 [string range
$line 2 [expr {$i - 1}]] eq \
5412 [string range
$line [expr {$i + 3}] end
])} {
5415 # unescape if quoted and chop off the a/ from the front
5416 if {[string index
$line 0] eq
"\""} {
5417 set fname
[string range
[lindex
$line 0] 2 end
]
5419 set fname
[string range
$line 2 [expr {$i - 1}]]
5421 makediffhdr
$fname $ids
5423 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
5424 $line match f1l f1c f2l f2c rest
]} {
5425 $ctext insert end
"$line\n" hunksep
5428 } elseif
{$diffinhdr} {
5429 if {![string compare
-length 12 "rename from " $line]} {
5430 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
5431 if {[string index
$fname 0] eq
"\""} {
5432 set fname
[lindex
$fname 0]
5434 set i
[lsearch
-exact $treediffs($ids) $fname]
5436 setinlist difffilestart
$i $curdiffstart
5438 } elseif
{![string compare
-length 10 $line "rename to "] ||
5439 ![string compare
-length 8 $line "copy to "]} {
5440 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
5441 if {[string index
$fname 0] eq
"\""} {
5442 set fname
[lindex
$fname 0]
5444 makediffhdr
$fname $ids
5445 } elseif
{[string compare
-length 3 $line "---"] == 0} {
5448 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
5452 $ctext insert end
"$line\n" filesep
5455 set x
[string range
$line 0 0]
5456 if {$x == "-" ||
$x == "+"} {
5457 set tag
[expr {$x == "+"}]
5458 $ctext insert end
"$line\n" d
$tag
5459 } elseif
{$x == " "} {
5460 $ctext insert end
"$line\n"
5462 # "\ No newline at end of file",
5463 # or something else we don't recognize
5464 $ctext insert end
"$line\n" hunksep
5468 $ctext conf
-state disabled
5473 return [expr {$nr >= 1000?
2: 1}]
5476 proc changediffdisp
{} {
5477 global ctext diffelide
5479 $ctext tag conf d0
-elide [lindex
$diffelide 0]
5480 $ctext tag conf d1
-elide [lindex
$diffelide 1]
5484 global difffilestart ctext
5485 set prev
[lindex
$difffilestart 0]
5486 set here
[$ctext index @
0,0]
5487 foreach loc
$difffilestart {
5488 if {[$ctext compare
$loc >= $here]} {
5498 global difffilestart ctext
5499 set here
[$ctext index @
0,0]
5500 foreach loc
$difffilestart {
5501 if {[$ctext compare
$loc > $here]} {
5508 proc clear_ctext
{{first
1.0}} {
5509 global ctext smarktop smarkbot
5512 set l
[lindex
[split $first .
] 0]
5513 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
5516 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
5519 $ctext delete
$first end
5520 if {$first eq
"1.0"} {
5521 catch
{unset pendinglinks
}
5525 proc settabs
{{firstab
{}}} {
5526 global firsttabstop tabstop ctext have_tk85
5528 if {$firstab ne
{} && $have_tk85} {
5529 set firsttabstop
$firstab
5531 set w
[font measure textfont
"0"]
5532 if {$firsttabstop != 0} {
5533 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
5534 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5535 } elseif
{$have_tk85 ||
$tabstop != 8} {
5536 $ctext conf
-tabs [expr {$tabstop * $w}]
5538 $ctext conf
-tabs {}
5542 proc incrsearch
{name ix op
} {
5543 global ctext searchstring searchdirn
5545 $ctext tag remove found
1.0 end
5546 if {[catch
{$ctext index anchor
}]} {
5547 # no anchor set, use start of selection, or of visible area
5548 set sel
[$ctext tag ranges sel
]
5550 $ctext mark
set anchor
[lindex
$sel 0]
5551 } elseif
{$searchdirn eq
"-forwards"} {
5552 $ctext mark
set anchor @
0,0
5554 $ctext mark
set anchor @
0,[winfo height
$ctext]
5557 if {$searchstring ne
{}} {
5558 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
5567 global sstring ctext searchstring searchdirn
5570 $sstring icursor end
5571 set searchdirn
-forwards
5572 if {$searchstring ne
{}} {
5573 set sel
[$ctext tag ranges sel
]
5575 set start
"[lindex $sel 0] + 1c"
5576 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5579 set match
[$ctext search
-count mlen
-- $searchstring $start]
5580 $ctext tag remove sel
1.0 end
5586 set mend
"$match + $mlen c"
5587 $ctext tag add sel
$match $mend
5588 $ctext mark
unset anchor
5592 proc dosearchback
{} {
5593 global sstring ctext searchstring searchdirn
5596 $sstring icursor end
5597 set searchdirn
-backwards
5598 if {$searchstring ne
{}} {
5599 set sel
[$ctext tag ranges sel
]
5601 set start
[lindex
$sel 0]
5602 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5603 set start @
0,[winfo height
$ctext]
5605 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
5606 $ctext tag remove sel
1.0 end
5612 set mend
"$match + $ml c"
5613 $ctext tag add sel
$match $mend
5614 $ctext mark
unset anchor
5618 proc searchmark
{first last
} {
5619 global ctext searchstring
5623 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
5624 if {$match eq
{}} break
5625 set mend
"$match + $mlen c"
5626 $ctext tag add found
$match $mend
5630 proc searchmarkvisible
{doall
} {
5631 global ctext smarktop smarkbot
5633 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
5634 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
5635 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
5636 # no overlap with previous
5637 searchmark
$topline $botline
5638 set smarktop
$topline
5639 set smarkbot
$botline
5641 if {$topline < $smarktop} {
5642 searchmark
$topline [expr {$smarktop-1}]
5643 set smarktop
$topline
5645 if {$botline > $smarkbot} {
5646 searchmark
[expr {$smarkbot+1}] $botline
5647 set smarkbot
$botline
5652 proc scrolltext
{f0 f1
} {
5655 .bleft.bottom.sb
set $f0 $f1
5656 if {$searchstring ne
{}} {
5662 global linespc charspc canvx0 canvy0
5663 global xspc1 xspc2 lthickness
5665 set linespc
[font metrics mainfont
-linespace]
5666 set charspc
[font measure mainfont
"m"]
5667 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
5668 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
5669 set lthickness
[expr {int
($linespc / 9) + 1}]
5670 set xspc1
(0) $linespc
5678 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5679 if {$ymax eq
{} ||
$ymax == 0} return
5680 set span
[$canv yview
]
5683 allcanvs yview moveto
[lindex
$span 0]
5685 if {[info exists selectedline
]} {
5686 selectline
$selectedline 0
5687 allcanvs yview moveto
[lindex
$span 0]
5691 proc parsefont
{f n
} {
5694 set fontattr
($f,family
) [lindex
$n 0]
5696 if {$s eq
{} ||
$s == 0} {
5699 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
5701 set fontattr
($f,size
) $s
5702 set fontattr
($f,weight
) normal
5703 set fontattr
($f,slant
) roman
5704 foreach style
[lrange
$n 2 end
] {
5707 "bold" {set fontattr
($f,weight
) $style}
5709 "italic" {set fontattr
($f,slant
) $style}
5714 proc fontflags
{f
{isbold
0}} {
5717 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
5718 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
5719 -slant $fontattr($f,slant
)]
5725 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
5726 if {$fontattr($f,weight
) eq
"bold"} {
5729 if {$fontattr($f,slant
) eq
"italic"} {
5735 proc incrfont
{inc
} {
5736 global mainfont textfont ctext canv phase cflist showrefstop
5737 global stopped entries fontattr
5740 set s
$fontattr(mainfont
,size
)
5745 set fontattr
(mainfont
,size
) $s
5746 font config mainfont
-size $s
5747 font config mainfontbold
-size $s
5748 set mainfont
[fontname mainfont
]
5749 set s
$fontattr(textfont
,size
)
5754 set fontattr
(textfont
,size
) $s
5755 font config textfont
-size $s
5756 font config textfontbold
-size $s
5757 set textfont
[fontname textfont
]
5764 global sha1entry sha1string
5765 if {[string length
$sha1string] == 40} {
5766 $sha1entry delete
0 end
5770 proc sha1change
{n1 n2 op
} {
5771 global sha1string currentid sha1but
5772 if {$sha1string == {}
5773 ||
([info exists currentid
] && $sha1string == $currentid)} {
5778 if {[$sha1but cget
-state] == $state} return
5779 if {$state == "normal"} {
5780 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
5782 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
5786 proc gotocommit
{} {
5787 global sha1string currentid commitrow tagids headids
5788 global displayorder numcommits curview
5790 if {$sha1string == {}
5791 ||
([info exists currentid
] && $sha1string == $currentid)} return
5792 if {[info exists tagids
($sha1string)]} {
5793 set id
$tagids($sha1string)
5794 } elseif
{[info exists headids
($sha1string)]} {
5795 set id
$headids($sha1string)
5797 set id
[string tolower
$sha1string]
5798 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
5800 foreach i
$displayorder {
5801 if {[string match
$id* $i]} {
5805 if {$matches ne
{}} {
5806 if {[llength
$matches] > 1} {
5807 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
5810 set id
[lindex
$matches 0]
5814 if {[info exists commitrow
($curview,$id)]} {
5815 selectline
$commitrow($curview,$id) 1
5818 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
5819 set msg
[mc
"SHA1 id %s is not known" $sha1string]
5821 set msg
[mc
"Tag/Head %s is not known" $sha1string]
5826 proc lineenter
{x y id
} {
5827 global hoverx hovery hoverid hovertimer
5828 global commitinfo canv
5830 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
5834 if {[info exists hovertimer
]} {
5835 after cancel
$hovertimer
5837 set hovertimer
[after
500 linehover
]
5841 proc linemotion
{x y id
} {
5842 global hoverx hovery hoverid hovertimer
5844 if {[info exists hoverid
] && $id == $hoverid} {
5847 if {[info exists hovertimer
]} {
5848 after cancel
$hovertimer
5850 set hovertimer
[after
500 linehover
]
5854 proc lineleave
{id
} {
5855 global hoverid hovertimer canv
5857 if {[info exists hoverid
] && $id == $hoverid} {
5859 if {[info exists hovertimer
]} {
5860 after cancel
$hovertimer
5868 global hoverx hovery hoverid hovertimer
5869 global canv linespc lthickness
5872 set text
[lindex
$commitinfo($hoverid) 0]
5873 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5874 if {$ymax == {}} return
5875 set yfrac
[lindex
[$canv yview
] 0]
5876 set x
[expr {$hoverx + 2 * $linespc}]
5877 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5878 set x0
[expr {$x - 2 * $lthickness}]
5879 set y0
[expr {$y - 2 * $lthickness}]
5880 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
5881 set y1
[expr {$y + $linespc + 2 * $lthickness}]
5882 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
5883 -fill \
#ffff80 -outline black -width 1 -tags hover]
5885 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
5890 proc clickisonarrow
{id y
} {
5893 set ranges
[rowranges
$id]
5894 set thresh
[expr {2 * $lthickness + 6}]
5895 set n
[expr {[llength
$ranges] - 1}]
5896 for {set i
1} {$i < $n} {incr i
} {
5897 set row
[lindex
$ranges $i]
5898 if {abs
([yc
$row] - $y) < $thresh} {
5905 proc arrowjump
{id n y
} {
5908 # 1 <-> 2, 3 <-> 4, etc...
5909 set n
[expr {(($n - 1) ^
1) + 1}]
5910 set row
[lindex
[rowranges
$id] $n]
5912 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5913 if {$ymax eq
{} ||
$ymax <= 0} return
5914 set view
[$canv yview
]
5915 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
5916 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
5920 allcanvs yview moveto
$yfrac
5923 proc lineclick
{x y id isnew
} {
5924 global ctext commitinfo children canv thickerline curview commitrow
5926 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
5931 # draw this line thicker than normal
5935 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5936 if {$ymax eq
{}} return
5937 set yfrac
[lindex
[$canv yview
] 0]
5938 set y
[expr {$y + $yfrac * $ymax}]
5940 set dirn
[clickisonarrow
$id $y]
5942 arrowjump
$id $dirn $y
5947 addtohistory
[list lineclick
$x $y $id 0]
5949 # fill the details pane with info about this line
5950 $ctext conf
-state normal
5953 $ctext insert end
"[mc "Parent
"]:\t"
5954 $ctext insert end
$id link0
5956 set info
$commitinfo($id)
5957 $ctext insert end
"\n\t[lindex $info 0]\n"
5958 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
5959 set date [formatdate
[lindex
$info 2]]
5960 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
5961 set kids
$children($curview,$id)
5963 $ctext insert end
"\n[mc "Children
"]:"
5965 foreach child
$kids {
5967 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
5968 set info
$commitinfo($child)
5969 $ctext insert end
"\n\t"
5970 $ctext insert end
$child link
$i
5971 setlink
$child link
$i
5972 $ctext insert end
"\n\t[lindex $info 0]"
5973 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
5974 set date [formatdate
[lindex
$info 2]]
5975 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
5978 $ctext conf
-state disabled
5982 proc normalline
{} {
5984 if {[info exists thickerline
]} {
5992 global commitrow curview
5993 if {[info exists commitrow
($curview,$id)]} {
5994 selectline
$commitrow($curview,$id) 1
6000 if {![info exists startmstime
]} {
6001 set startmstime
[clock clicks
-milliseconds]
6003 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
6006 proc rowmenu
{x y id
} {
6007 global rowctxmenu commitrow selectedline rowmenuid curview
6008 global nullid nullid2 fakerowmenu mainhead
6012 if {![info exists selectedline
]
6013 ||
$commitrow($curview,$id) eq
$selectedline} {
6018 if {$id ne
$nullid && $id ne
$nullid2} {
6019 set menu
$rowctxmenu
6020 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6022 set menu
$fakerowmenu
6024 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6025 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6026 $menu entryconfigure
[mc
"Make patch"] -state $state
6027 tk_popup
$menu $x $y
6030 proc diffvssel
{dirn
} {
6031 global rowmenuid selectedline displayorder
6033 if {![info exists selectedline
]} return
6035 set oldid
[lindex
$displayorder $selectedline]
6036 set newid
$rowmenuid
6038 set oldid
$rowmenuid
6039 set newid
[lindex
$displayorder $selectedline]
6041 addtohistory
[list doseldiff
$oldid $newid]
6042 doseldiff
$oldid $newid
6045 proc doseldiff
{oldid newid
} {
6049 $ctext conf
-state normal
6051 init_flist
[mc
"Top"]
6052 $ctext insert end
"[mc "From
"] "
6053 $ctext insert end
$oldid link0
6054 setlink
$oldid link0
6055 $ctext insert end
"\n "
6056 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6057 $ctext insert end
"\n\n[mc "To
"] "
6058 $ctext insert end
$newid link1
6059 setlink
$newid link1
6060 $ctext insert end
"\n "
6061 $ctext insert end
[lindex
$commitinfo($newid) 0]
6062 $ctext insert end
"\n"
6063 $ctext conf
-state disabled
6064 $ctext tag remove found
1.0 end
6065 startdiff
[list
$oldid $newid]
6069 global rowmenuid currentid commitinfo patchtop patchnum
6071 if {![info exists currentid
]} return
6072 set oldid
$currentid
6073 set oldhead
[lindex
$commitinfo($oldid) 0]
6074 set newid
$rowmenuid
6075 set newhead
[lindex
$commitinfo($newid) 0]
6078 catch
{destroy
$top}
6080 label
$top.title
-text [mc
"Generate patch"]
6081 grid
$top.title
- -pady 10
6082 label
$top.from
-text [mc
"From:"]
6083 entry
$top.fromsha1
-width 40 -relief flat
6084 $top.fromsha1 insert
0 $oldid
6085 $top.fromsha1 conf
-state readonly
6086 grid
$top.from
$top.fromsha1
-sticky w
6087 entry
$top.fromhead
-width 60 -relief flat
6088 $top.fromhead insert
0 $oldhead
6089 $top.fromhead conf
-state readonly
6090 grid x
$top.fromhead
-sticky w
6091 label
$top.to
-text [mc
"To:"]
6092 entry
$top.tosha1
-width 40 -relief flat
6093 $top.tosha1 insert
0 $newid
6094 $top.tosha1 conf
-state readonly
6095 grid
$top.to
$top.tosha1
-sticky w
6096 entry
$top.tohead
-width 60 -relief flat
6097 $top.tohead insert
0 $newhead
6098 $top.tohead conf
-state readonly
6099 grid x
$top.tohead
-sticky w
6100 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6101 grid
$top.
rev x
-pady 10
6102 label
$top.flab
-text [mc
"Output file:"]
6103 entry
$top.fname
-width 60
6104 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6106 grid
$top.flab
$top.fname
-sticky w
6108 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6109 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6110 grid
$top.buts.gen
$top.buts.can
6111 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6112 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6113 grid
$top.buts
- -pady 10 -sticky ew
6117 proc mkpatchrev
{} {
6120 set oldid
[$patchtop.fromsha1 get
]
6121 set oldhead
[$patchtop.fromhead get
]
6122 set newid
[$patchtop.tosha1 get
]
6123 set newhead
[$patchtop.tohead get
]
6124 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6125 v
[list
$newid $newhead $oldid $oldhead] {
6126 $patchtop.
$e conf
-state normal
6127 $patchtop.
$e delete
0 end
6128 $patchtop.
$e insert
0 $v
6129 $patchtop.
$e conf
-state readonly
6134 global patchtop nullid nullid2
6136 set oldid
[$patchtop.fromsha1 get
]
6137 set newid
[$patchtop.tosha1 get
]
6138 set fname
[$patchtop.fname get
]
6139 set cmd
[diffcmd
[list
$oldid $newid] -p]
6140 # trim off the initial "|"
6141 set cmd
[lrange
$cmd 1 end
]
6142 lappend cmd
>$fname &
6143 if {[catch
{eval exec $cmd} err
]} {
6144 error_popup
"[mc "Error creating
patch:"] $err"
6146 catch
{destroy
$patchtop}
6150 proc mkpatchcan
{} {
6153 catch
{destroy
$patchtop}
6158 global rowmenuid mktagtop commitinfo
6162 catch
{destroy
$top}
6164 label
$top.title
-text [mc
"Create tag"]
6165 grid
$top.title
- -pady 10
6166 label
$top.id
-text [mc
"ID:"]
6167 entry
$top.sha1
-width 40 -relief flat
6168 $top.sha1 insert
0 $rowmenuid
6169 $top.sha1 conf
-state readonly
6170 grid
$top.id
$top.sha1
-sticky w
6171 entry
$top.
head -width 60 -relief flat
6172 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6173 $top.
head conf
-state readonly
6174 grid x
$top.
head -sticky w
6175 label
$top.tlab
-text [mc
"Tag name:"]
6176 entry
$top.tag
-width 60
6177 grid
$top.tlab
$top.tag
-sticky w
6179 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6180 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6181 grid
$top.buts.gen
$top.buts.can
6182 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6183 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6184 grid
$top.buts
- -pady 10 -sticky ew
6189 global mktagtop env tagids idtags
6191 set id
[$mktagtop.sha1 get
]
6192 set tag
[$mktagtop.tag get
]
6194 error_popup
[mc
"No tag name specified"]
6197 if {[info exists tagids
($tag)]} {
6198 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6202 exec git tag
$tag $id
6204 error_popup
"[mc "Error creating tag
:"] $err"
6208 set tagids
($tag) $id
6209 lappend idtags
($id) $tag
6216 proc redrawtags
{id
} {
6217 global canv linehtag commitrow idpos selectedline curview
6218 global canvxmax iddrawn
6220 if {![info exists commitrow
($curview,$id)]} return
6221 if {![info exists iddrawn
($id)]} return
6222 drawcommits
$commitrow($curview,$id)
6223 $canv delete tag.
$id
6224 set xt
[eval drawtags
$id $idpos($id)]
6225 $canv coords
$linehtag($commitrow($curview,$id)) $xt [lindex
$idpos($id) 2]
6226 set text
[$canv itemcget
$linehtag($commitrow($curview,$id)) -text]
6227 set xr
[expr {$xt + [font measure mainfont
$text]}]
6228 if {$xr > $canvxmax} {
6232 if {[info exists selectedline
]
6233 && $selectedline == $commitrow($curview,$id)} {
6234 selectline
$selectedline 0
6241 catch
{destroy
$mktagtop}
6250 proc writecommit
{} {
6251 global rowmenuid wrcomtop commitinfo wrcomcmd
6253 set top .writecommit
6255 catch
{destroy
$top}
6257 label
$top.title
-text [mc
"Write commit to file"]
6258 grid
$top.title
- -pady 10
6259 label
$top.id
-text [mc
"ID:"]
6260 entry
$top.sha1
-width 40 -relief flat
6261 $top.sha1 insert
0 $rowmenuid
6262 $top.sha1 conf
-state readonly
6263 grid
$top.id
$top.sha1
-sticky w
6264 entry
$top.
head -width 60 -relief flat
6265 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6266 $top.
head conf
-state readonly
6267 grid x
$top.
head -sticky w
6268 label
$top.clab
-text [mc
"Command:"]
6269 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6270 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6271 label
$top.flab
-text [mc
"Output file:"]
6272 entry
$top.fname
-width 60
6273 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6274 grid
$top.flab
$top.fname
-sticky w
6276 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6277 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6278 grid
$top.buts.gen
$top.buts.can
6279 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6280 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6281 grid
$top.buts
- -pady 10 -sticky ew
6288 set id
[$wrcomtop.sha1 get
]
6289 set cmd
"echo $id | [$wrcomtop.cmd get]"
6290 set fname
[$wrcomtop.fname get
]
6291 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6292 error_popup
"[mc "Error writing commit
:"] $err"
6294 catch
{destroy
$wrcomtop}
6301 catch
{destroy
$wrcomtop}
6306 global rowmenuid mkbrtop
6309 catch
{destroy
$top}
6311 label
$top.title
-text [mc
"Create new branch"]
6312 grid
$top.title
- -pady 10
6313 label
$top.id
-text [mc
"ID:"]
6314 entry
$top.sha1
-width 40 -relief flat
6315 $top.sha1 insert
0 $rowmenuid
6316 $top.sha1 conf
-state readonly
6317 grid
$top.id
$top.sha1
-sticky w
6318 label
$top.nlab
-text [mc
"Name:"]
6319 entry
$top.name
-width 40
6320 grid
$top.nlab
$top.name
-sticky w
6322 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6323 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6324 grid
$top.buts.go
$top.buts.can
6325 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6326 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6327 grid
$top.buts
- -pady 10 -sticky ew
6332 global headids idheads
6334 set name
[$top.name get
]
6335 set id
[$top.sha1 get
]
6337 error_popup
[mc
"Please specify a name for the new branch"]
6340 catch
{destroy
$top}
6344 exec git branch
$name $id
6349 set headids
($name) $id
6350 lappend idheads
($id) $name
6359 proc cherrypick
{} {
6360 global rowmenuid curview commitrow
6363 set oldhead
[exec git rev-parse HEAD
]
6364 set dheads
[descheads
$rowmenuid]
6365 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
6366 set ok
[confirm_popup
[mc
"Commit %s is already\
6367 included in branch %s -- really re-apply it?" \
6368 [string range
$rowmenuid 0 7] $mainhead]]
6371 nowbusy cherrypick
[mc
"Cherry-picking"]
6373 # Unfortunately git-cherry-pick writes stuff to stderr even when
6374 # no error occurs, and exec takes that as an indication of error...
6375 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
6380 set newhead
[exec git rev-parse HEAD
]
6381 if {$newhead eq
$oldhead} {
6383 error_popup
[mc
"No changes committed"]
6386 addnewchild
$newhead $oldhead
6387 if {[info exists commitrow
($curview,$oldhead)]} {
6388 insertrow
$commitrow($curview,$oldhead) $newhead
6389 if {$mainhead ne
{}} {
6390 movehead
$newhead $mainhead
6391 movedhead
$newhead $mainhead
6400 global mainheadid mainhead rowmenuid confirm_ok resettype
6403 set w
".confirmreset"
6406 wm title
$w [mc
"Confirm reset"]
6407 message
$w.m
-text \
6408 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
6409 -justify center
-aspect 1000
6410 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
6411 frame
$w.f
-relief sunken
-border 2
6412 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
6413 grid
$w.f.rt
-sticky w
6415 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
6416 -text [mc
"Soft: Leave working tree and index untouched"]
6417 grid
$w.f.soft
-sticky w
6418 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
6419 -text [mc
"Mixed: Leave working tree untouched, reset index"]
6420 grid
$w.f.mixed
-sticky w
6421 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
6422 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
6423 grid
$w.f.hard
-sticky w
6424 pack
$w.f
-side top
-fill x
6425 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
6426 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
6427 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
6428 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
6429 bind $w <Visibility
> "grab $w; focus $w"
6431 if {!$confirm_ok} return
6432 if {[catch
{set fd
[open \
6433 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
6437 filerun
$fd [list readresetstat
$fd]
6438 nowbusy
reset [mc
"Resetting"]
6442 proc readresetstat
{fd
} {
6443 global mainhead mainheadid showlocalchanges rprogcoord
6445 if {[gets
$fd line
] >= 0} {
6446 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
6447 set rprogcoord
[expr {1.0 * $m / $n}]
6455 if {[catch
{close
$fd} err
]} {
6458 set oldhead
$mainheadid
6459 set newhead
[exec git rev-parse HEAD
]
6460 if {$newhead ne
$oldhead} {
6461 movehead
$newhead $mainhead
6462 movedhead
$newhead $mainhead
6463 set mainheadid
$newhead
6467 if {$showlocalchanges} {
6473 # context menu for a head
6474 proc headmenu
{x y id
head} {
6475 global headmenuid headmenuhead headctxmenu mainhead
6479 set headmenuhead
$head
6481 if {$head eq
$mainhead} {
6484 $headctxmenu entryconfigure
0 -state $state
6485 $headctxmenu entryconfigure
1 -state $state
6486 tk_popup
$headctxmenu $x $y
6490 global headmenuid headmenuhead mainhead headids
6491 global showlocalchanges mainheadid
6493 # check the tree is clean first??
6494 set oldmainhead
$mainhead
6495 nowbusy checkout
[mc
"Checking out"]
6499 exec git checkout
-q $headmenuhead
6505 set mainhead
$headmenuhead
6506 set mainheadid
$headmenuid
6507 if {[info exists headids
($oldmainhead)]} {
6508 redrawtags
$headids($oldmainhead)
6510 redrawtags
$headmenuid
6512 if {$showlocalchanges} {
6518 global headmenuid headmenuhead mainhead
6521 set head $headmenuhead
6523 # this check shouldn't be needed any more...
6524 if {$head eq
$mainhead} {
6525 error_popup
[mc
"Cannot delete the currently checked-out branch"]
6528 set dheads
[descheads
$id]
6529 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
6530 # the stuff on this branch isn't on any other branch
6531 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
6532 branch.\nReally delete branch %s?" $head $head]]} return
6536 if {[catch
{exec git branch
-D $head} err
]} {
6541 removehead
$id $head
6542 removedhead
$id $head
6549 # Display a list of tags and heads
6551 global showrefstop bgcolor fgcolor selectbgcolor
6552 global bglist fglist reflistfilter reflist maincursor
6555 set showrefstop
$top
6556 if {[winfo exists
$top]} {
6562 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
6563 text
$top.list
-background $bgcolor -foreground $fgcolor \
6564 -selectbackground $selectbgcolor -font mainfont \
6565 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6566 -width 30 -height 20 -cursor $maincursor \
6567 -spacing1 1 -spacing3 1 -state disabled
6568 $top.list tag configure highlight
-background $selectbgcolor
6569 lappend bglist
$top.list
6570 lappend fglist
$top.list
6571 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
6572 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
6573 grid
$top.list
$top.ysb
-sticky nsew
6574 grid
$top.xsb x
-sticky ew
6576 label
$top.f.l
-text "[mc "Filter
"]: "
6577 entry
$top.f.e
-width 20 -textvariable reflistfilter
6578 set reflistfilter
"*"
6579 trace add variable reflistfilter
write reflistfilter_change
6580 pack
$top.f.e
-side right
-fill x
-expand 1
6581 pack
$top.f.l
-side left
6582 grid
$top.f
- -sticky ew
-pady 2
6583 button
$top.close
-command [list destroy
$top] -text [mc
"Close"]
6585 grid columnconfigure
$top 0 -weight 1
6586 grid rowconfigure
$top 0 -weight 1
6587 bind $top.list
<1> {break}
6588 bind $top.list
<B1-Motion
> {break}
6589 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
6594 proc sel_reflist
{w x y
} {
6595 global showrefstop reflist headids tagids otherrefids
6597 if {![winfo exists
$showrefstop]} return
6598 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
6599 set ref
[lindex
$reflist [expr {$l-1}]]
6600 set n
[lindex
$ref 0]
6601 switch
-- [lindex
$ref 1] {
6602 "H" {selbyid
$headids($n)}
6603 "T" {selbyid
$tagids($n)}
6604 "o" {selbyid
$otherrefids($n)}
6606 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
6609 proc unsel_reflist
{} {
6612 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6613 $showrefstop.list tag remove highlight
0.0 end
6616 proc reflistfilter_change
{n1 n2 op
} {
6617 global reflistfilter
6619 after cancel refill_reflist
6620 after
200 refill_reflist
6623 proc refill_reflist
{} {
6624 global reflist reflistfilter showrefstop headids tagids otherrefids
6625 global commitrow curview commitinterest
6627 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6629 foreach n
[array names headids
] {
6630 if {[string match
$reflistfilter $n]} {
6631 if {[info exists commitrow
($curview,$headids($n))]} {
6632 lappend refs
[list
$n H
]
6634 set commitinterest
($headids($n)) {run refill_reflist
}
6638 foreach n
[array names tagids
] {
6639 if {[string match
$reflistfilter $n]} {
6640 if {[info exists commitrow
($curview,$tagids($n))]} {
6641 lappend refs
[list
$n T
]
6643 set commitinterest
($tagids($n)) {run refill_reflist
}
6647 foreach n
[array names otherrefids
] {
6648 if {[string match
$reflistfilter $n]} {
6649 if {[info exists commitrow
($curview,$otherrefids($n))]} {
6650 lappend refs
[list
$n o
]
6652 set commitinterest
($otherrefids($n)) {run refill_reflist
}
6656 set refs
[lsort
-index 0 $refs]
6657 if {$refs eq
$reflist} return
6659 # Update the contents of $showrefstop.list according to the
6660 # differences between $reflist (old) and $refs (new)
6661 $showrefstop.list conf
-state normal
6662 $showrefstop.list insert end
"\n"
6665 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
6666 if {$i < [llength
$reflist]} {
6667 if {$j < [llength
$refs]} {
6668 set cmp [string compare
[lindex
$reflist $i 0] \
6669 [lindex
$refs $j 0]]
6671 set cmp [string compare
[lindex
$reflist $i 1] \
6672 [lindex
$refs $j 1]]
6682 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
6690 set l
[expr {$j + 1}]
6691 $showrefstop.list image create
$l.0 -align baseline \
6692 -image reficon-
[lindex
$refs $j 1] -padx 2
6693 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
6699 # delete last newline
6700 $showrefstop.list delete end-2c end-1c
6701 $showrefstop.list conf
-state disabled
6704 # Stuff for finding nearby tags
6705 proc getallcommits
{} {
6706 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6707 global idheads idtags idotherrefs allparents tagobjid
6709 if {![info exists allcommits
]} {
6715 set allccache
[file join [gitdir
] "gitk.cache"]
6717 set f
[open
$allccache r
]
6726 set cmd
[list | git rev-list
--parents]
6727 set allcupdate
[expr {$seeds ne
{}}]
6731 set refs
[concat
[array names idheads
] [array names idtags
] \
6732 [array names idotherrefs
]]
6735 foreach name
[array names tagobjid
] {
6736 lappend tagobjs
$tagobjid($name)
6738 foreach id
[lsort
-unique $refs] {
6739 if {![info exists allparents
($id)] &&
6740 [lsearch
-exact $tagobjs $id] < 0} {
6751 set fd
[open
[concat
$cmd $ids] r
]
6752 fconfigure
$fd -blocking 0
6755 filerun
$fd [list getallclines
$fd]
6761 # Since most commits have 1 parent and 1 child, we group strings of
6762 # such commits into "arcs" joining branch/merge points (BMPs), which
6763 # are commits that either don't have 1 parent or don't have 1 child.
6765 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6766 # arcout(id) - outgoing arcs for BMP
6767 # arcids(a) - list of IDs on arc including end but not start
6768 # arcstart(a) - BMP ID at start of arc
6769 # arcend(a) - BMP ID at end of arc
6770 # growing(a) - arc a is still growing
6771 # arctags(a) - IDs out of arcids (excluding end) that have tags
6772 # archeads(a) - IDs out of arcids (excluding end) that have heads
6773 # The start of an arc is at the descendent end, so "incoming" means
6774 # coming from descendents, and "outgoing" means going towards ancestors.
6776 proc getallclines
{fd
} {
6777 global allparents allchildren idtags idheads nextarc
6778 global arcnos arcids arctags arcout arcend arcstart archeads growing
6779 global seeds allcommits cachedarcs allcupdate
6782 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
6783 set id
[lindex
$line 0]
6784 if {[info exists allparents
($id)]} {
6789 set olds
[lrange
$line 1 end
]
6790 set allparents
($id) $olds
6791 if {![info exists allchildren
($id)]} {
6792 set allchildren
($id) {}
6797 if {[llength
$olds] == 1 && [llength
$a] == 1} {
6798 lappend arcids
($a) $id
6799 if {[info exists idtags
($id)]} {
6800 lappend arctags
($a) $id
6802 if {[info exists idheads
($id)]} {
6803 lappend archeads
($a) $id
6805 if {[info exists allparents
($olds)]} {
6806 # seen parent already
6807 if {![info exists arcout
($olds)]} {
6810 lappend arcids
($a) $olds
6811 set arcend
($a) $olds
6814 lappend allchildren
($olds) $id
6815 lappend arcnos
($olds) $a
6819 foreach a
$arcnos($id) {
6820 lappend arcids
($a) $id
6827 lappend allchildren
($p) $id
6828 set a
[incr nextarc
]
6829 set arcstart
($a) $id
6836 if {[info exists allparents
($p)]} {
6837 # seen it already, may need to make a new branch
6838 if {![info exists arcout
($p)]} {
6841 lappend arcids
($a) $p
6845 lappend arcnos
($p) $a
6850 global cached_dheads cached_dtags cached_atags
6851 catch
{unset cached_dheads
}
6852 catch
{unset cached_dtags
}
6853 catch
{unset cached_atags
}
6856 return [expr {$nid >= 1000?
2: 1}]
6860 fconfigure
$fd -blocking 1
6863 # got an error reading the list of commits
6864 # if we were updating, try rereading the whole thing again
6870 error_popup
"[mc "Error reading commit topology information
;\
6871 branch and preceding
/following tag information\
6872 will be incomplete.
"]\n($err)"
6875 if {[incr allcommits
-1] == 0} {
6885 proc recalcarc
{a
} {
6886 global arctags archeads arcids idtags idheads
6890 foreach id
[lrange
$arcids($a) 0 end-1
] {
6891 if {[info exists idtags
($id)]} {
6894 if {[info exists idheads
($id)]} {
6899 set archeads
($a) $ah
6903 global arcnos arcids nextarc arctags archeads idtags idheads
6904 global arcstart arcend arcout allparents growing
6907 if {[llength
$a] != 1} {
6908 puts
"oops splitarc called but [llength $a] arcs already"
6912 set i
[lsearch
-exact $arcids($a) $p]
6914 puts
"oops splitarc $p not in arc $a"
6917 set na
[incr nextarc
]
6918 if {[info exists arcend
($a)]} {
6919 set arcend
($na) $arcend($a)
6921 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
6922 set j
[lsearch
-exact $arcnos($l) $a]
6923 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
6925 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
6926 set arcids
($a) [lrange
$arcids($a) 0 $i]
6928 set arcstart
($na) $p
6930 set arcids
($na) $tail
6931 if {[info exists growing
($a)]} {
6937 if {[llength
$arcnos($id)] == 1} {
6940 set j
[lsearch
-exact $arcnos($id) $a]
6941 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
6945 # reconstruct tags and heads lists
6946 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
6951 set archeads
($na) {}
6955 # Update things for a new commit added that is a child of one
6956 # existing commit. Used when cherry-picking.
6957 proc addnewchild
{id p
} {
6958 global allparents allchildren idtags nextarc
6959 global arcnos arcids arctags arcout arcend arcstart archeads growing
6960 global seeds allcommits
6962 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
6963 set allparents
($id) [list
$p]
6964 set allchildren
($id) {}
6967 lappend allchildren
($p) $id
6968 set a
[incr nextarc
]
6969 set arcstart
($a) $id
6972 set arcids
($a) [list
$p]
6974 if {![info exists arcout
($p)]} {
6977 lappend arcnos
($p) $a
6978 set arcout
($id) [list
$a]
6981 # This implements a cache for the topology information.
6982 # The cache saves, for each arc, the start and end of the arc,
6983 # the ids on the arc, and the outgoing arcs from the end.
6984 proc readcache
{f
} {
6985 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6986 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6991 if {$lim - $a > 500} {
6992 set lim
[expr {$a + 500}]
6996 # finish reading the cache and setting up arctags, etc.
6998 if {$line ne
"1"} {error
"bad final version"}
7000 foreach id
[array names idtags
] {
7001 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7002 [llength
$allparents($id)] == 1} {
7003 set a
[lindex
$arcnos($id) 0]
7004 if {$arctags($a) eq
{}} {
7009 foreach id
[array names idheads
] {
7010 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7011 [llength
$allparents($id)] == 1} {
7012 set a
[lindex
$arcnos($id) 0]
7013 if {$archeads($a) eq
{}} {
7018 foreach id
[lsort
-unique $possible_seeds] {
7019 if {$arcnos($id) eq
{}} {
7025 while {[incr a
] <= $lim} {
7027 if {[llength
$line] != 3} {error
"bad line"}
7028 set s
[lindex
$line 0]
7030 lappend arcout
($s) $a
7031 if {![info exists arcnos
($s)]} {
7032 lappend possible_seeds
$s
7035 set e
[lindex
$line 1]
7040 if {![info exists arcout
($e)]} {
7044 set arcids
($a) [lindex
$line 2]
7045 foreach id
$arcids($a) {
7046 lappend allparents
($s) $id
7048 lappend arcnos
($id) $a
7050 if {![info exists allparents
($s)]} {
7051 set allparents
($s) {}
7056 set nextarc
[expr {$a - 1}]
7069 global nextarc cachedarcs possible_seeds
7073 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7074 # make sure it's an integer
7075 set cachedarcs
[expr {int
([lindex
$line 1])}]
7076 if {$cachedarcs < 0} {error
"bad number of arcs"}
7078 set possible_seeds
{}
7086 proc dropcache
{err
} {
7087 global allcwait nextarc cachedarcs seeds
7089 #puts "dropping cache ($err)"
7090 foreach v
{arcnos arcout arcids arcstart arcend growing \
7091 arctags archeads allparents allchildren
} {
7102 proc writecache
{f
} {
7103 global cachearc cachedarcs allccache
7104 global arcstart arcend arcnos arcids arcout
7108 if {$lim - $a > 1000} {
7109 set lim
[expr {$a + 1000}]
7112 while {[incr a
] <= $lim} {
7113 if {[info exists arcend
($a)]} {
7114 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7116 puts
$f [list
$arcstart($a) {} $arcids($a)]
7121 catch
{file delete
$allccache}
7122 #puts "writing cache failed ($err)"
7125 set cachearc
[expr {$a - 1}]
7126 if {$a > $cachedarcs} {
7135 global nextarc cachedarcs cachearc allccache
7137 if {$nextarc == $cachedarcs} return
7139 set cachedarcs
$nextarc
7141 set f
[open
$allccache w
]
7142 puts
$f [list
1 $cachedarcs]
7147 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7148 # or 0 if neither is true.
7149 proc anc_or_desc
{a b
} {
7150 global arcout arcstart arcend arcnos cached_isanc
7152 if {$arcnos($a) eq
$arcnos($b)} {
7153 # Both are on the same arc(s); either both are the same BMP,
7154 # or if one is not a BMP, the other is also not a BMP or is
7155 # the BMP at end of the arc (and it only has 1 incoming arc).
7156 # Or both can be BMPs with no incoming arcs.
7157 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7160 # assert {[llength $arcnos($a)] == 1}
7161 set arc
[lindex
$arcnos($a) 0]
7162 set i
[lsearch
-exact $arcids($arc) $a]
7163 set j
[lsearch
-exact $arcids($arc) $b]
7164 if {$i < 0 ||
$i > $j} {
7171 if {![info exists arcout
($a)]} {
7172 set arc
[lindex
$arcnos($a) 0]
7173 if {[info exists arcend
($arc)]} {
7174 set aend
$arcend($arc)
7178 set a
$arcstart($arc)
7182 if {![info exists arcout
($b)]} {
7183 set arc
[lindex
$arcnos($b) 0]
7184 if {[info exists arcend
($arc)]} {
7185 set bend
$arcend($arc)
7189 set b
$arcstart($arc)
7199 if {[info exists cached_isanc
($a,$bend)]} {
7200 if {$cached_isanc($a,$bend)} {
7204 if {[info exists cached_isanc
($b,$aend)]} {
7205 if {$cached_isanc($b,$aend)} {
7208 if {[info exists cached_isanc
($a,$bend)]} {
7213 set todo
[list
$a $b]
7216 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7217 set x
[lindex
$todo $i]
7218 if {$anc($x) eq
{}} {
7221 foreach arc
$arcnos($x) {
7222 set xd
$arcstart($arc)
7224 set cached_isanc
($a,$bend) 1
7225 set cached_isanc
($b,$aend) 0
7227 } elseif
{$xd eq
$aend} {
7228 set cached_isanc
($b,$aend) 1
7229 set cached_isanc
($a,$bend) 0
7232 if {![info exists anc
($xd)]} {
7233 set anc
($xd) $anc($x)
7235 } elseif
{$anc($xd) ne
$anc($x)} {
7240 set cached_isanc
($a,$bend) 0
7241 set cached_isanc
($b,$aend) 0
7245 # This identifies whether $desc has an ancestor that is
7246 # a growing tip of the graph and which is not an ancestor of $anc
7247 # and returns 0 if so and 1 if not.
7248 # If we subsequently discover a tag on such a growing tip, and that
7249 # turns out to be a descendent of $anc (which it could, since we
7250 # don't necessarily see children before parents), then $desc
7251 # isn't a good choice to display as a descendent tag of
7252 # $anc (since it is the descendent of another tag which is
7253 # a descendent of $anc). Similarly, $anc isn't a good choice to
7254 # display as a ancestor tag of $desc.
7256 proc is_certain
{desc anc
} {
7257 global arcnos arcout arcstart arcend growing problems
7260 if {[llength
$arcnos($anc)] == 1} {
7261 # tags on the same arc are certain
7262 if {$arcnos($desc) eq
$arcnos($anc)} {
7265 if {![info exists arcout
($anc)]} {
7266 # if $anc is partway along an arc, use the start of the arc instead
7267 set a
[lindex
$arcnos($anc) 0]
7268 set anc
$arcstart($a)
7271 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7274 set a
[lindex
$arcnos($desc) 0]
7280 set anclist
[list
$x]
7284 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7285 set x
[lindex
$anclist $i]
7290 foreach a
$arcout($x) {
7291 if {[info exists growing
($a)]} {
7292 if {![info exists growanc
($x)] && $dl($x)} {
7298 if {[info exists dl
($y)]} {
7302 if {![info exists
done($y)]} {
7305 if {[info exists growanc
($x)]} {
7309 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7310 set z
[lindex
$xl $k]
7311 foreach c
$arcout($z) {
7312 if {[info exists arcend
($c)]} {
7314 if {[info exists dl
($v)] && $dl($v)} {
7316 if {![info exists
done($v)]} {
7319 if {[info exists growanc
($v)]} {
7329 } elseif
{$y eq
$anc ||
!$dl($x)} {
7340 foreach x
[array names growanc
] {
7349 proc validate_arctags
{a
} {
7350 global arctags idtags
7354 foreach id
$arctags($a) {
7356 if {![info exists idtags
($id)]} {
7357 set na
[lreplace
$na $i $i]
7364 proc validate_archeads
{a
} {
7365 global archeads idheads
7368 set na
$archeads($a)
7369 foreach id
$archeads($a) {
7371 if {![info exists idheads
($id)]} {
7372 set na
[lreplace
$na $i $i]
7376 set archeads
($a) $na
7379 # Return the list of IDs that have tags that are descendents of id,
7380 # ignoring IDs that are descendents of IDs already reported.
7381 proc desctags
{id
} {
7382 global arcnos arcstart arcids arctags idtags allparents
7383 global growing cached_dtags
7385 if {![info exists allparents
($id)]} {
7388 set t1
[clock clicks
-milliseconds]
7390 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7391 # part-way along an arc; check that arc first
7392 set a
[lindex
$arcnos($id) 0]
7393 if {$arctags($a) ne
{}} {
7395 set i
[lsearch
-exact $arcids($a) $id]
7397 foreach t
$arctags($a) {
7398 set j
[lsearch
-exact $arcids($a) $t]
7406 set id
$arcstart($a)
7407 if {[info exists idtags
($id)]} {
7411 if {[info exists cached_dtags
($id)]} {
7412 return $cached_dtags($id)
7419 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7420 set id
[lindex
$todo $i]
7422 set ta
[info exists hastaggedancestor
($id)]
7426 # ignore tags on starting node
7427 if {!$ta && $i > 0} {
7428 if {[info exists idtags
($id)]} {
7431 } elseif
{[info exists cached_dtags
($id)]} {
7432 set tagloc
($id) $cached_dtags($id)
7436 foreach a
$arcnos($id) {
7438 if {!$ta && $arctags($a) ne
{}} {
7440 if {$arctags($a) ne
{}} {
7441 lappend tagloc
($id) [lindex
$arctags($a) end
]
7444 if {$ta ||
$arctags($a) ne
{}} {
7445 set tomark
[list
$d]
7446 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7447 set dd [lindex
$tomark $j]
7448 if {![info exists hastaggedancestor
($dd)]} {
7449 if {[info exists
done($dd)]} {
7450 foreach b
$arcnos($dd) {
7451 lappend tomark
$arcstart($b)
7453 if {[info exists tagloc
($dd)]} {
7456 } elseif
{[info exists queued
($dd)]} {
7459 set hastaggedancestor
($dd) 1
7463 if {![info exists queued
($d)]} {
7466 if {![info exists hastaggedancestor
($d)]} {
7473 foreach id
[array names tagloc
] {
7474 if {![info exists hastaggedancestor
($id)]} {
7475 foreach t
$tagloc($id) {
7476 if {[lsearch
-exact $tags $t] < 0} {
7482 set t2
[clock clicks
-milliseconds]
7485 # remove tags that are descendents of other tags
7486 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7487 set a
[lindex
$tags $i]
7488 for {set j
0} {$j < $i} {incr j
} {
7489 set b
[lindex
$tags $j]
7490 set r
[anc_or_desc
$a $b]
7492 set tags
[lreplace
$tags $j $j]
7495 } elseif
{$r == -1} {
7496 set tags
[lreplace
$tags $i $i]
7503 if {[array names growing
] ne
{}} {
7504 # graph isn't finished, need to check if any tag could get
7505 # eclipsed by another tag coming later. Simply ignore any
7506 # tags that could later get eclipsed.
7509 if {[is_certain
$t $origid]} {
7513 if {$tags eq
$ctags} {
7514 set cached_dtags
($origid) $tags
7519 set cached_dtags
($origid) $tags
7521 set t3
[clock clicks
-milliseconds]
7522 if {0 && $t3 - $t1 >= 100} {
7523 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
7524 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7530 global arcnos arcids arcout arcend arctags idtags allparents
7531 global growing cached_atags
7533 if {![info exists allparents
($id)]} {
7536 set t1
[clock clicks
-milliseconds]
7538 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7539 # part-way along an arc; check that arc first
7540 set a
[lindex
$arcnos($id) 0]
7541 if {$arctags($a) ne
{}} {
7543 set i
[lsearch
-exact $arcids($a) $id]
7544 foreach t
$arctags($a) {
7545 set j
[lsearch
-exact $arcids($a) $t]
7551 if {![info exists arcend
($a)]} {
7555 if {[info exists idtags
($id)]} {
7559 if {[info exists cached_atags
($id)]} {
7560 return $cached_atags($id)
7568 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7569 set id
[lindex
$todo $i]
7571 set td
[info exists hastaggeddescendent
($id)]
7575 # ignore tags on starting node
7576 if {!$td && $i > 0} {
7577 if {[info exists idtags
($id)]} {
7580 } elseif
{[info exists cached_atags
($id)]} {
7581 set tagloc
($id) $cached_atags($id)
7585 foreach a
$arcout($id) {
7586 if {!$td && $arctags($a) ne
{}} {
7588 if {$arctags($a) ne
{}} {
7589 lappend tagloc
($id) [lindex
$arctags($a) 0]
7592 if {![info exists arcend
($a)]} continue
7594 if {$td ||
$arctags($a) ne
{}} {
7595 set tomark
[list
$d]
7596 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7597 set dd [lindex
$tomark $j]
7598 if {![info exists hastaggeddescendent
($dd)]} {
7599 if {[info exists
done($dd)]} {
7600 foreach b
$arcout($dd) {
7601 if {[info exists arcend
($b)]} {
7602 lappend tomark
$arcend($b)
7605 if {[info exists tagloc
($dd)]} {
7608 } elseif
{[info exists queued
($dd)]} {
7611 set hastaggeddescendent
($dd) 1
7615 if {![info exists queued
($d)]} {
7618 if {![info exists hastaggeddescendent
($d)]} {
7624 set t2
[clock clicks
-milliseconds]
7627 foreach id
[array names tagloc
] {
7628 if {![info exists hastaggeddescendent
($id)]} {
7629 foreach t
$tagloc($id) {
7630 if {[lsearch
-exact $tags $t] < 0} {
7637 # remove tags that are ancestors of other tags
7638 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7639 set a
[lindex
$tags $i]
7640 for {set j
0} {$j < $i} {incr j
} {
7641 set b
[lindex
$tags $j]
7642 set r
[anc_or_desc
$a $b]
7644 set tags
[lreplace
$tags $j $j]
7647 } elseif
{$r == 1} {
7648 set tags
[lreplace
$tags $i $i]
7655 if {[array names growing
] ne
{}} {
7656 # graph isn't finished, need to check if any tag could get
7657 # eclipsed by another tag coming later. Simply ignore any
7658 # tags that could later get eclipsed.
7661 if {[is_certain
$origid $t]} {
7665 if {$tags eq
$ctags} {
7666 set cached_atags
($origid) $tags
7671 set cached_atags
($origid) $tags
7673 set t3
[clock clicks
-milliseconds]
7674 if {0 && $t3 - $t1 >= 100} {
7675 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
7676 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7681 # Return the list of IDs that have heads that are descendents of id,
7682 # including id itself if it has a head.
7683 proc descheads
{id
} {
7684 global arcnos arcstart arcids archeads idheads cached_dheads
7687 if {![info exists allparents
($id)]} {
7691 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7692 # part-way along an arc; check it first
7693 set a
[lindex
$arcnos($id) 0]
7694 if {$archeads($a) ne
{}} {
7695 validate_archeads
$a
7696 set i
[lsearch
-exact $arcids($a) $id]
7697 foreach t
$archeads($a) {
7698 set j
[lsearch
-exact $arcids($a) $t]
7703 set id
$arcstart($a)
7709 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7710 set id
[lindex
$todo $i]
7711 if {[info exists cached_dheads
($id)]} {
7712 set ret
[concat
$ret $cached_dheads($id)]
7714 if {[info exists idheads
($id)]} {
7717 foreach a
$arcnos($id) {
7718 if {$archeads($a) ne
{}} {
7719 validate_archeads
$a
7720 if {$archeads($a) ne
{}} {
7721 set ret
[concat
$ret $archeads($a)]
7725 if {![info exists seen
($d)]} {
7732 set ret
[lsort
-unique $ret]
7733 set cached_dheads
($origid) $ret
7734 return [concat
$ret $aret]
7737 proc addedtag
{id
} {
7738 global arcnos arcout cached_dtags cached_atags
7740 if {![info exists arcnos
($id)]} return
7741 if {![info exists arcout
($id)]} {
7742 recalcarc
[lindex
$arcnos($id) 0]
7744 catch
{unset cached_dtags
}
7745 catch
{unset cached_atags
}
7748 proc addedhead
{hid
head} {
7749 global arcnos arcout cached_dheads
7751 if {![info exists arcnos
($hid)]} return
7752 if {![info exists arcout
($hid)]} {
7753 recalcarc
[lindex
$arcnos($hid) 0]
7755 catch
{unset cached_dheads
}
7758 proc removedhead
{hid
head} {
7759 global cached_dheads
7761 catch
{unset cached_dheads
}
7764 proc movedhead
{hid
head} {
7765 global arcnos arcout cached_dheads
7767 if {![info exists arcnos
($hid)]} return
7768 if {![info exists arcout
($hid)]} {
7769 recalcarc
[lindex
$arcnos($hid) 0]
7771 catch
{unset cached_dheads
}
7774 proc changedrefs
{} {
7775 global cached_dheads cached_dtags cached_atags
7776 global arctags archeads arcnos arcout idheads idtags
7778 foreach id
[concat
[array names idheads
] [array names idtags
]] {
7779 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
7780 set a
[lindex
$arcnos($id) 0]
7781 if {![info exists donearc
($a)]} {
7787 catch
{unset cached_dtags
}
7788 catch
{unset cached_atags
}
7789 catch
{unset cached_dheads
}
7792 proc rereadrefs
{} {
7793 global idtags idheads idotherrefs mainhead
7795 set refids
[concat
[array names idtags
] \
7796 [array names idheads
] [array names idotherrefs
]]
7797 foreach id
$refids {
7798 if {![info exists ref
($id)]} {
7799 set ref
($id) [listrefs
$id]
7802 set oldmainhead
$mainhead
7805 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
7806 [array names idheads
] [array names idotherrefs
]]]
7807 foreach id
$refids {
7808 set v
[listrefs
$id]
7809 if {![info exists ref
($id)] ||
$ref($id) != $v ||
7810 ($id eq
$oldmainhead && $id ne
$mainhead) ||
7811 ($id eq
$mainhead && $id ne
$oldmainhead)} {
7818 proc listrefs
{id
} {
7819 global idtags idheads idotherrefs
7822 if {[info exists idtags
($id)]} {
7826 if {[info exists idheads
($id)]} {
7830 if {[info exists idotherrefs
($id)]} {
7831 set z
$idotherrefs($id)
7833 return [list
$x $y $z]
7836 proc showtag
{tag isnew
} {
7837 global ctext tagcontents tagids linknum tagobjid
7840 addtohistory
[list showtag
$tag 0]
7842 $ctext conf
-state normal
7846 if {![info exists tagcontents
($tag)]} {
7848 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
7851 if {[info exists tagcontents
($tag)]} {
7852 set text
$tagcontents($tag)
7854 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
7856 appendwithlinks
$text {}
7857 $ctext conf
-state disabled
7868 proc mkfontdisp
{font top
which} {
7869 global fontattr fontpref
$font
7871 set fontpref
($font) [set $font]
7872 button
$top.
${font}but
-text $which -font optionfont \
7873 -command [list choosefont
$font $which]
7874 label
$top.
$font -relief flat
-font $font \
7875 -text $fontattr($font,family
) -justify left
7876 grid x
$top.
${font}but
$top.
$font -sticky w
7879 proc choosefont
{font
which} {
7880 global fontparam fontlist fonttop fontattr
7882 set fontparam
(which) $which
7883 set fontparam
(font
) $font
7884 set fontparam
(family
) [font actual
$font -family]
7885 set fontparam
(size
) $fontattr($font,size
)
7886 set fontparam
(weight
) $fontattr($font,weight
)
7887 set fontparam
(slant
) $fontattr($font,slant
)
7890 if {![winfo exists
$top]} {
7892 eval font config sample
[font actual
$font]
7894 wm title
$top [mc
"Gitk font chooser"]
7895 label
$top.l
-textvariable fontparam
(which)
7896 pack
$top.l
-side top
7897 set fontlist
[lsort
[font families
]]
7899 listbox
$top.f.fam
-listvariable fontlist \
7900 -yscrollcommand [list
$top.f.sb
set]
7901 bind $top.f.fam
<<ListboxSelect>> selfontfam
7902 scrollbar $top.f.sb -command [list $top.f.fam yview]
7903 pack $top.f.sb -side right -fill y
7904 pack $top.f.fam -side left -fill both -expand 1
7905 pack $top.f -side top -fill both -expand 1
7907 spinbox $top.g.size -from 4 -to 40 -width 4 \
7908 -textvariable fontparam(size) \
7909 -validatecommand {string is integer -strict %s}
7910 checkbutton $top.g.bold -padx 5 \
7911 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
7912 -variable fontparam(weight) -onvalue bold -offvalue normal
7913 checkbutton $top.g.ital -padx 5 \
7914 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
7915 -variable fontparam(slant) -onvalue italic -offvalue roman
7916 pack $top.g.size $top.g.bold $top.g.ital -side left
7917 pack $top.g -side top
7918 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7920 $top.c create text 100 25 -anchor center -text $which -font sample \
7921 -fill black -tags text
7922 bind $top.c <Configure> [list centertext $top.c]
7923 pack $top.c -side top -fill x
7925 button $top.buts.ok -text [mc "OK"] -command fontok -default active
7926 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
7927 grid $top.buts.ok $top.buts.can
7928 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7929 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7930 pack $top.buts -side bottom -fill x
7931 trace add variable fontparam write chg_fontparam
7934 $top.c itemconf text -text $which
7936 set i [lsearch -exact $fontlist $fontparam(family)]
7938 $top.f.fam selection set $i
7943 proc centertext {w} {
7944 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7948 global fontparam fontpref prefstop
7950 set f $fontparam(font)
7951 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7952 if {$fontparam(weight) eq "bold"} {
7953 lappend fontpref($f) "bold"
7955 if {$fontparam(slant) eq "italic"} {
7956 lappend fontpref($f) "italic"
7959 $w conf -text $fontparam(family) -font $fontpref($f)
7965 global fonttop fontparam
7967 if {[info exists fonttop]} {
7968 catch {destroy $fonttop}
7969 catch {font delete sample}
7975 proc selfontfam {} {
7976 global fonttop fontparam
7978 set i [$fonttop.f.fam curselection]
7980 set fontparam(family) [$fonttop.f.fam get $i]
7984 proc chg_fontparam {v sub op} {
7987 font config sample -$sub $fontparam($sub)
7991 global maxwidth maxgraphpct
7992 global oldprefs prefstop showneartags showlocalchanges
7993 global bgcolor fgcolor ctext diffcolors selectbgcolor
7994 global tabstop limitdiffs autoselect
7998 if {[winfo exists $top]} {
8002 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8003 limitdiffs tabstop} {
8004 set oldprefs($v) [set $v]
8007 wm title $top [mc "Gitk preferences"]
8008 label $top.ldisp -text [mc "Commit list display options"]
8009 grid $top.ldisp - -sticky w -pady 10
8010 label $top.spacer -text " "
8011 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8013 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8014 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8015 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8017 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8018 grid x $top.maxpctl $top.maxpct -sticky w
8019 frame $top.showlocal
8020 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8021 checkbutton $top.showlocal.b -variable showlocalchanges
8022 pack $top.showlocal.b $top.showlocal.l -side left
8023 grid x $top.showlocal -sticky w
8024 frame $top.autoselect
8025 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
8026 checkbutton $top.autoselect.b -variable autoselect
8027 pack $top.autoselect.b $top.autoselect.l -side left
8028 grid x $top.autoselect -sticky w
8030 label $top.ddisp -text [mc "Diff display options"]
8031 grid $top.ddisp - -sticky w -pady 10
8032 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8033 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8034 grid x $top.tabstopl $top.tabstop -sticky w
8036 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8037 checkbutton $top.ntag.b -variable showneartags
8038 pack $top.ntag.b $top.ntag.l -side left
8039 grid x $top.ntag -sticky w
8041 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8042 checkbutton $top.ldiff.b -variable limitdiffs
8043 pack $top.ldiff.b $top.ldiff.l -side left
8044 grid x $top.ldiff -sticky w
8046 label $top.cdisp -text [mc "Colors: press to choose"]
8047 grid $top.cdisp - -sticky w -pady 10
8048 label $top.bg -padx 40 -relief sunk -background $bgcolor
8049 button $top.bgbut -text [mc "Background"] -font optionfont \
8050 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8051 grid x $top.bgbut $top.bg -sticky w
8052 label $top.fg -padx 40 -relief sunk -background $fgcolor
8053 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8054 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8055 grid x $top.fgbut $top.fg -sticky w
8056 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8057 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8058 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8059 [list $ctext tag conf d0 -foreground]]
8060 grid x $top.diffoldbut $top.diffold -sticky w
8061 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8062 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8063 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8064 [list $ctext tag conf d1 -foreground]]
8065 grid x $top.diffnewbut $top.diffnew -sticky w
8066 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8067 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8068 -command [list choosecolor diffcolors 2 $top.hunksep \
8069 "diff hunk header" \
8070 [list $ctext tag conf hunksep -foreground]]
8071 grid x $top.hunksepbut $top.hunksep -sticky w
8072 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8073 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8074 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8075 grid x $top.selbgbut $top.selbgsep -sticky w
8077 label $top.cfont -text [mc "Fonts: press to choose"]
8078 grid $top.cfont - -sticky w -pady 10
8079 mkfontdisp mainfont $top [mc "Main font"]
8080 mkfontdisp textfont $top [mc "Diff display font"]
8081 mkfontdisp uifont $top [mc "User interface font"]
8084 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8085 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8086 grid $top.buts.ok $top.buts.can
8087 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8088 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8089 grid $top.buts - - -pady 10 -sticky ew
8090 bind $top <Visibility> "focus $top.buts.ok"
8093 proc choosecolor {v vi w x cmd} {
8096 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8097 -title [mc "Gitk: choose color for %s" $x]]
8098 if {$c eq {}} return
8099 $w conf -background $c
8105 global bglist cflist
8107 $w configure -selectbackground $c
8109 $cflist tag configure highlight \
8110 -background [$cflist cget -selectbackground]
8111 allcanvs itemconf secsel -fill $c
8118 $w conf -background $c
8126 $w conf -foreground $c
8128 allcanvs itemconf text -fill $c
8129 $canv itemconf circle -outline $c
8133 global oldprefs prefstop
8135 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8136 limitdiffs tabstop} {
8138 set $v $oldprefs($v)
8140 catch {destroy $prefstop}
8146 global maxwidth maxgraphpct
8147 global oldprefs prefstop showneartags showlocalchanges
8148 global fontpref mainfont textfont uifont
8149 global limitdiffs treediffs
8151 catch {destroy $prefstop}
8155 if {$mainfont ne $fontpref(mainfont)} {
8156 set mainfont $fontpref(mainfont)
8157 parsefont mainfont $mainfont
8158 eval font configure mainfont [fontflags mainfont]
8159 eval font configure mainfontbold [fontflags mainfont 1]
8163 if {$textfont ne $fontpref(textfont)} {
8164 set textfont $fontpref(textfont)
8165 parsefont textfont $textfont
8166 eval font configure textfont [fontflags textfont]
8167 eval font configure textfontbold [fontflags textfont 1]
8169 if {$uifont ne $fontpref(uifont)} {
8170 set uifont $fontpref(uifont)
8171 parsefont uifont $uifont
8172 eval font configure uifont [fontflags uifont]
8175 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8176 if {$showlocalchanges} {
8182 if {$limitdiffs != $oldprefs(limitdiffs)} {
8183 # treediffs elements are limited by path
8184 catch {unset treediffs}
8186 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8187 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8189 } elseif {$showneartags != $oldprefs(showneartags) ||
8190 $limitdiffs != $oldprefs(limitdiffs)} {
8195 proc formatdate {d} {
8196 global datetimeformat
8198 set d [clock format $d -format $datetimeformat]
8203 # This list of encoding names and aliases is distilled from
8204 # http://www.iana.org/assignments/character-sets.
8205 # Not all of them are supported by Tcl.
8206 set encoding_aliases {
8207 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8208 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8209 { ISO-10646-UTF-1 csISO10646UTF1 }
8210 { ISO_646.basic:1983 ref csISO646basic1983 }
8211 { INVARIANT csINVARIANT }
8212 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8213 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8214 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8215 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8216 { NATS-DANO iso-ir-9-1 csNATSDANO }
8217 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8218 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8219 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8220 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8221 { ISO-2022-KR csISO2022KR }
8223 { ISO-2022-JP csISO2022JP }
8224 { ISO-2022-JP-2 csISO2022JP2 }
8225 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8227 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8228 { IT iso-ir-15 ISO646-IT csISO15Italian }
8229 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8230 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8231 { greek7-old iso-ir-18 csISO18Greek7Old }
8232 { latin-greek iso-ir-19 csISO19LatinGreek }
8233 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8234 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8235 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8236 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8237 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8238 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8239 { INIS iso-ir-49 csISO49INIS }
8240 { INIS-8 iso-ir-50 csISO50INIS8 }
8241 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8242 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8243 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8244 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8245 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8246 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8248 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8249 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8250 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8251 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8252 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8253 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8254 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8255 { greek7 iso-ir-88 csISO88Greek7 }
8256 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8257 { iso-ir-90 csISO90 }
8258 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8259 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8260 csISO92JISC62991984b }
8261 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8262 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8263 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8264 csISO95JIS62291984handadd }
8265 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8266 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8267 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8268 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8270 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8271 { T.61-7bit iso-ir-102 csISO102T617bit }
8272 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8273 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8274 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8275 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8276 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8277 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8278 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8279 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8280 arabic csISOLatinArabic }
8281 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8282 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8283 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8284 greek greek8 csISOLatinGreek }
8285 { T.101-G2 iso-ir-128 csISO128T101G2 }
8286 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8288 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8289 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8290 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8291 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8292 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8293 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8294 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8295 csISOLatinCyrillic }
8296 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8297 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8298 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8299 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8300 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8301 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8302 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8303 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8304 { ISO_10367-box iso-ir-155 csISO10367Box }
8305 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8306 { latin-lap lap iso-ir-158 csISO158Lap }
8307 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8308 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8311 { JIS_X0201 X0201 csHalfWidthKatakana }
8312 { KSC5636 ISO646-KR csKSC5636 }
8313 { ISO-10646-UCS-2 csUnicode }
8314 { ISO-10646-UCS-4 csUCS4 }
8315 { DEC-MCS dec csDECMCS }
8316 { hp-roman8 roman8 r8 csHPRoman8 }
8317 { macintosh mac csMacintosh }
8318 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8320 { IBM038 EBCDIC-INT cp038 csIBM038 }
8321 { IBM273 CP273 csIBM273 }
8322 { IBM274 EBCDIC-BE CP274 csIBM274 }
8323 { IBM275 EBCDIC-BR cp275 csIBM275 }
8324 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8325 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8326 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8327 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8328 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8329 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8330 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8331 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8332 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8333 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8334 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8335 { IBM437 cp437 437 csPC8CodePage437 }
8336 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8337 { IBM775 cp775 csPC775Baltic }
8338 { IBM850 cp850 850 csPC850Multilingual }
8339 { IBM851 cp851 851 csIBM851 }
8340 { IBM852 cp852 852 csPCp852 }
8341 { IBM855 cp855 855 csIBM855 }
8342 { IBM857 cp857 857 csIBM857 }
8343 { IBM860 cp860 860 csIBM860 }
8344 { IBM861 cp861 861 cp-is csIBM861 }
8345 { IBM862 cp862 862 csPC862LatinHebrew }
8346 { IBM863 cp863 863 csIBM863 }
8347 { IBM864 cp864 csIBM864 }
8348 { IBM865 cp865 865 csIBM865 }
8349 { IBM866 cp866 866 csIBM866 }
8350 { IBM868 CP868 cp-ar csIBM868 }
8351 { IBM869 cp869 869 cp-gr csIBM869 }
8352 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8353 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8354 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8355 { IBM891 cp891 csIBM891 }
8356 { IBM903 cp903 csIBM903 }
8357 { IBM904 cp904 904 csIBBM904 }
8358 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8359 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8360 { IBM1026 CP1026 csIBM1026 }
8361 { EBCDIC-AT-DE csIBMEBCDICATDE }
8362 { EBCDIC-AT-DE-A csEBCDICATDEA }
8363 { EBCDIC-CA-FR csEBCDICCAFR }
8364 { EBCDIC-DK-NO csEBCDICDKNO }
8365 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8366 { EBCDIC-FI-SE csEBCDICFISE }
8367 { EBCDIC-FI-SE-A csEBCDICFISEA }
8368 { EBCDIC-FR csEBCDICFR }
8369 { EBCDIC-IT csEBCDICIT }
8370 { EBCDIC-PT csEBCDICPT }
8371 { EBCDIC-ES csEBCDICES }
8372 { EBCDIC-ES-A csEBCDICESA }
8373 { EBCDIC-ES-S csEBCDICESS }
8374 { EBCDIC-UK csEBCDICUK }
8375 { EBCDIC-US csEBCDICUS }
8376 { UNKNOWN-8BIT csUnknown8BiT }
8377 { MNEMONIC csMnemonic }
8382 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8383 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8384 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8385 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8386 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8387 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8388 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8389 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8390 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8391 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8392 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8393 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8394 { IBM1047 IBM-1047 }
8395 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8396 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8397 { UNICODE-1-1 csUnicode11 }
8400 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8401 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8403 { ISO-8859-15 ISO_8859-15 Latin-9 }
8404 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8405 { GBK CP936 MS936 windows-936 }
8406 { JIS_Encoding csJISEncoding }
8407 { Shift_JIS MS_Kanji csShiftJIS }
8408 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8410 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8411 { ISO-10646-UCS-Basic csUnicodeASCII }
8412 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8413 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8414 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8415 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8416 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8417 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8418 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8419 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8420 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8421 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8422 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8423 { Ventura-US csVenturaUS }
8424 { Ventura-International csVenturaInternational }
8425 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8426 { PC8-Turkish csPC8Turkish }
8427 { IBM-Symbols csIBMSymbols }
8428 { IBM-Thai csIBMThai }
8429 { HP-Legal csHPLegal }
8430 { HP-Pi-font csHPPiFont }
8431 { HP-Math8 csHPMath8 }
8432 { Adobe-Symbol-Encoding csHPPSMath }
8433 { HP-DeskTop csHPDesktop }
8434 { Ventura-Math csVenturaMath }
8435 { Microsoft-Publishing csMicrosoftPublishing }
8436 { Windows-31J csWindows31J }
8441 proc tcl_encoding {enc} {
8442 global encoding_aliases
8443 set names [encoding names]
8444 set lcnames [string tolower $names]
8445 set enc [string tolower $enc]
8446 set i [lsearch -exact $lcnames $enc]
8448 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8449 if {[regsub {^iso[-_]} $enc iso encx]} {
8450 set i [lsearch -exact $lcnames $encx]
8454 foreach l $encoding_aliases {
8455 set ll [string tolower $l]
8456 if {[lsearch -exact $ll $enc] < 0} continue
8457 # look through the aliases for one that tcl knows about
8459 set i [lsearch -exact $lcnames $e]
8461 if {[regsub {^iso[-_]} $e iso ex]} {
8462 set i [lsearch -exact $lcnames $ex]
8471 return [lindex $names $i]
8476 # First check that Tcl/Tk is recent enough
8477 if {[catch {package require Tk 8.4} err]} {
8478 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8479 Gitk requires at least Tcl/Tk 8.4."]
8485 set wrcomcmd "git diff-tree --stdin -p --pretty"
8489 set gitencoding [exec git config --get i18n.commitencoding]
8491 if {$gitencoding == ""} {
8492 set gitencoding "utf-8"
8494 set tclencoding [tcl_encoding $gitencoding]
8495 if {$tclencoding == {}} {
8496 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8499 set mainfont {Helvetica 9}
8500 set textfont {Courier 9}
8501 set uifont {Helvetica 9 bold}
8503 set findmergefiles 0
8511 set cmitmode "patch"
8512 set wrapcomment "none"
8516 set showlocalchanges 1
8518 set datetimeformat "%Y-%m-%d %H:%M:%S"
8521 set colors {green red blue magenta darkgrey brown orange}
8524 set diffcolors {red "#00a000" blue}
8527 set selectbgcolor gray85
8529 ## For msgcat loading, first locate the installation location.
8530 if { [info exists ::env(GITK_MSGSDIR)] } {
8531 ## Msgsdir was manually set in the environment.
8532 set gitk_msgsdir $::env(GITK_MSGSDIR)
8534 ## Let's guess the prefix from argv0.
8535 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
8536 set gitk_libdir [file join $gitk_prefix share gitk lib]
8537 set gitk_msgsdir [file join $gitk_libdir msgs]
8541 ## Internationalization (i18n) through msgcat and gettext. See
8542 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
8543 package require msgcat
8544 namespace import ::msgcat::mc
8545 ## And eventually load the actual message catalog
8546 ::msgcat::mcload $gitk_msgsdir
8548 catch {source ~/.gitk}
8550 font create optionfont -family sans-serif -size -12
8552 parsefont mainfont $mainfont
8553 eval font create mainfont [fontflags mainfont]
8554 eval font create mainfontbold [fontflags mainfont 1]
8556 parsefont textfont $textfont
8557 eval font create textfont [fontflags textfont]
8558 eval font create textfontbold [fontflags textfont 1]
8560 parsefont uifont $uifont
8561 eval font create uifont [fontflags uifont]
8565 # check that we can find a .git directory somewhere...
8566 if {[catch {set gitdir [gitdir]}]} {
8567 show_error {} . [mc "Cannot find a git repository here."]
8570 if {![file isdirectory $gitdir]} {
8571 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
8577 set cmdline_files {}
8579 set revtreeargscmd {}
8581 switch -glob -- $arg {
8583 "-d" { set datemode 1 }
8586 lappend revtreeargs $arg
8589 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8593 set revtreeargscmd [string range $arg 10 end]
8596 lappend revtreeargs $arg
8602 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8603 # no -- on command line, but some arguments (other than -d)
8605 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8606 set cmdline_files [split $f "\n"]
8607 set n [llength $cmdline_files]
8608 set revtreeargs [lrange $revtreeargs 0 end-$n]
8609 # Unfortunately git rev-parse doesn't produce an error when
8610 # something is both a revision and a filename. To be consistent
8611 # with git log and git rev-list, check revtreeargs for filenames.
8612 foreach arg $revtreeargs {
8613 if {[file exists $arg]} {
8614 show_error {} . [mc "Ambiguous argument '%s': both revision\
8620 # unfortunately we get both stdout and stderr in $err,
8621 # so look for "fatal:".
8622 set i [string first "fatal:" $err]
8624 set err [string range $err [expr {$i + 6}] end]
8626 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
8632 # find the list of unmerged files
8636 set fd [open "| git ls-files -u" r]
8638 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
8641 while {[gets $fd line] >= 0} {
8642 set i [string first "\t" $line]
8643 if {$i < 0} continue
8644 set fname [string range $line [expr {$i+1}] end]
8645 if {[lsearch -exact $mlist $fname] >= 0} continue
8647 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8648 lappend mlist $fname
8653 if {$nr_unmerged == 0} {
8654 show_error {} . [mc "No files selected: --merge specified but\
8655 no files are unmerged."]
8657 show_error {} . [mc "No files selected: --merge specified but\
8658 no unmerged files are within file limit."]
8662 set cmdline_files $mlist
8665 set nullid "0000000000000000000000000000000000000000"
8666 set nullid2 "0000000000000000000000000000000000000001"
8668 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8675 set highlight_paths {}
8677 set searchdirn -forwards
8681 set markingmatches 0
8682 set linkentercount 0
8683 set need_redisplay 0
8690 set selectedhlview [mc "None"]
8691 set highlight_related [mc "None"]
8692 set highlight_files {}
8696 set viewargscmd(0) {}
8705 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
8708 # wait for the window to become visible
8710 wm title . "[file tail $argv0]: [file tail [pwd]]"
8713 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
8714 # create a view for the files/dirs specified on the command line
8718 set viewname(1) [mc "Command line"]
8719 set viewfiles(1) $cmdline_files
8720 set viewargs(1) $revtreeargs
8721 set viewargscmd(1) $revtreeargscmd
8724 .bar.view entryconf [mc "Edit view..."] -state normal
8725 .bar.view entryconf [mc "Delete view"] -state normal
8728 if {[info exists permviews]} {
8729 foreach v $permviews {
8732 set viewname($n) [lindex $v 0]
8733 set viewfiles($n) [lindex $v 1]
8734 set viewargs($n) [lindex $v 2]
8735 set viewargscmd($n) [lindex $v 3]