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"
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}
1091 $flist_menu add command -label [mc "External diff"] \
1092 -command {external_diff}
1095 # Windows sends all mouse wheel events to the current focused window, not
1096 # the one where the mouse hovers, so bind those events here and redirect
1097 # to the correct window
1098 proc windows_mousewheel_redirector {W X Y D} {
1099 global canv canv2 canv3
1100 set w [winfo containing -displayof $W $X $Y]
1102 set u [expr {$D < 0 ? 5 : -5}]
1103 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1104 allcanvs yview scroll $u units
1107 $w yview scroll $u units
1113 # mouse-2 makes all windows scan vertically, but only the one
1114 # the cursor is in scans horizontally
1115 proc canvscan {op w x y} {
1116 global canv canv2 canv3
1117 foreach c [list $canv $canv2 $canv3] {
1126 proc scrollcanv {cscroll f0 f1} {
1127 $cscroll set $f0 $f1
1132 # when we make a key binding for the toplevel, make sure
1133 # it doesn't get triggered when that key is pressed
in the
1134 # find string entry widget.
1135 proc bindkey
{ev
script} {
1138 set escript
[bind Entry
$ev]
1139 if {$escript == {}} {
1140 set escript
[bind Entry
<Key
>]
1142 foreach e
$entries {
1143 bind $e $ev "$escript; break"
1147 # set the focus back to the toplevel for any click outside
1150 global ctext entries
1151 foreach e
[concat
$entries $ctext] {
1152 if {$w == $e} return
1157 # Adjust the progress bar for a change in requested extent or canvas size
1158 proc adjustprogress
{} {
1159 global progresscanv progressitem progresscoords
1160 global fprogitem fprogcoord lastprogupdate progupdatepending
1161 global rprogitem rprogcoord
1163 set w
[expr {[winfo width
$progresscanv] - 4}]
1164 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1165 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1166 set h
[winfo height
$progresscanv]
1167 $progresscanv coords
$progressitem $x0 0 $x1 $h
1168 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1169 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1170 set now
[clock clicks
-milliseconds]
1171 if {$now >= $lastprogupdate + 100} {
1172 set progupdatepending
0
1174 } elseif
{!$progupdatepending} {
1175 set progupdatepending
1
1176 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1180 proc doprogupdate
{} {
1181 global lastprogupdate progupdatepending
1183 if {$progupdatepending} {
1184 set progupdatepending
0
1185 set lastprogupdate
[clock clicks
-milliseconds]
1190 proc savestuff
{w
} {
1191 global canv canv2 canv3 mainfont textfont uifont tabstop
1192 global stuffsaved findmergefiles maxgraphpct
1193 global maxwidth showneartags showlocalchanges
1194 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
1195 global cmitmode wrapcomment datetimeformat limitdiffs
1196 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1197 global autoselect extdifftool
1199 if {$stuffsaved} return
1200 if {![winfo viewable .
]} return
1202 set f
[open
"~/.gitk-new" w
]
1203 puts
$f [list
set mainfont
$mainfont]
1204 puts
$f [list
set textfont
$textfont]
1205 puts
$f [list
set uifont
$uifont]
1206 puts
$f [list
set tabstop
$tabstop]
1207 puts
$f [list
set findmergefiles
$findmergefiles]
1208 puts
$f [list
set maxgraphpct
$maxgraphpct]
1209 puts
$f [list
set maxwidth
$maxwidth]
1210 puts
$f [list
set cmitmode
$cmitmode]
1211 puts
$f [list
set wrapcomment
$wrapcomment]
1212 puts
$f [list
set autoselect
$autoselect]
1213 puts
$f [list
set showneartags
$showneartags]
1214 puts
$f [list
set showlocalchanges
$showlocalchanges]
1215 puts
$f [list
set datetimeformat
$datetimeformat]
1216 puts
$f [list
set limitdiffs
$limitdiffs]
1217 puts
$f [list
set bgcolor
$bgcolor]
1218 puts
$f [list
set fgcolor
$fgcolor]
1219 puts
$f [list
set colors
$colors]
1220 puts
$f [list
set diffcolors
$diffcolors]
1221 puts
$f [list
set diffcontext
$diffcontext]
1222 puts
$f [list
set selectbgcolor
$selectbgcolor]
1223 puts
$f [list
set extdifftool
$extdifftool]
1225 puts
$f "set geometry(main) [wm geometry .]"
1226 puts
$f "set geometry(topwidth) [winfo width .tf]"
1227 puts
$f "set geometry(topheight) [winfo height .tf]"
1228 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1229 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1230 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1231 puts
$f "set geometry(botheight) [winfo height .bleft]"
1233 puts
-nonewline $f "set permviews {"
1234 for {set v
0} {$v < $nextviewnum} {incr v
} {
1235 if {$viewperm($v)} {
1236 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
1241 file rename
-force "~/.gitk-new" "~/.gitk"
1246 proc resizeclistpanes
{win w
} {
1248 if {[info exists oldwidth
($win)]} {
1249 set s0
[$win sash coord
0]
1250 set s1
[$win sash coord
1]
1252 set sash0
[expr {int
($w/2 - 2)}]
1253 set sash1
[expr {int
($w*5/6 - 2)}]
1255 set factor [expr {1.0 * $w / $oldwidth($win)}]
1256 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1257 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1261 if {$sash1 < $sash0 + 20} {
1262 set sash1
[expr {$sash0 + 20}]
1264 if {$sash1 > $w - 10} {
1265 set sash1
[expr {$w - 10}]
1266 if {$sash0 > $sash1 - 20} {
1267 set sash0
[expr {$sash1 - 20}]
1271 $win sash place
0 $sash0 [lindex
$s0 1]
1272 $win sash place
1 $sash1 [lindex
$s1 1]
1274 set oldwidth
($win) $w
1277 proc resizecdetpanes
{win w
} {
1279 if {[info exists oldwidth
($win)]} {
1280 set s0
[$win sash coord
0]
1282 set sash0
[expr {int
($w*3/4 - 2)}]
1284 set factor [expr {1.0 * $w / $oldwidth($win)}]
1285 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1289 if {$sash0 > $w - 15} {
1290 set sash0
[expr {$w - 15}]
1293 $win sash place
0 $sash0 [lindex
$s0 1]
1295 set oldwidth
($win) $w
1298 proc allcanvs args
{
1299 global canv canv2 canv3
1305 proc bindall
{event action
} {
1306 global canv canv2 canv3
1307 bind $canv $event $action
1308 bind $canv2 $event $action
1309 bind $canv3 $event $action
1315 if {[winfo exists
$w]} {
1320 wm title
$w [mc
"About gitk"]
1321 message
$w.m
-text [mc
"
1322 Gitk - a commit viewer for git
1324 Copyright © 2005-2006 Paul Mackerras
1326 Use and redistribute under the terms of the GNU General Public License"] \
1327 -justify center
-aspect 400 -border 2 -bg white
-relief groove
1328 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
1329 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1330 pack
$w.ok
-side bottom
1331 bind $w <Visibility
> "focus $w.ok"
1332 bind $w <Key-Escape
> "destroy $w"
1333 bind $w <Key-Return
> "destroy $w"
1338 if {[winfo exists
$w]} {
1342 if {[tk windowingsystem
] eq
{aqua
}} {
1348 wm title
$w [mc
"Gitk key bindings"]
1349 message
$w.m
-text "
1350 [mc "Gitk key bindings
:"]
1352 [mc "<%s-Q
> Quit
" $M1T]
1353 [mc "<Home
> Move to first commit
"]
1354 [mc "<End
> Move to last commit
"]
1355 [mc "<Up
>, p
, i Move up one commit
"]
1356 [mc "<Down
>, n
, k Move down one commit
"]
1357 [mc "<Left
>, z
, j Go back
in history list
"]
1358 [mc "<Right
>, x
, l Go forward
in history list
"]
1359 [mc "<PageUp
> Move up one page
in commit list
"]
1360 [mc "<PageDown
> Move down one page
in commit list
"]
1361 [mc "<%s-Home
> Scroll to top of commit list
" $M1T]
1362 [mc "<%s-End
> Scroll to bottom of commit list
" $M1T]
1363 [mc "<%s-Up
> Scroll commit list up one line
" $M1T]
1364 [mc "<%s-Down
> Scroll commit list down one line
" $M1T]
1365 [mc "<%s-PageUp
> Scroll commit list up one page
" $M1T]
1366 [mc "<%s-PageDown
> Scroll commit list down one page
" $M1T]
1367 [mc "<Shift-Up
> Find backwards
(upwards
, later commits
)"]
1368 [mc "<Shift-Down
> Find forwards
(downwards
, earlier commits
)"]
1369 [mc "<Delete
>, b Scroll
diff view up one page
"]
1370 [mc "<Backspace
> Scroll
diff view up one page
"]
1371 [mc "<Space
> Scroll
diff view down one page
"]
1372 [mc "u Scroll
diff view up
18 lines
"]
1373 [mc "d Scroll
diff view down
18 lines
"]
1374 [mc "<%s-F
> Find
" $M1T]
1375 [mc "<%s-G
> Move to next
find hit
" $M1T]
1376 [mc "<Return
> Move to next
find hit
"]
1377 [mc "/ Move to next
find hit
, or redo
find"]
1378 [mc "? Move to previous
find hit
"]
1379 [mc "f Scroll
diff view to next
file"]
1380 [mc "<%s-S
> Search
for next hit
in diff view
" $M1T]
1381 [mc "<%s-R
> Search
for previous hit
in diff view
" $M1T]
1382 [mc "<%s-KP
+> Increase font size
" $M1T]
1383 [mc "<%s-plus
> Increase font size
" $M1T]
1384 [mc "<%s-KP-
> Decrease font size
" $M1T]
1385 [mc "<%s-minus
> Decrease font size
" $M1T]
1388 -justify left
-bg white
-border 2 -relief groove
1389 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
1390 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1391 pack
$w.ok
-side bottom
1392 bind $w <Visibility
> "focus $w.ok"
1393 bind $w <Key-Escape
> "destroy $w"
1394 bind $w <Key-Return
> "destroy $w"
1397 # Procedures for manipulating the file list window at the
1398 # bottom right of the overall window.
1400 proc treeview
{w l openlevs
} {
1401 global treecontents treediropen treeheight treeparent treeindex
1411 set treecontents
() {}
1412 $w conf
-state normal
1414 while {[string range
$f 0 $prefixend] ne
$prefix} {
1415 if {$lev <= $openlevs} {
1416 $w mark
set e
:$treeindex($prefix) "end -1c"
1417 $w mark gravity e
:$treeindex($prefix) left
1419 set treeheight
($prefix) $ht
1420 incr ht
[lindex
$htstack end
]
1421 set htstack
[lreplace
$htstack end end
]
1422 set prefixend
[lindex
$prefendstack end
]
1423 set prefendstack
[lreplace
$prefendstack end end
]
1424 set prefix
[string range
$prefix 0 $prefixend]
1427 set tail [string range
$f [expr {$prefixend+1}] end
]
1428 while {[set slash
[string first
"/" $tail]] >= 0} {
1431 lappend prefendstack
$prefixend
1432 incr prefixend
[expr {$slash + 1}]
1433 set d
[string range
$tail 0 $slash]
1434 lappend treecontents
($prefix) $d
1435 set oldprefix
$prefix
1437 set treecontents
($prefix) {}
1438 set treeindex
($prefix) [incr ix
]
1439 set treeparent
($prefix) $oldprefix
1440 set tail [string range
$tail [expr {$slash+1}] end
]
1441 if {$lev <= $openlevs} {
1443 set treediropen
($prefix) [expr {$lev < $openlevs}]
1444 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
1445 $w mark
set d
:$ix "end -1c"
1446 $w mark gravity d
:$ix left
1448 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1450 $w image create end
-align center
-image $bm -padx 1 \
1452 $w insert end
$d [highlight_tag
$prefix]
1453 $w mark
set s
:$ix "end -1c"
1454 $w mark gravity s
:$ix left
1459 if {$lev <= $openlevs} {
1462 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1464 $w insert end
$tail [highlight_tag
$f]
1466 lappend treecontents
($prefix) $tail
1469 while {$htstack ne
{}} {
1470 set treeheight
($prefix) $ht
1471 incr ht
[lindex
$htstack end
]
1472 set htstack
[lreplace
$htstack end end
]
1473 set prefixend
[lindex
$prefendstack end
]
1474 set prefendstack
[lreplace
$prefendstack end end
]
1475 set prefix
[string range
$prefix 0 $prefixend]
1477 $w conf
-state disabled
1480 proc linetoelt
{l
} {
1481 global treeheight treecontents
1486 foreach e
$treecontents($prefix) {
1491 if {[string index
$e end
] eq
"/"} {
1492 set n
$treeheight($prefix$e)
1504 proc highlight_tree
{y prefix
} {
1505 global treeheight treecontents cflist
1507 foreach e
$treecontents($prefix) {
1509 if {[highlight_tag
$path] ne
{}} {
1510 $cflist tag add bold
$y.0 "$y.0 lineend"
1513 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
1514 set y
[highlight_tree
$y $path]
1520 proc treeclosedir
{w dir
} {
1521 global treediropen treeheight treeparent treeindex
1523 set ix
$treeindex($dir)
1524 $w conf
-state normal
1525 $w delete s
:$ix e
:$ix
1526 set treediropen
($dir) 0
1527 $w image configure a
:$ix -image tri-rt
1528 $w conf
-state disabled
1529 set n
[expr {1 - $treeheight($dir)}]
1530 while {$dir ne
{}} {
1531 incr treeheight
($dir) $n
1532 set dir
$treeparent($dir)
1536 proc treeopendir
{w dir
} {
1537 global treediropen treeheight treeparent treecontents treeindex
1539 set ix
$treeindex($dir)
1540 $w conf
-state normal
1541 $w image configure a
:$ix -image tri-dn
1542 $w mark
set e
:$ix s
:$ix
1543 $w mark gravity e
:$ix right
1546 set n
[llength
$treecontents($dir)]
1547 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
1550 incr treeheight
($x) $n
1552 foreach e
$treecontents($dir) {
1554 if {[string index
$e end
] eq
"/"} {
1555 set iy
$treeindex($de)
1556 $w mark
set d
:$iy e
:$ix
1557 $w mark gravity d
:$iy left
1558 $w insert e
:$ix $str
1559 set treediropen
($de) 0
1560 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
1562 $w insert e
:$ix $e [highlight_tag
$de]
1563 $w mark
set s
:$iy e
:$ix
1564 $w mark gravity s
:$iy left
1565 set treeheight
($de) 1
1567 $w insert e
:$ix $str
1568 $w insert e
:$ix $e [highlight_tag
$de]
1571 $w mark gravity e
:$ix left
1572 $w conf
-state disabled
1573 set treediropen
($dir) 1
1574 set top
[lindex
[split [$w index @
0,0] .
] 0]
1575 set ht
[$w cget
-height]
1576 set l
[lindex
[split [$w index s
:$ix] .
] 0]
1579 } elseif
{$l + $n + 1 > $top + $ht} {
1580 set top
[expr {$l + $n + 2 - $ht}]
1588 proc treeclick
{w x y
} {
1589 global treediropen cmitmode ctext cflist cflist_top
1591 if {$cmitmode ne
"tree"} return
1592 if {![info exists cflist_top
]} return
1593 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1594 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1595 $cflist tag add highlight
$l.0 "$l.0 lineend"
1601 set e
[linetoelt
$l]
1602 if {[string index
$e end
] ne
"/"} {
1604 } elseif
{$treediropen($e)} {
1611 proc setfilelist
{id
} {
1612 global treefilelist cflist
1614 treeview
$cflist $treefilelist($id) 0
1617 image create bitmap tri-rt
-background black
-foreground blue
-data {
1618 #define tri-rt_width 13
1619 #define tri-rt_height 13
1620 static unsigned char tri-rt_bits
[] = {
1621 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1622 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1625 #define tri-rt-mask_width 13
1626 #define tri-rt-mask_height 13
1627 static unsigned char tri-rt-mask_bits
[] = {
1628 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1629 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1632 image create bitmap tri-dn
-background black
-foreground blue
-data {
1633 #define tri-dn_width 13
1634 #define tri-dn_height 13
1635 static unsigned char tri-dn_bits
[] = {
1636 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1637 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1640 #define tri-dn-mask_width 13
1641 #define tri-dn-mask_height 13
1642 static unsigned char tri-dn-mask_bits
[] = {
1643 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1644 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1648 image create bitmap reficon-T
-background black
-foreground yellow
-data {
1649 #define tagicon_width 13
1650 #define tagicon_height 9
1651 static unsigned char tagicon_bits
[] = {
1652 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1653 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1655 #define tagicon-mask_width 13
1656 #define tagicon-mask_height 9
1657 static unsigned char tagicon-mask_bits
[] = {
1658 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1659 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1662 #define headicon_width 13
1663 #define headicon_height 9
1664 static unsigned char headicon_bits
[] = {
1665 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1666 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1669 #define headicon-mask_width 13
1670 #define headicon-mask_height 9
1671 static unsigned char headicon-mask_bits
[] = {
1672 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1673 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1675 image create bitmap reficon-H
-background black
-foreground green \
1676 -data $rectdata -maskdata $rectmask
1677 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
1678 -data $rectdata -maskdata $rectmask
1680 proc init_flist
{first
} {
1681 global cflist cflist_top selectedline difffilestart
1683 $cflist conf
-state normal
1684 $cflist delete
0.0 end
1686 $cflist insert end
$first
1688 $cflist tag add highlight
1.0 "1.0 lineend"
1690 catch
{unset cflist_top
}
1692 $cflist conf
-state disabled
1693 set difffilestart
{}
1696 proc highlight_tag
{f
} {
1697 global highlight_paths
1699 foreach p
$highlight_paths {
1700 if {[string match
$p $f]} {
1707 proc highlight_filelist
{} {
1708 global cmitmode cflist
1710 $cflist conf
-state normal
1711 if {$cmitmode ne
"tree"} {
1712 set end
[lindex
[split [$cflist index end
] .
] 0]
1713 for {set l
2} {$l < $end} {incr l
} {
1714 set line
[$cflist get
$l.0 "$l.0 lineend"]
1715 if {[highlight_tag
$line] ne
{}} {
1716 $cflist tag add bold
$l.0 "$l.0 lineend"
1722 $cflist conf
-state disabled
1725 proc unhighlight_filelist
{} {
1728 $cflist conf
-state normal
1729 $cflist tag remove bold
1.0 end
1730 $cflist conf
-state disabled
1733 proc add_flist
{fl
} {
1736 $cflist conf
-state normal
1738 $cflist insert end
"\n"
1739 $cflist insert end
$f [highlight_tag
$f]
1741 $cflist conf
-state disabled
1744 proc sel_flist
{w x y
} {
1745 global ctext difffilestart cflist cflist_top cmitmode
1747 if {$cmitmode eq
"tree"} return
1748 if {![info exists cflist_top
]} return
1749 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1750 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1751 $cflist tag add highlight
$l.0 "$l.0 lineend"
1756 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
1760 proc pop_flist_menu
{w X Y x y
} {
1761 global ctext cflist cmitmode flist_menu flist_menu_file
1762 global treediffs diffids
1765 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1767 if {$cmitmode eq
"tree"} {
1768 set e
[linetoelt
$l]
1769 if {[string index
$e end
] eq
"/"} return
1771 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
1773 set flist_menu_file
$e
1774 set xdiffstate
"normal"
1775 if {$cmitmode eq
"tree"} {
1776 set xdiffstate
"disabled"
1778 # Disable "External diff" item in tree mode
1779 $flist_menu entryconf
2 -state $xdiffstate
1780 tk_popup
$flist_menu $X $Y
1783 proc flist_hl
{only
} {
1784 global flist_menu_file findstring gdttype
1786 set x
[shellquote
$flist_menu_file]
1787 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
1790 append findstring
" " $x
1792 set gdttype
[mc
"touching paths:"]
1795 proc save_file_from_commit
{filename output what
} {
1798 if {[catch
{exec git show
$filename -- > $output} err
]} {
1799 if {[string match
"fatal: bad revision *" $err]} {
1802 error_popup
"Error getting \"$filename\" from $what: $err"
1808 proc external_diff_get_one_file
{diffid filename diffdir
} {
1809 global nullid nullid2 nullfile
1812 if {$diffid == $nullid} {
1813 set difffile
[file join [file dirname $gitdir] $filename]
1814 if {[file exists
$difffile]} {
1819 if {$diffid == $nullid2} {
1820 set difffile
[file join $diffdir "\[index\] [file tail $filename]"]
1821 return [save_file_from_commit
:$filename $difffile index
]
1823 set difffile
[file join $diffdir "\[$diffid\] [file tail $filename]"]
1824 return [save_file_from_commit
$diffid:$filename $difffile \
1828 proc external_diff
{} {
1829 global gitktmpdir nullid nullid2
1830 global flist_menu_file
1833 global gitdir extdifftool
1835 if {[llength
$diffids] == 1} {
1836 # no reference commit given
1837 set diffidto
[lindex
$diffids 0]
1838 if {$diffidto eq
$nullid} {
1839 # diffing working copy with index
1840 set diffidfrom
$nullid2
1841 } elseif
{$diffidto eq
$nullid2} {
1842 # diffing index with HEAD
1843 set diffidfrom
"HEAD"
1845 # use first parent commit
1846 global parentlist selectedline
1847 set diffidfrom
[lindex
$parentlist $selectedline 0]
1850 set diffidfrom
[lindex
$diffids 0]
1851 set diffidto
[lindex
$diffids 1]
1854 # make sure that several diffs wont collide
1855 if {![info exists gitktmpdir
]} {
1856 set gitktmpdir
[file join [file dirname $gitdir] \
1857 [format
".gitk-tmp.%s" [pid
]]]
1858 if {[catch
{file mkdir
$gitktmpdir} err
]} {
1859 error_popup
"Error creating temporary directory $gitktmpdir: $err"
1866 set diffdir
[file join $gitktmpdir $diffnum]
1867 if {[catch
{file mkdir
$diffdir} err
]} {
1868 error_popup
"Error creating temporary directory $diffdir: $err"
1872 # gather files to diff
1873 set difffromfile
[external_diff_get_one_file
$diffidfrom $flist_menu_file $diffdir]
1874 set difftofile
[external_diff_get_one_file
$diffidto $flist_menu_file $diffdir]
1876 if {$difffromfile ne
{} && $difftofile ne
{}} {
1877 set cmd
[concat |
[shellsplit
$extdifftool] \
1878 [list
$difffromfile $difftofile]]
1879 if {[catch
{set fl
[open
$cmd r
]} err
]} {
1880 file delete
-force $diffdir
1881 error_popup
[mc
"$extdifftool: command failed: $err"]
1883 fconfigure
$fl -blocking 0
1884 filerun
$fl [list delete_at_eof
$fl $diffdir]
1889 # delete $dir when we see eof on $f (presumably because the child has exited)
1890 proc delete_at_eof
{f dir
} {
1891 while {[gets
$f line
] >= 0} {}
1893 if {[catch
{close
$f} err
]} {
1894 error_popup
"External diff viewer failed: $err"
1896 file delete
-force $dir
1902 # Functions for adding and removing shell-type quoting
1904 proc shellquote
{str
} {
1905 if {![string match
"*\['\"\\ \t]*" $str]} {
1908 if {![string match
"*\['\"\\]*" $str]} {
1911 if {![string match
"*'*" $str]} {
1914 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1917 proc shellarglist
{l
} {
1923 append str
[shellquote
$a]
1928 proc shelldequote
{str
} {
1933 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
1934 append ret
[string range
$str $used end
]
1935 set used
[string length
$str]
1938 set first
[lindex
$first 0]
1939 set ch
[string index
$str $first]
1940 if {$first > $used} {
1941 append ret
[string range
$str $used [expr {$first - 1}]]
1944 if {$ch eq
" " ||
$ch eq
"\t"} break
1947 set first
[string first
"'" $str $used]
1949 error
"unmatched single-quote"
1951 append ret
[string range
$str $used [expr {$first - 1}]]
1956 if {$used >= [string length
$str]} {
1957 error
"trailing backslash"
1959 append ret
[string index
$str $used]
1964 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
1965 error
"unmatched double-quote"
1967 set first
[lindex
$first 0]
1968 set ch
[string index
$str $first]
1969 if {$first > $used} {
1970 append ret
[string range
$str $used [expr {$first - 1}]]
1973 if {$ch eq
"\""} break
1975 append ret
[string index
$str $used]
1979 return [list
$used $ret]
1982 proc shellsplit
{str
} {
1985 set str
[string trimleft
$str]
1986 if {$str eq
{}} break
1987 set dq
[shelldequote
$str]
1988 set n
[lindex
$dq 0]
1989 set word
[lindex
$dq 1]
1990 set str
[string range
$str $n end
]
1996 # Code to implement multiple views
1998 proc newview
{ishighlight
} {
1999 global nextviewnum newviewname newviewperm newishighlight
2000 global newviewargs revtreeargs viewargscmd newviewargscmd curview
2002 set newishighlight
$ishighlight
2004 if {[winfo exists
$top]} {
2008 set newviewname
($nextviewnum) "[mc "View
"] $nextviewnum"
2009 set newviewperm
($nextviewnum) 0
2010 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
2011 set newviewargscmd
($nextviewnum) $viewargscmd($curview)
2012 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
2017 global viewname viewperm newviewname newviewperm
2018 global viewargs newviewargs viewargscmd newviewargscmd
2020 set top .gitkvedit-
$curview
2021 if {[winfo exists
$top]} {
2025 set newviewname
($curview) $viewname($curview)
2026 set newviewperm
($curview) $viewperm($curview)
2027 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
2028 set newviewargscmd
($curview) $viewargscmd($curview)
2029 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
2032 proc vieweditor
{top n title
} {
2033 global newviewname newviewperm viewfiles bgcolor
2036 wm title
$top $title
2037 label
$top.
nl -text [mc
"Name"]
2038 entry
$top.name
-width 20 -textvariable newviewname
($n)
2039 grid
$top.
nl $top.name
-sticky w
-pady 5
2040 checkbutton
$top.perm
-text [mc
"Remember this view"] \
2041 -variable newviewperm
($n)
2042 grid
$top.perm
- -pady 5 -sticky w
2043 message
$top.al
-aspect 1000 \
2044 -text [mc
"Commits to include (arguments to git rev-list):"]
2045 grid
$top.al
- -sticky w
-pady 5
2046 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
2047 -background $bgcolor
2048 grid
$top.args
- -sticky ew
-padx 5
2050 message
$top.ac
-aspect 1000 \
2051 -text [mc
"Command to generate more commits to include:"]
2052 grid
$top.ac
- -sticky w
-pady 5
2053 entry
$top.argscmd
-width 50 -textvariable newviewargscmd
($n) \
2055 grid
$top.argscmd
- -sticky ew
-padx 5
2057 message
$top.l
-aspect 1000 \
2058 -text [mc
"Enter files and directories to include, one per line:"]
2059 grid
$top.l
- -sticky w
2060 text
$top.t
-width 40 -height 10 -background $bgcolor -font uifont
2061 if {[info exists viewfiles
($n)]} {
2062 foreach f
$viewfiles($n) {
2063 $top.t insert end
$f
2064 $top.t insert end
"\n"
2066 $top.t delete
{end
- 1c
} end
2067 $top.t mark
set insert
0.0
2069 grid
$top.t
- -sticky ew
-padx 5
2071 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n]
2072 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top]
2073 grid
$top.buts.ok
$top.buts.can
2074 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
2075 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
2076 grid
$top.buts
- -pady 10 -sticky ew
2080 proc doviewmenu
{m first cmd op argv
} {
2081 set nmenu
[$m index end
]
2082 for {set i
$first} {$i <= $nmenu} {incr i
} {
2083 if {[$m entrycget
$i -command] eq
$cmd} {
2084 eval $m $op $i $argv
2090 proc allviewmenus
{n op args
} {
2093 doviewmenu .bar.view
5 [list showview
$n] $op $args
2094 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
2097 proc newviewok
{top n
} {
2098 global nextviewnum newviewperm newviewname newishighlight
2099 global viewname viewfiles viewperm selectedview curview
2100 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
2103 set newargs
[shellsplit
$newviewargs($n)]
2105 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
2111 foreach f
[split [$top.t get
0.0 end
] "\n"] {
2112 set ft
[string trim
$f]
2117 if {![info exists viewfiles
($n)]} {
2118 # creating a new view
2120 set viewname
($n) $newviewname($n)
2121 set viewperm
($n) $newviewperm($n)
2122 set viewfiles
($n) $files
2123 set viewargs
($n) $newargs
2124 set viewargscmd
($n) $newviewargscmd($n)
2126 if {!$newishighlight} {
2129 run addvhighlight
$n
2132 # editing an existing view
2133 set viewperm
($n) $newviewperm($n)
2134 if {$newviewname($n) ne
$viewname($n)} {
2135 set viewname
($n) $newviewname($n)
2136 doviewmenu .bar.view
5 [list showview
$n] \
2137 entryconf
[list
-label $viewname($n)]
2138 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2139 # entryconf [list -label $viewname($n) -value $viewname($n)]
2141 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n) || \
2142 $newviewargscmd($n) ne
$viewargscmd($n)} {
2143 set viewfiles
($n) $files
2144 set viewargs
($n) $newargs
2145 set viewargscmd
($n) $newviewargscmd($n)
2146 if {$curview == $n} {
2151 catch
{destroy
$top}
2155 global curview viewdata viewperm hlview selectedhlview
2157 if {$curview == 0} return
2158 if {[info exists hlview
] && $hlview == $curview} {
2159 set selectedhlview
[mc
"None"]
2162 allviewmenus
$curview delete
2163 set viewdata
($curview) {}
2164 set viewperm
($curview) 0
2168 proc addviewmenu
{n
} {
2169 global viewname viewhlmenu
2171 .bar.view add radiobutton
-label $viewname($n) \
2172 -command [list showview
$n] -variable selectedview
-value $n
2173 #$viewhlmenu add radiobutton -label $viewname($n) \
2174 # -command [list addvhighlight $n] -variable selectedhlview
2177 proc flatten
{var
} {
2181 foreach i
[array names
$var] {
2182 lappend ret
$i [set $var\
($i\
)]
2187 proc unflatten
{var l
} {
2197 global curview viewdata viewfiles
2198 global displayorder parentlist rowidlist rowisopt rowfinal
2199 global colormap rowtextx commitrow nextcolor canvxmax
2200 global numcommits commitlisted
2201 global selectedline currentid canv canvy0
2203 global pending_select phase
2206 global selectedview selectfirst
2207 global vparentlist vdisporder vcmitlisted
2208 global hlview selectedhlview commitinterest
2210 if {$n == $curview} return
2212 if {[info exists selectedline
]} {
2213 set selid
$currentid
2214 set y
[yc
$selectedline]
2215 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2216 set span
[$canv yview
]
2217 set ytop
[expr {[lindex
$span 0] * $ymax}]
2218 set ybot
[expr {[lindex
$span 1] * $ymax}]
2219 if {$ytop < $y && $y < $ybot} {
2220 set yscreen
[expr {$y - $ytop}]
2222 } elseif
{[info exists pending_select
]} {
2223 set selid
$pending_select
2224 unset pending_select
2228 if {$curview >= 0} {
2229 set vparentlist
($curview) $parentlist
2230 set vdisporder
($curview) $displayorder
2231 set vcmitlisted
($curview) $commitlisted
2233 ![info exists viewdata
($curview)] ||
2234 [lindex
$viewdata($curview) 0] ne
{}} {
2235 set viewdata
($curview) \
2236 [list
$phase $rowidlist $rowisopt $rowfinal]
2239 catch
{unset treediffs
}
2241 if {[info exists hlview
] && $hlview == $n} {
2243 set selectedhlview
[mc
"None"]
2245 catch
{unset commitinterest
}
2249 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2250 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2253 if {![info exists viewdata
($n)]} {
2255 set pending_select
$selid
2262 set phase
[lindex
$v 0]
2263 set displayorder
$vdisporder($n)
2264 set parentlist
$vparentlist($n)
2265 set commitlisted
$vcmitlisted($n)
2266 set rowidlist
[lindex
$v 1]
2267 set rowisopt
[lindex
$v 2]
2268 set rowfinal
[lindex
$v 3]
2269 set numcommits
$commitidx($n)
2271 catch
{unset colormap
}
2272 catch
{unset rowtextx
}
2274 set canvxmax
[$canv cget
-width]
2281 if {[info exists yscreen
] && [info exists commitrow
($n,$selid)]} {
2282 set row
$commitrow($n,$selid)
2283 # try to get the selected row in the same position on the screen
2284 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2285 set ytop
[expr {[yc
$row] - $yscreen}]
2289 set yf
[expr {$ytop * 1.0 / $ymax}]
2291 allcanvs yview moveto
$yf
2295 } elseif
{$selid ne
{}} {
2296 set pending_select
$selid
2298 set row
[first_real_row
]
2299 if {$row < $numcommits} {
2306 if {$phase eq
"getcommits"} {
2307 show_status
[mc
"Reading commits..."]
2310 } elseif
{$numcommits == 0} {
2311 show_status
[mc
"No commits selected"]
2315 # Stuff relating to the highlighting facility
2317 proc ishighlighted
{row
} {
2318 global vhighlights fhighlights nhighlights rhighlights
2320 if {[info exists nhighlights
($row)] && $nhighlights($row) > 0} {
2321 return $nhighlights($row)
2323 if {[info exists vhighlights
($row)] && $vhighlights($row) > 0} {
2324 return $vhighlights($row)
2326 if {[info exists fhighlights
($row)] && $fhighlights($row) > 0} {
2327 return $fhighlights($row)
2329 if {[info exists rhighlights
($row)] && $rhighlights($row) > 0} {
2330 return $rhighlights($row)
2335 proc bolden
{row font
} {
2336 global canv linehtag selectedline boldrows
2338 lappend boldrows
$row
2339 $canv itemconf
$linehtag($row) -font $font
2340 if {[info exists selectedline
] && $row == $selectedline} {
2342 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2343 -outline {{}} -tags secsel \
2344 -fill [$canv cget
-selectbackground]]
2349 proc bolden_name
{row font
} {
2350 global canv2 linentag selectedline boldnamerows
2352 lappend boldnamerows
$row
2353 $canv2 itemconf
$linentag($row) -font $font
2354 if {[info exists selectedline
] && $row == $selectedline} {
2355 $canv2 delete secsel
2356 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2357 -outline {{}} -tags secsel \
2358 -fill [$canv2 cget
-selectbackground]]
2367 foreach row
$boldrows {
2368 if {![ishighlighted
$row]} {
2369 bolden
$row mainfont
2371 lappend stillbold
$row
2374 set boldrows
$stillbold
2377 proc addvhighlight
{n
} {
2378 global hlview curview viewdata vhl_done vhighlights commitidx
2380 if {[info exists hlview
]} {
2384 if {$n != $curview && ![info exists viewdata
($n)]} {
2385 set viewdata
($n) [list getcommits
{{}} 0 0 0]
2386 set vparentlist
($n) {}
2387 set vdisporder
($n) {}
2388 set vcmitlisted
($n) {}
2391 set vhl_done
$commitidx($hlview)
2392 if {$vhl_done > 0} {
2397 proc delvhighlight
{} {
2398 global hlview vhighlights
2400 if {![info exists hlview
]} return
2402 catch
{unset vhighlights
}
2406 proc vhighlightmore
{} {
2407 global hlview vhl_done commitidx vhighlights
2408 global displayorder vdisporder curview
2410 set max
$commitidx($hlview)
2411 if {$hlview == $curview} {
2412 set disp
$displayorder
2414 set disp
$vdisporder($hlview)
2416 set vr
[visiblerows
]
2417 set r0
[lindex
$vr 0]
2418 set r1
[lindex
$vr 1]
2419 for {set i
$vhl_done} {$i < $max} {incr i
} {
2420 set id
[lindex
$disp $i]
2421 if {[info exists commitrow
($curview,$id)]} {
2422 set row
$commitrow($curview,$id)
2423 if {$r0 <= $row && $row <= $r1} {
2424 if {![highlighted
$row]} {
2425 bolden
$row mainfontbold
2427 set vhighlights
($row) 1
2434 proc askvhighlight
{row id
} {
2435 global hlview vhighlights commitrow iddrawn
2437 if {[info exists commitrow
($hlview,$id)]} {
2438 if {[info exists iddrawn
($id)] && ![ishighlighted
$row]} {
2439 bolden
$row mainfontbold
2441 set vhighlights
($row) 1
2443 set vhighlights
($row) 0
2447 proc hfiles_change
{} {
2448 global highlight_files filehighlight fhighlights fh_serial
2449 global highlight_paths gdttype
2451 if {[info exists filehighlight
]} {
2452 # delete previous highlights
2453 catch
{close
$filehighlight}
2455 catch
{unset fhighlights
}
2457 unhighlight_filelist
2459 set highlight_paths
{}
2460 after cancel do_file_hl
$fh_serial
2462 if {$highlight_files ne
{}} {
2463 after
300 do_file_hl
$fh_serial
2467 proc gdttype_change
{name ix op
} {
2468 global gdttype highlight_files findstring findpattern
2471 if {$findstring ne
{}} {
2472 if {$gdttype eq
[mc
"containing:"]} {
2473 if {$highlight_files ne
{}} {
2474 set highlight_files
{}
2479 if {$findpattern ne
{}} {
2483 set highlight_files
$findstring
2488 # enable/disable findtype/findloc menus too
2491 proc find_change
{name ix op
} {
2492 global gdttype findstring highlight_files
2495 if {$gdttype eq
[mc
"containing:"]} {
2498 if {$highlight_files ne
$findstring} {
2499 set highlight_files
$findstring
2506 proc findcom_change args
{
2507 global nhighlights boldnamerows
2508 global findpattern findtype findstring gdttype
2511 # delete previous highlights, if any
2512 foreach row
$boldnamerows {
2513 bolden_name
$row mainfont
2516 catch
{unset nhighlights
}
2519 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
2521 } elseif
{$findtype eq
[mc
"Regexp"]} {
2522 set findpattern
$findstring
2524 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2526 set findpattern
"*$e*"
2530 proc makepatterns
{l
} {
2533 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2534 if {[string index
$ee end
] eq
"/"} {
2544 proc do_file_hl
{serial
} {
2545 global highlight_files filehighlight highlight_paths gdttype fhl_list
2547 if {$gdttype eq
[mc
"touching paths:"]} {
2548 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
2549 set highlight_paths
[makepatterns
$paths]
2551 set gdtargs
[concat
-- $paths]
2552 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
2553 set gdtargs
[list
"-S$highlight_files"]
2555 # must be "containing:", i.e. we're searching commit info
2558 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
2559 set filehighlight
[open
$cmd r
+]
2560 fconfigure
$filehighlight -blocking 0
2561 filerun
$filehighlight readfhighlight
2567 proc flushhighlights
{} {
2568 global filehighlight fhl_list
2570 if {[info exists filehighlight
]} {
2572 puts
$filehighlight ""
2573 flush
$filehighlight
2577 proc askfilehighlight
{row id
} {
2578 global filehighlight fhighlights fhl_list
2580 lappend fhl_list
$id
2581 set fhighlights
($row) -1
2582 puts
$filehighlight $id
2585 proc readfhighlight
{} {
2586 global filehighlight fhighlights commitrow curview iddrawn
2587 global fhl_list find_dirn
2589 if {![info exists filehighlight
]} {
2593 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
2594 set line
[string trim
$line]
2595 set i
[lsearch
-exact $fhl_list $line]
2596 if {$i < 0} continue
2597 for {set j
0} {$j < $i} {incr j
} {
2598 set id
[lindex
$fhl_list $j]
2599 if {[info exists commitrow
($curview,$id)]} {
2600 set fhighlights
($commitrow($curview,$id)) 0
2603 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
2604 if {$line eq
{}} continue
2605 if {![info exists commitrow
($curview,$line)]} continue
2606 set row
$commitrow($curview,$line)
2607 if {[info exists iddrawn
($line)] && ![ishighlighted
$row]} {
2608 bolden
$row mainfontbold
2610 set fhighlights
($row) 1
2612 if {[eof
$filehighlight]} {
2614 puts
"oops, git diff-tree died"
2615 catch
{close
$filehighlight}
2619 if {[info exists find_dirn
]} {
2625 proc doesmatch
{f
} {
2626 global findtype findpattern
2628 if {$findtype eq
[mc
"Regexp"]} {
2629 return [regexp
$findpattern $f]
2630 } elseif
{$findtype eq
[mc
"IgnCase"]} {
2631 return [string match
-nocase $findpattern $f]
2633 return [string match
$findpattern $f]
2637 proc askfindhighlight
{row id
} {
2638 global nhighlights commitinfo iddrawn
2640 global markingmatches
2642 if {![info exists commitinfo
($id)]} {
2645 set info
$commitinfo($id)
2647 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
2648 foreach f
$info ty
$fldtypes {
2649 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
2651 if {$ty eq
[mc
"Author"]} {
2658 if {$isbold && [info exists iddrawn
($id)]} {
2659 if {![ishighlighted
$row]} {
2660 bolden
$row mainfontbold
2662 bolden_name
$row mainfontbold
2665 if {$markingmatches} {
2666 markrowmatches
$row $id
2669 set nhighlights
($row) $isbold
2672 proc markrowmatches
{row id
} {
2673 global canv canv2 linehtag linentag commitinfo findloc
2675 set headline
[lindex
$commitinfo($id) 0]
2676 set author
[lindex
$commitinfo($id) 1]
2677 $canv delete match
$row
2678 $canv2 delete match
$row
2679 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
2680 set m
[findmatches
$headline]
2682 markmatches
$canv $row $headline $linehtag($row) $m \
2683 [$canv itemcget
$linehtag($row) -font] $row
2686 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
2687 set m
[findmatches
$author]
2689 markmatches
$canv2 $row $author $linentag($row) $m \
2690 [$canv2 itemcget
$linentag($row) -font] $row
2695 proc vrel_change
{name ix op
} {
2696 global highlight_related
2699 if {$highlight_related ne
[mc
"None"]} {
2704 # prepare for testing whether commits are descendents or ancestors of a
2705 proc rhighlight_sel
{a
} {
2706 global descendent desc_todo ancestor anc_todo
2707 global highlight_related rhighlights
2709 catch
{unset descendent
}
2710 set desc_todo
[list
$a]
2711 catch
{unset ancestor
}
2712 set anc_todo
[list
$a]
2713 if {$highlight_related ne
[mc
"None"]} {
2719 proc rhighlight_none
{} {
2722 catch
{unset rhighlights
}
2726 proc is_descendent
{a
} {
2727 global curview children commitrow descendent desc_todo
2730 set la
$commitrow($v,$a)
2734 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2735 set do [lindex
$todo $i]
2736 if {$commitrow($v,$do) < $la} {
2737 lappend leftover
$do
2740 foreach nk
$children($v,$do) {
2741 if {![info exists descendent
($nk)]} {
2742 set descendent
($nk) 1
2750 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2754 set descendent
($a) 0
2755 set desc_todo
$leftover
2758 proc is_ancestor
{a
} {
2759 global curview parentlist commitrow ancestor anc_todo
2762 set la
$commitrow($v,$a)
2766 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2767 set do [lindex
$todo $i]
2768 if {![info exists commitrow
($v,$do)] ||
$commitrow($v,$do) > $la} {
2769 lappend leftover
$do
2772 foreach np
[lindex
$parentlist $commitrow($v,$do)] {
2773 if {![info exists ancestor
($np)]} {
2782 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2787 set anc_todo
$leftover
2790 proc askrelhighlight
{row id
} {
2791 global descendent highlight_related iddrawn rhighlights
2792 global selectedline ancestor
2794 if {![info exists selectedline
]} return
2796 if {$highlight_related eq
[mc
"Descendant"] ||
2797 $highlight_related eq
[mc
"Not descendant"]} {
2798 if {![info exists descendent
($id)]} {
2801 if {$descendent($id) == ($highlight_related eq
[mc
"Descendant"])} {
2804 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
2805 $highlight_related eq
[mc
"Not ancestor"]} {
2806 if {![info exists ancestor
($id)]} {
2809 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
2813 if {[info exists iddrawn
($id)]} {
2814 if {$isbold && ![ishighlighted
$row]} {
2815 bolden
$row mainfontbold
2818 set rhighlights
($row) $isbold
2821 # Graph layout functions
2823 proc shortids
{ids
} {
2826 if {[llength
$id] > 1} {
2827 lappend res
[shortids
$id]
2828 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
2829 lappend res
[string range
$id 0 7]
2840 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
2841 if {($n & $mask) != 0} {
2842 set ret
[concat
$ret $o]
2844 set o
[concat
$o $o]
2849 # Work out where id should go in idlist so that order-token
2850 # values increase from left to right
2851 proc idcol
{idlist id
{i
0}} {
2852 global ordertok curview
2854 set t
$ordertok($curview,$id)
2855 if {$i >= [llength
$idlist] ||
2856 $t < $ordertok($curview,[lindex
$idlist $i])} {
2857 if {$i > [llength
$idlist]} {
2858 set i
[llength
$idlist]
2860 while {[incr i
-1] >= 0 &&
2861 $t < $ordertok($curview,[lindex
$idlist $i])} {}
2864 if {$t > $ordertok($curview,[lindex
$idlist $i])} {
2865 while {[incr i
] < [llength
$idlist] &&
2866 $t >= $ordertok($curview,[lindex
$idlist $i])} {}
2872 proc initlayout
{} {
2873 global rowidlist rowisopt rowfinal displayorder commitlisted
2874 global numcommits canvxmax canv
2877 global colormap rowtextx
2888 set canvxmax
[$canv cget
-width]
2889 catch
{unset colormap
}
2890 catch
{unset rowtextx
}
2894 proc setcanvscroll
{} {
2895 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2897 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2898 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
2899 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
2900 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
2903 proc visiblerows
{} {
2904 global canv numcommits linespc
2906 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2907 if {$ymax eq
{} ||
$ymax == 0} return
2909 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
2910 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
2914 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
2915 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
2916 if {$r1 >= $numcommits} {
2917 set r1
[expr {$numcommits - 1}]
2919 return [list
$r0 $r1]
2922 proc layoutmore
{} {
2923 global commitidx viewcomplete numcommits
2924 global uparrowlen downarrowlen mingaplen curview
2926 set show
$commitidx($curview)
2927 if {$show > $numcommits ||
$viewcomplete($curview)} {
2928 showstuff
$show $viewcomplete($curview)
2932 proc showstuff
{canshow last
} {
2933 global numcommits commitrow pending_select selectedline curview
2934 global mainheadid displayorder selectfirst
2935 global lastscrollset commitinterest
2937 if {$numcommits == 0} {
2939 set phase
"incrdraw"
2943 set prev
$numcommits
2944 set numcommits
$canshow
2945 set t
[clock clicks
-milliseconds]
2946 if {$prev < 100 ||
$last ||
$t - $lastscrollset > 500} {
2947 set lastscrollset
$t
2950 set rows
[visiblerows
]
2951 set r1
[lindex
$rows 1]
2952 if {$r1 >= $canshow} {
2953 set r1
[expr {$canshow - 1}]
2958 if {[info exists pending_select
] &&
2959 [info exists commitrow
($curview,$pending_select)] &&
2960 $commitrow($curview,$pending_select) < $numcommits} {
2961 selectline
$commitrow($curview,$pending_select) 1
2964 if {[info exists selectedline
] ||
[info exists pending_select
]} {
2967 set l
[first_real_row
]
2974 proc doshowlocalchanges
{} {
2975 global curview mainheadid phase commitrow
2977 if {[info exists commitrow
($curview,$mainheadid)] &&
2978 ($phase eq
{} ||
$commitrow($curview,$mainheadid) < $numcommits - 1)} {
2980 } elseif
{$phase ne
{}} {
2981 lappend commitinterest
($mainheadid) {}
2985 proc dohidelocalchanges
{} {
2986 global localfrow localirow lserial
2988 if {$localfrow >= 0} {
2989 removerow
$localfrow
2991 if {$localirow > 0} {
2995 if {$localirow >= 0} {
2996 removerow
$localirow
3002 # spawn off a process to do git diff-index --cached HEAD
3003 proc dodiffindex
{} {
3004 global localirow localfrow lserial showlocalchanges
3007 if {!$showlocalchanges ||
!$isworktree} return
3011 set fd
[open
"|git diff-index --cached HEAD" r
]
3012 fconfigure
$fd -blocking 0
3013 filerun
$fd [list readdiffindex
$fd $lserial]
3016 proc readdiffindex
{fd serial
} {
3017 global localirow commitrow mainheadid nullid2 curview
3018 global commitinfo commitdata lserial
3021 if {[gets
$fd line
] < 0} {
3027 # we only need to see one line and we don't really care what it says...
3030 # now see if there are any local changes not checked in to the index
3031 if {$serial == $lserial} {
3032 set fd
[open
"|git diff-files" r
]
3033 fconfigure
$fd -blocking 0
3034 filerun
$fd [list readdifffiles
$fd $serial]
3037 if {$isdiff && $serial == $lserial && $localirow == -1} {
3038 # add the line for the changes in the index to the graph
3039 set localirow
$commitrow($curview,$mainheadid)
3040 set hl
[mc
"Local changes checked in to index but not committed"]
3041 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
3042 set commitdata
($nullid2) "\n $hl\n"
3043 insertrow
$localirow $nullid2
3048 proc readdifffiles
{fd serial
} {
3049 global localirow localfrow commitrow mainheadid nullid curview
3050 global commitinfo commitdata lserial
3053 if {[gets
$fd line
] < 0} {
3059 # we only need to see one line and we don't really care what it says...
3062 if {$isdiff && $serial == $lserial && $localfrow == -1} {
3063 # add the line for the local diff to the graph
3064 if {$localirow >= 0} {
3065 set localfrow
$localirow
3068 set localfrow
$commitrow($curview,$mainheadid)
3070 set hl
[mc
"Local uncommitted changes, not checked in to index"]
3071 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
3072 set commitdata
($nullid) "\n $hl\n"
3073 insertrow
$localfrow $nullid
3078 proc nextuse
{id row
} {
3079 global commitrow curview children
3081 if {[info exists children
($curview,$id)]} {
3082 foreach kid
$children($curview,$id) {
3083 if {![info exists commitrow
($curview,$kid)]} {
3086 if {$commitrow($curview,$kid) > $row} {
3087 return $commitrow($curview,$kid)
3091 if {[info exists commitrow
($curview,$id)]} {
3092 return $commitrow($curview,$id)
3097 proc prevuse
{id row
} {
3098 global commitrow curview children
3101 if {[info exists children
($curview,$id)]} {
3102 foreach kid
$children($curview,$id) {
3103 if {![info exists commitrow
($curview,$kid)]} break
3104 if {$commitrow($curview,$kid) < $row} {
3105 set ret
$commitrow($curview,$kid)
3112 proc make_idlist
{row
} {
3113 global displayorder parentlist uparrowlen downarrowlen mingaplen
3114 global commitidx curview ordertok children commitrow
3116 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
3120 set ra
[expr {$row - $downarrowlen}]
3124 set rb
[expr {$row + $uparrowlen}]
3125 if {$rb > $commitidx($curview)} {
3126 set rb
$commitidx($curview)
3129 for {} {$r < $ra} {incr r
} {
3130 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3131 foreach p
[lindex
$parentlist $r] {
3132 if {$p eq
$nextid} continue
3133 set rn
[nextuse
$p $r]
3135 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3136 lappend ids
[list
$ordertok($curview,$p) $p]
3140 for {} {$r < $row} {incr r
} {
3141 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3142 foreach p
[lindex
$parentlist $r] {
3143 if {$p eq
$nextid} continue
3144 set rn
[nextuse
$p $r]
3145 if {$rn < 0 ||
$rn >= $row} {
3146 lappend ids
[list
$ordertok($curview,$p) $p]
3150 set id
[lindex
$displayorder $row]
3151 lappend ids
[list
$ordertok($curview,$id) $id]
3153 foreach p
[lindex
$parentlist $r] {
3154 set firstkid
[lindex
$children($curview,$p) 0]
3155 if {$commitrow($curview,$firstkid) < $row} {
3156 lappend ids
[list
$ordertok($curview,$p) $p]
3160 set id
[lindex
$displayorder $r]
3162 set firstkid
[lindex
$children($curview,$id) 0]
3163 if {$firstkid ne
{} && $commitrow($curview,$firstkid) < $row} {
3164 lappend ids
[list
$ordertok($curview,$id) $id]
3169 foreach idx
[lsort
-unique $ids] {
3170 lappend idlist
[lindex
$idx 1]
3175 proc rowsequal
{a b
} {
3176 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3177 set a
[lreplace
$a $i $i]
3179 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3180 set b
[lreplace
$b $i $i]
3182 return [expr {$a eq
$b}]
3185 proc makeupline
{id row rend
col} {
3186 global rowidlist uparrowlen downarrowlen mingaplen
3188 for {set r
$rend} {1} {set r
$rstart} {
3189 set rstart
[prevuse
$id $r]
3190 if {$rstart < 0} return
3191 if {$rstart < $row} break
3193 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3194 set rstart
[expr {$rend - $uparrowlen - 1}]
3196 for {set r
$rstart} {[incr r
] <= $row} {} {
3197 set idlist
[lindex
$rowidlist $r]
3198 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3199 set col [idcol
$idlist $id $col]
3200 lset rowidlist
$r [linsert
$idlist $col $id]
3206 proc layoutrows
{row endrow
} {
3207 global rowidlist rowisopt rowfinal displayorder
3208 global uparrowlen downarrowlen maxwidth mingaplen
3209 global children parentlist
3210 global commitidx viewcomplete curview commitrow
3214 set rm1
[expr {$row - 1}]
3215 foreach id
[lindex
$rowidlist $rm1] {
3220 set final
[lindex
$rowfinal $rm1]
3222 for {} {$row < $endrow} {incr row
} {
3223 set rm1
[expr {$row - 1}]
3224 if {$rm1 < 0 ||
$idlist eq
{}} {
3225 set idlist
[make_idlist
$row]
3228 set id
[lindex
$displayorder $rm1]
3229 set col [lsearch
-exact $idlist $id]
3230 set idlist
[lreplace
$idlist $col $col]
3231 foreach p
[lindex
$parentlist $rm1] {
3232 if {[lsearch
-exact $idlist $p] < 0} {
3233 set col [idcol
$idlist $p $col]
3234 set idlist
[linsert
$idlist $col $p]
3235 # if not the first child, we have to insert a line going up
3236 if {$id ne
[lindex
$children($curview,$p) 0]} {
3237 makeupline
$p $rm1 $row $col
3241 set id
[lindex
$displayorder $row]
3242 if {$row > $downarrowlen} {
3243 set termrow
[expr {$row - $downarrowlen - 1}]
3244 foreach p
[lindex
$parentlist $termrow] {
3245 set i
[lsearch
-exact $idlist $p]
3246 if {$i < 0} continue
3247 set nr
[nextuse
$p $termrow]
3248 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3249 set idlist
[lreplace
$idlist $i $i]
3253 set col [lsearch
-exact $idlist $id]
3255 set col [idcol
$idlist $id]
3256 set idlist
[linsert
$idlist $col $id]
3257 if {$children($curview,$id) ne
{}} {
3258 makeupline
$id $rm1 $row $col
3261 set r
[expr {$row + $uparrowlen - 1}]
3262 if {$r < $commitidx($curview)} {
3264 foreach p
[lindex
$parentlist $r] {
3265 if {[lsearch
-exact $idlist $p] >= 0} continue
3266 set fk
[lindex
$children($curview,$p) 0]
3267 if {$commitrow($curview,$fk) < $row} {
3268 set x
[idcol
$idlist $p $x]
3269 set idlist
[linsert
$idlist $x $p]
3272 if {[incr r
] < $commitidx($curview)} {
3273 set p
[lindex
$displayorder $r]
3274 if {[lsearch
-exact $idlist $p] < 0} {
3275 set fk
[lindex
$children($curview,$p) 0]
3276 if {$fk ne
{} && $commitrow($curview,$fk) < $row} {
3277 set x
[idcol
$idlist $p $x]
3278 set idlist
[linsert
$idlist $x $p]
3284 if {$final && !$viewcomplete($curview) &&
3285 $row + $uparrowlen + $mingaplen + $downarrowlen
3286 >= $commitidx($curview)} {
3289 set l
[llength
$rowidlist]
3291 lappend rowidlist
$idlist
3293 lappend rowfinal
$final
3294 } elseif
{$row < $l} {
3295 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3296 lset rowidlist
$row $idlist
3299 lset rowfinal
$row $final
3301 set pad
[ntimes
[expr {$row - $l}] {}]
3302 set rowidlist
[concat
$rowidlist $pad]
3303 lappend rowidlist
$idlist
3304 set rowfinal
[concat
$rowfinal $pad]
3305 lappend rowfinal
$final
3306 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3312 proc changedrow
{row
} {
3313 global displayorder iddrawn rowisopt need_redisplay
3315 set l
[llength
$rowisopt]
3317 lset rowisopt
$row 0
3318 if {$row + 1 < $l} {
3319 lset rowisopt
[expr {$row + 1}] 0
3320 if {$row + 2 < $l} {
3321 lset rowisopt
[expr {$row + 2}] 0
3325 set id
[lindex
$displayorder $row]
3326 if {[info exists iddrawn
($id)]} {
3327 set need_redisplay
1
3331 proc insert_pad
{row
col npad
} {
3334 set pad
[ntimes
$npad {}]
3335 set idlist
[lindex
$rowidlist $row]
3336 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3337 set aft
[lrange
$idlist $col end
]
3338 set i
[lsearch
-exact $aft {}]
3340 set aft
[lreplace
$aft $i $i]
3342 lset rowidlist
$row [concat
$bef $pad $aft]
3346 proc optimize_rows
{row
col endrow
} {
3347 global rowidlist rowisopt displayorder curview children
3352 for {} {$row < $endrow} {incr row
; set col 0} {
3353 if {[lindex
$rowisopt $row]} continue
3355 set y0
[expr {$row - 1}]
3356 set ym
[expr {$row - 2}]
3357 set idlist
[lindex
$rowidlist $row]
3358 set previdlist
[lindex
$rowidlist $y0]
3359 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3361 set pprevidlist
[lindex
$rowidlist $ym]
3362 if {$pprevidlist eq
{}} continue
3368 for {} {$col < [llength
$idlist]} {incr
col} {
3369 set id
[lindex
$idlist $col]
3370 if {[lindex
$previdlist $col] eq
$id} continue
3375 set x0
[lsearch
-exact $previdlist $id]
3376 if {$x0 < 0} continue
3377 set z
[expr {$x0 - $col}]
3381 set xm
[lsearch
-exact $pprevidlist $id]
3383 set z0
[expr {$xm - $x0}]
3387 # if row y0 is the first child of $id then it's not an arrow
3388 if {[lindex
$children($curview,$id) 0] ne
3389 [lindex
$displayorder $y0]} {
3393 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3394 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3397 # Looking at lines from this row to the previous row,
3398 # make them go straight up if they end in an arrow on
3399 # the previous row; otherwise make them go straight up
3401 if {$z < -1 ||
($z < 0 && $isarrow)} {
3402 # Line currently goes left too much;
3403 # insert pads in the previous row, then optimize it
3404 set npad
[expr {-1 - $z + $isarrow}]
3405 insert_pad
$y0 $x0 $npad
3407 optimize_rows
$y0 $x0 $row
3409 set previdlist
[lindex
$rowidlist $y0]
3410 set x0
[lsearch
-exact $previdlist $id]
3411 set z
[expr {$x0 - $col}]
3413 set pprevidlist
[lindex
$rowidlist $ym]
3414 set xm
[lsearch
-exact $pprevidlist $id]
3415 set z0
[expr {$xm - $x0}]
3417 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3418 # Line currently goes right too much;
3419 # insert pads in this line
3420 set npad
[expr {$z - 1 + $isarrow}]
3421 insert_pad
$row $col $npad
3422 set idlist
[lindex
$rowidlist $row]
3424 set z
[expr {$x0 - $col}]
3427 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3428 # this line links to its first child on row $row-2
3429 set id
[lindex
$displayorder $ym]
3430 set xc
[lsearch
-exact $pprevidlist $id]
3432 set z0
[expr {$xc - $x0}]
3435 # avoid lines jigging left then immediately right
3436 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3437 insert_pad
$y0 $x0 1
3439 optimize_rows
$y0 $x0 $row
3440 set previdlist
[lindex
$rowidlist $y0]
3444 # Find the first column that doesn't have a line going right
3445 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
3446 set id
[lindex
$idlist $col]
3447 if {$id eq
{}} break
3448 set x0
[lsearch
-exact $previdlist $id]
3450 # check if this is the link to the first child
3451 set kid
[lindex
$displayorder $y0]
3452 if {[lindex
$children($curview,$id) 0] eq
$kid} {
3453 # it is, work out offset to child
3454 set x0
[lsearch
-exact $previdlist $kid]
3457 if {$x0 <= $col} break
3459 # Insert a pad at that column as long as it has a line and
3460 # isn't the last column
3461 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
3462 set idlist
[linsert
$idlist $col {}]
3463 lset rowidlist
$row $idlist
3471 global canvx0 linespc
3472 return [expr {$canvx0 + $col * $linespc}]
3476 global canvy0 linespc
3477 return [expr {$canvy0 + $row * $linespc}]
3480 proc linewidth
{id
} {
3481 global thickerline lthickness
3484 if {[info exists thickerline
] && $id eq
$thickerline} {
3485 set wid
[expr {2 * $lthickness}]
3490 proc rowranges
{id
} {
3491 global commitrow curview children uparrowlen downarrowlen
3494 set kids
$children($curview,$id)
3500 foreach child
$kids {
3501 if {![info exists commitrow
($curview,$child)]} break
3502 set row
$commitrow($curview,$child)
3503 if {![info exists prev
]} {
3504 lappend ret
[expr {$row + 1}]
3506 if {$row <= $prevrow} {
3507 puts
"oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3509 # see if the line extends the whole way from prevrow to row
3510 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3511 [lsearch
-exact [lindex
$rowidlist \
3512 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
3513 # it doesn't, see where it ends
3514 set r
[expr {$prevrow + $downarrowlen}]
3515 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3516 while {[incr r
-1] > $prevrow &&
3517 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3519 while {[incr r
] <= $row &&
3520 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3524 # see where it starts up again
3525 set r
[expr {$row - $uparrowlen}]
3526 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3527 while {[incr r
] < $row &&
3528 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3530 while {[incr r
-1] >= $prevrow &&
3531 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3537 if {$child eq
$id} {
3546 proc drawlineseg
{id row endrow arrowlow
} {
3547 global rowidlist displayorder iddrawn linesegs
3548 global canv colormap linespc curview maxlinelen parentlist
3550 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
3551 set le
[expr {$row + 1}]
3554 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
3560 set x
[lindex
$displayorder $le]
3565 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
3566 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
3582 if {[info exists linesegs
($id)]} {
3583 set lines
$linesegs($id)
3585 set r0
[lindex
$li 0]
3587 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
3597 set li
[lindex
$lines [expr {$i-1}]]
3598 set r1
[lindex
$li 1]
3599 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
3604 set x
[lindex
$cols [expr {$le - $row}]]
3605 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
3606 set dir
[expr {$xp - $x}]
3608 set ith
[lindex
$lines $i 2]
3609 set coords
[$canv coords
$ith]
3610 set ah
[$canv itemcget
$ith -arrow]
3611 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
3612 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
3613 if {$x2 ne
{} && $x - $x2 == $dir} {
3614 set coords
[lrange
$coords 0 end-2
]
3617 set coords
[list
[xc
$le $x] [yc
$le]]
3620 set itl
[lindex
$lines [expr {$i-1}] 2]
3621 set al
[$canv itemcget
$itl -arrow]
3622 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
3623 } elseif
{$arrowlow} {
3624 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
3625 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
3629 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
3630 for {set y
$le} {[incr y
-1] > $row} {} {
3632 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
3633 set ndir
[expr {$xp - $x}]
3634 if {$dir != $ndir ||
$xp < 0} {
3635 lappend coords
[xc
$y $x] [yc
$y]
3641 # join parent line to first child
3642 set ch
[lindex
$displayorder $row]
3643 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
3645 puts
"oops: drawlineseg: child $ch not on row $row"
3646 } elseif
{$xc != $x} {
3647 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
3648 set d
[expr {int
(0.5 * $linespc)}]
3651 set x2
[expr {$x1 - $d}]
3653 set x2
[expr {$x1 + $d}]
3656 set y1
[expr {$y2 + $d}]
3657 lappend coords
$x1 $y1 $x2 $y2
3658 } elseif
{$xc < $x - 1} {
3659 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
3660 } elseif
{$xc > $x + 1} {
3661 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
3665 lappend coords
[xc
$row $x] [yc
$row]
3667 set xn
[xc
$row $xp]
3669 lappend coords
$xn $yn
3673 set t
[$canv create line
$coords -width [linewidth
$id] \
3674 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
3677 set lines
[linsert
$lines $i [list
$row $le $t]]
3679 $canv coords
$ith $coords
3680 if {$arrow ne
$ah} {
3681 $canv itemconf
$ith -arrow $arrow
3683 lset lines
$i 0 $row
3686 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
3687 set ndir
[expr {$xo - $xp}]
3688 set clow
[$canv coords
$itl]
3689 if {$dir == $ndir} {
3690 set clow
[lrange
$clow 2 end
]
3692 set coords
[concat
$coords $clow]
3694 lset lines
[expr {$i-1}] 1 $le
3696 # coalesce two pieces
3698 set b
[lindex
$lines [expr {$i-1}] 0]
3699 set e
[lindex
$lines $i 1]
3700 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
3702 $canv coords
$itl $coords
3703 if {$arrow ne
$al} {
3704 $canv itemconf
$itl -arrow $arrow
3708 set linesegs
($id) $lines
3712 proc drawparentlinks
{id row
} {
3713 global rowidlist canv colormap curview parentlist
3714 global idpos linespc
3716 set rowids
[lindex
$rowidlist $row]
3717 set col [lsearch
-exact $rowids $id]
3718 if {$col < 0} return
3719 set olds
[lindex
$parentlist $row]
3720 set row2
[expr {$row + 1}]
3721 set x
[xc
$row $col]
3724 set d
[expr {int
(0.5 * $linespc)}]
3725 set ymid
[expr {$y + $d}]
3726 set ids
[lindex
$rowidlist $row2]
3727 # rmx = right-most X coord used
3730 set i
[lsearch
-exact $ids $p]
3732 puts
"oops, parent $p of $id not in list"
3735 set x2
[xc
$row2 $i]
3739 set j
[lsearch
-exact $rowids $p]
3741 # drawlineseg will do this one for us
3745 # should handle duplicated parents here...
3746 set coords
[list
$x $y]
3748 # if attaching to a vertical segment, draw a smaller
3749 # slant for visual distinctness
3752 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
3754 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
3756 } elseif
{$i < $col && $i < $j} {
3757 # segment slants towards us already
3758 lappend coords
[xc
$row $j] $y
3760 if {$i < $col - 1} {
3761 lappend coords
[expr {$x2 + $linespc}] $y
3762 } elseif
{$i > $col + 1} {
3763 lappend coords
[expr {$x2 - $linespc}] $y
3765 lappend coords
$x2 $y2
3768 lappend coords
$x2 $y2
3770 set t
[$canv create line
$coords -width [linewidth
$p] \
3771 -fill $colormap($p) -tags lines.
$p]
3775 if {$rmx > [lindex
$idpos($id) 1]} {
3776 lset idpos
($id) 1 $rmx
3781 proc drawlines
{id
} {
3784 $canv itemconf lines.
$id -width [linewidth
$id]
3787 proc drawcmittext
{id row
col} {
3788 global linespc canv canv2 canv3 canvy0 fgcolor curview
3789 global commitlisted commitinfo rowidlist parentlist
3790 global rowtextx idpos idtags idheads idotherrefs
3791 global linehtag linentag linedtag selectedline
3792 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3794 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
3795 set listed
[lindex
$commitlisted $row]
3796 if {$id eq
$nullid} {
3798 } elseif
{$id eq
$nullid2} {
3801 set ofill
[expr {$listed != 0 ?
$listed == 2 ?
"gray" : "blue" : "white"}]
3803 set x
[xc
$row $col]
3805 set orad
[expr {$linespc / 3}]
3807 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
3808 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3809 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3810 } elseif
{$listed == 3} {
3811 # triangle pointing left for left-side commits
3812 set t
[$canv create polygon \
3813 [expr {$x - $orad}] $y \
3814 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3815 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3816 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3818 # triangle pointing right for right-side commits
3819 set t
[$canv create polygon \
3820 [expr {$x + $orad - 1}] $y \
3821 [expr {$x - $orad}] [expr {$y - $orad}] \
3822 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3823 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3826 $canv bind $t <1> {selcanvline
{} %x
%y
}
3827 set rmx
[llength
[lindex
$rowidlist $row]]
3828 set olds
[lindex
$parentlist $row]
3830 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
3832 set i
[lsearch
-exact $nextids $p]
3838 set xt
[xc
$row $rmx]
3839 set rowtextx
($row) $xt
3840 set idpos
($id) [list
$x $xt $y]
3841 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
3842 ||
[info exists idotherrefs
($id)]} {
3843 set xt
[drawtags
$id $x $xt $y]
3845 set headline
[lindex
$commitinfo($id) 0]
3846 set name
[lindex
$commitinfo($id) 1]
3847 set date [lindex
$commitinfo($id) 2]
3848 set date [formatdate
$date]
3851 set isbold
[ishighlighted
$row]
3853 lappend boldrows
$row
3854 set font mainfontbold
3856 lappend boldnamerows
$row
3857 set nfont mainfontbold
3860 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
3861 -text $headline -font $font -tags text
]
3862 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
3863 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
3864 -text $name -font $nfont -tags text
]
3865 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
3866 -text $date -font mainfont
-tags text
]
3867 if {[info exists selectedline
] && $selectedline == $row} {
3870 set xr
[expr {$xt + [font measure
$font $headline]}]
3871 if {$xr > $canvxmax} {
3877 proc drawcmitrow
{row
} {
3878 global displayorder rowidlist nrows_drawn
3879 global iddrawn markingmatches
3880 global commitinfo parentlist numcommits
3881 global filehighlight fhighlights findpattern nhighlights
3882 global hlview vhighlights
3883 global highlight_related rhighlights
3885 if {$row >= $numcommits} return
3887 set id
[lindex
$displayorder $row]
3888 if {[info exists hlview
] && ![info exists vhighlights
($row)]} {
3889 askvhighlight
$row $id
3891 if {[info exists filehighlight
] && ![info exists fhighlights
($row)]} {
3892 askfilehighlight
$row $id
3894 if {$findpattern ne
{} && ![info exists nhighlights
($row)]} {
3895 askfindhighlight
$row $id
3897 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($row)]} {
3898 askrelhighlight
$row $id
3900 if {![info exists iddrawn
($id)]} {
3901 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
3903 puts
"oops, row $row id $id not in list"
3906 if {![info exists commitinfo
($id)]} {
3910 drawcmittext
$id $row $col
3914 if {$markingmatches} {
3915 markrowmatches
$row $id
3919 proc drawcommits
{row
{endrow
{}}} {
3920 global numcommits iddrawn displayorder curview need_redisplay
3921 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3926 if {$endrow eq
{}} {
3929 if {$endrow >= $numcommits} {
3930 set endrow
[expr {$numcommits - 1}]
3933 set rl1
[expr {$row - $downarrowlen - 3}]
3937 set ro1
[expr {$row - 3}]
3941 set r2
[expr {$endrow + $uparrowlen + 3}]
3942 if {$r2 > $numcommits} {
3945 for {set r
$rl1} {$r < $r2} {incr r
} {
3946 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
3950 set rl1
[expr {$r + 1}]
3956 optimize_rows
$ro1 0 $r2
3957 if {$need_redisplay ||
$nrows_drawn > 2000} {
3962 # make the lines join to already-drawn rows either side
3963 set r
[expr {$row - 1}]
3964 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
3967 set er
[expr {$endrow + 1}]
3968 if {$er >= $numcommits ||
3969 ![info exists iddrawn
([lindex
$displayorder $er])]} {
3972 for {} {$r <= $er} {incr r
} {
3973 set id
[lindex
$displayorder $r]
3974 set wasdrawn
[info exists iddrawn
($id)]
3976 if {$r == $er} break
3977 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3978 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
3979 drawparentlinks
$id $r
3981 set rowids
[lindex
$rowidlist $r]
3982 foreach lid
$rowids {
3983 if {$lid eq
{}} continue
3984 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
3986 # see if this is the first child of any of its parents
3987 foreach p
[lindex
$parentlist $r] {
3988 if {[lsearch
-exact $rowids $p] < 0} {
3989 # make this line extend up to the child
3990 set lineend
($p) [drawlineseg
$p $r $er 0]
3994 set lineend
($lid) [drawlineseg
$lid $r $er 1]
4000 proc drawfrac
{f0 f1
} {
4003 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4004 if {$ymax eq
{} ||
$ymax == 0} return
4005 set y0
[expr {int
($f0 * $ymax)}]
4006 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
4007 set y1
[expr {int
($f1 * $ymax)}]
4008 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
4009 drawcommits
$row $endrow
4012 proc drawvisible
{} {
4014 eval drawfrac
[$canv yview
]
4017 proc clear_display
{} {
4018 global iddrawn linesegs need_redisplay nrows_drawn
4019 global vhighlights fhighlights nhighlights rhighlights
4022 catch
{unset iddrawn
}
4023 catch
{unset linesegs
}
4024 catch
{unset vhighlights
}
4025 catch
{unset fhighlights
}
4026 catch
{unset nhighlights
}
4027 catch
{unset rhighlights
}
4028 set need_redisplay
0
4032 proc findcrossings
{id
} {
4033 global rowidlist parentlist numcommits displayorder
4037 foreach
{s e
} [rowranges
$id] {
4038 if {$e >= $numcommits} {
4039 set e
[expr {$numcommits - 1}]
4041 if {$e <= $s} continue
4042 for {set row
$e} {[incr row
-1] >= $s} {} {
4043 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
4045 set olds
[lindex
$parentlist $row]
4046 set kid
[lindex
$displayorder $row]
4047 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
4048 if {$kidx < 0} continue
4049 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
4051 set px
[lsearch
-exact $nextrow $p]
4052 if {$px < 0} continue
4053 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
4054 if {[lsearch
-exact $ccross $p] >= 0} continue
4055 if {$x == $px + ($kidx < $px?
-1: 1)} {
4057 } elseif
{[lsearch
-exact $cross $p] < 0} {
4064 return [concat
$ccross {{}} $cross]
4067 proc assigncolor
{id
} {
4068 global colormap colors nextcolor
4069 global commitrow parentlist children children curview
4071 if {[info exists colormap
($id)]} return
4072 set ncolors
[llength
$colors]
4073 if {[info exists children
($curview,$id)]} {
4074 set kids
$children($curview,$id)
4078 if {[llength
$kids] == 1} {
4079 set child
[lindex
$kids 0]
4080 if {[info exists colormap
($child)]
4081 && [llength
[lindex
$parentlist $commitrow($curview,$child)]] == 1} {
4082 set colormap
($id) $colormap($child)
4088 foreach x
[findcrossings
$id] {
4090 # delimiter between corner crossings and other crossings
4091 if {[llength
$badcolors] >= $ncolors - 1} break
4092 set origbad
$badcolors
4094 if {[info exists colormap
($x)]
4095 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
4096 lappend badcolors
$colormap($x)
4099 if {[llength
$badcolors] >= $ncolors} {
4100 set badcolors
$origbad
4102 set origbad
$badcolors
4103 if {[llength
$badcolors] < $ncolors - 1} {
4104 foreach child
$kids {
4105 if {[info exists colormap
($child)]
4106 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
4107 lappend badcolors
$colormap($child)
4109 foreach p
[lindex
$parentlist $commitrow($curview,$child)] {
4110 if {[info exists colormap
($p)]
4111 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
4112 lappend badcolors
$colormap($p)
4116 if {[llength
$badcolors] >= $ncolors} {
4117 set badcolors
$origbad
4120 for {set i
0} {$i <= $ncolors} {incr i
} {
4121 set c
[lindex
$colors $nextcolor]
4122 if {[incr nextcolor
] >= $ncolors} {
4125 if {[lsearch
-exact $badcolors $c]} break
4127 set colormap
($id) $c
4130 proc bindline
{t id
} {
4133 $canv bind $t <Enter
> "lineenter %x %y $id"
4134 $canv bind $t <Motion
> "linemotion %x %y $id"
4135 $canv bind $t <Leave
> "lineleave $id"
4136 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4139 proc drawtags
{id x xt y1
} {
4140 global idtags idheads idotherrefs mainhead
4141 global linespc lthickness
4142 global canv commitrow rowtextx curview fgcolor bgcolor
4147 if {[info exists idtags
($id)]} {
4148 set marks
$idtags($id)
4149 set ntags
[llength
$marks]
4151 if {[info exists idheads
($id)]} {
4152 set marks
[concat
$marks $idheads($id)]
4153 set nheads
[llength
$idheads($id)]
4155 if {[info exists idotherrefs
($id)]} {
4156 set marks
[concat
$marks $idotherrefs($id)]
4162 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4163 set yt
[expr {$y1 - 0.5 * $linespc}]
4164 set yb
[expr {$yt + $linespc - 1}]
4168 foreach tag
$marks {
4170 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4171 set wid
[font measure mainfontbold
$tag]
4173 set wid
[font measure mainfont
$tag]
4177 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4179 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4180 -width $lthickness -fill black
-tags tag.
$id]
4182 foreach tag
$marks x
$xvals wid
$wvals {
4183 set xl
[expr {$x + $delta}]
4184 set xr
[expr {$x + $delta + $wid + $lthickness}]
4186 if {[incr ntags
-1] >= 0} {
4188 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4189 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4190 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4191 $canv bind $t <1> [list showtag
$tag 1]
4192 set rowtextx
($commitrow($curview,$id)) [expr {$xr + $linespc}]
4194 # draw a head or other ref
4195 if {[incr nheads
-1] >= 0} {
4197 if {$tag eq
$mainhead} {
4198 set font mainfontbold
4203 set xl
[expr {$xl - $delta/2}]
4204 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4205 -width 1 -outline black
-fill $col -tags tag.
$id
4206 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4207 set rwid
[font measure mainfont
$remoteprefix]
4208 set xi
[expr {$x + 1}]
4209 set yti
[expr {$yt + 1}]
4210 set xri
[expr {$x + $rwid}]
4211 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4212 -width 0 -fill "#ffddaa" -tags tag.
$id
4215 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4216 -font $font -tags [list tag.
$id text
]]
4218 $canv bind $t <1> [list showtag
$tag 1]
4219 } elseif
{$nheads >= 0} {
4220 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4226 proc xcoord
{i level
ln} {
4227 global canvx0 xspc1 xspc2
4229 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4230 if {$i > 0 && $i == $level} {
4231 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4232 } elseif
{$i > $level} {
4233 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4238 proc show_status
{msg
} {
4242 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4243 -tags text
-fill $fgcolor
4246 # Insert a new commit as the child of the commit on row $row.
4247 # The new commit will be displayed on row $row and the commits
4248 # on that row and below will move down one row.
4249 proc insertrow
{row newcmit
} {
4250 global displayorder parentlist commitlisted children
4251 global commitrow curview rowidlist rowisopt rowfinal numcommits
4253 global selectedline commitidx ordertok
4255 if {$row >= $numcommits} {
4256 puts
"oops, inserting new row $row but only have $numcommits rows"
4259 set p
[lindex
$displayorder $row]
4260 set displayorder
[linsert
$displayorder $row $newcmit]
4261 set parentlist
[linsert
$parentlist $row $p]
4262 set kids
$children($curview,$p)
4263 lappend kids
$newcmit
4264 set children
($curview,$p) $kids
4265 set children
($curview,$newcmit) {}
4266 set commitlisted
[linsert
$commitlisted $row 1]
4267 set l
[llength
$displayorder]
4268 for {set r
$row} {$r < $l} {incr r
} {
4269 set id
[lindex
$displayorder $r]
4270 set commitrow
($curview,$id) $r
4272 incr commitidx
($curview)
4273 set ordertok
($curview,$newcmit) $ordertok($curview,$p)
4275 if {$row < [llength
$rowidlist]} {
4276 set idlist
[lindex
$rowidlist $row]
4277 if {$idlist ne
{}} {
4278 if {[llength
$kids] == 1} {
4279 set col [lsearch
-exact $idlist $p]
4280 lset idlist
$col $newcmit
4282 set col [llength
$idlist]
4283 lappend idlist
$newcmit
4286 set rowidlist
[linsert
$rowidlist $row $idlist]
4287 set rowisopt
[linsert
$rowisopt $row 0]
4288 set rowfinal
[linsert
$rowfinal $row [lindex
$rowfinal $row]]
4293 if {[info exists selectedline
] && $selectedline >= $row} {
4299 # Remove a commit that was inserted with insertrow on row $row.
4300 proc removerow
{row
} {
4301 global displayorder parentlist commitlisted children
4302 global commitrow curview rowidlist rowisopt rowfinal numcommits
4304 global linesegends selectedline commitidx
4306 if {$row >= $numcommits} {
4307 puts
"oops, removing row $row but only have $numcommits rows"
4310 set rp1
[expr {$row + 1}]
4311 set id
[lindex
$displayorder $row]
4312 set p
[lindex
$parentlist $row]
4313 set displayorder
[lreplace
$displayorder $row $row]
4314 set parentlist
[lreplace
$parentlist $row $row]
4315 set commitlisted
[lreplace
$commitlisted $row $row]
4316 set kids
$children($curview,$p)
4317 set i
[lsearch
-exact $kids $id]
4319 set kids
[lreplace
$kids $i $i]
4320 set children
($curview,$p) $kids
4322 set l
[llength
$displayorder]
4323 for {set r
$row} {$r < $l} {incr r
} {
4324 set id
[lindex
$displayorder $r]
4325 set commitrow
($curview,$id) $r
4327 incr commitidx
($curview) -1
4329 if {$row < [llength
$rowidlist]} {
4330 set rowidlist
[lreplace
$rowidlist $row $row]
4331 set rowisopt
[lreplace
$rowisopt $row $row]
4332 set rowfinal
[lreplace
$rowfinal $row $row]
4337 if {[info exists selectedline
] && $selectedline > $row} {
4338 incr selectedline
-1
4343 # Don't change the text pane cursor if it is currently the hand cursor,
4344 # showing that we are over a sha1 ID link.
4345 proc settextcursor
{c
} {
4346 global ctext curtextcursor
4348 if {[$ctext cget
-cursor] == $curtextcursor} {
4349 $ctext config
-cursor $c
4351 set curtextcursor
$c
4354 proc nowbusy
{what
{name
{}}} {
4355 global isbusy busyname statusw
4357 if {[array names isbusy
] eq
{}} {
4358 . config
-cursor watch
4362 set busyname
($what) $name
4364 $statusw conf
-text $name
4368 proc notbusy
{what
} {
4369 global isbusy maincursor textcursor busyname statusw
4373 if {$busyname($what) ne
{} &&
4374 [$statusw cget
-text] eq
$busyname($what)} {
4375 $statusw conf
-text {}
4378 if {[array names isbusy
] eq
{}} {
4379 . config
-cursor $maincursor
4380 settextcursor
$textcursor
4384 proc findmatches
{f
} {
4385 global findtype findstring
4386 if {$findtype == [mc
"Regexp"]} {
4387 set matches
[regexp
-indices -all -inline $findstring $f]
4390 if {$findtype == [mc
"IgnCase"]} {
4391 set f
[string tolower
$f]
4392 set fs
[string tolower
$fs]
4396 set l
[string length
$fs]
4397 while {[set j
[string first
$fs $f $i]] >= 0} {
4398 lappend matches
[list
$j [expr {$j+$l-1}]]
4399 set i
[expr {$j + $l}]
4405 proc dofind
{{dirn
1} {wrap
1}} {
4406 global findstring findstartline findcurline selectedline numcommits
4407 global gdttype filehighlight fh_serial find_dirn findallowwrap
4409 if {[info exists find_dirn
]} {
4410 if {$find_dirn == $dirn} return
4414 if {$findstring eq
{} ||
$numcommits == 0} return
4415 if {![info exists selectedline
]} {
4416 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4418 set findstartline
$selectedline
4420 set findcurline
$findstartline
4421 nowbusy finding
[mc
"Searching"]
4422 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4423 after cancel do_file_hl
$fh_serial
4424 do_file_hl
$fh_serial
4427 set findallowwrap
$wrap
4431 proc stopfinding
{} {
4432 global find_dirn findcurline fprogcoord
4434 if {[info exists find_dirn
]} {
4444 global commitdata commitinfo numcommits findpattern findloc
4445 global findstartline findcurline displayorder
4446 global find_dirn gdttype fhighlights fprogcoord
4447 global findallowwrap
4449 if {![info exists find_dirn
]} {
4452 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4455 if {$find_dirn > 0} {
4457 if {$l >= $numcommits} {
4460 if {$l <= $findstartline} {
4461 set lim
[expr {$findstartline + 1}]
4464 set moretodo
$findallowwrap
4471 if {$l >= $findstartline} {
4472 set lim
[expr {$findstartline - 1}]
4475 set moretodo
$findallowwrap
4478 set n
[expr {($lim - $l) * $find_dirn}]
4485 if {$gdttype eq
[mc
"containing:"]} {
4486 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4487 set id
[lindex
$displayorder $l]
4488 # shouldn't happen unless git log doesn't give all the commits...
4489 if {![info exists commitdata
($id)]} continue
4490 if {![doesmatch
$commitdata($id)]} continue
4491 if {![info exists commitinfo
($id)]} {
4494 set info
$commitinfo($id)
4495 foreach f
$info ty
$fldtypes {
4496 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
4505 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4506 set id
[lindex
$displayorder $l]
4507 if {![info exists fhighlights
($l)]} {
4508 askfilehighlight
$l $id
4511 set findcurline
[expr {$l - $find_dirn}]
4513 } elseif
{$fhighlights($l)} {
4519 if {$found ||
($domore && !$moretodo)} {
4535 set findcurline
[expr {$l - $find_dirn}]
4537 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
4541 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
4546 proc findselectline
{l
} {
4547 global findloc commentend ctext findcurline markingmatches gdttype
4549 set markingmatches
1
4552 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
4553 # highlight the matches in the comments
4554 set f
[$ctext get
1.0 $commentend]
4555 set matches
[findmatches
$f]
4556 foreach match
$matches {
4557 set start
[lindex
$match 0]
4558 set end
[expr {[lindex
$match 1] + 1}]
4559 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
4565 # mark the bits of a headline or author that match a find string
4566 proc markmatches
{canv l str tag matches font row
} {
4569 set bbox
[$canv bbox
$tag]
4570 set x0
[lindex
$bbox 0]
4571 set y0
[lindex
$bbox 1]
4572 set y1
[lindex
$bbox 3]
4573 foreach match
$matches {
4574 set start
[lindex
$match 0]
4575 set end
[lindex
$match 1]
4576 if {$start > $end} continue
4577 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
4578 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
4579 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
4580 [expr {$x0+$xlen+2}] $y1 \
4581 -outline {} -tags [list match
$l matches
] -fill yellow
]
4583 if {[info exists selectedline
] && $row == $selectedline} {
4584 $canv raise
$t secsel
4589 proc unmarkmatches
{} {
4590 global markingmatches
4592 allcanvs delete matches
4593 set markingmatches
0
4597 proc selcanvline
{w x y
} {
4598 global canv canvy0 ctext linespc
4600 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4601 if {$ymax == {}} return
4602 set yfrac
[lindex
[$canv yview
] 0]
4603 set y
[expr {$y + $yfrac * $ymax}]
4604 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
4609 if {![info exists rowtextx
($l)] ||
$x < $rowtextx($l)} return
4615 proc commit_descriptor
{p
} {
4617 if {![info exists commitinfo
($p)]} {
4621 if {[llength
$commitinfo($p)] > 1} {
4622 set l
[lindex
$commitinfo($p) 0]
4627 # append some text to the ctext widget, and make any SHA1 ID
4628 # that we know about be a clickable link.
4629 proc appendwithlinks
{text tags
} {
4630 global ctext commitrow linknum curview pendinglinks
4632 set start
[$ctext index
"end - 1c"]
4633 $ctext insert end
$text $tags
4634 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
4638 set linkid
[string range
$text $s $e]
4640 $ctext tag delete link
$linknum
4641 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
4642 setlink
$linkid link
$linknum
4647 proc setlink
{id lk
} {
4648 global curview commitrow ctext pendinglinks commitinterest
4650 if {[info exists commitrow
($curview,$id)]} {
4651 $ctext tag conf
$lk -foreground blue
-underline 1
4652 $ctext tag
bind $lk <1> [list selectline
$commitrow($curview,$id) 1]
4653 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
4654 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
4656 lappend pendinglinks
($id) $lk
4657 lappend commitinterest
($id) {makelink
%I
}
4661 proc makelink
{id
} {
4664 if {![info exists pendinglinks
($id)]} return
4665 foreach lk
$pendinglinks($id) {
4668 unset pendinglinks
($id)
4671 proc linkcursor
{w inc
} {
4672 global linkentercount curtextcursor
4674 if {[incr linkentercount
$inc] > 0} {
4675 $w configure
-cursor hand2
4677 $w configure
-cursor $curtextcursor
4678 if {$linkentercount < 0} {
4679 set linkentercount
0
4684 proc viewnextline
{dir
} {
4688 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4689 set wnow
[$canv yview
]
4690 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4691 set newtop
[expr {$wtop + $dir * $linespc}]
4694 } elseif
{$newtop > $ymax} {
4697 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4700 # add a list of tag or branch names at position pos
4701 # returns the number of names inserted
4702 proc appendrefs
{pos ids var
} {
4703 global ctext commitrow linknum curview
$var maxrefs
4705 if {[catch
{$ctext index
$pos}]} {
4708 $ctext conf
-state normal
4709 $ctext delete
$pos "$pos lineend"
4712 foreach tag
[set $var\
($id\
)] {
4713 lappend tags
[list
$tag $id]
4716 if {[llength
$tags] > $maxrefs} {
4717 $ctext insert
$pos "many ([llength $tags])"
4719 set tags
[lsort
-index 0 -decreasing $tags]
4722 set id
[lindex
$ti 1]
4725 $ctext tag delete
$lk
4726 $ctext insert
$pos $sep
4727 $ctext insert
$pos [lindex
$ti 0] $lk
4732 $ctext conf
-state disabled
4733 return [llength
$tags]
4736 # called when we have finished computing the nearby tags
4737 proc dispneartags
{delay
} {
4738 global selectedline currentid showneartags tagphase
4740 if {![info exists selectedline
] ||
!$showneartags} return
4741 after cancel dispnexttag
4743 after
200 dispnexttag
4746 after idle dispnexttag
4751 proc dispnexttag
{} {
4752 global selectedline currentid showneartags tagphase ctext
4754 if {![info exists selectedline
] ||
!$showneartags} return
4755 switch
-- $tagphase {
4757 set dtags
[desctags
$currentid]
4759 appendrefs precedes
$dtags idtags
4763 set atags
[anctags
$currentid]
4765 appendrefs follows
$atags idtags
4769 set dheads
[descheads
$currentid]
4770 if {$dheads ne
{}} {
4771 if {[appendrefs branch
$dheads idheads
] > 1
4772 && [$ctext get
"branch -3c"] eq
"h"} {
4773 # turn "Branch" into "Branches"
4774 $ctext conf
-state normal
4775 $ctext insert
"branch -2c" "es"
4776 $ctext conf
-state disabled
4781 if {[incr tagphase
] <= 2} {
4782 after idle dispnexttag
4786 proc make_secsel
{l
} {
4787 global linehtag linentag linedtag canv canv2 canv3
4789 if {![info exists linehtag
($l)]} return
4791 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
4792 -tags secsel
-fill [$canv cget
-selectbackground]]
4794 $canv2 delete secsel
4795 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
4796 -tags secsel
-fill [$canv2 cget
-selectbackground]]
4798 $canv3 delete secsel
4799 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
4800 -tags secsel
-fill [$canv3 cget
-selectbackground]]
4804 proc selectline
{l isnew
} {
4805 global canv ctext commitinfo selectedline
4807 global canvy0 linespc parentlist children curview
4808 global currentid sha1entry
4809 global commentend idtags linknum
4810 global mergemax numcommits pending_select
4811 global cmitmode showneartags allcommits
4814 catch
{unset pending_select
}
4819 if {$l < 0 ||
$l >= $numcommits} return
4820 set y
[expr {$canvy0 + $l * $linespc}]
4821 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4822 set ytop
[expr {$y - $linespc - 1}]
4823 set ybot
[expr {$y + $linespc + 1}]
4824 set wnow
[$canv yview
]
4825 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4826 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
4827 set wh
[expr {$wbot - $wtop}]
4829 if {$ytop < $wtop} {
4830 if {$ybot < $wtop} {
4831 set newtop
[expr {$y - $wh / 2.0}]
4834 if {$newtop > $wtop - $linespc} {
4835 set newtop
[expr {$wtop - $linespc}]
4838 } elseif
{$ybot > $wbot} {
4839 if {$ytop > $wbot} {
4840 set newtop
[expr {$y - $wh / 2.0}]
4842 set newtop
[expr {$ybot - $wh}]
4843 if {$newtop < $wtop + $linespc} {
4844 set newtop
[expr {$wtop + $linespc}]
4848 if {$newtop != $wtop} {
4852 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4859 addtohistory
[list selectline
$l 0]
4864 set id
[lindex
$displayorder $l]
4866 $sha1entry delete
0 end
4867 $sha1entry insert
0 $id
4869 $sha1entry selection from
0
4870 $sha1entry selection to end
4874 $ctext conf
-state normal
4877 set info
$commitinfo($id)
4878 set date [formatdate
[lindex
$info 2]]
4879 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
4880 set date [formatdate
[lindex
$info 4]]
4881 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
4882 if {[info exists idtags
($id)]} {
4883 $ctext insert end
[mc
"Tags:"]
4884 foreach tag
$idtags($id) {
4885 $ctext insert end
" $tag"
4887 $ctext insert end
"\n"
4891 set olds
[lindex
$parentlist $l]
4892 if {[llength
$olds] > 1} {
4895 if {$np >= $mergemax} {
4900 $ctext insert end
"[mc "Parent
"]: " $tag
4901 appendwithlinks
[commit_descriptor
$p] {}
4906 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
4910 foreach c
$children($curview,$id) {
4911 append headers
"[mc "Child
"]: [commit_descriptor $c]"
4914 # make anything that looks like a SHA1 ID be a clickable link
4915 appendwithlinks
$headers {}
4916 if {$showneartags} {
4917 if {![info exists allcommits
]} {
4920 $ctext insert end
"[mc "Branch
"]: "
4921 $ctext mark
set branch
"end -1c"
4922 $ctext mark gravity branch left
4923 $ctext insert end
"\n[mc "Follows
"]: "
4924 $ctext mark
set follows
"end -1c"
4925 $ctext mark gravity follows left
4926 $ctext insert end
"\n[mc "Precedes
"]: "
4927 $ctext mark
set precedes
"end -1c"
4928 $ctext mark gravity precedes left
4929 $ctext insert end
"\n"
4932 $ctext insert end
"\n"
4933 set comment
[lindex
$info 5]
4934 if {[string first
"\r" $comment] >= 0} {
4935 set comment
[string map
{"\r" "\n "} $comment]
4937 appendwithlinks
$comment {comment
}
4939 $ctext tag remove found
1.0 end
4940 $ctext conf
-state disabled
4941 set commentend
[$ctext index
"end - 1c"]
4943 init_flist
[mc
"Comments"]
4944 if {$cmitmode eq
"tree"} {
4946 } elseif
{[llength
$olds] <= 1} {
4953 proc selfirstline
{} {
4958 proc sellastline
{} {
4961 set l
[expr {$numcommits - 1}]
4965 proc selnextline
{dir
} {
4968 if {![info exists selectedline
]} return
4969 set l
[expr {$selectedline + $dir}]
4974 proc selnextpage
{dir
} {
4975 global canv linespc selectedline numcommits
4977 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
4981 allcanvs yview scroll
[expr {$dir * $lpp}] units
4983 if {![info exists selectedline
]} return
4984 set l
[expr {$selectedline + $dir * $lpp}]
4987 } elseif
{$l >= $numcommits} {
4988 set l
[expr $numcommits - 1]
4994 proc unselectline
{} {
4995 global selectedline currentid
4997 catch
{unset selectedline
}
4998 catch
{unset currentid
}
4999 allcanvs delete secsel
5003 proc reselectline
{} {
5006 if {[info exists selectedline
]} {
5007 selectline
$selectedline 0
5011 proc addtohistory
{cmd
} {
5012 global
history historyindex curview
5014 set elt
[list
$curview $cmd]
5015 if {$historyindex > 0
5016 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
5020 if {$historyindex < [llength
$history]} {
5021 set history [lreplace
$history $historyindex end
$elt]
5023 lappend
history $elt
5026 if {$historyindex > 1} {
5027 .tf.bar.leftbut conf
-state normal
5029 .tf.bar.leftbut conf
-state disabled
5031 .tf.bar.rightbut conf
-state disabled
5037 set view
[lindex
$elt 0]
5038 set cmd
[lindex
$elt 1]
5039 if {$curview != $view} {
5046 global
history historyindex
5049 if {$historyindex > 1} {
5050 incr historyindex
-1
5051 godo
[lindex
$history [expr {$historyindex - 1}]]
5052 .tf.bar.rightbut conf
-state normal
5054 if {$historyindex <= 1} {
5055 .tf.bar.leftbut conf
-state disabled
5060 global
history historyindex
5063 if {$historyindex < [llength
$history]} {
5064 set cmd
[lindex
$history $historyindex]
5067 .tf.bar.leftbut conf
-state normal
5069 if {$historyindex >= [llength
$history]} {
5070 .tf.bar.rightbut conf
-state disabled
5075 global treefilelist treeidlist diffids diffmergeid treepending
5076 global nullid nullid2
5079 catch
{unset diffmergeid
}
5080 if {![info exists treefilelist
($id)]} {
5081 if {![info exists treepending
]} {
5082 if {$id eq
$nullid} {
5083 set cmd
[list | git ls-files
]
5084 } elseif
{$id eq
$nullid2} {
5085 set cmd
[list | git ls-files
--stage -t]
5087 set cmd
[list | git ls-tree
-r $id]
5089 if {[catch
{set gtf
[open
$cmd r
]}]} {
5093 set treefilelist
($id) {}
5094 set treeidlist
($id) {}
5095 fconfigure
$gtf -blocking 0
5096 filerun
$gtf [list gettreeline
$gtf $id]
5103 proc gettreeline
{gtf id
} {
5104 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5107 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
5108 if {$diffids eq
$nullid} {
5111 set i
[string first
"\t" $line]
5112 if {$i < 0} continue
5113 set fname
[string range
$line [expr {$i+1}] end
]
5114 set line
[string range
$line 0 [expr {$i-1}]]
5115 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
5116 set sha1
[lindex
$line 2]
5117 if {[string index
$fname 0] eq
"\""} {
5118 set fname
[lindex
$fname 0]
5120 lappend treeidlist
($id) $sha1
5122 lappend treefilelist
($id) $fname
5125 return [expr {$nl >= 1000?
2: 1}]
5129 if {$cmitmode ne
"tree"} {
5130 if {![info exists diffmergeid
]} {
5131 gettreediffs
$diffids
5133 } elseif
{$id ne
$diffids} {
5142 global treefilelist treeidlist diffids nullid nullid2
5143 global ctext commentend
5145 set i
[lsearch
-exact $treefilelist($diffids) $f]
5147 puts
"oops, $f not in list for id $diffids"
5150 if {$diffids eq
$nullid} {
5151 if {[catch
{set bf
[open
$f r
]} err
]} {
5152 puts
"oops, can't read $f: $err"
5156 set blob
[lindex
$treeidlist($diffids) $i]
5157 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5158 puts
"oops, error reading blob $blob: $err"
5162 fconfigure
$bf -blocking 0
5163 filerun
$bf [list getblobline
$bf $diffids]
5164 $ctext config
-state normal
5165 clear_ctext
$commentend
5166 $ctext insert end
"\n"
5167 $ctext insert end
"$f\n" filesep
5168 $ctext config
-state disabled
5169 $ctext yview
$commentend
5173 proc getblobline
{bf id
} {
5174 global diffids cmitmode ctext
5176 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5180 $ctext config
-state normal
5182 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5183 $ctext insert end
"$line\n"
5186 # delete last newline
5187 $ctext delete
"end - 2c" "end - 1c"
5191 $ctext config
-state disabled
5192 return [expr {$nl >= 1000?
2: 1}]
5195 proc mergediff
{id l
} {
5196 global diffmergeid mdifffd
5200 global limitdiffs viewfiles curview
5204 # this doesn't seem to actually affect anything...
5205 set cmd
[concat | git diff-tree
--no-commit-id --cc -U$diffcontext $id]
5206 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5207 set cmd
[concat
$cmd -- $viewfiles($curview)]
5209 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5210 error_popup
"[mc "Error getting merge diffs
:"] $err"
5213 fconfigure
$mdf -blocking 0
5214 set mdifffd
($id) $mdf
5215 set np
[llength
[lindex
$parentlist $l]]
5217 filerun
$mdf [list getmergediffline
$mdf $id $np]
5220 proc getmergediffline
{mdf id np
} {
5221 global diffmergeid ctext cflist mergemax
5222 global difffilestart mdifffd
5224 $ctext conf
-state normal
5226 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5227 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5228 ||
$mdf != $mdifffd($id)} {
5232 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5233 # start of a new file
5234 $ctext insert end
"\n"
5235 set here
[$ctext index
"end - 1c"]
5236 lappend difffilestart
$here
5237 add_flist
[list
$fname]
5238 set l
[expr {(78 - [string length
$fname]) / 2}]
5239 set pad
[string range
"----------------------------------------" 1 $l]
5240 $ctext insert end
"$pad $fname $pad\n" filesep
5241 } elseif
{[regexp
{^@@
} $line]} {
5242 $ctext insert end
"$line\n" hunksep
5243 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5246 # parse the prefix - one ' ', '-' or '+' for each parent
5251 for {set j
0} {$j < $np} {incr j
} {
5252 set c
[string range
$line $j $j]
5255 } elseif
{$c == "-"} {
5257 } elseif
{$c == "+"} {
5266 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5267 # line doesn't appear in result, parents in $minuses have the line
5268 set num
[lindex
$minuses 0]
5269 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5270 # line appears in result, parents in $pluses don't have the line
5271 lappend tags mresult
5272 set num
[lindex
$spaces 0]
5275 if {$num >= $mergemax} {
5280 $ctext insert end
"$line\n" $tags
5283 $ctext conf
-state disabled
5288 return [expr {$nr >= 1000?
2: 1}]
5291 proc startdiff
{ids
} {
5292 global treediffs diffids treepending diffmergeid nullid nullid2
5296 catch
{unset diffmergeid
}
5297 if {![info exists treediffs
($ids)] ||
5298 [lsearch
-exact $ids $nullid] >= 0 ||
5299 [lsearch
-exact $ids $nullid2] >= 0} {
5300 if {![info exists treepending
]} {
5308 proc path_filter
{filter name
} {
5310 set l
[string length
$p]
5311 if {[string index
$p end
] eq
"/"} {
5312 if {[string compare
-length $l $p $name] == 0} {
5316 if {[string compare
-length $l $p $name] == 0 &&
5317 ([string length
$name] == $l ||
5318 [string index
$name $l] eq
"/")} {
5326 proc addtocflist
{ids
} {
5329 add_flist
$treediffs($ids)
5333 proc diffcmd
{ids flags
} {
5334 global nullid nullid2
5336 set i
[lsearch
-exact $ids $nullid]
5337 set j
[lsearch
-exact $ids $nullid2]
5339 if {[llength
$ids] > 1 && $j < 0} {
5340 # comparing working directory with some specific revision
5341 set cmd
[concat | git diff-index
$flags]
5343 lappend cmd
-R [lindex
$ids 1]
5345 lappend cmd
[lindex
$ids 0]
5348 # comparing working directory with index
5349 set cmd
[concat | git diff-files
$flags]
5354 } elseif
{$j >= 0} {
5355 set cmd
[concat | git diff-index
--cached $flags]
5356 if {[llength
$ids] > 1} {
5357 # comparing index with specific revision
5359 lappend cmd
-R [lindex
$ids 1]
5361 lappend cmd
[lindex
$ids 0]
5364 # comparing index with HEAD
5368 set cmd
[concat | git diff-tree
-r $flags $ids]
5373 proc gettreediffs
{ids
} {
5374 global treediff treepending
5376 set treepending
$ids
5378 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5379 fconfigure
$gdtf -blocking 0
5380 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5383 proc gettreediffline
{gdtf ids
} {
5384 global treediff treediffs treepending diffids diffmergeid
5385 global cmitmode viewfiles curview limitdiffs
5388 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5389 set i
[string first
"\t" $line]
5391 set file [string range
$line [expr {$i+1}] end
]
5392 if {[string index
$file 0] eq
"\""} {
5393 set file [lindex
$file 0]
5395 lappend treediff
$file
5399 return [expr {$nr >= 1000?
2: 1}]
5402 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5404 foreach f
$treediff {
5405 if {[path_filter
$viewfiles($curview) $f]} {
5409 set treediffs
($ids) $flist
5411 set treediffs
($ids) $treediff
5414 if {$cmitmode eq
"tree"} {
5416 } elseif
{$ids != $diffids} {
5417 if {![info exists diffmergeid
]} {
5418 gettreediffs
$diffids
5426 # empty string or positive integer
5427 proc diffcontextvalidate
{v
} {
5428 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5431 proc diffcontextchange
{n1 n2 op
} {
5432 global diffcontextstring diffcontext
5434 if {[string is integer
-strict $diffcontextstring]} {
5435 if {$diffcontextstring > 0} {
5436 set diffcontext
$diffcontextstring
5442 proc changeignorespace
{} {
5446 proc getblobdiffs
{ids
} {
5447 global blobdifffd diffids env
5448 global diffinhdr treediffs
5451 global limitdiffs viewfiles curview
5453 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5457 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5458 set cmd
[concat
$cmd -- $viewfiles($curview)]
5460 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5461 puts
"error getting diffs: $err"
5465 fconfigure
$bdf -blocking 0
5466 set blobdifffd
($ids) $bdf
5467 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5470 proc setinlist
{var i val
} {
5473 while {[llength
[set $var]] < $i} {
5476 if {[llength
[set $var]] == $i} {
5483 proc makediffhdr
{fname ids
} {
5484 global ctext curdiffstart treediffs
5486 set i
[lsearch
-exact $treediffs($ids) $fname]
5488 setinlist difffilestart
$i $curdiffstart
5490 set l
[expr {(78 - [string length
$fname]) / 2}]
5491 set pad
[string range
"----------------------------------------" 1 $l]
5492 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
5495 proc getblobdiffline
{bdf ids
} {
5496 global diffids blobdifffd ctext curdiffstart
5497 global diffnexthead diffnextnote difffilestart
5498 global diffinhdr treediffs
5501 $ctext conf
-state normal
5502 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
5503 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
5507 if {![string compare
-length 11 "diff --git " $line]} {
5508 # trim off "diff --git "
5509 set line
[string range
$line 11 end
]
5511 # start of a new file
5512 $ctext insert end
"\n"
5513 set curdiffstart
[$ctext index
"end - 1c"]
5514 $ctext insert end
"\n" filesep
5515 # If the name hasn't changed the length will be odd,
5516 # the middle char will be a space, and the two bits either
5517 # side will be a/name and b/name, or "a/name" and "b/name".
5518 # If the name has changed we'll get "rename from" and
5519 # "rename to" or "copy from" and "copy to" lines following this,
5520 # and we'll use them to get the filenames.
5521 # This complexity is necessary because spaces in the filename(s)
5522 # don't get escaped.
5523 set l
[string length
$line]
5524 set i
[expr {$l / 2}]
5525 if {!(($l & 1) && [string index
$line $i] eq
" " &&
5526 [string range
$line 2 [expr {$i - 1}]] eq \
5527 [string range
$line [expr {$i + 3}] end
])} {
5530 # unescape if quoted and chop off the a/ from the front
5531 if {[string index
$line 0] eq
"\""} {
5532 set fname
[string range
[lindex
$line 0] 2 end
]
5534 set fname
[string range
$line 2 [expr {$i - 1}]]
5536 makediffhdr
$fname $ids
5538 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
5539 $line match f1l f1c f2l f2c rest
]} {
5540 $ctext insert end
"$line\n" hunksep
5543 } elseif
{$diffinhdr} {
5544 if {![string compare
-length 12 "rename from " $line]} {
5545 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
5546 if {[string index
$fname 0] eq
"\""} {
5547 set fname
[lindex
$fname 0]
5549 set i
[lsearch
-exact $treediffs($ids) $fname]
5551 setinlist difffilestart
$i $curdiffstart
5553 } elseif
{![string compare
-length 10 $line "rename to "] ||
5554 ![string compare
-length 8 $line "copy to "]} {
5555 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
5556 if {[string index
$fname 0] eq
"\""} {
5557 set fname
[lindex
$fname 0]
5559 makediffhdr
$fname $ids
5560 } elseif
{[string compare
-length 3 $line "---"] == 0} {
5563 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
5567 $ctext insert end
"$line\n" filesep
5570 set x
[string range
$line 0 0]
5571 if {$x == "-" ||
$x == "+"} {
5572 set tag
[expr {$x == "+"}]
5573 $ctext insert end
"$line\n" d
$tag
5574 } elseif
{$x == " "} {
5575 $ctext insert end
"$line\n"
5577 # "\ No newline at end of file",
5578 # or something else we don't recognize
5579 $ctext insert end
"$line\n" hunksep
5583 $ctext conf
-state disabled
5588 return [expr {$nr >= 1000?
2: 1}]
5591 proc changediffdisp
{} {
5592 global ctext diffelide
5594 $ctext tag conf d0
-elide [lindex
$diffelide 0]
5595 $ctext tag conf d1
-elide [lindex
$diffelide 1]
5598 proc highlightfile
{loc cline
} {
5599 global ctext cflist cflist_top
5602 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
5603 $cflist tag add highlight
$cline.0 "$cline.0 lineend"
5604 $cflist see
$cline.0
5605 set cflist_top
$cline
5609 global difffilestart ctext cmitmode
5611 if {$cmitmode eq
"tree"} return
5614 set here
[$ctext index @
0,0]
5615 foreach loc
$difffilestart {
5616 if {[$ctext compare
$loc >= $here]} {
5617 highlightfile
$prev $prevline
5623 highlightfile
$prev $prevline
5627 global difffilestart ctext cmitmode
5629 if {$cmitmode eq
"tree"} return
5630 set here
[$ctext index @
0,0]
5632 foreach loc
$difffilestart {
5634 if {[$ctext compare
$loc > $here]} {
5635 highlightfile
$loc $line
5641 proc clear_ctext
{{first
1.0}} {
5642 global ctext smarktop smarkbot
5645 set l
[lindex
[split $first .
] 0]
5646 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
5649 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
5652 $ctext delete
$first end
5653 if {$first eq
"1.0"} {
5654 catch
{unset pendinglinks
}
5658 proc settabs
{{firstab
{}}} {
5659 global firsttabstop tabstop ctext have_tk85
5661 if {$firstab ne
{} && $have_tk85} {
5662 set firsttabstop
$firstab
5664 set w
[font measure textfont
"0"]
5665 if {$firsttabstop != 0} {
5666 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
5667 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5668 } elseif
{$have_tk85 ||
$tabstop != 8} {
5669 $ctext conf
-tabs [expr {$tabstop * $w}]
5671 $ctext conf
-tabs {}
5675 proc incrsearch
{name ix op
} {
5676 global ctext searchstring searchdirn
5678 $ctext tag remove found
1.0 end
5679 if {[catch
{$ctext index anchor
}]} {
5680 # no anchor set, use start of selection, or of visible area
5681 set sel
[$ctext tag ranges sel
]
5683 $ctext mark
set anchor
[lindex
$sel 0]
5684 } elseif
{$searchdirn eq
"-forwards"} {
5685 $ctext mark
set anchor @
0,0
5687 $ctext mark
set anchor @
0,[winfo height
$ctext]
5690 if {$searchstring ne
{}} {
5691 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
5700 global sstring ctext searchstring searchdirn
5703 $sstring icursor end
5704 set searchdirn
-forwards
5705 if {$searchstring ne
{}} {
5706 set sel
[$ctext tag ranges sel
]
5708 set start
"[lindex $sel 0] + 1c"
5709 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5712 set match
[$ctext search
-count mlen
-- $searchstring $start]
5713 $ctext tag remove sel
1.0 end
5719 set mend
"$match + $mlen c"
5720 $ctext tag add sel
$match $mend
5721 $ctext mark
unset anchor
5725 proc dosearchback
{} {
5726 global sstring ctext searchstring searchdirn
5729 $sstring icursor end
5730 set searchdirn
-backwards
5731 if {$searchstring ne
{}} {
5732 set sel
[$ctext tag ranges sel
]
5734 set start
[lindex
$sel 0]
5735 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5736 set start @
0,[winfo height
$ctext]
5738 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
5739 $ctext tag remove sel
1.0 end
5745 set mend
"$match + $ml c"
5746 $ctext tag add sel
$match $mend
5747 $ctext mark
unset anchor
5751 proc searchmark
{first last
} {
5752 global ctext searchstring
5756 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
5757 if {$match eq
{}} break
5758 set mend
"$match + $mlen c"
5759 $ctext tag add found
$match $mend
5763 proc searchmarkvisible
{doall
} {
5764 global ctext smarktop smarkbot
5766 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
5767 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
5768 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
5769 # no overlap with previous
5770 searchmark
$topline $botline
5771 set smarktop
$topline
5772 set smarkbot
$botline
5774 if {$topline < $smarktop} {
5775 searchmark
$topline [expr {$smarktop-1}]
5776 set smarktop
$topline
5778 if {$botline > $smarkbot} {
5779 searchmark
[expr {$smarkbot+1}] $botline
5780 set smarkbot
$botline
5785 proc scrolltext
{f0 f1
} {
5788 .bleft.bottom.sb
set $f0 $f1
5789 if {$searchstring ne
{}} {
5795 global linespc charspc canvx0 canvy0
5796 global xspc1 xspc2 lthickness
5798 set linespc
[font metrics mainfont
-linespace]
5799 set charspc
[font measure mainfont
"m"]
5800 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
5801 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
5802 set lthickness
[expr {int
($linespc / 9) + 1}]
5803 set xspc1
(0) $linespc
5811 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5812 if {$ymax eq
{} ||
$ymax == 0} return
5813 set span
[$canv yview
]
5816 allcanvs yview moveto
[lindex
$span 0]
5818 if {[info exists selectedline
]} {
5819 selectline
$selectedline 0
5820 allcanvs yview moveto
[lindex
$span 0]
5824 proc parsefont
{f n
} {
5827 set fontattr
($f,family
) [lindex
$n 0]
5829 if {$s eq
{} ||
$s == 0} {
5832 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
5834 set fontattr
($f,size
) $s
5835 set fontattr
($f,weight
) normal
5836 set fontattr
($f,slant
) roman
5837 foreach style
[lrange
$n 2 end
] {
5840 "bold" {set fontattr
($f,weight
) $style}
5842 "italic" {set fontattr
($f,slant
) $style}
5847 proc fontflags
{f
{isbold
0}} {
5850 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
5851 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
5852 -slant $fontattr($f,slant
)]
5858 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
5859 if {$fontattr($f,weight
) eq
"bold"} {
5862 if {$fontattr($f,slant
) eq
"italic"} {
5868 proc incrfont
{inc
} {
5869 global mainfont textfont ctext canv phase cflist showrefstop
5870 global stopped entries fontattr
5873 set s
$fontattr(mainfont
,size
)
5878 set fontattr
(mainfont
,size
) $s
5879 font config mainfont
-size $s
5880 font config mainfontbold
-size $s
5881 set mainfont
[fontname mainfont
]
5882 set s
$fontattr(textfont
,size
)
5887 set fontattr
(textfont
,size
) $s
5888 font config textfont
-size $s
5889 font config textfontbold
-size $s
5890 set textfont
[fontname textfont
]
5897 global sha1entry sha1string
5898 if {[string length
$sha1string] == 40} {
5899 $sha1entry delete
0 end
5903 proc sha1change
{n1 n2 op
} {
5904 global sha1string currentid sha1but
5905 if {$sha1string == {}
5906 ||
([info exists currentid
] && $sha1string == $currentid)} {
5911 if {[$sha1but cget
-state] == $state} return
5912 if {$state == "normal"} {
5913 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
5915 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
5919 proc gotocommit
{} {
5920 global sha1string currentid commitrow tagids headids
5921 global displayorder numcommits curview
5923 if {$sha1string == {}
5924 ||
([info exists currentid
] && $sha1string == $currentid)} return
5925 if {[info exists tagids
($sha1string)]} {
5926 set id
$tagids($sha1string)
5927 } elseif
{[info exists headids
($sha1string)]} {
5928 set id
$headids($sha1string)
5930 set id
[string tolower
$sha1string]
5931 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
5933 foreach i
$displayorder {
5934 if {[string match
$id* $i]} {
5938 if {$matches ne
{}} {
5939 if {[llength
$matches] > 1} {
5940 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
5943 set id
[lindex
$matches 0]
5947 if {[info exists commitrow
($curview,$id)]} {
5948 selectline
$commitrow($curview,$id) 1
5951 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
5952 set msg
[mc
"SHA1 id %s is not known" $sha1string]
5954 set msg
[mc
"Tag/Head %s is not known" $sha1string]
5959 proc lineenter
{x y id
} {
5960 global hoverx hovery hoverid hovertimer
5961 global commitinfo canv
5963 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
5967 if {[info exists hovertimer
]} {
5968 after cancel
$hovertimer
5970 set hovertimer
[after
500 linehover
]
5974 proc linemotion
{x y id
} {
5975 global hoverx hovery hoverid hovertimer
5977 if {[info exists hoverid
] && $id == $hoverid} {
5980 if {[info exists hovertimer
]} {
5981 after cancel
$hovertimer
5983 set hovertimer
[after
500 linehover
]
5987 proc lineleave
{id
} {
5988 global hoverid hovertimer canv
5990 if {[info exists hoverid
] && $id == $hoverid} {
5992 if {[info exists hovertimer
]} {
5993 after cancel
$hovertimer
6001 global hoverx hovery hoverid hovertimer
6002 global canv linespc lthickness
6005 set text
[lindex
$commitinfo($hoverid) 0]
6006 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6007 if {$ymax == {}} return
6008 set yfrac
[lindex
[$canv yview
] 0]
6009 set x
[expr {$hoverx + 2 * $linespc}]
6010 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
6011 set x0
[expr {$x - 2 * $lthickness}]
6012 set y0
[expr {$y - 2 * $lthickness}]
6013 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
6014 set y1
[expr {$y + $linespc + 2 * $lthickness}]
6015 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
6016 -fill \
#ffff80 -outline black -width 1 -tags hover]
6018 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
6023 proc clickisonarrow
{id y
} {
6026 set ranges
[rowranges
$id]
6027 set thresh
[expr {2 * $lthickness + 6}]
6028 set n
[expr {[llength
$ranges] - 1}]
6029 for {set i
1} {$i < $n} {incr i
} {
6030 set row
[lindex
$ranges $i]
6031 if {abs
([yc
$row] - $y) < $thresh} {
6038 proc arrowjump
{id n y
} {
6041 # 1 <-> 2, 3 <-> 4, etc...
6042 set n
[expr {(($n - 1) ^
1) + 1}]
6043 set row
[lindex
[rowranges
$id] $n]
6045 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6046 if {$ymax eq
{} ||
$ymax <= 0} return
6047 set view
[$canv yview
]
6048 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
6049 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
6053 allcanvs yview moveto
$yfrac
6056 proc lineclick
{x y id isnew
} {
6057 global ctext commitinfo children canv thickerline curview commitrow
6059 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
6064 # draw this line thicker than normal
6068 set ymax
[lindex
[$canv cget
-scrollregion] 3]
6069 if {$ymax eq
{}} return
6070 set yfrac
[lindex
[$canv yview
] 0]
6071 set y
[expr {$y + $yfrac * $ymax}]
6073 set dirn
[clickisonarrow
$id $y]
6075 arrowjump
$id $dirn $y
6080 addtohistory
[list lineclick
$x $y $id 0]
6082 # fill the details pane with info about this line
6083 $ctext conf
-state normal
6086 $ctext insert end
"[mc "Parent
"]:\t"
6087 $ctext insert end
$id link0
6089 set info
$commitinfo($id)
6090 $ctext insert end
"\n\t[lindex $info 0]\n"
6091 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
6092 set date [formatdate
[lindex
$info 2]]
6093 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
6094 set kids
$children($curview,$id)
6096 $ctext insert end
"\n[mc "Children
"]:"
6098 foreach child
$kids {
6100 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
6101 set info
$commitinfo($child)
6102 $ctext insert end
"\n\t"
6103 $ctext insert end
$child link
$i
6104 setlink
$child link
$i
6105 $ctext insert end
"\n\t[lindex $info 0]"
6106 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
6107 set date [formatdate
[lindex
$info 2]]
6108 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
6111 $ctext conf
-state disabled
6115 proc normalline
{} {
6117 if {[info exists thickerline
]} {
6125 global commitrow curview
6126 if {[info exists commitrow
($curview,$id)]} {
6127 selectline
$commitrow($curview,$id) 1
6133 if {![info exists startmstime
]} {
6134 set startmstime
[clock clicks
-milliseconds]
6136 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
6139 proc rowmenu
{x y id
} {
6140 global rowctxmenu commitrow selectedline rowmenuid curview
6141 global nullid nullid2 fakerowmenu mainhead
6145 if {![info exists selectedline
]
6146 ||
$commitrow($curview,$id) eq
$selectedline} {
6151 if {$id ne
$nullid && $id ne
$nullid2} {
6152 set menu
$rowctxmenu
6153 if {$mainhead ne
{}} {
6154 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6156 $menu entryconfigure
7 -label [mc
"Detached head: can't reset" $mainhead] -state disabled
6159 set menu
$fakerowmenu
6161 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6162 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6163 $menu entryconfigure
[mc
"Make patch"] -state $state
6164 tk_popup
$menu $x $y
6167 proc diffvssel
{dirn
} {
6168 global rowmenuid selectedline displayorder
6170 if {![info exists selectedline
]} return
6172 set oldid
[lindex
$displayorder $selectedline]
6173 set newid
$rowmenuid
6175 set oldid
$rowmenuid
6176 set newid
[lindex
$displayorder $selectedline]
6178 addtohistory
[list doseldiff
$oldid $newid]
6179 doseldiff
$oldid $newid
6182 proc doseldiff
{oldid newid
} {
6186 $ctext conf
-state normal
6188 init_flist
[mc
"Top"]
6189 $ctext insert end
"[mc "From
"] "
6190 $ctext insert end
$oldid link0
6191 setlink
$oldid link0
6192 $ctext insert end
"\n "
6193 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6194 $ctext insert end
"\n\n[mc "To
"] "
6195 $ctext insert end
$newid link1
6196 setlink
$newid link1
6197 $ctext insert end
"\n "
6198 $ctext insert end
[lindex
$commitinfo($newid) 0]
6199 $ctext insert end
"\n"
6200 $ctext conf
-state disabled
6201 $ctext tag remove found
1.0 end
6202 startdiff
[list
$oldid $newid]
6206 global rowmenuid currentid commitinfo patchtop patchnum
6208 if {![info exists currentid
]} return
6209 set oldid
$currentid
6210 set oldhead
[lindex
$commitinfo($oldid) 0]
6211 set newid
$rowmenuid
6212 set newhead
[lindex
$commitinfo($newid) 0]
6215 catch
{destroy
$top}
6217 label
$top.title
-text [mc
"Generate patch"]
6218 grid
$top.title
- -pady 10
6219 label
$top.from
-text [mc
"From:"]
6220 entry
$top.fromsha1
-width 40 -relief flat
6221 $top.fromsha1 insert
0 $oldid
6222 $top.fromsha1 conf
-state readonly
6223 grid
$top.from
$top.fromsha1
-sticky w
6224 entry
$top.fromhead
-width 60 -relief flat
6225 $top.fromhead insert
0 $oldhead
6226 $top.fromhead conf
-state readonly
6227 grid x
$top.fromhead
-sticky w
6228 label
$top.to
-text [mc
"To:"]
6229 entry
$top.tosha1
-width 40 -relief flat
6230 $top.tosha1 insert
0 $newid
6231 $top.tosha1 conf
-state readonly
6232 grid
$top.to
$top.tosha1
-sticky w
6233 entry
$top.tohead
-width 60 -relief flat
6234 $top.tohead insert
0 $newhead
6235 $top.tohead conf
-state readonly
6236 grid x
$top.tohead
-sticky w
6237 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6238 grid
$top.
rev x
-pady 10
6239 label
$top.flab
-text [mc
"Output file:"]
6240 entry
$top.fname
-width 60
6241 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6243 grid
$top.flab
$top.fname
-sticky w
6245 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6246 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6247 grid
$top.buts.gen
$top.buts.can
6248 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6249 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6250 grid
$top.buts
- -pady 10 -sticky ew
6254 proc mkpatchrev
{} {
6257 set oldid
[$patchtop.fromsha1 get
]
6258 set oldhead
[$patchtop.fromhead get
]
6259 set newid
[$patchtop.tosha1 get
]
6260 set newhead
[$patchtop.tohead get
]
6261 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6262 v
[list
$newid $newhead $oldid $oldhead] {
6263 $patchtop.
$e conf
-state normal
6264 $patchtop.
$e delete
0 end
6265 $patchtop.
$e insert
0 $v
6266 $patchtop.
$e conf
-state readonly
6271 global patchtop nullid nullid2
6273 set oldid
[$patchtop.fromsha1 get
]
6274 set newid
[$patchtop.tosha1 get
]
6275 set fname
[$patchtop.fname get
]
6276 set cmd
[diffcmd
[list
$oldid $newid] -p]
6277 # trim off the initial "|"
6278 set cmd
[lrange
$cmd 1 end
]
6279 lappend cmd
>$fname &
6280 if {[catch
{eval exec $cmd} err
]} {
6281 error_popup
"[mc "Error creating
patch:"] $err"
6283 catch
{destroy
$patchtop}
6287 proc mkpatchcan
{} {
6290 catch
{destroy
$patchtop}
6295 global rowmenuid mktagtop commitinfo
6299 catch
{destroy
$top}
6301 label
$top.title
-text [mc
"Create tag"]
6302 grid
$top.title
- -pady 10
6303 label
$top.id
-text [mc
"ID:"]
6304 entry
$top.sha1
-width 40 -relief flat
6305 $top.sha1 insert
0 $rowmenuid
6306 $top.sha1 conf
-state readonly
6307 grid
$top.id
$top.sha1
-sticky w
6308 entry
$top.
head -width 60 -relief flat
6309 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6310 $top.
head conf
-state readonly
6311 grid x
$top.
head -sticky w
6312 label
$top.tlab
-text [mc
"Tag name:"]
6313 entry
$top.tag
-width 60
6314 grid
$top.tlab
$top.tag
-sticky w
6316 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6317 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6318 grid
$top.buts.gen
$top.buts.can
6319 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6320 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6321 grid
$top.buts
- -pady 10 -sticky ew
6326 global mktagtop env tagids idtags
6328 set id
[$mktagtop.sha1 get
]
6329 set tag
[$mktagtop.tag get
]
6331 error_popup
[mc
"No tag name specified"]
6334 if {[info exists tagids
($tag)]} {
6335 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6339 exec git tag
$tag $id
6341 error_popup
"[mc "Error creating tag
:"] $err"
6345 set tagids
($tag) $id
6346 lappend idtags
($id) $tag
6353 proc redrawtags
{id
} {
6354 global canv linehtag commitrow idpos selectedline curview
6355 global canvxmax iddrawn
6357 if {![info exists commitrow
($curview,$id)]} return
6358 if {![info exists iddrawn
($id)]} return
6359 drawcommits
$commitrow($curview,$id)
6360 $canv delete tag.
$id
6361 set xt
[eval drawtags
$id $idpos($id)]
6362 $canv coords
$linehtag($commitrow($curview,$id)) $xt [lindex
$idpos($id) 2]
6363 set text
[$canv itemcget
$linehtag($commitrow($curview,$id)) -text]
6364 set xr
[expr {$xt + [font measure mainfont
$text]}]
6365 if {$xr > $canvxmax} {
6369 if {[info exists selectedline
]
6370 && $selectedline == $commitrow($curview,$id)} {
6371 selectline
$selectedline 0
6378 catch
{destroy
$mktagtop}
6387 proc writecommit
{} {
6388 global rowmenuid wrcomtop commitinfo wrcomcmd
6390 set top .writecommit
6392 catch
{destroy
$top}
6394 label
$top.title
-text [mc
"Write commit to file"]
6395 grid
$top.title
- -pady 10
6396 label
$top.id
-text [mc
"ID:"]
6397 entry
$top.sha1
-width 40 -relief flat
6398 $top.sha1 insert
0 $rowmenuid
6399 $top.sha1 conf
-state readonly
6400 grid
$top.id
$top.sha1
-sticky w
6401 entry
$top.
head -width 60 -relief flat
6402 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6403 $top.
head conf
-state readonly
6404 grid x
$top.
head -sticky w
6405 label
$top.clab
-text [mc
"Command:"]
6406 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6407 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6408 label
$top.flab
-text [mc
"Output file:"]
6409 entry
$top.fname
-width 60
6410 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6411 grid
$top.flab
$top.fname
-sticky w
6413 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6414 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6415 grid
$top.buts.gen
$top.buts.can
6416 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6417 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6418 grid
$top.buts
- -pady 10 -sticky ew
6425 set id
[$wrcomtop.sha1 get
]
6426 set cmd
"echo $id | [$wrcomtop.cmd get]"
6427 set fname
[$wrcomtop.fname get
]
6428 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6429 error_popup
"[mc "Error writing commit
:"] $err"
6431 catch
{destroy
$wrcomtop}
6438 catch
{destroy
$wrcomtop}
6443 global rowmenuid mkbrtop
6446 catch
{destroy
$top}
6448 label
$top.title
-text [mc
"Create new branch"]
6449 grid
$top.title
- -pady 10
6450 label
$top.id
-text [mc
"ID:"]
6451 entry
$top.sha1
-width 40 -relief flat
6452 $top.sha1 insert
0 $rowmenuid
6453 $top.sha1 conf
-state readonly
6454 grid
$top.id
$top.sha1
-sticky w
6455 label
$top.nlab
-text [mc
"Name:"]
6456 entry
$top.name
-width 40
6457 grid
$top.nlab
$top.name
-sticky w
6459 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6460 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6461 grid
$top.buts.go
$top.buts.can
6462 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6463 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6464 grid
$top.buts
- -pady 10 -sticky ew
6469 global headids idheads
6471 set name
[$top.name get
]
6472 set id
[$top.sha1 get
]
6474 error_popup
[mc
"Please specify a name for the new branch"]
6477 catch
{destroy
$top}
6481 exec git branch
$name $id
6486 set headids
($name) $id
6487 lappend idheads
($id) $name
6496 proc cherrypick
{} {
6497 global rowmenuid curview commitrow
6500 set oldhead
[exec git rev-parse HEAD
]
6501 set dheads
[descheads
$rowmenuid]
6502 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
6503 set ok
[confirm_popup
[mc
"Commit %s is already\
6504 included in branch %s -- really re-apply it?" \
6505 [string range
$rowmenuid 0 7] $mainhead]]
6508 nowbusy cherrypick
[mc
"Cherry-picking"]
6510 # Unfortunately git-cherry-pick writes stuff to stderr even when
6511 # no error occurs, and exec takes that as an indication of error...
6512 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
6517 set newhead
[exec git rev-parse HEAD
]
6518 if {$newhead eq
$oldhead} {
6520 error_popup
[mc
"No changes committed"]
6523 addnewchild
$newhead $oldhead
6524 if {[info exists commitrow
($curview,$oldhead)]} {
6525 insertrow
$commitrow($curview,$oldhead) $newhead
6526 if {$mainhead ne
{}} {
6527 movehead
$newhead $mainhead
6528 movedhead
$newhead $mainhead
6537 global mainheadid mainhead rowmenuid confirm_ok resettype
6540 set w
".confirmreset"
6543 wm title
$w [mc
"Confirm reset"]
6544 message
$w.m
-text \
6545 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
6546 -justify center
-aspect 1000
6547 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
6548 frame
$w.f
-relief sunken
-border 2
6549 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
6550 grid
$w.f.rt
-sticky w
6552 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
6553 -text [mc
"Soft: Leave working tree and index untouched"]
6554 grid
$w.f.soft
-sticky w
6555 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
6556 -text [mc
"Mixed: Leave working tree untouched, reset index"]
6557 grid
$w.f.mixed
-sticky w
6558 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
6559 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
6560 grid
$w.f.hard
-sticky w
6561 pack
$w.f
-side top
-fill x
6562 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
6563 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
6564 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
6565 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
6566 bind $w <Visibility
> "grab $w; focus $w"
6568 if {!$confirm_ok} return
6569 if {[catch
{set fd
[open \
6570 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
6574 filerun
$fd [list readresetstat
$fd]
6575 nowbusy
reset [mc
"Resetting"]
6579 proc readresetstat
{fd
} {
6580 global mainhead mainheadid showlocalchanges rprogcoord
6582 if {[gets
$fd line
] >= 0} {
6583 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
6584 set rprogcoord
[expr {1.0 * $m / $n}]
6592 if {[catch
{close
$fd} err
]} {
6595 set oldhead
$mainheadid
6596 set newhead
[exec git rev-parse HEAD
]
6597 if {$newhead ne
$oldhead} {
6598 movehead
$newhead $mainhead
6599 movedhead
$newhead $mainhead
6600 set mainheadid
$newhead
6604 if {$showlocalchanges} {
6610 # context menu for a head
6611 proc headmenu
{x y id
head} {
6612 global headmenuid headmenuhead headctxmenu mainhead
6616 set headmenuhead
$head
6618 if {$head eq
$mainhead} {
6621 $headctxmenu entryconfigure
0 -state $state
6622 $headctxmenu entryconfigure
1 -state $state
6623 tk_popup
$headctxmenu $x $y
6627 global headmenuid headmenuhead mainhead headids
6628 global showlocalchanges mainheadid
6630 # check the tree is clean first??
6631 set oldmainhead
$mainhead
6632 nowbusy checkout
[mc
"Checking out"]
6636 exec git checkout
-q $headmenuhead
6642 set mainhead
$headmenuhead
6643 set mainheadid
$headmenuid
6644 if {[info exists headids
($oldmainhead)]} {
6645 redrawtags
$headids($oldmainhead)
6647 redrawtags
$headmenuid
6649 if {$showlocalchanges} {
6655 global headmenuid headmenuhead mainhead
6658 set head $headmenuhead
6660 # this check shouldn't be needed any more...
6661 if {$head eq
$mainhead} {
6662 error_popup
[mc
"Cannot delete the currently checked-out branch"]
6665 set dheads
[descheads
$id]
6666 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
6667 # the stuff on this branch isn't on any other branch
6668 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
6669 branch.\nReally delete branch %s?" $head $head]]} return
6673 if {[catch
{exec git branch
-D $head} err
]} {
6678 removehead
$id $head
6679 removedhead
$id $head
6686 # Display a list of tags and heads
6688 global showrefstop bgcolor fgcolor selectbgcolor
6689 global bglist fglist reflistfilter reflist maincursor
6692 set showrefstop
$top
6693 if {[winfo exists
$top]} {
6699 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
6700 text
$top.list
-background $bgcolor -foreground $fgcolor \
6701 -selectbackground $selectbgcolor -font mainfont \
6702 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6703 -width 30 -height 20 -cursor $maincursor \
6704 -spacing1 1 -spacing3 1 -state disabled
6705 $top.list tag configure highlight
-background $selectbgcolor
6706 lappend bglist
$top.list
6707 lappend fglist
$top.list
6708 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
6709 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
6710 grid
$top.list
$top.ysb
-sticky nsew
6711 grid
$top.xsb x
-sticky ew
6713 label
$top.f.l
-text "[mc "Filter
"]: "
6714 entry
$top.f.e
-width 20 -textvariable reflistfilter
6715 set reflistfilter
"*"
6716 trace add variable reflistfilter
write reflistfilter_change
6717 pack
$top.f.e
-side right
-fill x
-expand 1
6718 pack
$top.f.l
-side left
6719 grid
$top.f
- -sticky ew
-pady 2
6720 button
$top.close
-command [list destroy
$top] -text [mc
"Close"]
6722 grid columnconfigure
$top 0 -weight 1
6723 grid rowconfigure
$top 0 -weight 1
6724 bind $top.list
<1> {break}
6725 bind $top.list
<B1-Motion
> {break}
6726 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
6731 proc sel_reflist
{w x y
} {
6732 global showrefstop reflist headids tagids otherrefids
6734 if {![winfo exists
$showrefstop]} return
6735 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
6736 set ref
[lindex
$reflist [expr {$l-1}]]
6737 set n
[lindex
$ref 0]
6738 switch
-- [lindex
$ref 1] {
6739 "H" {selbyid
$headids($n)}
6740 "T" {selbyid
$tagids($n)}
6741 "o" {selbyid
$otherrefids($n)}
6743 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
6746 proc unsel_reflist
{} {
6749 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6750 $showrefstop.list tag remove highlight
0.0 end
6753 proc reflistfilter_change
{n1 n2 op
} {
6754 global reflistfilter
6756 after cancel refill_reflist
6757 after
200 refill_reflist
6760 proc refill_reflist
{} {
6761 global reflist reflistfilter showrefstop headids tagids otherrefids
6762 global commitrow curview commitinterest
6764 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6766 foreach n
[array names headids
] {
6767 if {[string match
$reflistfilter $n]} {
6768 if {[info exists commitrow
($curview,$headids($n))]} {
6769 lappend refs
[list
$n H
]
6771 set commitinterest
($headids($n)) {run refill_reflist
}
6775 foreach n
[array names tagids
] {
6776 if {[string match
$reflistfilter $n]} {
6777 if {[info exists commitrow
($curview,$tagids($n))]} {
6778 lappend refs
[list
$n T
]
6780 set commitinterest
($tagids($n)) {run refill_reflist
}
6784 foreach n
[array names otherrefids
] {
6785 if {[string match
$reflistfilter $n]} {
6786 if {[info exists commitrow
($curview,$otherrefids($n))]} {
6787 lappend refs
[list
$n o
]
6789 set commitinterest
($otherrefids($n)) {run refill_reflist
}
6793 set refs
[lsort
-index 0 $refs]
6794 if {$refs eq
$reflist} return
6796 # Update the contents of $showrefstop.list according to the
6797 # differences between $reflist (old) and $refs (new)
6798 $showrefstop.list conf
-state normal
6799 $showrefstop.list insert end
"\n"
6802 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
6803 if {$i < [llength
$reflist]} {
6804 if {$j < [llength
$refs]} {
6805 set cmp [string compare
[lindex
$reflist $i 0] \
6806 [lindex
$refs $j 0]]
6808 set cmp [string compare
[lindex
$reflist $i 1] \
6809 [lindex
$refs $j 1]]
6819 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
6827 set l
[expr {$j + 1}]
6828 $showrefstop.list image create
$l.0 -align baseline \
6829 -image reficon-
[lindex
$refs $j 1] -padx 2
6830 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
6836 # delete last newline
6837 $showrefstop.list delete end-2c end-1c
6838 $showrefstop.list conf
-state disabled
6841 # Stuff for finding nearby tags
6842 proc getallcommits
{} {
6843 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6844 global idheads idtags idotherrefs allparents tagobjid
6846 if {![info exists allcommits
]} {
6852 set allccache
[file join [gitdir
] "gitk.cache"]
6854 set f
[open
$allccache r
]
6863 set cmd
[list | git rev-list
--parents]
6864 set allcupdate
[expr {$seeds ne
{}}]
6868 set refs
[concat
[array names idheads
] [array names idtags
] \
6869 [array names idotherrefs
]]
6872 foreach name
[array names tagobjid
] {
6873 lappend tagobjs
$tagobjid($name)
6875 foreach id
[lsort
-unique $refs] {
6876 if {![info exists allparents
($id)] &&
6877 [lsearch
-exact $tagobjs $id] < 0} {
6888 set fd
[open
[concat
$cmd $ids] r
]
6889 fconfigure
$fd -blocking 0
6892 filerun
$fd [list getallclines
$fd]
6898 # Since most commits have 1 parent and 1 child, we group strings of
6899 # such commits into "arcs" joining branch/merge points (BMPs), which
6900 # are commits that either don't have 1 parent or don't have 1 child.
6902 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6903 # arcout(id) - outgoing arcs for BMP
6904 # arcids(a) - list of IDs on arc including end but not start
6905 # arcstart(a) - BMP ID at start of arc
6906 # arcend(a) - BMP ID at end of arc
6907 # growing(a) - arc a is still growing
6908 # arctags(a) - IDs out of arcids (excluding end) that have tags
6909 # archeads(a) - IDs out of arcids (excluding end) that have heads
6910 # The start of an arc is at the descendent end, so "incoming" means
6911 # coming from descendents, and "outgoing" means going towards ancestors.
6913 proc getallclines
{fd
} {
6914 global allparents allchildren idtags idheads nextarc
6915 global arcnos arcids arctags arcout arcend arcstart archeads growing
6916 global seeds allcommits cachedarcs allcupdate
6919 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
6920 set id
[lindex
$line 0]
6921 if {[info exists allparents
($id)]} {
6926 set olds
[lrange
$line 1 end
]
6927 set allparents
($id) $olds
6928 if {![info exists allchildren
($id)]} {
6929 set allchildren
($id) {}
6934 if {[llength
$olds] == 1 && [llength
$a] == 1} {
6935 lappend arcids
($a) $id
6936 if {[info exists idtags
($id)]} {
6937 lappend arctags
($a) $id
6939 if {[info exists idheads
($id)]} {
6940 lappend archeads
($a) $id
6942 if {[info exists allparents
($olds)]} {
6943 # seen parent already
6944 if {![info exists arcout
($olds)]} {
6947 lappend arcids
($a) $olds
6948 set arcend
($a) $olds
6951 lappend allchildren
($olds) $id
6952 lappend arcnos
($olds) $a
6956 foreach a
$arcnos($id) {
6957 lappend arcids
($a) $id
6964 lappend allchildren
($p) $id
6965 set a
[incr nextarc
]
6966 set arcstart
($a) $id
6973 if {[info exists allparents
($p)]} {
6974 # seen it already, may need to make a new branch
6975 if {![info exists arcout
($p)]} {
6978 lappend arcids
($a) $p
6982 lappend arcnos
($p) $a
6987 global cached_dheads cached_dtags cached_atags
6988 catch
{unset cached_dheads
}
6989 catch
{unset cached_dtags
}
6990 catch
{unset cached_atags
}
6993 return [expr {$nid >= 1000?
2: 1}]
6997 fconfigure
$fd -blocking 1
7000 # got an error reading the list of commits
7001 # if we were updating, try rereading the whole thing again
7007 error_popup
"[mc "Error reading commit topology information
;\
7008 branch and preceding
/following tag information\
7009 will be incomplete.
"]\n($err)"
7012 if {[incr allcommits
-1] == 0} {
7022 proc recalcarc
{a
} {
7023 global arctags archeads arcids idtags idheads
7027 foreach id
[lrange
$arcids($a) 0 end-1
] {
7028 if {[info exists idtags
($id)]} {
7031 if {[info exists idheads
($id)]} {
7036 set archeads
($a) $ah
7040 global arcnos arcids nextarc arctags archeads idtags idheads
7041 global arcstart arcend arcout allparents growing
7044 if {[llength
$a] != 1} {
7045 puts
"oops splitarc called but [llength $a] arcs already"
7049 set i
[lsearch
-exact $arcids($a) $p]
7051 puts
"oops splitarc $p not in arc $a"
7054 set na
[incr nextarc
]
7055 if {[info exists arcend
($a)]} {
7056 set arcend
($na) $arcend($a)
7058 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
7059 set j
[lsearch
-exact $arcnos($l) $a]
7060 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
7062 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
7063 set arcids
($a) [lrange
$arcids($a) 0 $i]
7065 set arcstart
($na) $p
7067 set arcids
($na) $tail
7068 if {[info exists growing
($a)]} {
7074 if {[llength
$arcnos($id)] == 1} {
7077 set j
[lsearch
-exact $arcnos($id) $a]
7078 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
7082 # reconstruct tags and heads lists
7083 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
7088 set archeads
($na) {}
7092 # Update things for a new commit added that is a child of one
7093 # existing commit. Used when cherry-picking.
7094 proc addnewchild
{id p
} {
7095 global allparents allchildren idtags nextarc
7096 global arcnos arcids arctags arcout arcend arcstart archeads growing
7097 global seeds allcommits
7099 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
7100 set allparents
($id) [list
$p]
7101 set allchildren
($id) {}
7104 lappend allchildren
($p) $id
7105 set a
[incr nextarc
]
7106 set arcstart
($a) $id
7109 set arcids
($a) [list
$p]
7111 if {![info exists arcout
($p)]} {
7114 lappend arcnos
($p) $a
7115 set arcout
($id) [list
$a]
7118 # This implements a cache for the topology information.
7119 # The cache saves, for each arc, the start and end of the arc,
7120 # the ids on the arc, and the outgoing arcs from the end.
7121 proc readcache
{f
} {
7122 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7123 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7128 if {$lim - $a > 500} {
7129 set lim
[expr {$a + 500}]
7133 # finish reading the cache and setting up arctags, etc.
7135 if {$line ne
"1"} {error
"bad final version"}
7137 foreach id
[array names idtags
] {
7138 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7139 [llength
$allparents($id)] == 1} {
7140 set a
[lindex
$arcnos($id) 0]
7141 if {$arctags($a) eq
{}} {
7146 foreach id
[array names idheads
] {
7147 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
7148 [llength
$allparents($id)] == 1} {
7149 set a
[lindex
$arcnos($id) 0]
7150 if {$archeads($a) eq
{}} {
7155 foreach id
[lsort
-unique $possible_seeds] {
7156 if {$arcnos($id) eq
{}} {
7162 while {[incr a
] <= $lim} {
7164 if {[llength
$line] != 3} {error
"bad line"}
7165 set s
[lindex
$line 0]
7167 lappend arcout
($s) $a
7168 if {![info exists arcnos
($s)]} {
7169 lappend possible_seeds
$s
7172 set e
[lindex
$line 1]
7177 if {![info exists arcout
($e)]} {
7181 set arcids
($a) [lindex
$line 2]
7182 foreach id
$arcids($a) {
7183 lappend allparents
($s) $id
7185 lappend arcnos
($id) $a
7187 if {![info exists allparents
($s)]} {
7188 set allparents
($s) {}
7193 set nextarc
[expr {$a - 1}]
7206 global nextarc cachedarcs possible_seeds
7210 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7211 # make sure it's an integer
7212 set cachedarcs
[expr {int
([lindex
$line 1])}]
7213 if {$cachedarcs < 0} {error
"bad number of arcs"}
7215 set possible_seeds
{}
7223 proc dropcache
{err
} {
7224 global allcwait nextarc cachedarcs seeds
7226 #puts "dropping cache ($err)"
7227 foreach v
{arcnos arcout arcids arcstart arcend growing \
7228 arctags archeads allparents allchildren
} {
7239 proc writecache
{f
} {
7240 global cachearc cachedarcs allccache
7241 global arcstart arcend arcnos arcids arcout
7245 if {$lim - $a > 1000} {
7246 set lim
[expr {$a + 1000}]
7249 while {[incr a
] <= $lim} {
7250 if {[info exists arcend
($a)]} {
7251 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7253 puts
$f [list
$arcstart($a) {} $arcids($a)]
7258 catch
{file delete
$allccache}
7259 #puts "writing cache failed ($err)"
7262 set cachearc
[expr {$a - 1}]
7263 if {$a > $cachedarcs} {
7272 global nextarc cachedarcs cachearc allccache
7274 if {$nextarc == $cachedarcs} return
7276 set cachedarcs
$nextarc
7278 set f
[open
$allccache w
]
7279 puts
$f [list
1 $cachedarcs]
7284 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7285 # or 0 if neither is true.
7286 proc anc_or_desc
{a b
} {
7287 global arcout arcstart arcend arcnos cached_isanc
7289 if {$arcnos($a) eq
$arcnos($b)} {
7290 # Both are on the same arc(s); either both are the same BMP,
7291 # or if one is not a BMP, the other is also not a BMP or is
7292 # the BMP at end of the arc (and it only has 1 incoming arc).
7293 # Or both can be BMPs with no incoming arcs.
7294 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7297 # assert {[llength $arcnos($a)] == 1}
7298 set arc
[lindex
$arcnos($a) 0]
7299 set i
[lsearch
-exact $arcids($arc) $a]
7300 set j
[lsearch
-exact $arcids($arc) $b]
7301 if {$i < 0 ||
$i > $j} {
7308 if {![info exists arcout
($a)]} {
7309 set arc
[lindex
$arcnos($a) 0]
7310 if {[info exists arcend
($arc)]} {
7311 set aend
$arcend($arc)
7315 set a
$arcstart($arc)
7319 if {![info exists arcout
($b)]} {
7320 set arc
[lindex
$arcnos($b) 0]
7321 if {[info exists arcend
($arc)]} {
7322 set bend
$arcend($arc)
7326 set b
$arcstart($arc)
7336 if {[info exists cached_isanc
($a,$bend)]} {
7337 if {$cached_isanc($a,$bend)} {
7341 if {[info exists cached_isanc
($b,$aend)]} {
7342 if {$cached_isanc($b,$aend)} {
7345 if {[info exists cached_isanc
($a,$bend)]} {
7350 set todo
[list
$a $b]
7353 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7354 set x
[lindex
$todo $i]
7355 if {$anc($x) eq
{}} {
7358 foreach arc
$arcnos($x) {
7359 set xd
$arcstart($arc)
7361 set cached_isanc
($a,$bend) 1
7362 set cached_isanc
($b,$aend) 0
7364 } elseif
{$xd eq
$aend} {
7365 set cached_isanc
($b,$aend) 1
7366 set cached_isanc
($a,$bend) 0
7369 if {![info exists anc
($xd)]} {
7370 set anc
($xd) $anc($x)
7372 } elseif
{$anc($xd) ne
$anc($x)} {
7377 set cached_isanc
($a,$bend) 0
7378 set cached_isanc
($b,$aend) 0
7382 # This identifies whether $desc has an ancestor that is
7383 # a growing tip of the graph and which is not an ancestor of $anc
7384 # and returns 0 if so and 1 if not.
7385 # If we subsequently discover a tag on such a growing tip, and that
7386 # turns out to be a descendent of $anc (which it could, since we
7387 # don't necessarily see children before parents), then $desc
7388 # isn't a good choice to display as a descendent tag of
7389 # $anc (since it is the descendent of another tag which is
7390 # a descendent of $anc). Similarly, $anc isn't a good choice to
7391 # display as a ancestor tag of $desc.
7393 proc is_certain
{desc anc
} {
7394 global arcnos arcout arcstart arcend growing problems
7397 if {[llength
$arcnos($anc)] == 1} {
7398 # tags on the same arc are certain
7399 if {$arcnos($desc) eq
$arcnos($anc)} {
7402 if {![info exists arcout
($anc)]} {
7403 # if $anc is partway along an arc, use the start of the arc instead
7404 set a
[lindex
$arcnos($anc) 0]
7405 set anc
$arcstart($a)
7408 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7411 set a
[lindex
$arcnos($desc) 0]
7417 set anclist
[list
$x]
7421 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7422 set x
[lindex
$anclist $i]
7427 foreach a
$arcout($x) {
7428 if {[info exists growing
($a)]} {
7429 if {![info exists growanc
($x)] && $dl($x)} {
7435 if {[info exists dl
($y)]} {
7439 if {![info exists
done($y)]} {
7442 if {[info exists growanc
($x)]} {
7446 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7447 set z
[lindex
$xl $k]
7448 foreach c
$arcout($z) {
7449 if {[info exists arcend
($c)]} {
7451 if {[info exists dl
($v)] && $dl($v)} {
7453 if {![info exists
done($v)]} {
7456 if {[info exists growanc
($v)]} {
7466 } elseif
{$y eq
$anc ||
!$dl($x)} {
7477 foreach x
[array names growanc
] {
7486 proc validate_arctags
{a
} {
7487 global arctags idtags
7491 foreach id
$arctags($a) {
7493 if {![info exists idtags
($id)]} {
7494 set na
[lreplace
$na $i $i]
7501 proc validate_archeads
{a
} {
7502 global archeads idheads
7505 set na
$archeads($a)
7506 foreach id
$archeads($a) {
7508 if {![info exists idheads
($id)]} {
7509 set na
[lreplace
$na $i $i]
7513 set archeads
($a) $na
7516 # Return the list of IDs that have tags that are descendents of id,
7517 # ignoring IDs that are descendents of IDs already reported.
7518 proc desctags
{id
} {
7519 global arcnos arcstart arcids arctags idtags allparents
7520 global growing cached_dtags
7522 if {![info exists allparents
($id)]} {
7525 set t1
[clock clicks
-milliseconds]
7527 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7528 # part-way along an arc; check that arc first
7529 set a
[lindex
$arcnos($id) 0]
7530 if {$arctags($a) ne
{}} {
7532 set i
[lsearch
-exact $arcids($a) $id]
7534 foreach t
$arctags($a) {
7535 set j
[lsearch
-exact $arcids($a) $t]
7543 set id
$arcstart($a)
7544 if {[info exists idtags
($id)]} {
7548 if {[info exists cached_dtags
($id)]} {
7549 return $cached_dtags($id)
7556 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7557 set id
[lindex
$todo $i]
7559 set ta
[info exists hastaggedancestor
($id)]
7563 # ignore tags on starting node
7564 if {!$ta && $i > 0} {
7565 if {[info exists idtags
($id)]} {
7568 } elseif
{[info exists cached_dtags
($id)]} {
7569 set tagloc
($id) $cached_dtags($id)
7573 foreach a
$arcnos($id) {
7575 if {!$ta && $arctags($a) ne
{}} {
7577 if {$arctags($a) ne
{}} {
7578 lappend tagloc
($id) [lindex
$arctags($a) end
]
7581 if {$ta ||
$arctags($a) ne
{}} {
7582 set tomark
[list
$d]
7583 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7584 set dd [lindex
$tomark $j]
7585 if {![info exists hastaggedancestor
($dd)]} {
7586 if {[info exists
done($dd)]} {
7587 foreach b
$arcnos($dd) {
7588 lappend tomark
$arcstart($b)
7590 if {[info exists tagloc
($dd)]} {
7593 } elseif
{[info exists queued
($dd)]} {
7596 set hastaggedancestor
($dd) 1
7600 if {![info exists queued
($d)]} {
7603 if {![info exists hastaggedancestor
($d)]} {
7610 foreach id
[array names tagloc
] {
7611 if {![info exists hastaggedancestor
($id)]} {
7612 foreach t
$tagloc($id) {
7613 if {[lsearch
-exact $tags $t] < 0} {
7619 set t2
[clock clicks
-milliseconds]
7622 # remove tags that are descendents of other tags
7623 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7624 set a
[lindex
$tags $i]
7625 for {set j
0} {$j < $i} {incr j
} {
7626 set b
[lindex
$tags $j]
7627 set r
[anc_or_desc
$a $b]
7629 set tags
[lreplace
$tags $j $j]
7632 } elseif
{$r == -1} {
7633 set tags
[lreplace
$tags $i $i]
7640 if {[array names growing
] ne
{}} {
7641 # graph isn't finished, need to check if any tag could get
7642 # eclipsed by another tag coming later. Simply ignore any
7643 # tags that could later get eclipsed.
7646 if {[is_certain
$t $origid]} {
7650 if {$tags eq
$ctags} {
7651 set cached_dtags
($origid) $tags
7656 set cached_dtags
($origid) $tags
7658 set t3
[clock clicks
-milliseconds]
7659 if {0 && $t3 - $t1 >= 100} {
7660 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
7661 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7667 global arcnos arcids arcout arcend arctags idtags allparents
7668 global growing cached_atags
7670 if {![info exists allparents
($id)]} {
7673 set t1
[clock clicks
-milliseconds]
7675 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7676 # part-way along an arc; check that arc first
7677 set a
[lindex
$arcnos($id) 0]
7678 if {$arctags($a) ne
{}} {
7680 set i
[lsearch
-exact $arcids($a) $id]
7681 foreach t
$arctags($a) {
7682 set j
[lsearch
-exact $arcids($a) $t]
7688 if {![info exists arcend
($a)]} {
7692 if {[info exists idtags
($id)]} {
7696 if {[info exists cached_atags
($id)]} {
7697 return $cached_atags($id)
7705 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7706 set id
[lindex
$todo $i]
7708 set td
[info exists hastaggeddescendent
($id)]
7712 # ignore tags on starting node
7713 if {!$td && $i > 0} {
7714 if {[info exists idtags
($id)]} {
7717 } elseif
{[info exists cached_atags
($id)]} {
7718 set tagloc
($id) $cached_atags($id)
7722 foreach a
$arcout($id) {
7723 if {!$td && $arctags($a) ne
{}} {
7725 if {$arctags($a) ne
{}} {
7726 lappend tagloc
($id) [lindex
$arctags($a) 0]
7729 if {![info exists arcend
($a)]} continue
7731 if {$td ||
$arctags($a) ne
{}} {
7732 set tomark
[list
$d]
7733 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7734 set dd [lindex
$tomark $j]
7735 if {![info exists hastaggeddescendent
($dd)]} {
7736 if {[info exists
done($dd)]} {
7737 foreach b
$arcout($dd) {
7738 if {[info exists arcend
($b)]} {
7739 lappend tomark
$arcend($b)
7742 if {[info exists tagloc
($dd)]} {
7745 } elseif
{[info exists queued
($dd)]} {
7748 set hastaggeddescendent
($dd) 1
7752 if {![info exists queued
($d)]} {
7755 if {![info exists hastaggeddescendent
($d)]} {
7761 set t2
[clock clicks
-milliseconds]
7764 foreach id
[array names tagloc
] {
7765 if {![info exists hastaggeddescendent
($id)]} {
7766 foreach t
$tagloc($id) {
7767 if {[lsearch
-exact $tags $t] < 0} {
7774 # remove tags that are ancestors of other tags
7775 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7776 set a
[lindex
$tags $i]
7777 for {set j
0} {$j < $i} {incr j
} {
7778 set b
[lindex
$tags $j]
7779 set r
[anc_or_desc
$a $b]
7781 set tags
[lreplace
$tags $j $j]
7784 } elseif
{$r == 1} {
7785 set tags
[lreplace
$tags $i $i]
7792 if {[array names growing
] ne
{}} {
7793 # graph isn't finished, need to check if any tag could get
7794 # eclipsed by another tag coming later. Simply ignore any
7795 # tags that could later get eclipsed.
7798 if {[is_certain
$origid $t]} {
7802 if {$tags eq
$ctags} {
7803 set cached_atags
($origid) $tags
7808 set cached_atags
($origid) $tags
7810 set t3
[clock clicks
-milliseconds]
7811 if {0 && $t3 - $t1 >= 100} {
7812 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
7813 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7818 # Return the list of IDs that have heads that are descendents of id,
7819 # including id itself if it has a head.
7820 proc descheads
{id
} {
7821 global arcnos arcstart arcids archeads idheads cached_dheads
7824 if {![info exists allparents
($id)]} {
7828 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7829 # part-way along an arc; check it first
7830 set a
[lindex
$arcnos($id) 0]
7831 if {$archeads($a) ne
{}} {
7832 validate_archeads
$a
7833 set i
[lsearch
-exact $arcids($a) $id]
7834 foreach t
$archeads($a) {
7835 set j
[lsearch
-exact $arcids($a) $t]
7840 set id
$arcstart($a)
7846 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7847 set id
[lindex
$todo $i]
7848 if {[info exists cached_dheads
($id)]} {
7849 set ret
[concat
$ret $cached_dheads($id)]
7851 if {[info exists idheads
($id)]} {
7854 foreach a
$arcnos($id) {
7855 if {$archeads($a) ne
{}} {
7856 validate_archeads
$a
7857 if {$archeads($a) ne
{}} {
7858 set ret
[concat
$ret $archeads($a)]
7862 if {![info exists seen
($d)]} {
7869 set ret
[lsort
-unique $ret]
7870 set cached_dheads
($origid) $ret
7871 return [concat
$ret $aret]
7874 proc addedtag
{id
} {
7875 global arcnos arcout cached_dtags cached_atags
7877 if {![info exists arcnos
($id)]} return
7878 if {![info exists arcout
($id)]} {
7879 recalcarc
[lindex
$arcnos($id) 0]
7881 catch
{unset cached_dtags
}
7882 catch
{unset cached_atags
}
7885 proc addedhead
{hid
head} {
7886 global arcnos arcout cached_dheads
7888 if {![info exists arcnos
($hid)]} return
7889 if {![info exists arcout
($hid)]} {
7890 recalcarc
[lindex
$arcnos($hid) 0]
7892 catch
{unset cached_dheads
}
7895 proc removedhead
{hid
head} {
7896 global cached_dheads
7898 catch
{unset cached_dheads
}
7901 proc movedhead
{hid
head} {
7902 global arcnos arcout cached_dheads
7904 if {![info exists arcnos
($hid)]} return
7905 if {![info exists arcout
($hid)]} {
7906 recalcarc
[lindex
$arcnos($hid) 0]
7908 catch
{unset cached_dheads
}
7911 proc changedrefs
{} {
7912 global cached_dheads cached_dtags cached_atags
7913 global arctags archeads arcnos arcout idheads idtags
7915 foreach id
[concat
[array names idheads
] [array names idtags
]] {
7916 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
7917 set a
[lindex
$arcnos($id) 0]
7918 if {![info exists donearc
($a)]} {
7924 catch
{unset cached_dtags
}
7925 catch
{unset cached_atags
}
7926 catch
{unset cached_dheads
}
7929 proc rereadrefs
{} {
7930 global idtags idheads idotherrefs mainhead
7932 set refids
[concat
[array names idtags
] \
7933 [array names idheads
] [array names idotherrefs
]]
7934 foreach id
$refids {
7935 if {![info exists ref
($id)]} {
7936 set ref
($id) [listrefs
$id]
7939 set oldmainhead
$mainhead
7942 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
7943 [array names idheads
] [array names idotherrefs
]]]
7944 foreach id
$refids {
7945 set v
[listrefs
$id]
7946 if {![info exists ref
($id)] ||
$ref($id) != $v ||
7947 ($id eq
$oldmainhead && $id ne
$mainhead) ||
7948 ($id eq
$mainhead && $id ne
$oldmainhead)} {
7955 proc listrefs
{id
} {
7956 global idtags idheads idotherrefs
7959 if {[info exists idtags
($id)]} {
7963 if {[info exists idheads
($id)]} {
7967 if {[info exists idotherrefs
($id)]} {
7968 set z
$idotherrefs($id)
7970 return [list
$x $y $z]
7973 proc showtag
{tag isnew
} {
7974 global ctext tagcontents tagids linknum tagobjid
7977 addtohistory
[list showtag
$tag 0]
7979 $ctext conf
-state normal
7983 if {![info exists tagcontents
($tag)]} {
7985 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
7988 if {[info exists tagcontents
($tag)]} {
7989 set text
$tagcontents($tag)
7991 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
7993 appendwithlinks
$text {}
7994 $ctext conf
-state disabled
8006 if {[info exists gitktmpdir
]} {
8007 catch
{file delete
-force $gitktmpdir}
8011 proc mkfontdisp
{font top
which} {
8012 global fontattr fontpref
$font
8014 set fontpref
($font) [set $font]
8015 button
$top.
${font}but
-text $which -font optionfont \
8016 -command [list choosefont
$font $which]
8017 label
$top.
$font -relief flat
-font $font \
8018 -text $fontattr($font,family
) -justify left
8019 grid x
$top.
${font}but
$top.
$font -sticky w
8022 proc choosefont
{font
which} {
8023 global fontparam fontlist fonttop fontattr
8025 set fontparam
(which) $which
8026 set fontparam
(font
) $font
8027 set fontparam
(family
) [font actual
$font -family]
8028 set fontparam
(size
) $fontattr($font,size
)
8029 set fontparam
(weight
) $fontattr($font,weight
)
8030 set fontparam
(slant
) $fontattr($font,slant
)
8033 if {![winfo exists
$top]} {
8035 eval font config sample
[font actual
$font]
8037 wm title
$top [mc
"Gitk font chooser"]
8038 label
$top.l
-textvariable fontparam
(which)
8039 pack
$top.l
-side top
8040 set fontlist
[lsort
[font families
]]
8042 listbox
$top.f.fam
-listvariable fontlist \
8043 -yscrollcommand [list
$top.f.sb
set]
8044 bind $top.f.fam
<<ListboxSelect>> selfontfam
8045 scrollbar $top.f.sb -command [list $top.f.fam yview]
8046 pack $top.f.sb -side right -fill y
8047 pack $top.f.fam -side left -fill both -expand 1
8048 pack $top.f -side top -fill both -expand 1
8050 spinbox $top.g.size -from 4 -to 40 -width 4 \
8051 -textvariable fontparam(size) \
8052 -validatecommand {string is integer -strict %s}
8053 checkbutton $top.g.bold -padx 5 \
8054 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
8055 -variable fontparam(weight) -onvalue bold -offvalue normal
8056 checkbutton $top.g.ital -padx 5 \
8057 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
8058 -variable fontparam(slant) -onvalue italic -offvalue roman
8059 pack $top.g.size $top.g.bold $top.g.ital -side left
8060 pack $top.g -side top
8061 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
8063 $top.c create text 100 25 -anchor center -text $which -font sample \
8064 -fill black -tags text
8065 bind $top.c <Configure> [list centertext $top.c]
8066 pack $top.c -side top -fill x
8068 button $top.buts.ok -text [mc "OK"] -command fontok -default active
8069 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
8070 grid $top.buts.ok $top.buts.can
8071 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8072 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8073 pack $top.buts -side bottom -fill x
8074 trace add variable fontparam write chg_fontparam
8077 $top.c itemconf text -text $which
8079 set i [lsearch -exact $fontlist $fontparam(family)]
8081 $top.f.fam selection set $i
8086 proc centertext {w} {
8087 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
8091 global fontparam fontpref prefstop
8093 set f $fontparam(font)
8094 set fontpref($f) [list $fontparam(family) $fontparam(size)]
8095 if {$fontparam(weight) eq "bold"} {
8096 lappend fontpref($f) "bold"
8098 if {$fontparam(slant) eq "italic"} {
8099 lappend fontpref($f) "italic"
8102 $w conf -text $fontparam(family) -font $fontpref($f)
8108 global fonttop fontparam
8110 if {[info exists fonttop]} {
8111 catch {destroy $fonttop}
8112 catch {font delete sample}
8118 proc selfontfam {} {
8119 global fonttop fontparam
8121 set i [$fonttop.f.fam curselection]
8123 set fontparam(family) [$fonttop.f.fam get $i]
8127 proc chg_fontparam {v sub op} {
8130 font config sample -$sub $fontparam($sub)
8134 global maxwidth maxgraphpct
8135 global oldprefs prefstop showneartags showlocalchanges
8136 global bgcolor fgcolor ctext diffcolors selectbgcolor
8137 global tabstop limitdiffs autoselect extdifftool
8141 if {[winfo exists $top]} {
8145 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8146 limitdiffs tabstop} {
8147 set oldprefs($v) [set $v]
8150 wm title $top [mc "Gitk preferences"]
8151 label $top.ldisp -text [mc "Commit list display options"]
8152 grid $top.ldisp - -sticky w -pady 10
8153 label $top.spacer -text " "
8154 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8156 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8157 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8158 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8160 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8161 grid x $top.maxpctl $top.maxpct -sticky w
8162 frame $top.showlocal
8163 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8164 checkbutton $top.showlocal.b -variable showlocalchanges
8165 pack $top.showlocal.b $top.showlocal.l -side left
8166 grid x $top.showlocal -sticky w
8167 frame $top.autoselect
8168 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
8169 checkbutton $top.autoselect.b -variable autoselect
8170 pack $top.autoselect.b $top.autoselect.l -side left
8171 grid x $top.autoselect -sticky w
8173 label $top.ddisp -text [mc "Diff display options"]
8174 grid $top.ddisp - -sticky w -pady 10
8175 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8176 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8177 grid x $top.tabstopl $top.tabstop -sticky w
8179 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8180 checkbutton $top.ntag.b -variable showneartags
8181 pack $top.ntag.b $top.ntag.l -side left
8182 grid x $top.ntag -sticky w
8184 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8185 checkbutton $top.ldiff.b -variable limitdiffs
8186 pack $top.ldiff.b $top.ldiff.l -side left
8187 grid x $top.ldiff -sticky w
8189 entry $top.extdifft -textvariable extdifftool
8191 label $top.extdifff.l -text [mc "External diff tool" ] -font optionfont \
8193 button $top.extdifff.b -text [mc "Choose..."] -font optionfont \
8194 -command choose_extdiff
8195 pack $top.extdifff.l $top.extdifff.b -side left
8196 grid x $top.extdifff $top.extdifft -sticky w
8198 label $top.cdisp -text [mc "Colors: press to choose"]
8199 grid $top.cdisp - -sticky w -pady 10
8200 label $top.bg -padx 40 -relief sunk -background $bgcolor
8201 button $top.bgbut -text [mc "Background"] -font optionfont \
8202 -command [list choosecolor bgcolor {} $top.bg background setbg]
8203 grid x $top.bgbut $top.bg -sticky w
8204 label $top.fg -padx 40 -relief sunk -background $fgcolor
8205 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8206 -command [list choosecolor fgcolor {} $top.fg foreground setfg]
8207 grid x $top.fgbut $top.fg -sticky w
8208 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8209 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8210 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8211 [list $ctext tag conf d0 -foreground]]
8212 grid x $top.diffoldbut $top.diffold -sticky w
8213 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8214 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8215 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8216 [list $ctext tag conf d1 -foreground]]
8217 grid x $top.diffnewbut $top.diffnew -sticky w
8218 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8219 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8220 -command [list choosecolor diffcolors 2 $top.hunksep \
8221 "diff hunk header" \
8222 [list $ctext tag conf hunksep -foreground]]
8223 grid x $top.hunksepbut $top.hunksep -sticky w
8224 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8225 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8226 -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
8227 grid x $top.selbgbut $top.selbgsep -sticky w
8229 label $top.cfont -text [mc "Fonts: press to choose"]
8230 grid $top.cfont - -sticky w -pady 10
8231 mkfontdisp mainfont $top [mc "Main font"]
8232 mkfontdisp textfont $top [mc "Diff display font"]
8233 mkfontdisp uifont $top [mc "User interface font"]
8236 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8237 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8238 grid $top.buts.ok $top.buts.can
8239 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8240 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8241 grid $top.buts - - -pady 10 -sticky ew
8242 bind $top <Visibility> "focus $top.buts.ok"
8245 proc choose_extdiff {} {
8248 set prog [tk_getOpenFile -title "External diff tool" -multiple false]
8250 set extdifftool $prog
8254 proc choosecolor {v vi w x cmd} {
8257 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8258 -title [mc "Gitk: choose color for %s" $x]]
8259 if {$c eq {}} return
8260 $w conf -background $c
8266 global bglist cflist
8268 $w configure -selectbackground $c
8270 $cflist tag configure highlight \
8271 -background [$cflist cget -selectbackground]
8272 allcanvs itemconf secsel -fill $c
8279 $w conf -background $c
8287 $w conf -foreground $c
8289 allcanvs itemconf text -fill $c
8290 $canv itemconf circle -outline $c
8294 global oldprefs prefstop
8296 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8297 limitdiffs tabstop} {
8299 set $v $oldprefs($v)
8301 catch {destroy $prefstop}
8307 global maxwidth maxgraphpct
8308 global oldprefs prefstop showneartags showlocalchanges
8309 global fontpref mainfont textfont uifont
8310 global limitdiffs treediffs
8312 catch {destroy $prefstop}
8316 if {$mainfont ne $fontpref(mainfont)} {
8317 set mainfont $fontpref(mainfont)
8318 parsefont mainfont $mainfont
8319 eval font configure mainfont [fontflags mainfont]
8320 eval font configure mainfontbold [fontflags mainfont 1]
8324 if {$textfont ne $fontpref(textfont)} {
8325 set textfont $fontpref(textfont)
8326 parsefont textfont $textfont
8327 eval font configure textfont [fontflags textfont]
8328 eval font configure textfontbold [fontflags textfont 1]
8330 if {$uifont ne $fontpref(uifont)} {
8331 set uifont $fontpref(uifont)
8332 parsefont uifont $uifont
8333 eval font configure uifont [fontflags uifont]
8336 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8337 if {$showlocalchanges} {
8343 if {$limitdiffs != $oldprefs(limitdiffs)} {
8344 # treediffs elements are limited by path
8345 catch {unset treediffs}
8347 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8348 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8350 } elseif {$showneartags != $oldprefs(showneartags) ||
8351 $limitdiffs != $oldprefs(limitdiffs)} {
8356 proc formatdate {d} {
8357 global datetimeformat
8359 set d [clock format $d -format $datetimeformat]
8364 # This list of encoding names and aliases is distilled from
8365 # http://www.iana.org/assignments/character-sets.
8366 # Not all of them are supported by Tcl.
8367 set encoding_aliases {
8368 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8369 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8370 { ISO-10646-UTF-1 csISO10646UTF1 }
8371 { ISO_646.basic:1983 ref csISO646basic1983 }
8372 { INVARIANT csINVARIANT }
8373 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8374 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8375 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8376 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8377 { NATS-DANO iso-ir-9-1 csNATSDANO }
8378 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8379 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8380 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8381 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8382 { ISO-2022-KR csISO2022KR }
8384 { ISO-2022-JP csISO2022JP }
8385 { ISO-2022-JP-2 csISO2022JP2 }
8386 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8388 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8389 { IT iso-ir-15 ISO646-IT csISO15Italian }
8390 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8391 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8392 { greek7-old iso-ir-18 csISO18Greek7Old }
8393 { latin-greek iso-ir-19 csISO19LatinGreek }
8394 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8395 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8396 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8397 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8398 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8399 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8400 { INIS iso-ir-49 csISO49INIS }
8401 { INIS-8 iso-ir-50 csISO50INIS8 }
8402 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8403 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8404 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8405 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8406 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8407 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8409 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8410 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8411 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8412 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8413 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8414 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8415 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8416 { greek7 iso-ir-88 csISO88Greek7 }
8417 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8418 { iso-ir-90 csISO90 }
8419 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8420 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8421 csISO92JISC62991984b }
8422 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8423 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8424 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8425 csISO95JIS62291984handadd }
8426 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8427 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8428 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8429 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8431 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8432 { T.61-7bit iso-ir-102 csISO102T617bit }
8433 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8434 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8435 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8436 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8437 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8438 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8439 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8440 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8441 arabic csISOLatinArabic }
8442 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8443 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8444 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8445 greek greek8 csISOLatinGreek }
8446 { T.101-G2 iso-ir-128 csISO128T101G2 }
8447 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8449 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8450 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8451 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8452 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8453 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8454 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8455 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8456 csISOLatinCyrillic }
8457 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8458 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8459 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8460 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8461 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8462 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8463 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8464 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8465 { ISO_10367-box iso-ir-155 csISO10367Box }
8466 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8467 { latin-lap lap iso-ir-158 csISO158Lap }
8468 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8469 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8472 { JIS_X0201 X0201 csHalfWidthKatakana }
8473 { KSC5636 ISO646-KR csKSC5636 }
8474 { ISO-10646-UCS-2 csUnicode }
8475 { ISO-10646-UCS-4 csUCS4 }
8476 { DEC-MCS dec csDECMCS }
8477 { hp-roman8 roman8 r8 csHPRoman8 }
8478 { macintosh mac csMacintosh }
8479 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8481 { IBM038 EBCDIC-INT cp038 csIBM038 }
8482 { IBM273 CP273 csIBM273 }
8483 { IBM274 EBCDIC-BE CP274 csIBM274 }
8484 { IBM275 EBCDIC-BR cp275 csIBM275 }
8485 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8486 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8487 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8488 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8489 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8490 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8491 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8492 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8493 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8494 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8495 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8496 { IBM437 cp437 437 csPC8CodePage437 }
8497 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8498 { IBM775 cp775 csPC775Baltic }
8499 { IBM850 cp850 850 csPC850Multilingual }
8500 { IBM851 cp851 851 csIBM851 }
8501 { IBM852 cp852 852 csPCp852 }
8502 { IBM855 cp855 855 csIBM855 }
8503 { IBM857 cp857 857 csIBM857 }
8504 { IBM860 cp860 860 csIBM860 }
8505 { IBM861 cp861 861 cp-is csIBM861 }
8506 { IBM862 cp862 862 csPC862LatinHebrew }
8507 { IBM863 cp863 863 csIBM863 }
8508 { IBM864 cp864 csIBM864 }
8509 { IBM865 cp865 865 csIBM865 }
8510 { IBM866 cp866 866 csIBM866 }
8511 { IBM868 CP868 cp-ar csIBM868 }
8512 { IBM869 cp869 869 cp-gr csIBM869 }
8513 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8514 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8515 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8516 { IBM891 cp891 csIBM891 }
8517 { IBM903 cp903 csIBM903 }
8518 { IBM904 cp904 904 csIBBM904 }
8519 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8520 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8521 { IBM1026 CP1026 csIBM1026 }
8522 { EBCDIC-AT-DE csIBMEBCDICATDE }
8523 { EBCDIC-AT-DE-A csEBCDICATDEA }
8524 { EBCDIC-CA-FR csEBCDICCAFR }
8525 { EBCDIC-DK-NO csEBCDICDKNO }
8526 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8527 { EBCDIC-FI-SE csEBCDICFISE }
8528 { EBCDIC-FI-SE-A csEBCDICFISEA }
8529 { EBCDIC-FR csEBCDICFR }
8530 { EBCDIC-IT csEBCDICIT }
8531 { EBCDIC-PT csEBCDICPT }
8532 { EBCDIC-ES csEBCDICES }
8533 { EBCDIC-ES-A csEBCDICESA }
8534 { EBCDIC-ES-S csEBCDICESS }
8535 { EBCDIC-UK csEBCDICUK }
8536 { EBCDIC-US csEBCDICUS }
8537 { UNKNOWN-8BIT csUnknown8BiT }
8538 { MNEMONIC csMnemonic }
8543 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8544 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8545 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8546 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8547 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8548 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8549 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8550 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8551 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8552 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8553 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8554 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8555 { IBM1047 IBM-1047 }
8556 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8557 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8558 { UNICODE-1-1 csUnicode11 }
8561 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8562 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8564 { ISO-8859-15 ISO_8859-15 Latin-9 }
8565 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8566 { GBK CP936 MS936 windows-936 }
8567 { JIS_Encoding csJISEncoding }
8568 { Shift_JIS MS_Kanji csShiftJIS }
8569 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8571 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8572 { ISO-10646-UCS-Basic csUnicodeASCII }
8573 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8574 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8575 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8576 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8577 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8578 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8579 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8580 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8581 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8582 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8583 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8584 { Ventura-US csVenturaUS }
8585 { Ventura-International csVenturaInternational }
8586 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8587 { PC8-Turkish csPC8Turkish }
8588 { IBM-Symbols csIBMSymbols }
8589 { IBM-Thai csIBMThai }
8590 { HP-Legal csHPLegal }
8591 { HP-Pi-font csHPPiFont }
8592 { HP-Math8 csHPMath8 }
8593 { Adobe-Symbol-Encoding csHPPSMath }
8594 { HP-DeskTop csHPDesktop }
8595 { Ventura-Math csVenturaMath }
8596 { Microsoft-Publishing csMicrosoftPublishing }
8597 { Windows-31J csWindows31J }
8602 proc tcl_encoding {enc} {
8603 global encoding_aliases
8604 set names [encoding names]
8605 set lcnames [string tolower $names]
8606 set enc [string tolower $enc]
8607 set i [lsearch -exact $lcnames $enc]
8609 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8610 if {[regsub {^iso[-_]} $enc iso encx]} {
8611 set i [lsearch -exact $lcnames $encx]
8615 foreach l $encoding_aliases {
8616 set ll [string tolower $l]
8617 if {[lsearch -exact $ll $enc] < 0} continue
8618 # look through the aliases for one that tcl knows about
8620 set i [lsearch -exact $lcnames $e]
8622 if {[regsub {^iso[-_]} $e iso ex]} {
8623 set i [lsearch -exact $lcnames $ex]
8632 return [lindex $names $i]
8637 # First check that Tcl/Tk is recent enough
8638 if {[catch {package require Tk 8.4} err]} {
8639 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8640 Gitk requires at least Tcl/Tk 8.4."]
8646 set wrcomcmd "git diff-tree --stdin -p --pretty"
8650 set gitencoding [exec git config --get i18n.commitencoding]
8652 if {$gitencoding == ""} {
8653 set gitencoding "utf-8"
8655 set tclencoding [tcl_encoding $gitencoding]
8656 if {$tclencoding == {}} {
8657 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8660 set mainfont {Helvetica 9}
8661 set textfont {Courier 9}
8662 set uifont {Helvetica 9 bold}
8664 set findmergefiles 0
8672 set cmitmode "patch"
8673 set wrapcomment "none"
8677 set showlocalchanges 1
8679 set datetimeformat "%Y-%m-%d %H:%M:%S"
8682 set extdifftool "meld"
8684 set colors {green red blue magenta darkgrey brown orange}
8687 set diffcolors {red "#00a000" blue}
8690 set selectbgcolor gray85
8692 ## For msgcat loading, first locate the installation location.
8693 if { [info exists ::env(GITK_MSGSDIR)] } {
8694 ## Msgsdir was manually set in the environment.
8695 set gitk_msgsdir $::env(GITK_MSGSDIR)
8697 ## Let's guess the prefix from argv0.
8698 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
8699 set gitk_libdir [file join $gitk_prefix share gitk lib]
8700 set gitk_msgsdir [file join $gitk_libdir msgs]
8704 ## Internationalization (i18n) through msgcat and gettext. See
8705 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
8706 package require msgcat
8707 namespace import ::msgcat::mc
8708 ## And eventually load the actual message catalog
8709 ::msgcat::mcload $gitk_msgsdir
8711 catch {source ~/.gitk}
8713 font create optionfont -family sans-serif -size -12
8715 parsefont mainfont $mainfont
8716 eval font create mainfont [fontflags mainfont]
8717 eval font create mainfontbold [fontflags mainfont 1]
8719 parsefont textfont $textfont
8720 eval font create textfont [fontflags textfont]
8721 eval font create textfontbold [fontflags textfont 1]
8723 parsefont uifont $uifont
8724 eval font create uifont [fontflags uifont]
8728 # check that we can find a .git directory somewhere...
8729 if {[catch {set gitdir [gitdir]}]} {
8730 show_error {} . [mc "Cannot find a git repository here."]
8733 if {![file isdirectory $gitdir]} {
8734 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
8740 set cmdline_files {}
8742 set revtreeargscmd {}
8744 switch -glob -- $arg {
8746 "-d" { set datemode 1 }
8749 lappend revtreeargs $arg
8752 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8756 set revtreeargscmd [string range $arg 10 end]
8759 lappend revtreeargs $arg
8765 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8766 # no -- on command line, but some arguments (other than -d)
8768 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8769 set cmdline_files [split $f "\n"]
8770 set n [llength $cmdline_files]
8771 set revtreeargs [lrange $revtreeargs 0 end-$n]
8772 # Unfortunately git rev-parse doesn't produce an error when
8773 # something is both a revision and a filename. To be consistent
8774 # with git log and git rev-list, check revtreeargs for filenames.
8775 foreach arg $revtreeargs {
8776 if {[file exists $arg]} {
8777 show_error {} . [mc "Ambiguous argument '%s': both revision\
8783 # unfortunately we get both stdout and stderr in $err,
8784 # so look for "fatal:".
8785 set i [string first "fatal:" $err]
8787 set err [string range $err [expr {$i + 6}] end]
8789 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
8795 # find the list of unmerged files
8799 set fd [open "| git ls-files -u" r]
8801 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
8804 while {[gets $fd line] >= 0} {
8805 set i [string first "\t" $line]
8806 if {$i < 0} continue
8807 set fname [string range $line [expr {$i+1}] end]
8808 if {[lsearch -exact $mlist $fname] >= 0} continue
8810 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8811 lappend mlist $fname
8816 if {$nr_unmerged == 0} {
8817 show_error {} . [mc "No files selected: --merge specified but\
8818 no files are unmerged."]
8820 show_error {} . [mc "No files selected: --merge specified but\
8821 no unmerged files are within file limit."]
8825 set cmdline_files $mlist
8828 set nullid "0000000000000000000000000000000000000000"
8829 set nullid2 "0000000000000000000000000000000000000001"
8830 set nullfile "/dev/null"
8832 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8839 set highlight_paths {}
8841 set searchdirn -forwards
8845 set markingmatches 0
8846 set linkentercount 0
8847 set need_redisplay 0
8854 set selectedhlview [mc "None"]
8855 set highlight_related [mc "None"]
8856 set highlight_files {}
8860 set viewargscmd(0) {}
8869 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
8872 # wait for the window to become visible
8874 wm title . "[file tail $argv0]: [file tail [pwd]]"
8877 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
8878 # create a view for the files/dirs specified on the command line
8882 set viewname(1) [mc "Command line"]
8883 set viewfiles(1) $cmdline_files
8884 set viewargs(1) $revtreeargs
8885 set viewargscmd(1) $revtreeargscmd
8888 .bar.view entryconf [mc "Edit view..."] -state normal
8889 .bar.view entryconf [mc "Delete view"] -state normal
8892 if {[info exists permviews]} {
8893 foreach v $permviews {
8896 set viewname($n) [lindex $v 0]
8897 set viewfiles($n) [lindex $v 1]
8898 set viewargs($n) [lindex $v 2]
8899 set viewargscmd($n) [lindex $v 3]